/* Try to reduce cases_on (and nonrecursive recursor) application
if major became a constructor */
expr visit_cases_on_app(expr const & e_0) {
expr e = default_visit_app(e_0);
buffer<expr> args;
expr const & fn = get_app_args(e, args);
lean_assert(is_constant(fn));
bool is_cases_on = is_cases_on_recursor(env(), const_name(fn));
name const & rec_name = const_name(fn);
name const & I_name = rec_name.get_prefix();
unsigned nparams = *inductive::get_num_params(env(), I_name);
unsigned nindices = *inductive::get_num_indices(env(), I_name);
unsigned major_idx;
if (is_cases_on) {
major_idx = nparams + 1 + nindices;
} else {
major_idx = *inductive::get_elim_major_idx(env(), rec_name);
}
expr major = beta_reduce(args[major_idx]);
if (is_constructor_app(env(), major)) {
/* Major premise became a constructor. So, we should reduce. */
expr new_e = e;
if (is_cases_on) {
/* unfold cases_on */
if (auto r = unfold_term(env(), new_e))
new_e = *r;
else
return e;
}
/* reduce */
if (auto r = ctx().norm_ext(new_e))
return compiler_step_visitor::visit(beta_reduce(*r));
}
return e;
}
expr visit_cases_on(name const & fn, buffer<expr> & args) {
name const & I_name = fn.get_prefix();
if (is_inductive_predicate(env(), I_name))
throw exception(sstream() << "code generation failed, inductive predicate '" << I_name << "' is not supported");
bool is_builtin = is_vm_builtin_function(fn);
buffer<name> cnames;
get_intro_rule_names(env(), I_name, cnames);
lean_assert(args.size() >= cnames.size() + 1);
if (args.size() > cnames.size() + 1)
distribute_extra_args_over_minors(I_name, cnames, args);
lean_assert(args.size() == cnames.size() + 1);
/* Process major premise */
args[0] = visit(args[0]);
unsigned num_reachable = 0;
optional<expr> reachable_case;
/* Process minor premises */
for (unsigned i = 0; i < cnames.size(); i++) {
buffer<bool> rel_fields;
get_constructor_info(cnames[i], rel_fields);
auto p = visit_minor_premise(args[i+1], rel_fields);
expr new_minor = p.first;
if (i == 0 && has_trivial_structure(I_name, rel_fields)) {
/* Optimization for an inductive datatype that has a single constructor with only one relevant field */
return beta_reduce(mk_app(new_minor, args[0]));
}
args[i+1] = new_minor;
if (!p.second) {
num_reachable++;
reachable_case = p.first;
}
}
if (num_reachable == 0) {
return mk_unreachable_expr();
} else if (num_reachable == 1 && !is_builtin) {
/* Use _cases.1 */
return mk_app(mk_cases(1), args[0], *reachable_case);
} else if (is_builtin) {
return mk_app(mk_constant(fn), args);
} else {
return mk_app(mk_cases(cnames.size()), args);
}
}
/* 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);
}
int main(int argc, char *argv[])
{
if(argc == 1) {
printf("usage: %s <cmds> ...\n", argv[0]);
printf("<cmds> is one of:\n");
printf("<expr> -- push <expr> onto stack\n");
printf("<expr> <name> -alpha -- push alpha rename of <expr> using <name>\n");
printf("<expr> -beta -- push beta reduce of <expr>\n");
printf("<expr> -eta -- push eta convert of <expr>\n");
printf("<body> <var> -lambda -- push lambda binding free <var> in <body>\n");
printf("<fun> <arg> -apply -- push apply of <fun> and <arg>\n");
printf("<expr1> <expr2> -alpheq -- push \\x.\\y.x (true) or \\x.\\y.y (false) if <expr1> and <expr2> are alpha equivalent\n");
printf("-body -- move cursor into body of lambda\n");
printf("-fun -- move cursor into func of apply\n");
printf("-arg -- move cursor into arg of apply\n");
printf("-up -- move cursor up one level\n");
printf("-top -- move cursor to top level\n");
printf("<expr1> <expr2> -swap -- swap <expr1> and <expr2>\n");
printf("<expr> -dup -- duplicate <expr>\n");
printf("<expr1> <expr2> -repl -- replace <expr1> with <expr2> and remove <expr2>\n");
printf("-print -- print expression stack\n");
return 0;
}
struct termnode *term_top = NULL;
struct term *church_true, *church_false;
{
enum term_parse_res res;
char *expr = "\\a.\\b.a";
FILE *stream = fmemopen(expr, strlen(expr), "r");
church_true = term_parse(stream, &res);
fclose(stream);
expr = "\\a.\\b.b";
stream = fmemopen(expr, strlen(expr), "r");
church_false = term_parse(stream, &res);
fclose(stream);
}
for(int i = 1; i < argc; i++) {
if(strcmp(argv[i], "-alpha") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *var = termstack_get(term_top, 0);
if(var->type != TYPE_VAR) {
fprintf(stderr, "alpha requires second arg VAR, got ");
term_print(stderr, var);
fputc('\n', stderr);
break;
}
struct term *expr = termstack_get(term_top, 1);
struct term *renamed = alpha_rename(expr, var->var);
if(renamed) {
termstack_push(&term_top, renamed);
} else {
fprintf(stderr, "alpha rename failed\n");
break;
}
} else if(strcmp(argv[i], "-beta") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *term = termstack_get(term_top, 0);
struct term *reduced = beta_reduce(term);
if(reduced) {
termstack_push(&term_top, reduced);
} else {
fprintf(stderr, "beta reduction failed\n");
break;
}
} else if(strcmp(argv[i], "-eta") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *converted = eta_convert(term_top->t);
if(converted) {
termstack_push(&term_top, converted);
} else {
fprintf(stderr, "eta conversion failed\n");
break;
}
} else if(strcmp(argv[i], "-lambda") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *var = termstack_get(term_top, 0);
struct term *body = termstack_get(term_top, 1);
if(var->type != TYPE_VAR) {
fprintf(stderr, "lambda requires VAR, got ");
term_print(stderr, var);
fputc('\n', stderr);
break;
}
struct term *lambda = make_lambda(var->var, body);
if(lambda) {
termstack_push(&term_top, lambda);
} else {
fprintf(stderr, "create lambda failed\n");
break;
}
} else if(strcmp(argv[i], "-apply") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *arg = termstack_get(term_top, 0);
struct term *fun = termstack_get(term_top, 1);
struct term *appl = make_appl(fun, arg);
if(appl) {
termstack_push(&term_top, appl);
} else {
fprintf(stderr, "create apply failed\n");
break;
}
} else if(strcmp(argv[i], "-alpheq") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *t1_term = termstack_get(term_top, 0);
struct term *t2_term = termstack_get(term_top, 1);
if(alpha_eq(t1_term, t2_term)) {
termstack_push(&term_top, term_duplicate(church_true));
} else {
termstack_push(&term_top, term_duplicate(church_false));
}
} else if(strcmp(argv[i], "-print") == 0) {
for(struct termnode *n = term_top; n; n = n->next) {
term_print(stdout, termtrace_current(n->trace));
fprintf(stdout, "\n");
}
} else if(strcmp(argv[i], "-body") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
if(termtrace_current(term_top->trace)->type != TYPE_LAMBDA) {
fprintf(stderr, "not a lambda\n");
break;
}
termtrace_go_body(&term_top->trace);
} else if(strcmp(argv[i], "-fun") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
if(termtrace_current(term_top->trace)->type != TYPE_APPL) {
fprintf(stderr, "not an apply\n");
break;
}
termtrace_go_fun(&term_top->trace);
} else if(strcmp(argv[i], "-arg") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
if(termtrace_current(term_top->trace)->type != TYPE_APPL) {
fprintf(stderr, "not an apply\n");
break;
}
termtrace_go_arg(&term_top->trace);
} else if(strcmp(argv[i], "-up") == 0) {
if(term_top->trace->prev)
termtrace_go_prev(&term_top->trace);
} else if(strcmp(argv[i], "-top") == 0) {
while(term_top->trace->prev)
termtrace_go_prev(&term_top->trace);
} else if(strcmp(argv[i], "-swap") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct termnode *next = term_top->next;
term_top->next = next->next;
next->next = term_top;
term_top = next;
} else if(strcmp(argv[i], "-dup") == 0) {
if(! termstack_get(term_top, 0)) {
fprintf(stderr, "stack underflow\n");
break;
}
termstack_push(&term_top,
term_duplicate(termtrace_current(term_top->trace)));
} else if(strcmp(argv[i], "-repl") == 0) {
if(! termstack_get(term_top, 1)) {
fprintf(stderr, "stack underflow\n");
break;
}
struct term *newterm = term_duplicate(termtrace_current(term_top->trace));
destroy_term(termstack_pop(&term_top));
destroy_term(termtrace_replace(term_top->trace, newterm));
} else {
FILE *stream = fmemopen(argv[i], strlen(argv[i]), "r");
if(! stream)
continue;
enum term_parse_res res;
struct term *term = term_parse(stream, &res);
fclose(stream);
if(term == NULL) {
long loc = ftell(stream);
if(! feof(stream))
loc--;
printf("parse error: %s at char %lu\n", term_parse_str(res), loc+1);
printf("%s\n", argv[i]);
for(long i = 0; i < loc; i++)
printf(" ");
printf("^\n");
break;
}
termstack_push(&term_top, term);
}
}
struct term *t;
while(NULL != (t = termstack_get(term_top, 0))) {
destroy_term(termstack_pop(&term_top));
}
destroy_term(church_true);
destroy_term(church_false);
return 0;
}
