/* 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];
}
static int
l_f(hash_list h, unsigned x, unsigned y)
{
switch(h->new_class) {
case LIG_SIMPLE: {break;}
case LIG_LEFT_Z: {
h->new_class = LIG_PENDING;
h->lig_z = l_eval(h->lig_z, y);
h->new_class = LIG_SIMPLE;
break;
}
case LIG_RIGHT_Z: {
h->new_class = LIG_PENDING;
h->lig_z = l_eval(x, h->lig_z);
h->new_class = LIG_SIMPLE;
break;
}
case LIG_BOTH_Z: {
h->new_class = LIG_PENDING;
h->lig_z = l_eval(l_eval(x,h->lig_z), y);
h->new_class = LIG_SIMPLE;
break;
}
case LIG_PENDING: {
x_lig_cycle = x;
y_lig_cycle = y;
h->lig_z = CHAR_ERROR;
h->new_class = LIG_SIMPLE;
break;
}
default: {
internal_error_1("f (new_class=%d)", h->new_class);
}
}
return (h->lig_z);
}
void l_eval_path(const char *filename, LClosure *closure) {
FILE *fp = fopen(filename, "r");
if(fp == NULL) {
printf("An error occurred while opening the file %s.\n", filename);
exit(1);
}
LValue* f = l_value_new(L_STR_TYPE, closure);
f->core.str = make_stringbuf((char*)filename);
l_closure_set(closure, "-filename", f, true);
stringbuf *source = make_stringbuf("");
source->str = saferead(fp);
l_eval(source->str, filename, closure);
}
/* 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 */
}
}
/* Call a built-in function */
long
fcall(long f, long av[2]) /*, int n*/
{
long v, t;
long r, d;
switch (D_GET_DATA(f)){
case KW_RPLACA:
case KW_RPLACD:
case KW_CAR:
case KW_CDR:
if (D_GET_TAG(av[0]) != TAG_CONS)
return err_msg(errmsg_ill_type, 1, f);
break;
case KW_GT:
#ifndef MINIMALISTIC
case KW_LT:
case KW_GTE:
case KW_LTE:
case KW_REM:
#endif
if ((D_GET_TAG(av[0]) != TAG_INT) || (D_GET_TAG(av[1]) != TAG_INT))
return err_msg(errmsg_ill_type, 1, f);
break;
#ifndef MINIMALISTIC
case KW_ZEROP:
case KW_RAND:
case KW_INCR:
case KW_DECR:
if (D_GET_TAG(av[0]) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
break;
#endif
}
switch (D_GET_DATA(f)){
#ifndef MINIMALISTIC
case KW_LAMBDA:
return err_msg(errmsg_ill_call, 1, f);
break;
#endif
case KW_QUIT:
quit();
break;
case KW_EQ:
#ifndef MINIMALISTIC
case KW_EQMATH:
#endif
v = (av[0] == av[1]) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_EQUAL:
return l_equal(av[0], av[1]);
#endif
case KW_CONS:
v = l_cons(av[0], av[1]);
break;
case KW_RPLACA:
v = t_cons_car[D_GET_DATA(av[0])] = av[1];
break;
case KW_RPLACD:
v = t_cons_cdr[D_GET_DATA(av[0])] = av[1];
break;
case KW_CAR:
v = l_car(av[0]);
break;
case KW_CDR:
v = l_cdr(av[0]);
break;
case KW_NULL:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_CONSP:
return (D_GET_TAG(av[0]) == TAG_CONS) ? TAG_T : TAG_NIL;
case KW_SYMBP:
return (D_GET_TAG(av[0]) == TAG_SYMB) ? TAG_T : TAG_NIL;
case KW_NUMBERP:
v = (D_GET_TAG(av[0]) == TAG_INT) ? TAG_T : TAG_NIL;
break;
case KW_LIST:
v = av[0];
break;
case KW_NOT:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_READ:
v = l_read();
break;
case KW_EVAL:
v = l_eval(av[0]);
break;
case KW_PRINC:
v = l_print(av[0]);
break;
case KW_TERPRI:
printf("\n");
v = TAG_NIL;
break;
case KW_GC:
gcollect();
v = TAG_T;
break;
case KW_ADD:
for (r = 0, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r + int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_TIMES:
for (r = 1, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r * int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_SUB:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 0;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 0 - int_get_c(l_car(av[0]));
} else {
r = int_get_c(l_car(av[0]));
for (t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r - int_get_c(l_car(t));
}
}
v = int_make_l(r);
break;
case KW_QUOTIENT:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 1;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if ((d = int_get_c(l_car(av[0]))) == 0){
return err_msg(errmsg_zero_div, 1, f);
} if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 1 / d;
} else {
for (r = d, t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
if ((d = int_get_c(l_car(t))) == 0)
return err_msg(errmsg_zero_div, 1, f);
r = r / d;
}
}
v = int_make_l(r);
break;
case KW_GT:
v = (int_get_c(av[0]) > int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_DIVIDE:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = l_cons(int_make_l(r / d), int_make_l(r % d));
break;
case KW_LT:
v = (int_get_c(av[0]) < int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ATOM:
v = (D_GET_TAG(av[0]) != TAG_CONS) ? TAG_T : TAG_NIL;
break;
case KW_GTE:
v = (int_get_c(av[0]) >= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_LTE:
v = (int_get_c(av[0]) <= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ZEROP:
v = (int_get_c(av[0]) == 0) ? TAG_T : TAG_NIL;
break;
case KW_RAND:
v = int_make_l(rand() % int_get_c(av[0]));
break;
case KW_INCR:
v = int_make_l(int_get_c(av[0])+1);
break;
case KW_DECR:
v = int_make_l(int_get_c(av[0])-1);
break;
case KW_REM:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = int_make_l(r % d);
break;
#endif
}
return v;
}
/* Execute special form (defun, setq. etc... arguments are not evaluated) */
long
special(long f, long a)
{
long t, v, u;
int l, i;
switch (D_GET_DATA(f)){
case KW_DEFUN:
if (list_len(a) < 2)
return err_msg(errmsg_ill_syntax, 1, f);
#ifdef SCHEME
/* (define (func var1 varn) (func content)) */
v = l_car(a); /* function name */
v = l_car(v); /* list of function name, arg and function body */
if (D_GET_TAG(v) != TAG_SYMB)
return err_msg(errmsg_ill_syntax, 1, f);
t = l_cdr(v); /* list of function args */
l = list_len(t); /* #args */
a = l_cons( v, l_cons( l_cdr(l_car(a)) , l_cdr(a)));
#endif
/* (defun func (var1 varn) (func content)) */
v = l_car(a); /* function name */
if (D_GET_TAG(v) != TAG_SYMB)
return err_msg(errmsg_ill_syntax, 1, f);
t = l_cdr(a); /* list of function arg and function body */
l = list_len(l_car(t)); /* #args */
i = D_GET_DATA(v);
t_symb_fval[i] = t;
t_symb_ftype[i] = FTYPE(FTYPE_USER, l);
break;
case KW_SETQ:
t = l_car(a); /* symbol name */
if (D_GET_TAG(t) != TAG_SYMB)
return err_msg(errmsg_ill_type, 1, f);
if ((v = l_eval(l_car(l_cdr(a)))) < 0) /* value */
return -1;
t_symb_val[D_GET_DATA(t)] = v;
break;
case KW_QUOTE:
v = l_car(a);
break;
case KW_PROGN:
for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
}
break;
case KW_WHILE:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
if ((v = l_eval(l_car(a))) < 0)
return -1;
while (D_GET_TAG(v) != TAG_NIL) {
for (t = l_cdr(a); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
}
v = l_eval(l_car(a));
}
break;
#ifndef MINIMALISTIC
case KW_AND:
for (v = TAG_T, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
if (D_GET_TAG(t) == TAG_NIL)
break;
}
break;
#endif
case KW_OR:
for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if ((v = l_eval(l_car(t))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL)
break;
}
break;
case KW_COND:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
v = TAG_NIL;
for (t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
u = l_car(t);
if (D_GET_TAG(u) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
if ((v = l_eval(l_car(u))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL){
for (u = l_cdr(u); D_GET_TAG(u) == TAG_CONS; u = l_cdr(u)){
if ((v = l_eval(l_car(u))) < 0)
return -1;
}
break;
}
}
break;
#ifndef MINIMALISTIC
case KW_COMMENT:
v = TAG_T;
break;
#endif
case KW_IF:
if (D_GET_TAG(a) != TAG_CONS)
return err_msg(errmsg_ill_syntax, 1, f);
l = list_len(a);
if ((l == 2) || (l == 3)){
if ((v = l_eval(l_car(a))) < 0)
return -1;
if (D_GET_TAG(v) != TAG_NIL)
return l_eval(l_car(l_cdr(a)));
return (l == 2) ? TAG_NIL : l_eval(l_car(l_cdr(l_cdr(a))));
} else {
return err_msg(errmsg_ill_syntax, 1, f);
}
break;
}
return v;
}
/* Function application (user defined function) */
long
apply(long func, long aparams, int n)
{
long fdef, fbody, f, sym, a, v;
int i;
#ifdef ZX81
/*
..almost useless, let's save space
#asm
ld hl,0
add hl,sp
ld (__sp),hl
#endasm
if (200 + &t_stack[t_stack_ptr]>=_sp)
return err_msg(errmsg_stack_of, 0, 0);
*/
#else
if (t_stack_ptr + n > STACK_SIZE) /* stack overflow */
return err_msg(errmsg_stack_of, 0, 0);
#endif
if (D_GET_TAG(func) == TAG_SYMB){ /* function symbol */
fdef = t_symb_fval[D_GET_DATA(func)];
} else if (D_GET_TAG(func) == TAG_CONS){ /* lambda exp */
fdef = func;
}
/* bind */
f = l_car(fdef); /* formal parameters */
a = aparams; /* actual parameters */
t_stack_ptr = t_stack_ptr + n;
for (i = 0; i < n; i++, f = l_cdr(f), a = l_cdr(a)){
sym = l_car(f);
/* push old symbol values onto stack */
t_stack[t_stack_ptr - i - 1] = t_symb_val[D_GET_DATA(sym)];
/* bind argument value to symbol */
t_symb_val[D_GET_DATA(sym)] = l_car(a);
}
if (gc_protect(aparams) < 0)
return -1;
/* evaluate function body */
fbody = l_cdr(fdef); /* function body */
for (v = TAG_NIL; D_GET_TAG(fbody) == TAG_CONS; fbody = l_cdr(fbody)){
if ((v = l_eval(l_car(fbody))) < 0)
break; /* error ... never return immediately - need unbinding. */
}
/* pop gc_protected objects, including 'gc_unprotect(aparams)'. */
while ((t_stack[t_stack_ptr-1] & D_GC_MARK) != 0)
--t_stack_ptr;
/* unbind: restore old variable values from stack */
for (i = 0, f = l_car(fdef); i < n; i++, f = l_cdr(f)){
sym = l_car(f);
t_symb_val[D_GET_DATA(sym)] = t_stack[t_stack_ptr - i - 1];
}
t_stack_ptr = t_stack_ptr - n;
return v;
}
