Пример #1
0
object_t apply(object_t p, object_t argl) {
  proc_t proc = obj_get_proc(p);
  if(isprimitiveproc(proc)) /* primitive procedure */
    return (proc->fn)(argl);
  else {
    object_t extended = extend_environment(lambda_params(p), argl, lambda_env(p));
    return eval_sequence(lambda_body(p), &extended);
  }
}
Пример #2
0
static bool is_self_evaluating(object_t *obj) {
    return isfixnum(obj) || isboolean(obj) || ischaracter(obj) ||
        isstring(obj) || isprimitiveproc(obj);
}
Пример #3
0
//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);
}