/* Put all primitive procedures from table to environment */ static void init_primitive_procedures(env_hashtable *env) { int i; object *t; for (i = 0; proc_init_table[i].value; i++) { t = primitive_procedure(proc_init_table[i].value); env_hashtable_insert(env, proc_init_table[i].key, t); } }
/* Apply procedure */ object *apply(object *proc, object *args) { primitive_proc p; env_hashtable *e; object *params, *param, *arg; char *s_param; if (TYPE(proc) == OBJ_PRIMITIVE_PROCEDURE) { p = PROC(proc); return p(args); } else if (TYPE(proc) == OBJ_COMPOUND_PROCEDURE) { e = env_hashtable_child(CPROC_ENV(proc)); params = CPROC_PARAMS(proc); while (params != null_object) { if (TYPE(params) != OBJ_PAIR) { param = params; arg = args; } else { param = CAR(params); arg = CAR(args); } s_param = STR(param); env_hashtable_insert(e, s_param, arg); if (TYPE(params) != OBJ_PAIR) break; params = CDR(params); args = CDR(args); } return eval(CPROC_BODY(proc), e); } return NULL; }
/* Evaluate object * NULL return value means Nothing */ object *eval(object *obj, env_hashtable *env) { object *cur, *eobj, *last_pair, *t, *ecar, *ecdr; if (!obj) return NULL; /* Detect syntatic construction */ if (TYPE(obj) == OBJ_PAIR && TYPE(CAR(obj)) == OBJ_SYMBOL) { t = CAR(obj); if (strcmp("lambda", STR(t)) == 0) { t = CDDR(obj); t = cons(symbol("begin"), t); eobj = compound_procedure(CADR(obj), t, env); return eobj; } else if (strcmp("define", STR(t)) == 0) { eobj = eval(CADDR(obj), env); env_hashtable_insert(env, STR(CADR(obj)), eobj); return NULL; /* Not error, just nothing */ } else if (strcmp("begin", STR(t)) == 0) { obj = CDR(obj); eobj = NULL; /* Not error, just nothing */ while (obj != null_object) { eobj = eval(CAR(obj), env); obj = CDR(obj); } return eobj; } else if (strcmp("apply", STR(t)) == 0) { eobj = eval(CADR(obj), env); t = eval(CADDR(obj), env); return apply(eobj, t); } else if (strcmp("quote", STR(t)) == 0) { return CADR(obj); } } /* Object evaluation */ switch (TYPE(obj)) { case OBJ_NUMBER: case OBJ_BOOLEAN: return obj; case OBJ_SYMBOL: return env_hashtable_find(env, STR(obj)); case OBJ_PAIR: cur = obj; eobj = null_object; last_pair = NULL; while (cur != null_object && TYPE(cur) == OBJ_PAIR) { t = cons(eval(CAR(cur), env), null_object); if (!last_pair) eobj = t; else CDR(last_pair) = t; last_pair = t; cur = CDR(cur); } ecar = CAR(eobj); ecdr = CDR(eobj); return apply(ecar, ecdr); default: return NULL; } }