Exemple #1
0
int test_eval()
{
   symbol *sa = new_symbol("a");
   symbol *sb = new_symbol("b");
   symbol *sc = new_symbol("c");
   symbol *plus = new_symbol("+");

   prim_proc *proc = new_prim_proc(proc_plus_integer);

   integer *i10 = new_integer(10);
   integer *i20 = new_integer(20);
   integer *i30 = new_integer(30);
   integer *i60 = new_integer(60);

   list *vara = cons(sa, cons(sb, cons(sc, NULL)));
   list *val10 = cons(i10, cons(i20, cons(i30, NULL)));
   list *plus_i = cons(plus, val10);

   environment *env = NULL;

   env = extend_env(vara, val10, env);

   assert(generic_equal(eval(sa, env), i10));
   assert(generic_equal(eval(i10, env), i10));

   define_var_val(plus, proc, env);

   assert(generic_equal(car(list_of_values(val10, env)), i10));
   assert(generic_equal(eval(plus_i, env), i60)); 

   return 1;
   
}
Exemple #2
0
//one arg: ops
static cellpoint list_of_values(void)
{
	args_push(args_ref(1));
	reg = no_operands();
	if (is_true(reg)){
		reg = NIL;
	}else {
		//get the first operand
		args_push(args_ref(1));
		reg = first_operand();
		//eval the first operand with tail_context is a_false
		args_push(a_false);
		args_push(reg);
		reg = eval();
		stack_push(&vars_stack, reg);
		//eval the rest operands
		args_push(args_ref(1));
		reg = rest_operands();
		args_push(reg);
		reg = list_of_values();
		
		reg = cons(stack_pop(&vars_stack), reg);
	}
	args_pop(1);
	return reg;
}
Exemple #3
0
extern li_object *li_eval(li_object *exp, li_object *env) {
    li_object *seq, *proc, *args;
    int done;

    done = 0;
    while (!li_is_self_evaluating(exp) && !done) {
        li_stack_trace_push(exp);
        if (li_is_symbol(exp)) {
            exp = li_environment_lookup(env, exp);
            done = 1;
        } else if (li_is_quoted(exp)) {
            check_special_form(li_cdr(exp) && !li_cddr(exp), exp);
            exp = li_cadr(exp);
            done = 1;
        } else if (li_is_quasiquoted(exp)) {
            check_special_form(li_cdr(exp) && !li_cddr(exp), exp);
            exp = eval_quasiquote(li_cadr(exp), env);
            done = 1;
        } else if (li_is_application(exp)) {
            proc = li_eval(li_car(exp), env);
            args = li_cdr(exp);
            if (li_is_procedure(proc))
                args = list_of_values(args, env);
            if (li_is_lambda(proc)) {
                env = extend_environment(li_to_lambda(proc).vars, args,
                        li_to_lambda(proc).env);
                for (seq = li_to_lambda(proc).body; seq && li_cdr(seq);
                        seq = li_cdr(seq))
                    li_eval(li_car(seq), env);
                exp = li_car(seq);
            } else if (li_is_macro(proc)) {
                exp = expand_macro(proc, args);
            } else if (li_is_primitive_procedure(proc)) {
                exp = li_to_primitive_procedure(proc)(args);
                done = 1;
            } else if (li_is_special_form(proc)) {
                exp = li_to_special_form(proc)(args, env);
            } else {
                li_error("not applicable", proc);
            }
        } else {
            li_error("unknown expression type", exp);
        }
        li_stack_trace_pop();
    }
    return exp;
}
Exemple #4
0
static pSlipObject list_of_values(pSlip gd, pSlipObject exps, pSlipEnvironment env)
{
	if (is_no_operands(gd, exps) == S_TRUE)
	{
		return gd->singleton_EmptyList;
	}
	else
	{
		pSlipObject x;

		x = slip_eval(gd, first_operand(exps), env);
		if (x == NULL)
			x = gd->singleton_Nil;

		return cons(gd, x, list_of_values(gd, rest_operands(exps), env));
	}
}
Exemple #5
0
object *eval(object *exp, object *env) {

    object *procedure;
    object *arguments;
    object *result;
    bool tailcall = false;

