static at *call_method(at *obj, struct hashelem *hx, at *args)
{
at *fun = hx->function;
assert(FUNCTIONP(fun));
if (Class(fun) == de_class) {
// DE
at *p = eval_arglist(args);
return with_object(obj, fun, p, hx->sofar);
} else if (Class(fun) == df_class) {
// DF
return with_object(obj, fun, args, hx->sofar);
} else if (Class(fun) == dm_class) {
// DM
at *p = new_cons(new_cons(fun, args), NIL);
at *q = with_object(obj, at_mexpand, p, hx->sofar);
return eval(q);
} else {
// DX, DY, DH
at *p = new_cons(fun, new_cons(obj, args));
return Class(fun)->listeval(fun, p);
}
}
void putmethod(class_t *cl, at *name, at *value)
{
ifn (SYMBOLP(name))
RAISEF("not a symbol", name);
if (value && !FUNCTIONP(value))
RAISEF("not a function", value);
clear_hashok(cl);
at **last = &(cl->methods);
at *list = *last;
while (CONSP(list)) {
at *q = Car(list);
ifn (CONSP(q))
RAISEF("not a pair", q);
if (Car(q) == name) {
if (value) {
/* replace */
Cdr(q) = value;
return;
} else {
/* remove */
*last = Cdr(list);
Cdr(list) = NIL;
return;
}
}
last = &Cdr(list);
list = *last;
}
/* not an existing method, append */
if (value)
*last = new_cons(new_cons(name, value), NIL);
}
cell_t *evaluate(cell_t *exp, environ_t *env) {
++__tl_eval_level;
// push a frame
eval_stack_t s;
s.next = eval_stack;
s.value = env;
eval_stack = &s;
if (DFLAG) {
printf("Eval (%d) got : ", __tl_eval_level);
pretty_print(exp);
}
if (NULL == exp) {
DRETURN(RET_VAL, NULL);
} else if (NILP(exp)) {
DRETURN(RET_VAL, nil_cell);
} else if (ATOMP(exp)) {
if (SYMBOLP(exp)) {
DRETURN(RET_VAL, find_value(env, exp));
} else if (STRINGP(exp) || NUMBERP(exp)) {
DRETURN(RET_VAL, exp);
} else {
DEBUGPRINT_("Expression not valid.\n");
pretty_print(orig_sexpr);
GOTO_TOPLEVEL();
return NULL; /* unreachable */
}
} else { /* list */
handle_t *he = handle_push(exp);
cell_t *first = evaluate(CAR(exp), env); // exp handled
exp = handle_get(he);
handle_pop(he);
cell_t *rest = CDR(exp);
if (DFLAG) {
printf("First is: ");
pretty_print(first);
printf("Rest is: ");
pretty_print(rest);
}
if (NULL == first) {
fast_error(" malformed expression.");
/* This is unreachable */
} else if (PRIMITIVEP(first)) {
cell_t *(*f)(cell_t *, environ_t *) = CELL_PRIMITIVE(first);
DRETURN(RET_PRIM, (*f)(rest, env));
} else if (FUNCTIONP(first)) { /* function call */
cell_t *t;
handle_t *hf;
hf = handle_push(first);
t = evargs(rest, env); // first handled
first = handle_get(hf);
handle_pop(hf);
DRETURN(RET_FUNCALL, invoke(first, t, env)); // no need for handles
}
undefun_error(first, exp); /* Not primitive or funcall, error.*/
return NULL; /* Unreachable, undefun_error() does not return. */
}
}