struct lispobj *apply(struct lispobj *proc, struct lispobj *args)
{
if(proc != NULL && OBJ_TYPE(proc) == CONS) {
struct lispobj *ret;
if(NEW_SYMBOL("SUBR") == CAR(proc)) {
/* Apply primitive function. */
struct lispobj *body, *(*subr)(struct lispobj *);
body = CADR(proc);
subr = (struct lispobj *) NUMBER_VALUE(body);
//subr = (struct lispobj *) body;
ret = heap_grab(subr(args));
} else if(NEW_SYMBOL("PROC") == CAR(proc)) {
/* Apply user defined procedure. */
struct lispobj *body, *params, *penv;
body = CADDR(proc);
params = CADR(proc);
penv = CADDDR(proc);
if(length(params) == length(args)) {
struct lispobj *env;
if(params == NULL || params == NEW_SYMBOL("NIL")) {
env = penv;
ret = eval_progn(body, env);
} else {
env = heap_grab(NEW_CONS(env_frame_make(params, args), penv));
ret = eval_progn(body, env);
heap_release(env);
}
} else {
char error[64];
snprintf(error,
64,
"Has recieved wrong number of parameters: %d.\n",
length(args));
ret = heap_grab(NEW_ERROR(error));
}
} else {
goto error;
}
return ret;
}
error:
return heap_grab(NEW_ERROR("Unknown procedure.\n"));
}
static struct lispobj *eval_progn(struct lispobj *exps, struct lispobj *env)
{
if(exps == NULL) {
return exps;
} else if(CDR(exps) == NULL) {
return eval(CAR(exps), env);
} else {
eval(CAR(exps), env);
return eval_progn(CDR(exps), env);
}
}
struct lispobj *eval(struct lispobj *obj, struct lispobj *env)
{
struct lispobj *ret;
if(obj == NULL || OBJ_TYPE(obj) == NUMBER ||
OBJ_TYPE(obj) == ERROR || OBJ_TYPE(obj) == STRING) {
/* Return self-evaluating object. */
ret = heap_grab(obj);
} else if(OBJ_TYPE(obj) == SYMBOL) {
/* Lookup value of the variable in the env. */
struct lispobj *val;
val = env_var_lookup(obj, env);
if(OBJ_TYPE(val) == ERROR) {
ret = heap_grab(val);
} else {
ret = heap_grab(CDR(val));
}
} else if(NEW_SYMBOL("QUOTE") == CAR(obj)) {
/* (quote whatever) */
if(length(obj) != 2) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Return quoted object. */
ret = heap_grab(CADR(obj));
}
#ifdef __DEBUG_GC__
printf("eval quote debug:");
heap_debug_object(ret);
printf("\n");
#endif
} else if(NEW_SYMBOL("SETQ") == CAR(obj)) {
/* (setq var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to assign existing variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_assign(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("LABEL") == CAR(obj)) {
/* (label var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to define new variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_define(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("IF") == CAR(obj)) {
/* (if predicate consequence alternative) */
if(length(obj) != 4) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Invoke condition function. */
struct lispobj *pred;
pred = eval(CADR(obj), env);
if(pred != NULL && OBJ_TYPE(pred) == ERROR) {
ret = pred;
} else {
if(pred) {
/* Eval consequence. */
ret = eval(CADDR(obj), env);
} else {
/* Eval alternative. */
ret = eval(CADDDR(obj), env);
}
heap_release(pred);
}
}
} else if(NEW_SYMBOL("COND") == CAR(obj)) {
/* (cond (cond1 ret1) (cond2 ret2)) */
if(length(obj) < 2) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_cond(CDR(obj), env);
}
}
else if(NEW_SYMBOL("LET") == CAR(obj)) {
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_let(CDR(obj), env);
}
} else if(NEW_SYMBOL("PROGN") == CAR(obj)) {
ret = eval_progn(CDR(obj), env);
} else if(NEW_SYMBOL("LAMBDA") == CAR(obj)) {
/* (lambda (var) (proc var var)) */
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Make and return new procedure. */
ret = heap_grab(env_proc_make(CADR(obj), CDDR(obj), env));
}
} else {
/* Apply case. */
struct lispobj *proc = eval(CAR(obj), env);
if(proc != NULL && OBJ_TYPE(proc) == ERROR) {
ret = proc;
} else {
struct lispobj *args = heap_grab(env_val_list(CDR(obj), env));
if(args != NULL && OBJ_TYPE(args) == ERROR) {
ret = args;
} else {
ret = apply(proc, args);
heap_release(args);
}
heap_release(proc);
}
}
return ret;
}
obj apply_internal (obj fn, obj args)
{
switch (get_type (fn))
{
case rom_symbol_type:
{
const rom_object *p = get_rom_header (fn);
built_in_fn f = (built_in_fn) pgm_read_word_near (&p -> global_fn);
if (! f)
throw_error (no_fdefn);
obj argv = make_argv (args, pgm_read_byte_near (&p -> is_fexpr));
objhdr *argv_hdr = get_header (argv);
argv_hdr -> flags |= gc_fixed;
obj res = f (argv);
argv_hdr -> flags &= ~ gc_fixed;
return (res);
}
case symbol_type:
{
objhdr *fn_hdr = get_header (fn);
fn = fn_hdr -> u.symbol_val.global_fn;
if (! fn)
throw_error (no_fdefn);
// fall through to "apply closure"
}
case closure_type:
{
objhdr *fn_hdr = get_header (fn);
obj code = fn_hdr -> u.closure_val.code;
obj new_env;
{
obj type_sym, params;
decons (code, &type_sym, &code);
decons (code, ¶ms, &code);
if (type_sym == obj_LAMBDA)
new_env = make_lambda_binding (params, args);
else
new_env = make_fexpr_binding (params, args);
}
if (new_env)
{
objhdr *env_hdr = NULL;
env_hdr = get_header (new_env);
env_hdr -> u.array_val [1] = fn_hdr -> u.closure_val.environment;
}
else
new_env = fn_hdr -> u.closure_val.environment;
bool unprotect = save_env ();
obj keep_env = current_environment;
current_environment = new_env;
obj res = eval_progn (code, obj_NIL);
current_environment = keep_env;
if (unprotect)
get_header (current_environment) -> flags &= ~gc_fixed;
return (res);
}
default:
return (obj_NIL);
}
}