    do {

        if (is_self_evaluating(exp))
            return exp;

        if (is_variable(exp))
            return lookup_variable_value(exp, env);

        if (is_quoted(exp))
            return text_of_quotation(exp);

        if (is_assignment(exp))
            return eval_assignment(exp, env);

        if (is_definition(exp))
            return eval_definition(exp, env);

        if (is_if(exp)) {
            exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
            tailcall = true;
            continue;
        }

        if (is_lambda(exp))
            return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);

        if (is_begin(exp)) {
            exp = begin_actions(exp);
            while (!is_last_exp(exp)) {
                eval(first_exp(exp), env);
                exp = rest_exps(exp);
            }
            exp = first_exp(exp);
            tailcall = true;
            continue;
        }

        if (is_cond(exp)) {
            exp = cond_to_if(exp);
            tailcall = true;
            continue;
        }

        if (is_let(exp)) {
            exp = let_to_application(exp);
            tailcall = true;
            continue;
        }

        if (is_and(exp)) {
            exp = and_tests(exp);
            if (is_empty(exp))
                 return make_boolean(true);
            while (!is_last_exp(exp)) {
                result = eval(first_exp(exp), env);
                if (is_false(result))
                    return result;
                exp = rest_exps(exp);
            }
            exp = first_exp(exp);
            tailcall = true;
            continue;
        }

        if (is_or(exp)) {
            exp = or_tests(exp);
            if (is_empty(exp)) {
                return make_boolean(false);
            }
            while (!is_last_exp(exp)) {
                result = eval(first_exp(exp), env);
                if (is_true(result))
                    return result;
                exp = rest_exps(exp);
            }
            exp = first_exp(exp);
            tailcall = true;
            continue;
        }

        if (is_application(exp)) {

            procedure = eval(operator(exp), env);
            arguments = list_of_values(operands(exp), env);

            if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
                exp = eval_expression(arguments);
                env = eval_environment(arguments);
                tailcall = true;
                continue;
            }

