Ejemplo n.º 1
0
/////////////////////////////////////////////////////////////
//apply
//requires three arguments:proc , args & tail_context
////////////////////////////////////////////////////////////
cellpoint apply(void)
{
	if (is_true(is_prim_proc(args_ref(1)))){
		reg = args_ref(1);
		args_push(args_ref(2));
		args_push(reg);
		reg = apply_prim_proc();
	}else if (is_true(is_compound_proc(args_ref(1)))){
		//if this application isn't in a tail context,
		//then store the current_env
		if (is_false(args_ref(3))){
			stack_push(&env_stack, current_env);
		}
		/*for test
		  test the tail recursion
		 */
//		printf("call ");
//		write(args_ref(1));
//		newline();
//		args_push(env_stack);
//		printf("the length of env_stack: %d\n", get_integer(list_len()));
		//calls procedure_parameters
		args_push(args_ref(1));
		reg = procedure_parameters();
		stack_push(&vars_stack, reg);
		//calls procedure_env
		args_push(args_ref(1));
		reg = procedure_env();
		//calls extend_env
		stack_push(&vars_stack, args_ref(2));
		args_push(reg);
		args_push(stack_pop(&vars_stack));
		args_push(stack_pop(&vars_stack));
		current_env = extend_env();
		//calls procedure_body
		args_push(args_ref(1));
		reg = procedure_body();
		//calls eval_lambda_body
		args_push(reg);
		reg = eval_lambda_body();
		//if this application isn't in tail context,
		//then restore the stored current_env
		if (is_false(args_ref(3))){
			current_env = stack_pop(&env_stack);
		}
	}else {
		printf("Unknown procedure : ");
		write(args_ref(1));
		newline();
		error_handler();
	}
	args_pop(3);
	return reg;
}
Ejemplo n.º 2
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);
}
Ejemplo n.º 3
0
Archivo: eval.c Proyecto: ingramj/bs
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");
    }
}
Ejemplo n.º 4
0
object *is_procedure_proc(object *arguments) {
    object *obj;
    obj = car(arguments);
    return make_boolean((is_primitive_proc(obj) || is_compound_proc(obj)));
}