/* 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; }