static void *module_lispcore_init ( TAMEnv *env )
{
LispCoreData *d;
ASSERT(env);
d = malloc(sizeof(LispCoreData));
CHECK_MEM(d);
/* the space here is important! this is a symbol that the user will not
* be able to access ... */
d->arg1 = tam_object_symbol_new(" arg1", env);
d->arg2 = tam_object_symbol_new(" arg2", env);
d->rest = tam_object_symbol_new(" rest", env);
NEWARGS(d->arg_list_cache_1); /* (arg1) */
ADDARG(d->arg_list_cache_1, d->arg1);
ASSERT(d->arg_list_cache_1);
ASSERT(tam_object_proc_formals_validate(d->arg_list_cache_1, env, 0));
NEWARGS(d->arg_list_cache_2); /* (arg1 arg2) */
ADDARG(d->arg_list_cache_2, d->arg2);
ADDARG(d->arg_list_cache_2, d->arg1);
ASSERT(d->arg_list_cache_2);
ASSERT(tam_object_proc_formals_validate(d->arg_list_cache_1, env, 0));
NEWARGS(d->arg_list_cache_3);
ADDARG(d->arg_list_cache_3, d->rest);
ADDARG(d->arg_list_cache_3, tam_env_dot_get(env));
ASSERT(d->arg_list_cache_3);
ASSERT(tam_object_proc_formals_validate(d->arg_list_cache_3, env, 0));
tam_primitive_register("eval", core_eval, d, d->arg_list_cache_1, env);
tam_primitive_register("car", core_car, d, d->arg_list_cache_1, env);
tam_primitive_register("cdr", core_cdr, d, d->arg_list_cache_1, env);
tam_primitive_register("null?", core_is_null, d, d->arg_list_cache_1, env);
tam_primitive_register("pair?", core_is_pair, d, d->arg_list_cache_1, env);
tam_primitive_register("cons", core_cons, d, d->arg_list_cache_2, env);
tam_primitive_register("remainder", core_mod, d, d->arg_list_cache_2, env);
tam_primitive_register("+", core_add, d, d->arg_list_cache_3, env);
tam_primitive_register("-", core_sub, d, d->arg_list_cache_3, env);
tam_primitive_register("*", core_mul, d, d->arg_list_cache_3, env);
tam_primitive_register("/", core_div, d, d->arg_list_cache_3, env);
tam_primitive_register("and", core_and, d, d->arg_list_cache_3, env);
tam_primitive_register("or", core_or, d, d->arg_list_cache_3, env);
tam_primitive_register("not", core_not, d, d->arg_list_cache_1, env);
tam_primitive_register(">", core_gt, d, d->arg_list_cache_3, env);
tam_primitive_register(">=", core_gte, d, d->arg_list_cache_3, env);
tam_primitive_register("<", core_lt, d, d->arg_list_cache_3, env);
tam_primitive_register("<=", core_lte, d, d->arg_list_cache_3, env);
tam_primitive_register("=", core_number_eq, d, d->arg_list_cache_3, env);
return d;
}
void input(FILE *fd, void (*cb)(struct message *), struct message *p)
{
int c;
#define ST(X) do { p->status = (X); } while(0)
#define MK(X) do { p->X = p->p; } while(0)
#define RST() do { \
ST(AT_BOM); \
p->p = p->buffer; \
p->sz = p->argc = 0; \
p->org = p->cmd = NULL; \
} while (0)
#define ADDCH(X) do { \
*p->p++ = X; p->sz++; \
if (p->sz >= (sizeof p->buffer)-1) \
RST(); \
} while (0)
#define ADDARG(s) do { \
assert(p->argc < MAX_ARGS); \
p->argv[p->argc] = s; \
if (s) p->argc++; \
} while (0)
RST();
while ((c = fgetc(fd)) != EOF) {
switch (p->status) {
case AT_BOM:
switch (c) {
case ':': ST(IN_ORG); MK(org); break;
case ' ': break; /* ignored */
case '\r': ST(IN_EOL); break;
case '\n': RST(); break;
default: ST(IN_CMD); MK(cmd); ADDCH(c); break;
} break;
case IN_ORG:
switch(c) {
case ' ': ST(IN_SPC0); ADDCH(0); break;
case '\r': ST(IN_EOL); ADDCH(0); break;
case '\n': RST(); break;
case ':': /* NO BREAK HERE, valid char */
default: ADDCH(c); break;
} break;
case IN_SPC0:
switch(c) {
case ' ': break; /* ignore extra */
case '\r': ST(IN_EOL); break;
case '\n': RST(); break;
default: ST(IN_CMD); MK(cmd); ADDCH(c); break;
} break;
case IN_CMD:
switch(c) {
case ' ': ST(IN_SPC1); ADDCH(0); break;
case '\r': ST(IN_EOL); ADDCH(0); break;
case '\n': ADDARG(NULL); cb(p); RST(); break;
case ':': /* NO BREAK HERE, valid char */
default: ADDCH(c); break;
} break;
case IN_SPC1:
switch(c) {
case ' ': break; /* ignore */
case '\r': ST(IN_EOL); break;
case '\n': ADDARG(NULL); cb(p); RST(); break;
case ':': ST(IN_ARGN); ADDARG(p->p); break;
default: ST(IN_ARG); ADDARG(p->p); ADDCH(c); break;
} break;
case IN_ARG:
switch (c) {
case ' ': ST(IN_SPC1); ADDCH(0); break;
case '\r': ST(IN_EOL); ADDCH(0); break;
case '\n': ADDARG(NULL); cb(p); RST(); break;
case ':':
default: ADDCH(c); break;
} break;
case IN_ARGN:
switch (c) {
case '\r': ST(IN_EOL); ADDCH(0); break;
case '\n': ADDARG(NULL); cb(p); RST(); break;
default: ADDCH(c); break;
} break;
case IN_EOL:
switch (c) {
case '\r': break;
case '\n': ADDARG(NULL); cb(p); RST(); break;
case ':': RST(); ST(IN_ORG); break;
default: RST(); break;
} break;
} /* switch */
} /* while */
} /* input */
