/* "Cons" operation */
long
l_cons(long car, long cdr)
{
int s;
if (t_cons_free < 0){ /* no cons cells */
if (gc_protect(car) < 0)
return -1;
if (gc_protect(cdr) < 0)
return -1;
gcollect(); /* invoke garbage collector */
gc_unprotect(cdr);
gc_unprotect(car);
}
/* get a free cons cell from a free list */
s = t_cons_free;
if (t_cons_car[t_cons_free] != t_cons_free)
t_cons_free = t_cons_car[t_cons_free]; /* next free cell */
else
t_cons_free = -1; /* self-loop: end of free list */
/* constract a new cell */
t_cons_car[s] = car;
t_cons_cdr[s] = cdr;
return (TAG_CONS | s);
}
/* Evaluate arguments */
long
eval_args(long func, long arg, long av[2], int n)
{
long x, y;
if ((n != FTYPE_ANY_ARGS) && (n != list_len(arg)))
return err_msg(errmsg_ill_nargs, 1, func);
switch (n){
case 0:
av[0] = TAG_NIL;
break;
case 1:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
break;
case 2:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
if ((av[1] = l_eval(l_car(l_cdr(arg)))) < 0)
return -1;
gc_unprotect(av[0]);
break;
case FTYPE_ANY_ARGS: /* return evaluated arguments as a list */
if (D_GET_TAG(arg) != TAG_CONS){
av[0] = TAG_NIL;
} else {
if ((x = l_eval(l_car(arg))) < 0)
return -1;
if ((av[0] = y = l_cons(x, TAG_NIL)) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
for (arg = l_cdr(arg); D_GET_TAG(arg) == TAG_CONS; arg = l_cdr(arg)){
if ((x = l_eval(l_car(arg))) < 0)
return -1;
rplacd(y, l_cons(x, TAG_NIL));
y = l_cdr(y);
}
gc_unprotect(av[0]);
}
}
return av[0];
}
/* Compile a string */
void compile_string(compiler_type *comp_void, char *str, bool include_baselib) {
compiler_core_type *compiler = (compiler_core_type *)comp_void;
ins_stream_type *baselib = 0; /* TODO: should be gc root */
char path[PATH_MAX];
/* Actually parse the input stream. */
yylex_init_extra(compiler, &(compiler->scanner));
yy_scan_string(str, compiler->scanner);
/* TODO: Need a better way to handle GC than leaking */
gc_protect(compiler->gc);
/* Inject include for base library */
if (include_baselib) {
strcpy(path, compiler->home);
strcat(path, "/lib/baselib.scm");
STREAM_NEW(baselib, string, path);
setup_include(compiler, baselib);
}
parse_internal(compiler, compiler->scanner);
gc_unprotect(compiler->gc);
yylex_destroy(compiler->scanner);
}
/* Top level */
void
toplevel(void)
{
long s, v;
for (;;){
t_stack_ptr = 0;
printf("\n] "); /* prompt */
if ((s = l_read()) < 0) /* read */
continue;
if (s == TAG_EOF) /* end of file */
break;
if (gc_protect(s) < 0)
break;
if ((v = l_eval(s)) < 0) /* eval */
continue;
gc_unprotect(s);
printf("\n");
(void) l_print(v); /* print */
}
}
/* Compile a file */
void compile_file(compiler_type *comp_void, char *file_name, bool include_baselib) {
compiler_core_type *compiler = (compiler_core_type *)comp_void;
ins_stream_type *baselib = 0; /* TODO: should be gc root */
FILE *in = 0;
char path[PATH_MAX];
/* Actually parse the input stream. */
yylex_init_extra(compiler, &(compiler->scanner));
in = fopen(file_name, "r");
if (!in) {
(void)fprintf(stderr, "Error %i while attempting to open '%s'\n",
errno, file_name);
assert(0);
}
//yyset_in(in, compiler->scanner);
yy_switch_to_buffer(
yy_create_buffer(in, YY_BUF_SIZE, compiler->scanner), compiler->scanner);
push_include_path(compiler, file_name);
/* TODO: Need a better way to handle GC than leaking */
gc_protect(compiler->gc);
/* Inject include for base library */
if (include_baselib) {
strcpy(path, compiler->home);
strcat(path, "/lib/baselib.scm");
STREAM_NEW(baselib, string, path);
setup_include(compiler, baselib);
}
parse_internal(compiler, compiler->scanner);
gc_unprotect(compiler->gc);
yylex_destroy(compiler->scanner);
}
/* Read an S-expression */
long
l_read(void)
{
long s, v, t;
char token[32];
char ch, i;
/* skip spaces */
if ((ch = skip_space()) < 0){ /* eof */
return TAG_EOF;
} else if (ch == ';'){ /* comment */
while (gchar() != '\n')
;
return -1;
}
#ifdef ZX81
else if (ch == '\"'){ /* quote macro */
#else
else if (ch == '\''){ /* quote macro */
#endif
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
t = l_cons(t, TAG_NIL);
s = l_cons((TAG_SYMB|KW_QUOTE), t);
} else if (ch != '('){ /* t, nil, symbol, or integer */
token[0] = ch;
for (i = 1; ; i++){
ch = gchar();
if (isspace(ch) || iscntrl(ch) || (ch < 0)
|| (ch == ';') || (ch == '(') || (ch == ')')){
ugchar(ch);
token[i] = '\0';
/* Changed to permint the definition of "1+" and "1-" */
if ((isdigit((char)token[0]) && (token[1] != '+') && (token[1] != '-'))
/* if (isdigit((char)token[0]) */
|| ((token[0] == '-') && isdigit((char)token[1]))
|| ((token[0] == '+') && isdigit((char)token[1]))){ /* integer */
s = int_make_l(atol(token));
#ifdef SCHEME
} else if (strcmp(token, "#f") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "#t") == 0){ /* t */
s = TAG_T;
#else
} else if (strcmp(token, "nil") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "t") == 0){ /* t */
s = TAG_T;
#endif
} else { /* symbol */
s = TAG_SYMB | symb_make(token);
}
break;
}
token[i] = ch;
}
} else /* ch == '(' */ { /* list */
if ((ch = skip_space()) < 0){
return err_msg(errmsg_eof, 0, 0);
} else if (ch == ')'){
s = TAG_NIL; /* "()" = nil */
} else {
ugchar(ch);
if ((t = l_read()) < 0)
return err_msg(errmsg_eof, 0, 0);
if (t == TAG_EOF)
return -1;
if ((s = v = l_cons(t, TAG_NIL)) < 0)
return -1;
if (gc_protect(s) < 0)
return -1;
for (;;){
if ((ch = skip_space()) < 0) /* look ahead next char */
return err_msg(errmsg_eof, 0, 0);
if (ch == ')')
break;
ugchar(ch);
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
if ((t = l_cons(t, TAG_NIL)) < 0)
return -1;
rplacd(v, t);
v = l_cdr(v);
}
gc_unprotect(s);
}
}
return s;
}
char
skip_space(void)
{
char ch;
for (;;){
if ((ch = gchar()) < 0)
return -1; /* end-of-file */
if (!isspace(ch) && !iscntrl(ch))
break;
}
return ch;
}
