static void handle_unset_oosvar(
unset_item_t* punset_item,
variables_t* pvars,
cst_outputs_t* pcst_outputs)
{
int all_non_null_or_error = TRUE;
sllmv_t* pmvkeys = evaluate_list(punset_item->pkeylist_evaluators, pvars, &all_non_null_or_error);
if (all_non_null_or_error)
mlhmmv_root_remove(pvars->poosvars, pmvkeys);
sllmv_free(pmvkeys);
}
Lexeme * evaluate_list(Lexeme * list, Lexeme * env) {
/* Evaluate items in a list and return the values
* in another list.
*/
if (list == NULL) {
return NULL;
}
else {
Lexeme * first = evaluate(car(list), env);
return expression_list_tree(first, evaluate_list(cdr(list), env));
}
}
// As with oosvars, unset removes the key. E.g. if 'v = { 1:2, 3:4 }' then
// 'unset v[1]' results in 'v = { 3:4 }'.
static void handle_unset_indexed_local_variable(
unset_item_t* punset_item,
variables_t* pvars,
cst_outputs_t* pcst_outputs)
{
int all_non_null_or_error = TRUE;
sllmv_t* pmvkeys = evaluate_list(punset_item->pkeylist_evaluators, pvars, &all_non_null_or_error);
if (all_non_null_or_error) {
local_stack_frame_t* pframe = local_stack_get_top_frame(pvars->plocal_stack);
// 'unset nonesuch[someindex]' requires the existence check first: else we'd be poking data
// into the absent-value stack-frame-index-0 slot.
mlhmmv_xvalue_t* pxval = local_stack_frame_ref_extended_from_indexed(pframe,
punset_item->local_variable_frame_relative_index, NULL);
if (pxval != NULL) {
mlhmmv_level_remove(pxval->pnext_level, pmvkeys->phead);
}
}
sllmv_free(pmvkeys);
}
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {
char comeback = 1;
while(comeback) {
comeback = 0;
if(is_self_evaluating(exp)) {
return exp;
}
if(list_begins_with(exp, quote_symbol)) {
return cadr(exp);
}
// (define... )
if(list_begins_with(exp, define_symbol)) {
object_t *var = cadr(exp);
// (define a b)
if(issymbol(var)) {
object_t *val = caddr(exp);
return define_var(env, var, val);
}
// (define (a ...) ...) TODO use scheme macro
if(ispair(var)) {
object_t *name = car(cadr(exp)),
*formals = cdr(cadr(exp)),
*body = cddr(exp),
*lambda = cons(lambda_symbol,
cons(formals, body));
exp = cons(define_symbol,
cons(name, cons(lambda, empty_list)));
comeback = 1;
continue;
}
fprintf(stderr, "Syntax error.\n");
exit(-1);
}
// (set! a b)
if(list_begins_with(exp, set_symbol)) {
object_t *var = cadr(exp);
object_t *val = caddr(exp);
return set_var(env, var, val);
}
// (if c a b)
if(list_begins_with(exp, if_symbol)) {
exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
comeback = 1;
continue;
}
// (cond ...)
if(list_begins_with(exp, cond_symbol)) {
object_t *tail = cons(void_symbol, empty_list);
object_t *ifs = tail; //empty_list;
object_t *rules = reverse_list(cdr(exp));
while(!isemptylist(rules)) {
object_t *rule = car(rules),
*condition = car(rule),
*consequence = cadr(rule);
if(isemptylist(consequence)) {
consequence = cons(void_obj, empty_list);
}
ifs = cons(if_symbol,
cons(condition,
cons(consequence,
cons(ifs, empty_list))));
rules = cdr(rules);
}
exp = ifs;
comeback = 1;
continue;
}
// (begin ...)
if(list_begins_with(exp, begin_symbol)) {
object_t *result = empty_list, *exps;
for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
result = eval(car(exps), env);
}
return result;
}
if(list_begins_with(exp, lambda_symbol)) {
object_t *fn = cons(begin_symbol,
cdr(cdr(exp)));
return make_compound_proc(empty_list, cadr(exp),
fn,
env);
}
// (let ...)
if(list_begins_with(exp, let_symbol)) {
//if(! issymbol(cadr(exp)))
object_t *bindings = cadr(exp);
object_t *body = cddr(exp);
object_t *formals = empty_list;
object_t *values = empty_list;
while(!isemptylist(bindings)) {
formals = cons(caar(bindings), formals);
values = cons(cadr(car(bindings)), values);
bindings = cdr(bindings);
}
exp = cons(cons(lambda_symbol, cons(formals, body)),
values);
comeback = 1;
continue;
}
if(issymbol(exp)) {
return var_get_value(env, exp);
}
if(ispair(exp)) {
object_t *exp_car = car(exp);
object_t *fn = eval(exp_car, env); //var_get_value(env, car);
if(!iscallable(fn)) {
fprintf(stderr, "object_t is not callable\n");
exit(-1);
}
object_t *args = cdr(exp);
object_t *evaluated_args = evaluate_list(env, args, empty_list);
if(isprimitiveproc(fn)) {
return fn->value.prim_proc.fn(evaluated_args);
} else if(iscompoundproc(fn)) {
object_t *fn_formals = fn->value.compound_proc.formals;
object_t *fn_body = fn->value.compound_proc.body;
object_t *fn_env = fn->value.compound_proc.env;
ARGS_EQ(evaluated_args, list_size(fn_formals));
exp = fn_body;
env = extend_environment(fn_formals, evaluated_args, fn_env);
comeback = 1;
continue;
}
assert(0);
}
}
fprintf(stderr, "Unable to evaluate expression: \n");
write(exp);
exit(-1);
}
