static int
read_num_or_name(int c, FILE *cfile)
{
int i = 0;
int rv = TOK_NUMBER_OR_NAME;
tokbuf[i++] = c;
for (; i < sizeof(tokbuf); i++) {
c = get_char(cfile);
if (!isascii(c) || (c != '-' && c != '_' && !isalnum(c))) {
ungetc(c, cfile);
ugflag = 1;
break;
}
if (!isxdigit(c))
rv = TOK_NAME;
tokbuf[i] = c;
}
if (i == sizeof(tokbuf)) {
parse_warn("token larger than internal buffer");
i--;
}
tokbuf[i] = 0;
tval = tokbuf;
return (intern(tval, rv));
}
void parser_t::push_block(block_t *new_current)
{
const enum block_type_t type = new_current->type();
new_current->src_lineno = parser_t::get_lineno();
const wchar_t *filename = parser_t::current_filename();
if (filename != NULL)
{
new_current->src_filename = intern(filename);
}
const block_t *old_current = this->current_block();
if (old_current && old_current->skip)
{
new_current->skip = true;
}
/*
New blocks should be skipped if the outer block is skipped,
except TOP ans SUBST block, which open up new environments. Fake
blocks should always be skipped. Rather complicated... :-(
*/
new_current->skip = old_current ? old_current->skip : 0;
/*
Type TOP and SUBST are never skipped
*/
if (type == TOP || type == SUBST)
{
new_current->skip = 0;
}
/*
Fake blocks and function definition blocks are never executed
*/
if (type == FAKE || type == FUNCTION_DEF)
{
new_current->skip = 1;
}
new_current->job = 0;
new_current->loop_status=LOOP_NORMAL;
this->block_stack.push_back(new_current);
// Types TOP and SUBST are not considered blocks for the purposes of `status -b`
if (type != TOP && type != SUBST)
{
is_block = 1;
}
if ((new_current->type() != FUNCTION_DEF) &&
(new_current->type() != FAKE) &&
(new_current->type() != TOP))
{
env_push(type == FUNCTION_CALL);
new_current->wants_pop_env = true;
}
}
static Lisp_Object
read_file_name (Lisp_Object default_filename, Lisp_Object mustmatch,
Lisp_Object initial, Lisp_Object predicate)
{
return CALLN (Ffuncall, intern ("read-file-name"),
callint_message, Qnil, default_filename,
mustmatch, initial, predicate);
}
TestSuite *ts_sort(TestSuite *suite)
{
Searcher *sea, **searchers;
Store *store = open_ram_store(), *fs_store;
search = intern("search");
string = intern("string");
integer = intern("integer");
flt = intern("flt");
sort_test_setup(store);
suite = ADD_SUITE(suite);
tst_run_test(suite, test_sort_field_to_s, NULL);
tst_run_test(suite, test_sort_to_s, NULL);
sea = isea_new(ir_open(store));
tst_run_test(suite, test_sorts, (void *)sea);
searcher_close(sea);
do_byte_test = false;
#ifdef POSH_OS_WIN32
fs_store = open_fs_store(".\\test\\testdir\\store");
#else
fs_store = open_fs_store("./test/testdir/store");
#endif
sort_multi_test_setup(store, fs_store);
searchers = ALLOC_N(Searcher *, 2);
searchers[0] = isea_new(ir_open(store));
searchers[1] = isea_new(ir_open(fs_store));
sea = msea_new(searchers, 2, true);
tst_run_test(suite, test_sorts, (void *)sea);
searcher_close(sea);
store_deref(store);
store_deref(fs_store);
return suite;
}
// Reader marcro ' (single quote). It reads an expression and returns (quote <expr>).
static Obj *read_quote(void *root) {
DEFINE2(sym, tmp);
*sym = intern(root, "quote");
*tmp = read_expr(root);
*tmp = cons(root, tmp, &Nil);
*tmp = cons(root, sym, tmp);
return *tmp;
}
/*
* <identifier> -> <initial> <subsequent>* | <peculiar identifier>
* <initial> -> <letter> | <special initial>
* <letter> -> a | b | c | ... | z
*
* <special initial> -> ! | $ | % | & | * | / | : | < | = | > | ? | ^ | _ | ~
* <subsequent> -> <initial> | <digit> | <special subsequent>
* <digit> -> 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
* <special subsequent> -> + | - | . | @
*/
static SCM read_symbol(FILE *file, int first_char)
{
SCM symbol;
char *buf = read_word(file, first_char);
symbol = intern(buf);
free(buf);
return symbol;
}
void
Init_float()
{
cFloat = define_class(intern("Float"), cNumeric);
define_singleton_method(cFloat, intern("new"), (void*)float_s_new, 1);
define_method(cFloat, intern("*"), float_multiply, 1);
define_method(cFloat, intern("+"), float_addition, 1);
define_method(cFloat, intern("-"), float_subtract, 1);
define_method(cFloat, intern("/"), float_divide, 1);
define_method(cFloat, intern("**"), float_pow, 1);
define_method(cFloat, intern("to_f"), float_to_f, 0);
define_method(cFloat, intern("to_i"), float_to_i, 0);
define_method(cFloat, intern("to_s"), float_to_s, 0);
}
void set_argv(static_context_t *this_context, int argc, char **argv)
{
array_t *ARGV = array_new();
int i;
for (i = 0; i < argc; i++)
array_push(this_context, ARGV, string_new_cstr(argv[i]));
send2(Object, s_const_set, intern("ARGV"), ARGV);
}
static SExp subr_get_raw_value(int s, int argnum) {
SExp buf = vm_stack_ref(s, 0);
SFixnum ofs = S2FIXNUM(type_check(vm_stack_ref(s, 1), &TFixnum));
SExp type = type_check(vm_stack_ref(s, 2), &TSymbol);
char* ptr;
if (s2ptr((char*)&ptr, buf) == NULL) {
return error("Illegal type");
} else {
if (eq(type, intern("int"))) {
return fixnum2s(*(int*)(ptr + ofs));
} else if (eq(type, intern("int32"))) {
return fixnum2s(*(int*)(ptr + ofs));
} else if (eq(type, intern("int16"))) {
return fixnum2s(*(short*)(ptr + ofs));
} else if (eq(type, intern("int8"))) {
return fixnum2s(*(char*)(ptr + ofs));
} else if (eq(type, intern("uint32"))) {
return fixnum2s(*(unsigned int*)(ptr + ofs));
} else if (eq(type, intern("uint16"))) {
return fixnum2s(*(unsigned short*)(ptr + ofs));
} else if (eq(type, intern("uint8"))) {
return fixnum2s(*(unsigned char*)(ptr + ofs));
} else {
return error("Illegal type");
}
}
}
int TAREXPORT
tar_inflate( tar_streamp strm, int flush ) {
assert( strm );
if( intern(*strm).put( *strm, flush != TAR_HEADER_FLUSH ) )
return TAR_OK;
else
return TAR_ENTRY_END;
}
Obj *read_quote(Env *env, Obj *root, char **p) {
VAR(sym);
VAR(tmp);
*sym = intern(env, root, "quote");
*tmp = read(env, root, p);
*tmp = make_cell(env, root, tmp, &Nil);
*tmp = make_cell(env, root, sym, tmp);
return *tmp;
}
int TAREXPORT
tar_inflateGetHeader( tar_streamp strm,
tar_headerp head ) {
assert(strm);
assert(head);
auto& internal = intern( *strm );
internal.header( head );
return TAR_OK;
}
int TAREXPORT
tar_inflateEnd( tar_streamp strm ) {
assert( strm );
delete &intern( *strm );
// Signal to externals that the stream
// has ended
strm->state = nullptr;
return TAR_OK;
}
static ad_device_data *
sound_ao_create(Lisp_Object ao_options)
{
int driver;
ao_device *device;
ao_option *options;
ao_sample_format *fmt;
/* result */
sound_ao_data_t *aod;
/* option keywords */
Lisp_Object opt_driver;
char *optext_driver = NULL;
/* parse options */
opt_driver = Fplist_get(ao_options, intern(":driver"), Qnil);
if (!NILP(opt_driver) && !STRINGP(opt_driver)) {
wrong_type_argument(Qstringp, opt_driver);
return NULL;
} else if (STRINGP(opt_driver))
optext_driver = (char*)XSTRING_DATA(opt_driver);
/* -- initialise -- */
ao_initialize();
fmt = xmalloc(sizeof(ao_sample_format));
/* -- Setup for driver -- */
if (optext_driver != NULL)
driver = ao_driver_id(optext_driver);
else
driver = ao_default_driver_id();
/* just some generics */
fmt->channels = 2;
fmt->rate = 44100;
fmt->bits = 16;
fmt->byte_format = AO_FMT_LITTLE;
options = NULL;
/* -- Open driver -- */
device = ao_open_live(driver, fmt, options);
if (device == NULL) {
message(GETTEXT("audio-ao: Unsupported driver."));
xfree(fmt);
aod = NULL;
} else {
aod = xnew_and_zero(sound_ao_data_t);
aod->ad = device;
aod->options = NULL;
aod->fmt = fmt;
aod->driver_id = driver;
}
return aod;
}
/* Read a lisp object. This is the main interface to the reader. */
sexpr *readobj(IC *ic) {
reader *r = ic->r;
char *token;
/* These are used by strtod(). Number is the return value, and
unparsed is set to the portion of the string not parsed.
If it is not pointing at the terminating '\0' when we are done, then
we failed to get a number. */
double number;
char *unparsed;
token = gettoken(r);
if(token == NULL) return ic->eof;
if(!strcmp(token, "(")) return readlist(ic);
if(!strcmp(token, "\'") ||
!strcmp(token, "`") ||
!strcmp(token, ",") ||
!strcmp(token, ",@")) {
/* We are going to read the following object, and then wrap it in
a call to something. Figure out what that something is. */
sexpr *quoter = NULL;
protect_ptr(ic->g, (void **)"er);
if(!strcmp(token, "\'"))
STORE(ic->g, NULL, quoter, ic->n_quote);
else if(!strcmp(token, "`"))
STORE(ic->g, NULL, quoter, ic->n_quasiquote);
else if(!strcmp(token, ","))
STORE(ic->g, NULL, quoter, ic->n_unquote);
else if(!strcmp(token, ",@"))
STORE(ic->g, NULL, quoter, ic->n_unquote_splicing);
else {
fprintf(stderr,
"Fatal error in lisp reader - this should never happen!\n");
longjmp(ic->quit, 1);
}
sexpr *obj = readobj(ic);
protect_ptr(ic->g, (void **)&obj);
sexpr *ret = listl(ic, quoter, obj, NULL);
unprotect_ptr(ic->g);
unprotect_ptr(ic->g);
return ret;
}
/* Check to see if it's a valid number. */
if(strcasecmp(token, "inf") &&
strcasecmp(token, "infinity") &&
strcasecmp(token, "nan")) {
number = strtod(token, &unparsed);
if(unparsed != token && *unparsed == '\0')
return mk_number(ic, number);
}
return intern(ic, token);
}
function_info_t::function_info_t(const function_info_t &data, const wchar_t *filename, int def_offset, bool autoload) :
definition(data.definition),
description(data.description),
definition_file(intern(filename)),
definition_offset(def_offset),
named_arguments(data.named_arguments),
is_autoload(autoload),
shadows(data.shadows)
{
}
void
LTX_PUBFUN(ase_mono, init)(void)
{
LTX_PUBFUN(ase_interval, init)();
LTX_PUBFUN(ase_neighbourhood, init)();
LTX_PUBFUN(ase_cartesian, init)();
LTX_PUBFUN(ase_metric, init)();
Fprovide(intern("ase-mono"));
}
static Lisp_Object
coding_from_cp (UINT codepage)
{
char buffer[30];
sprintf (buffer, "cp%d-dos", (int) codepage);
return intern (buffer);
/* We don't need to check that this coding system actually exists
right here, because that is done later for all coding systems
used, regardless of where they originate. */
}
//
// createElement
// We've just matched an element start tag. Create and fill in a UXMLElement object
// for it.
//
UXMLElement *
UXMLParser::createElement(RegexMatcher &mEl, UErrorCode &status) {
// First capture group is the element's name.
UXMLElement *el = new UXMLElement(this, intern(mEl.group(1, status), status), status);
// Scan for attributes.
int32_t pos = mEl.end(1, status); // The position after the end of the tag name
while (mAttrValue.lookingAt(pos, status)) { // loop runs once per attribute on this element.
UnicodeString attName = mAttrValue.group(1, status);
UnicodeString attValue = mAttrValue.group(2, status);
// Trim the quotes from the att value. These are left over from the original regex
// that parsed the attribue, which couldn't conveniently strip them.
attValue.remove(0,1); // one char from the beginning
attValue.truncate(attValue.length()-1); // and one from the end.
// XML Attribue value normalization.
// This is one of the really screwy parts of the XML spec.
// See http://www.w3.org/TR/2004/REC-xml11-20040204/#AVNormalize
// Note that non-validating parsers must treat all entities as type CDATA
// which simplifies things some.
// Att normalization step 1: normalize any newlines in the attribute value
mNewLineNormalizer.reset(attValue);
attValue = mNewLineNormalizer.replaceAll(fOneLF, status);
// Next change all xml white space chars to plain \u0020 spaces.
mAttrNormalizer.reset(attValue);
UnicodeString oneSpace((UChar)0x0020);
attValue = mAttrNormalizer.replaceAll(oneSpace, status);
// Replace character entities.
replaceCharRefs(attValue, status);
// Save the attribute name and value in our document structure.
el->fAttNames.addElement((void *)intern(attName, status), status);
el->fAttValues.addElement(attValue.clone(), status);
pos = mAttrValue.end(2, status);
}
fPos = mEl.end(0, status);
return el;
}
static Lisp_Object
read_file_name (Lisp_Object default_filename, Lisp_Object mustmatch,
Lisp_Object initial, Lisp_Object predicate)
{
struct gcpro gcpro1;
GCPRO1 (default_filename);
RETURN_UNGCPRO (CALLN (Ffuncall, intern ("read-file-name"),
callint_message, Qnil, default_filename,
mustmatch, initial, predicate));
}
void symbol_init (int n) {
if (n < SYMBOL_MINIMUM_STACK) {
symbol_pool = make_stack (SYMBOL_MINIMUM_STACK);
} else {
symbol_pool = make_stack (n);
}
symbol_nil = intern ("NIL");
}
static ad_device_data *
sound_nas_create(Lisp_Object nas_options)
{
sound_nas_data_t *snd;
char *server[6] = {NULL, NULL, NULL, NULL, NULL, NULL};
int i, server_cnt = 0;
AuServer *aud = NULL;
Lisp_Object opt_server = Qnil;
/* parse options */
opt_server = Fplist_get(nas_options, intern(":server"), Qnil);
if (!NILP(opt_server) && !STRINGP(opt_server) && !DEVICEP(opt_server)) {
wrong_type_argument(Qstringp, opt_server);
return NULL;
}
if (NILP(opt_server))
nas_setup_defaults(server, &server_cnt);
else if (STRINGP(opt_server))
server[server_cnt++] = (char*)XSTRING_DATA(opt_server);
#ifdef HAVE_X_WINDOWS
else if (DEVICEP(opt_server) && DEVICE_X_P(XDEVICE(opt_server)))
server[server_cnt++] =
(char*)XSTRING_DATA(
DEVICE_CONNECTION(XDEVICE(opt_server)));
#endif
NAS_DEBUG("trying %d connections\n", server_cnt);
for (i = 0; i<server_cnt; i++)
if ((aud = nas_try_connection(server[i])))
break;
if (!aud) {
NAS_DEBUG_C("cannot contact any NAS server\n");
warn_when_safe(Qnas, Qwarning,
GETTEXT("No NAS servers in sight.\n"));
return NULL; /* Could not contact NAS server */
}
/* -- initialise -- */
snd = xnew_and_zero(sound_nas_data_t);
snd->aud = aud;
/* round up SOUND_MAX_AUDIO_FRAME_SIZE to multiple of NAS_FRAG_SIZE
* divide by 3 first because of 2:1 split */
snd->proposed_buffer_size =
(SOUND_MAX_AUDIO_FRAME_SIZE/3 + NAS_FRAG_SIZE-1)
& ~(NAS_FRAG_SIZE-1);
NAS_DEBUG_C("proposed buffer size: %u\n", snd->proposed_buffer_size);
NAS_DEBUG_C("created: 0x%x\n", (unsigned int)snd);
return snd;
}
int main(int argc, char *argv[])
{
init();
init2();
static_context_t ctx;
ctx.file = (char *)__FILE__;
ctx.method = (char *)__FUNCTION__;
ctx.line = __LINE__;
ctx.parent = 0;
ctx.block = 0;
static_context_t *this_context = &ctx;
/* awesome hardcoding work here */
load_path = array_new();
array_push(this_context, load_path, string_new_cstr("."));
array_push(this_context, load_path, string_new_cstr("./mspec/lib"));
jump_begin(JUMP_RESCUE)
send3(Kernel, s_define_method, intern("load"), kernel_load, 1);
send3(Kernel, s_define_method, intern("require"), kernel_require, 1);
send3(Kernel, s_define_method, intern("eval"), kernel_eval, -1);
Init_hash(this_context);
Init_regexp(this_context);
init_core(&ctx, g_main);
if (argc > 1) {
set_argv(this_context, argc - 2, argv + 2);
kernel_load(this_context, g_main, string_new_cstr(argv[1]));
}
else {
set_argv(this_context, 0, 0);
simple_irb(this_context, g_main);
}
jump_rescue
object_t *cls = send0(exc, s_class);
printf("%s: %s\n", ((symbol_t *)((class_t *)cls)->name)->string, ((string_t *)((exception_t *)exc)->message)->bytes);
array_t *array = (array_t *)((exception_t *)exc)->backtrace;
int i;
for (i = 0; i < array->used; i++)
printf("\tfrom %s\n", ((string_t *)array->values[i])->bytes);
jump_ensure
jump_end
exit(0);
return 0;
}
function_info_t::function_info_t(const function_data_t &data, const wchar_t *filename,
int def_offset, bool autoload)
: definition(data.definition),
description(data.description),
definition_file(intern(filename)),
definition_offset(def_offset),
named_arguments(data.named_arguments),
inherit_vars(snapshot_vars(data.inherit_vars)),
is_autoload(autoload),
shadow_builtin(data.shadow_builtin),
shadow_scope(data.shadow_scope) {}
static void
prefixlist_push(struct prefixlist *pl, const char *path)
{
struct prefix *prevpf = SLIST_FIRST(pl);
struct prefix *pf;
char *cp;
pf = ecalloc(1, sizeof(struct prefix));
if (prevpf != NULL) {
cp = emalloc(strlen(prevpf->pf_prefix) + 1 +
strlen(path) + 1);
(void) sprintf(cp, "%s/%s", prevpf->pf_prefix, path);
pf->pf_prefix = intern(cp);
free(cp);
} else
pf->pf_prefix = intern(path);
SLIST_INSERT_HEAD(pl, pf, pf_next);
}
void
toi_set_argv(int argc, char **argv)
{
int i;
VALUE ary = ary_new();
for (i = 0; i < argc; i++)
ary_push(ary, string_new(argv[i]));
define_global_variable(intern("ARGV"), ary);
}
static Lisp_Object
coding_from_cp (UINT codepage)
{
char buffer[30];
sprintf (buffer, "cp%d-dos", (int) codepage);
return intern (buffer);
/* We don't need to check that this coding system exists right here,
because that is done when the coding system is actually
instantiated, i.e. it is passed through Fcheck_coding_system()
there. */
}
void
Init_kernel()
{
if (!cObject)
cObject = define_class(intern("Object"), Qnil);
if (!cKernel)
cKernel = define_class(intern("Kernel"), cObject);
define_global_function(intern("!"), kernel_not, 1);
define_global_function(intern("puts"), kernel_puts_thunk, -1);
define_global_function(intern("write"), kernel_write, 1);
define_global_function(intern("print"), kernel_write, 1);
define_global_function(intern("exit"), kernel_exit, -1);
define_global_function(intern("sleep"), kernel_sleep, 1);
define_global_function(intern("self"), kernel_s_self, 0);
}
static Obj *read_symbol(void *root, char c) {
char buf[SYMBOL_MAX_LEN + 1];
buf[0] = c;
int len = 1;
while (isalnum(peek()) || strchr(symbol_chars, peek())) {
if (SYMBOL_MAX_LEN <= len)
error("Symbol name too long");
buf[len++] = getchar();
}
buf[len] = '\0';
return intern(root, buf);
}
void pinit() {
for(int i = DOCOL; i <= NOT; i++) {
switch(i){
case DOCOL:
//case PUSNXT:
enter(i);
break;
default:
intern(i, 0);
}
primaddr[i] = *dict - 1;
}
}
