/* Evaluate an S-expression */
long
l_eval(long s)
{
long v, f, a, av[2];
int n;
switch(D_GET_TAG(s)){
case TAG_NIL: /* self-evaluating objects */
case TAG_T:
case TAG_INT:
v = s;
break;
case TAG_SYMB: /* symbol ... refer to the symbol table */
if ((v = t_symb_val[D_GET_DATA(s)]) == TAG_UNDEF)
return err_msg(errmsg_sym_undef, 1, s);
break;
case TAG_CONS: /* cons ... function call */
f = l_car(s); /* function name or lambda exp */
a = l_cdr(s); /* actual argument list */
#ifndef minimalistic
if ((D_GET_TAG(f) == TAG_CONS) && (D_GET_TAG(l_car(f)) == TAG_SYMB)
&& ((D_GET_DATA(l_car(f)) == KW_LAMBDA))){ /* lambda exp */
if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
return -1;
v = apply(l_cdr(f), av[0], list_len(l_car(l_cdr(f))));
} else
#endif
if (D_GET_TAG(f) == TAG_SYMB){
n = FTYPE_GET_NARGS(t_symb_ftype[D_GET_DATA(f)]);
switch (FTYPE_GET_TYPE(t_symb_ftype[D_GET_DATA(f)])){
case FTYPE_UNDEF:
return err_msg(errmsg_func_undef, 1, f);
case FTYPE_SPECIAL:
v = special(f, a);
break;
case FTYPE_SYS:
if (eval_args(f, a, av, n) < 0)
return -1;
v = fcall(f, av/*, n*/);
break;
case FTYPE_USER:
if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
return -1;
v = apply(f, av[0], n);
}
} else {
return err_msg(errmsg_ill_call, 1, s);
}
break;
}
return v;
}
/* 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];
}
/* Length of a list */
int
list_len(long s)
{
int i;
for (i = 0; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s))
i++;
return i;
}
/* mark recursively */
void
gc_mark(long s)
{
for ( ; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s)){
if ((t_cons_car[D_GET_DATA(s)] & D_GC_MARK) != 0) /* visited before */
return;
t_cons_car[D_GET_DATA(s)] |= D_GC_MARK; /* mark */
gc_mark(l_car(s)); /* visit car part */
}
}
Term *
func_op_names(TermList terms)
{
Term *ops_t;
ops_t = (Term *)get_list_pos(terms, 1);
if (! ops_t ) {
report_fatal_external_error((char *)"Cannot retrieve OP instance term");
}
if (ops_t->type != LISP_LIST) {
report_fatal_external_error((char *)"Term is not of type LISP_LIST");
}
TermList name_list = sl_make_slist();
for (L_List p_l = ops_t->u.l_list; p_l; p_l = l_cdr(p_l)) {
Term *t = l_car(p_l);
if (t->type == TT_INTENTION) {
Op_Instance *opi = (Op_Instance *)(t->u.in->top_op);
Op_Structure *op_s = op_instance_op(opi);
name_list = build_term_list(name_list, build_id(op_name(op_s)));
} else if (t->type == TT_OP_INSTANCE) {
Op_Instance *opi = (Op_Instance *)(t->u.opi);
Op_Structure *op_s = op_instance_op(opi);
if (! op_s) {
name_list = build_term_list(name_list, build_id(declare_atom("NOT-AN-OP")));
} else {
name_list = build_term_list(name_list, build_id(op_name(op_s)));
}
} else {
name_list = build_term_list(name_list, build_id(declare_atom("NOT-AN-OP-INSTANCE")));
}
}
return build_term_l_list_from_c_list(name_list);
}
/* 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;
}
/* Print an S-expression */
long
l_print(long s)
{
long v, t;
int i;
switch(D_GET_TAG(s)){
#ifdef SCHEME
case TAG_NIL:
printf("#f");
break;
case TAG_T:
printf("#t");
break;
#else
case TAG_NIL:
printf("nil");
break;
case TAG_T:
printf("t");
break;
#endif
case TAG_INT:
v = int_get_c(s);
printf("%ld", v);
break;
case TAG_SYMB:
i = s & D_MASK_DATA;
printf("%s", t_symb_pname[i]);
break;
case TAG_EOF:
printf("<eof>");
break;
case TAG_UNDEF: /* for debugging */
printf("<undefined>");
break;
case TAG_CONS:
printf("(");
t = s;
l_print(l_car(t));
while (D_GET_TAG(l_cdr(t)) == TAG_CONS) {
printf(" ");
t = l_cdr(t);
l_print(l_car(t));
}
if (D_GET_TAG(l_cdr(t)) != TAG_NIL){
printf(" . ");
l_print(l_cdr(t));
}
printf(")");
break;
}
return TAG_T;
}
/* 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;
}
/* 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;
}