virtual action_result resolve(expr const & pr) const override {
try {
expr it = pr;
bool skip = true;
for (unsigned i = 0; i < m_num_new_eqs; i++) {
if (!is_lambda(it)) {
break;
skip = false;
}
it = binding_body(it);
}
if (skip && closed(it)) {
// new eq hypotheses were not used
return action_result::solved(it);
}
state & s = curr_state();
app_builder & b = get_app_builder();
hypothesis const & h = s.get_hypothesis_decl(href_index(m_eq_href));
expr type = h.get_type();
expr lhs, rhs;
lean_verify(is_eq(type, lhs, rhs));
name nc_name(m_I_name, "no_confusion");
expr new_pr = mk_app(b.mk_app(nc_name, {m_target, lhs, rhs, m_eq_href}), pr);
return action_result::solved(new_pr);
} catch (app_builder_exception &) {
return action_result::failed();
}
}
thing_th *funky_callable(thing_th *args) {
while(args) {
if(!is_lambda(Car(args)))
return NULL;
args=Cdr(args);
}
return lookup_txt("true");
}
optional<expr> expand_core(expr const & e) {
lean_assert(!is_lambda(e));
expr t = ctx().whnf(ctx().infer(e));
if (!is_pi(t))
return none_expr();
expr r = mk_lambda(name("x"), binding_domain(t), mk_app(e, mk_var(0)));
return some_expr(visit(r));
}
virtual expr visit_local(expr const & e) override {
auto fnidx = get_fn_idx(e);
if (!fnidx) return replace_visitor_with_tc::visit_local(e);
expr new_fn = m_ues.get_fn(*fnidx);
if (e == new_fn) return replace_visitor_with_tc::visit_local(e);
unsigned arity = m_ues.get_arity_of(*fnidx);
if (0 < arity) {
expr new_e = m_ctx.eta_expand(e);
if (!is_lambda(new_e)) throw_ill_formed_eqns();
return visit(new_e);
}
return new_fn;
}
void visit_binding(expr const & _e) {
if (should_visit(_e)) {
buffer<expr> ls;
expr e = _e;
while (is_lambda(e) || is_pi(e)) {
expr d = instantiate_rev(binding_domain(e), ls.size(), ls.data());
expr l = mk_local(mk_fresh_name(), binding_name(e), d, binding_info(e));
ls.push_back(l);
e = binding_body(e);
}
visit(instantiate_rev(e, ls.size(), ls.data()));
}
}
/* Return new minor premise and a flag indicating whether the body is unreachable or not */
pair<expr, bool> visit_minor_premise(expr e, buffer<bool> const & rel_fields) {
type_context::tmp_locals locals(ctx());
for (unsigned i = 0; i < rel_fields.size(); i++) {
lean_assert(is_lambda(e));
if (rel_fields[i]) {
expr l = locals.push_local_from_binding(e);
e = instantiate(binding_body(e), l);
} else {
e = instantiate(binding_body(e), mk_neutral_expr());
}
}
e = visit(e);
bool unreachable = is_unreachable_expr(e);
return mk_pair(locals.mk_lambda(e), unreachable);
}
expr pack(unsigned i, unsigned arity, buffer<expr> const & args, expr const & type) {
lean_assert(arity > 0);
if (i == arity - 1) {
return args[i];
} else {
lean_assert(is_constant(get_app_fn(type), get_psigma_name()));
expr a = args[i];
expr A = app_arg(app_fn(type));
expr B = app_arg(type);
lean_assert(is_lambda(B));
expr new_type = instantiate(binding_body(B), a);
expr b = pack(i+1, arity, args, new_type);
bool mask[2] = {true, true};
expr AB[2] = {A, B};
return mk_app(mk_app(m_ctx, get_psigma_mk_name(), 2, mask, AB), a, b);
}
}
virtual expr visit_app(expr const & e) override {
expr const & fn = get_app_fn(e);
if (!is_constant(fn))
return default_visit_app(e);
name const & n = const_name(fn);
if (is_vm_builtin_function(n))
return default_visit_app(e);
if (is_cases_on_recursor(env(), n) || is_nonrecursive_recursor(n))
return visit_cases_on_app(e);
unsigned nargs = get_app_num_args(e);
declaration d = env().get(n);
if (!d.is_definition() || d.is_theorem())
return default_visit_app(e);
expr v = d.get_value();
unsigned arity = 0;
while (is_lambda(v)) {
arity++;
v = binding_body(v);
}
if (arity > nargs) {
// not fully applied
return default_visit_app(e);
}
if (is_inline(env(), n) || is_simple_application(v)) {
if (auto r = unfold_term(env(), e))
return visit(*r);
}
/*
TODO(Leo): this is not safe here.
Reason: we may put recursors have have been eliminated in previous steps.
We need to move this code to a different place, or make sure
that we can recursors will be eliminated later
if (auto r = ctx().reduce_projection(e)) {
return visit(*r);
}
*/
return default_visit_app(e);
}
/* Given a cases_on application, distribute extra arguments over minor premisses.
cases_on major minor_1 ... minor_n a_1 ... a_n
We apply a similar transformation at erase_irrelevant, but its effect can be undone
in subsequent compilation steps.
*/
void distribute_extra_args_over_minors(name const & I_name, buffer<name> const & cnames, buffer<expr> & args) {
lean_assert(args.size() > cnames.size() + 1);
unsigned nparams = *inductive::get_num_params(env(), I_name);
for (unsigned i = 0; i < cnames.size(); i++) {
unsigned carity = get_constructor_arity(env(), cnames[i]);
unsigned data_sz = carity - nparams;
type_context::tmp_locals locals(ctx());
expr new_minor = args[i+1];
for (unsigned j = 0; j < data_sz; j++) {
if (!is_lambda(new_minor))
throw exception("unexpected occurrence of 'cases_on' expression, "
"the minor premise is expected to be a lambda-expression");
expr local = locals.push_local_from_binding(new_minor);
new_minor = instantiate(binding_body(new_minor), local);
}
new_minor = beta_reduce(mk_app(new_minor, args.size() - cnames.size() - 1, args.data() + cnames.size() + 1));
args[i+1] = locals.mk_lambda(new_minor);
}
args.shrink(cnames.size() + 1);
}
virtual expr visit_app(expr const & e) override {
buffer<expr> args;
expr const & fn = get_app_args(e, args);
for (expr & arg : args)
arg = visit(arg);
auto fnidx = get_fn_idx(fn);
if (!fnidx) return replace_visitor_with_tc::visit_app(e);
expr new_fn = m_ues.get_fn(*fnidx);
if (fn == new_fn) return replace_visitor_with_tc::visit_app(e);
unsigned arity = m_ues.get_arity_of(*fnidx);
if (args.size() < arity) {
expr new_e = m_ctx.eta_expand(e);
if (!is_lambda(new_e)) throw_ill_formed_eqns();
return visit(new_e);
}
expr new_fn_type = m_ctx.infer(new_fn);
expr sigma_type = binding_domain(new_fn_type);
expr arg = pack(0, arity, args, sigma_type);
expr r = mk_app(new_fn, arg);
return copy_tag(e, mk_app(r, args.size() - arity, args.data() + arity));
}
expr compiler_step_visitor::visit_lambda_let(expr const & e) {
type_context::tmp_locals locals(m_ctx);
expr t = e;
while (true) {
/* Types are ignored in compilation steps. So, we do not invoke visit for d. */
if (is_lambda(t)) {
expr d = instantiate_rev(binding_domain(t), locals.size(), locals.data());
locals.push_local(binding_name(t), d, binding_info(t));
t = binding_body(t);
} else if (is_let(t)) {
expr d = instantiate_rev(let_type(t), locals.size(), locals.data());
expr v = visit(instantiate_rev(let_value(t), locals.size(), locals.data()));
locals.push_let(let_name(t), d, v);
t = let_body(t);
} else {
break;
}
}
t = instantiate_rev(t, locals.size(), locals.data());
t = visit(t);
return copy_tag(e, locals.mk_lambda(t));
}
data_t *eval(const data_t *exp, data_t *env) {
if(eval_plz_die) {
eval_plz_die = 0;
ExitThread(0);
}
if(is_self_evaluating(exp))
return (data_t*)exp;
if(is_variable(exp))
return lookup_variable_value(exp, env);
if(is_quoted_expression(exp))
return get_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))
return eval_if(exp, env);
if(is_lambda(exp))
return make_procedure(get_lambda_parameters(exp), get_lambda_body(exp), env);
if(is_begin(exp))
return eval_sequence(get_begin_actions(exp), env);
if(is_cond(exp))
return eval(cond_to_if(exp), env);
if(is_letrec(exp))
return eval(letrec_to_let(exp), env);
if(is_let_star(exp))
return eval(let_star_to_nested_lets(exp), env);
if(is_let(exp))
return eval(let_to_combination(exp), env);
if(is_application(exp))
return apply(
eval(get_operator(exp), env),
get_list_of_values(get_operands(exp), env));
printf("Unknown expression type -- EVAL '");
return make_symbol("error");
}
///////////////////////////////////////////////////////////////////
//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;
}
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);
}
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;
}
Value * evaluate(Environment *env, Value *expr) {
EvaluationContext *ctx;
Value *temp, *result;
Value *operator;
Value *operand_val, *operand_cons;
Value *operands, *operands_end, *nil_value;
int num_operands;
/* Set up a new evaluation context and record our local variables, so that
* the garbage-collector can see any temporary values we use.
*/
ctx = push_new_evalctx(env, expr);
evalctx_register(&temp);
evalctx_register(&result);
evalctx_register(&operator);
evalctx_register(&operand_val);
evalctx_register(&operand_cons);
evalctx_register(&operands);
evalctx_register(&operands_end);
evalctx_register(&nil_value);
#ifdef VERBOSE_EVAL
printf("\nEvaluating expression: ");
print_value(stdout, expr);
printf("\n");
#endif
/* If this is a special form, evaluate it. Otherwise, this function will
* simply pass the input through to the result.
*/
result = eval_special_form(env, expr);
if (result != expr)
goto Done; /* It was a special form. */
/*
* If the input is an atom, we need to resolve it to a value, using the
* current environment.
*/
if (is_atom(expr)) {
/* Treat the atom as a name - resolve it to a value. */
result = resolve_binding(env, expr->string_val);
if (result == NULL) {
result = make_error("couldn't resolve name \"%s\" to a value!",
expr->string_val);
}
goto Done;
}
/*
* If the input isn't an atom and isn't a cons-pair, then assume it's a
* value that doesn't need evaluating, and just return it.
*/
if (!is_cons_pair(expr)) {
result = expr;
goto Done;
}
/*
* Evaluate operator into a lambda expression.
*/
temp = get_car(expr);
operator = evaluate(env, temp);
if (is_error(operator)) {
result = operator;
goto Done;
}
if (!is_lambda(operator)) {
result = make_error("operator is not a valid lambda expression");
goto Done;
}
#ifdef VERBOSE_EVAL
printf("Operator: ");
print_value(stdout, operator);
printf("\n");
#endif
/*
* Evaluate each operand into a value, and build a list up of the values.
*/
#ifdef VERBOSE_EVAL
printf("Starting evaluation of operands.\n");
#endif
num_operands = 0;
operands_end = NULL;
operands = nil_value = make_nil();
temp = get_cdr(expr);
while (is_cons_pair(temp)) {
Value *raw_operand;
num_operands++;
/* This is the raw unevaluated value. */
raw_operand = get_car(temp);
/* Evaluate the raw input into a value. */
operand_val = evaluate(env, raw_operand);
if (is_error(operand_val)) {
result = operand_val;
goto Done;
}
operand_cons = make_cons(operand_val, nil_value);
if (operands_end != NULL)
set_cdr(operands_end, operand_cons);
else
operands = operand_cons;
operands_end = operand_cons;
temp = get_cdr(temp);
}
/*
* Apply the operator to the operands, to generate a result.
*/
if (operator->lambda_val->native_impl) {
/* Native lambdas don't need an environment created for them. Rather,
* we just pass the list of arguments to the native function, and it
* processes the arguments as needed.
*/
result = operator->lambda_val->func(num_operands, operands);
}
else {
/* These don't need registered on the explicit stack. (I hope.) */
Environment *child_env;
Value *body_iter;
/* It's an interpreted lambda. Create a child environment, then
* populate it with values based on the lambda's argument-specification
* and the input operands.
*/
child_env = make_environment(operator->lambda_val->parent_env);
temp = bind_arguments(child_env, operator->lambda_val, operands);
if (is_error(temp)) {
result = temp;
goto Done;
}
/* Evaluate each expression in the lambda, using the child environment.
* The result of the last expression is the result of the lambda.
*/
body_iter = operator->lambda_val->body;
do {
result = evaluate(child_env, get_car(body_iter));
body_iter = get_cdr(body_iter);
}
while (!is_nil(body_iter));
}
Done:
#ifdef VERBOSE_EVAL
printf("Result: ");
print_value(stdout, result);
printf("\n\n");
#endif
/* Record the result and then perform garbage-collection. */
pop_evalctx(result);
collect_garbage();
return result;
}
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");
}
}
