Exemple #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);
  }
}
Exemple #2
0
//one arg: exp
static cellpoint eval_lambda(void)
{
	args_push(args_ref(1));
	reg = lambda_parameters();
	stack_push(&vars_stack, reg);
	args_push(args_ref(1));
	reg = lambda_body();
	stack_push(&vars_stack, reg);
	//make a compound procedure object
	args_push(current_env);
	args_push(stack_pop(&vars_stack));
	args_push(stack_pop(&vars_stack));
	reg = make_procedure();
	args_pop(1);
	return reg;
}
Exemple #3
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 #4
0
object *bs_eval(object *exp, object *env)
{
tailcall:
    if (is_empty_list(exp)) {
        error("unable to evaluate empty list");
    } else if (is_self_evaluating(exp)) {
        return exp;
    } else if (is_variable(exp)) {
        return lookup_variable_value(exp, env);
    } else if (is_quoted(exp)) {
        return quoted_expression(exp);
    } else if (is_assignment(exp)) {
        return eval_assignment(exp, env);
    } else if (is_definition(exp)) {
        return eval_definition(exp, env);
    } else if (is_if(exp)) {
        if (is_true(bs_eval(if_predicate(exp), env))) {
            exp = if_consequent(exp);
        } else {
            exp = if_alternate(exp);
        }
        goto tailcall;
    } else if (is_lambda(exp)) {
        return make_compound_proc(lambda_parameters(exp),
                lambda_body(exp),
                env);
    } else if (is_begin(exp)) {
        exp = begin_actions(exp);
        if (is_empty_list(exp)) {
            error("empty begin block");
        }
        while (!is_empty_list(cdr(exp))) {
            bs_eval(car(exp), env);
            exp = cdr(exp);
        }
        exp = car(exp);
        goto tailcall;
    } else if (is_cond(exp)) {
        exp = cond_to_if(exp);
        goto tailcall;
    } else if (is_let(exp)) {
        exp = let_to_application(exp);
        goto tailcall;
    } else if (is_and(exp)) {
        exp = and_tests(exp);
        if (is_empty_list(exp)) {
            return get_boolean(1);
        }
        object *result;
        while (!is_empty_list(cdr(exp))) {
            result = bs_eval(car(exp), env);
            if (is_false(result)) {
                return result;
            }
            exp = cdr(exp);
        }
        exp = car(exp);
        goto tailcall;
    } else if (is_or(exp)) {
        exp = or_tests(exp);
        if (is_empty_list(exp)) {
            return get_boolean(0);
        }
        object *result;
        while (!is_empty_list(cdr(exp))) {
            result = bs_eval(car(exp), env);
            if (is_true(result)) {
                return result;
            }
            exp = cdr(exp);
        }
        exp = car(exp);
        goto tailcall;
    } else if (is_application(exp)) {
        object *procedure = bs_eval(application_operator(exp), env);
        object *parameters = eval_parameters(application_operands(exp), env);

        // handle eval specially for tailcall requirement.
        if (is_primitive_proc(procedure) &&
                procedure->value.primitive_proc == eval_proc) {
            exp = eval_expression(parameters);
            env = eval_environment(parameters);
            goto tailcall;
        }

        // handle apply specially for tailcall requirement.
        if (is_primitive_proc(procedure) &&
                procedure->value.primitive_proc == apply_proc) {
            procedure = apply_operator(parameters);
            parameters = apply_operands(parameters);
        }

        if (is_primitive_proc(procedure)) {
            return (procedure->value.primitive_proc)(parameters);
        } else if (is_compound_proc(procedure)) {
            env = extend_environment(
                    procedure->value.compound_proc.parameters,
                    parameters,
                    procedure->value.compound_proc.env);
            exp = make_begin(procedure->value.compound_proc.body);
            goto tailcall;
        } else {
            error("unable to apply unknown procedure type");
        }
    } else {
        error("unable to evaluate expression");
    }
}
Exemple #5
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;
}