            if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
                procedure = apply_operator(arguments);
                arguments = apply_operands(arguments);
            }

            if (is_primitive_proc(procedure))
                return (procedure->data.primitive_proc.fn)(arguments);

            if (is_compound_proc(procedure)) {
                env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
                exp = make_begin(procedure->data.compound_proc.body);
                tailcall = true;
                continue;
            }

            return make_error(342, "unknown procedure type");
        } // is_application()

    } while (tailcall);

    fprintf(stderr, "cannot eval unknown expression type\n");
    exit(EXIT_FAILURE);
}
Exemple #6
0
object *list_of_values(object *exps, object *env) {
    return is_no_operands(exps) ?
        empty_list() :
        cons(eval(first_operand(exps), env), list_of_values(rest_operands(exps), env));
}
Exemple #7
0
static pSlipObject slip_eval(pSlip gd, pSlipObject exp, pSlipEnvironment env)
{
	pSlipObject proc;
	pSlipObject args;

	tailcall:
	if (is_self_evaluating(exp) == S_TRUE)
	{
		return exp;
	}
	else if (is_variable(exp) == S_TRUE)
	{
		return lookup_variable_value(gd, exp, env);
	}
	else if (is_quoted(gd, exp) == S_TRUE)
	{
		return text_of_quotation(exp);
	}
	else if (is_assignment(gd, exp) == S_TRUE)
	{
		return eval_assignment(gd, exp, env);
	}
	else if (is_definition(gd, exp) == S_TRUE)
	{
		return eval_definition(gd, exp, env);
	}
	else if (is_if(gd, exp) == S_TRUE)
	{
		exp = is_true(gd, slip_eval(gd, if_predicate(exp), env)) == S_TRUE ? if_consequent(exp) : if_alternative(gd, exp);
		goto tailcall;
	}
	else if (is_lambda(gd, exp) == S_TRUE)
	{
		return s_NewCompoundProc(gd, lambda_parameters(exp), lambda_body(exp), env);
	}
	else if (is_begin(gd, exp) == S_TRUE)
	{
		exp = begin_actions(exp);
		while (!is_last_exp(gd, exp))
		{
			slip_eval(gd, first_exp(exp), env);
			exp = rest_exps(exp);
		}
		exp = first_exp(exp);
		goto tailcall;
	}
	else if (is_cond(gd, exp) == S_TRUE)
	{
		exp = cond_to_if(gd, exp);
		goto tailcall;
	}
	else if (is_let(gd, exp) == S_TRUE)
	{
		exp = let_to_application(gd, exp);
		goto tailcall;
	}
	else if (is_application(exp) == S_TRUE)
	{
		proc = slip_eval(gd, slip_operator(exp), env);
		if (proc == NULL)
			return gd->singleton_False;

		if (proc->type == eType_PRIMITIVE_PROC || proc->type == eType_COMPOUND_PROC)
		{
			args = list_of_values(gd, operands(exp), env);
			if (args == NULL)
				return gd->singleton_False;

			if (sIsObject_PrimitiveProc(proc) == S_TRUE)
			{
				return proc->data.prim_proc.func(gd, args);
			}
			else if (sIsObject_CompoundProc(proc) == S_TRUE)
			{
				env = setup_environment(gd, proc->data.comp_proc.env, proc->data.comp_proc.params, args);
				exp = make_begin(gd, proc->data.comp_proc.code);
				goto tailcall;
			}
			else
			{
				throw_error(gd, "unknown procedure type\n");
				return gd->singleton_False;
			}
		}
		else
			return proc;
	}
	else
	{
		throw_error(gd, "cannot eval unknown expression type\n");
		return NULL;
	}

	throw_error(gd, "what??\n");
	return NULL;
}
Exemple #8
0
///////////////////////////////////////////////////////////////////
//eval
//requires two arguments:exp & tail_context
///////////////////////////////////////////////////////////////////
cellpoint eval(void)
{
	if (is_true(is_self_evaluating(args_ref(1)))){
		reg = args_ref(1);
	}else if (is_true(is_variable(args_ref(1)))){
		reg = args_ref(1);
		args_push(current_env);
		args_push(reg);
		reg = lookup_var_val();
	}else if (is_true(is_quoted(args_ref(1)))){
		args_push(args_ref(1));
		reg = quotation_text();
	}else if (is_true(is_assignment(args_ref(1)))){
		args_push(args_ref(1));
		reg = eval_assignment();
	}else if (is_true(is_definition(args_ref(1)))){
		args_push(args_ref(1));
		reg = eval_definition();
	}else if (is_true(is_if(args_ref(1)))){
		//eval if expression with the second argument (tail_context)
		reg = args_ref(1);
		args_push(args_ref(2));
		args_push(reg);
		reg = eval_if();
	}else if (is_true(is_lambda(args_ref(1)))){
		args_push(args_ref(1));
		reg = eval_lambda();
	}else if (is_true(is_begin(args_ref(1)))){
		args_push(args_ref(1));
		reg = begin_actions();
		//eval the actions of begin exp with the second argument (tail_context)
		args_push(args_ref(2));
		args_push(reg);
		reg = eval_sequence();
	}else if (is_true(is_cond(args_ref(1)))){
		args_push(args_ref(1));
		reg = cond_2_if();
		//eval the exp with the second argument (tail_context)
		args_push(args_ref(2));
		args_push(reg);
		reg = eval();
	}else if (is_true(is_and(args_ref(1)))){
		reg = args_ref(1);
		args_push(args_ref(2));
		args_push(reg);
		reg = eval_and();
	}else if (is_true(is_or(args_ref(1)))){
		reg = args_ref(1);
		args_push(args_ref(2));
		args_push(reg);
		reg = eval_or();
	}else if (is_true(is_let(args_ref(1)))){
		//convert let to combination
		args_push(args_ref(1));
		reg = let_2_combination();
		//evals the combination
		args_push(args_ref(2));
		args_push(reg);
		reg = eval();
	}else if (is_true(is_letstar(args_ref(1)))){
		//convert let* to nested lets
		args_push(args_ref(1));
		reg = letstar_2_nested_lets();
		//evals the nested lets
		args_push(args_ref(2));
		args_push(reg);
		reg = eval();
	}else if (is_true(is_application(args_ref(1)))){
		//computes operator
		args_push(args_ref(1));
		reg = operator();
		args_push(a_false);
		args_push(reg);
		reg = eval();
		stack_push(&vars_stack, reg);
		//computes operands
		args_push(args_ref(1));
		reg = operands();
		args_push(reg);
		reg = list_of_values();
		//calls apply with the second argument (tail_context)
		args_push(args_ref(2));
		args_push(reg);
		args_push(stack_pop(&vars_stack));
		reg = apply();
	}else {
		printf("Unknown expression type -- EVAL\n");
		error_handler();
	}
	args_pop(2);
	return reg;
}