term* normalize_no_unfold(typing_context* Delta, term* t) { if (t == NULL) return NULL; switch (t->tag) { case VAR: { return term_dup(t); } case APP: { term* l = normalize_no_unfold(Delta, t->left); term* r = normalize_no_unfold(Delta, t->right); if (l->tag == LAM) { term* subs = substitute(l->var, r, l->right); free_term(l); free_term(r); return normalize_no_unfold_and_free(Delta, subs); } return make_app(l, r); } case IMPLICIT: case HOLE: case TYPE: case LAM: case PI: return term_dup(t); default: sentinel("unexpected tag %d"); } error: return NULL; }
static term* elim_over_intro(typing_context* Delta, term* t) { check(t && t->args && t->args[t->num_args - 1], "ill formed term"); check(t->tag == ELIM && t->args[t->num_args - 1]->tag == INTRO, "elim_over_intro must be called on an eliminator applied to a constructor"); term* last = t->args[t->num_args - 1]; datatype* T = elim_to_datatype(t->var, Delta); int index = datatype_intro_index(last->var, T); check(index != -1, "bad intro index while evaluating %W", t, print_term); term *app = term_dup(t->args[index + 1]); int i; for (i = 0; i < last->num_args; i++) { app = make_app(app, term_dup(last->args[i])); if (constructor_arg_is_inductive(T, last->var, i)) { term *inductive = term_dup(t); free_term(inductive->args[inductive->num_args - 1]); inductive->args[inductive->num_args - 1] = term_dup(last->args[i]); app = make_app(app, inductive); } } free_term(t); t = NULL; return app; error: return NULL; }
term* normalize_fuel(context *Sigma, typing_context* Delta, term* t, int fuel) { if (t == NULL) return NULL; check(term_locally_well_formed(t), "%W must be locally well formed", t, print_term); check(fuel >= 0, "Stack depth exceeded") switch (t->tag) { case VAR: return normalize_fuel_var(Sigma, Delta, t, fuel); case APP: return normalize_fuel_app(Sigma, Delta, t, fuel); case LAM: return normalize_fuel_lambda(Sigma, Delta, t, fuel); case PI: return normalize_fuel_pi(Sigma, Delta, t, fuel); case ELIM: return normalize_fuel_elim(Sigma, Delta, t, fuel); case INTRO: return normalize_fuel_intro(Sigma, Delta, t, fuel); case DATATYPE: return normalize_fuel_datatype(Sigma, Delta, t, fuel); default: return term_dup(t); } error: return NULL; }
term* normalize_fuel_var(context *Sigma, typing_context* Delta, term* t, int fuel) { term* defn = context_lookup(t->var, Sigma); if (defn == NULL) { return term_dup(t); } return normalize_fuel(Sigma, Delta, defn, fuel-1); }
term* normalize_fuel_elim(context *Sigma, typing_context* Delta, term* t, int fuel) { term* ans = NULL; term* last = normalize_fuel(Sigma, Delta, t->args[t->num_args - 1], fuel-1); if (!last) goto error; if (last->tag == INTRO) { term* c = term_dup(t); free_term(c->args[c->num_args - 1]); c->args[c->num_args - 1] = last; return normalize_and_free_fuel(Sigma, Delta, elim_over_intro(Delta, c), fuel-1); } else { ans = make_elim(variable_dup(t->var), t->num_args, t->num_params, t->num_indices); int i; for (i = 0; i < t->num_indices; i++) { ans->indices[i] = normalize_fuel(Sigma, Delta, t->indices[i], fuel-1); if (!ans->indices[i]) goto error; } for (i = 0; i < t->num_params; i++) { ans->params[i] = normalize_fuel(Sigma, Delta, t->params[i], fuel-1); if (!ans->params[i]) goto error; } for (i = 0; i < t->num_args - 1; i++) { ans->args[i] = normalize_fuel(Sigma, Delta, t->args[i], fuel-1); if (!ans->args[i]) goto error; } ans->args[t->num_args-1] = last; return ans; } error: free_term(last); free_term(ans); return NULL; }
term* whnf(context *Sigma, typing_context* Delta, term* t) { if (t == NULL) return NULL; switch (t->tag) { case VAR: { term* defn = context_lookup(t->var, Sigma); if (defn == NULL) { return term_dup(t); } return whnf(Sigma, Delta, defn); } case APP: { term* l = whnf(Sigma, Delta, t->left); if (l->tag == LAM) { term* subs = substitute(l->var, t->right, l->right); free_term(l); return whnf_and_free(Sigma, Delta, subs); } return make_app(l, term_dup(t->right)); } case ELIM: { term* last = t->args[t->num_args - 1]; term* nlast = whnf(Sigma, Delta, last); term* c = term_dup(t); free_term(c->args[c->num_args - 1]); c->args[c->num_args - 1] = nlast; if (nlast->tag == INTRO) { return whnf_and_free(Sigma, Delta, elim_over_intro(Delta, c)); } else { return c; } } case HOLE: case DATATYPE: case TYPE: case LAM: case INTRO: case PI: case IMPLICIT: return term_dup(t); } }
static term* elim_over_intro(typing_context* Delta, term* t) { check(t && t->args && t->args[t->num_args - 1], "ill formed term"); term* last = t->args[t->num_args - 1]; datatype* T = elim_to_datatype(t->var, Delta); int index = datatype_intro_index(last->var, T); term *app = term_dup(t->args[index + 1]); int i; for (i = 0; i < last->num_args; i++) { app = make_app(app, term_dup(last->args[i])); if (constructor_arg_is_inductive(T, last->var, i)) { term *inductive = term_dup(t); free_term(inductive->args[inductive->num_args - 1]); inductive->args[inductive->num_args - 1] = term_dup(last->args[i]); app = make_app(app, inductive); } } free_term(t); t = NULL; return app; error: return NULL; }
term* term_dup(term* t) { if (t == NULL) return NULL; term* ans = make_term(); ans->tag = t->tag; ans->var = variable_dup(t->var); ans->left = term_dup(t->left); ans->right = term_dup(t->right); DUP_VEC(ans->num_args, ans->args, t->num_args, t->args, term_dup, struct term*); DUP_VEC(ans->num_params, ans->params, t->num_params, t->params, term_dup, struct term*); DUP_VEC(ans->num_indices, ans->indices, t->num_indices, t->indices, term_dup, struct term*); return ans; }
term* normalize_fuel_intro(context *Sigma, typing_context* Delta, term* t, int fuel) { term* ans = make_intro(variable_dup(t->var), term_dup(t->left), t->num_args, t->num_params); int i; for (i = 0; i < t->num_params; i++) { ans->params[i] = normalize_fuel(Sigma, Delta, t->params[i], fuel-1); } for (i = 0; i < t->num_args; i++) { // FIXME: this leaks on error --jrw ans->args[i] = normalize_fuel(Sigma, Delta, t->args[i], fuel-1); if (!ans->args[i]) goto error; } return ans; error: free_term(ans); return NULL; }
/* invariant: no sharing between returned term and *any* arguments. the caller must free the result. */ term* substitute(variable* from, term* to, term* haystack) { if (haystack == NULL) return NULL; check(from != NULL && to != NULL, "substitute requires non-NULL arguments"); check(term_locally_well_formed(to), "substitute requires %W to be locally well-formed", to, print_term); check(term_locally_well_formed(haystack),"substitute requires %W to be locally well-formed", haystack, print_term); switch(haystack->tag) { case VAR: if (variable_equal(from, haystack->var)) { return term_dup(to); } else { return term_dup(haystack); } case HOLE: return term_dup(haystack); case LAM: if (variable_equal(from, haystack->var)) { return make_lambda(variable_dup(haystack->var), substitute(from, to, haystack->left), term_dup(haystack->right)); } else { if (is_free(haystack->var, to)) { variable *g = gensym(haystack->var->name); term *tg = make_var(g); term* new_haystack = make_lambda(variable_dup(g), term_dup(haystack->left), substitute(haystack->var, tg, haystack->right)); free_term(tg); term* ans = substitute(from, to, new_haystack); free_term(new_haystack); return ans; } return make_lambda(variable_dup(haystack->var), substitute(from, to, haystack->left), substitute(from, to, haystack->right)); } case PI: if (variable_equal(from, haystack->var)) { return make_pi(variable_dup(haystack->var), substitute(from, to, haystack->left), term_dup(haystack->right)); } else { if (is_free(haystack->var, to)) { variable *g = gensym(haystack->var->name); term *tg = make_var(g); term* new_haystack = make_pi(variable_dup(g), term_dup(haystack->left), substitute(haystack->var, tg, haystack->right)); free_term(tg); term* ans = substitute(from, to, new_haystack); free_term(new_haystack); return ans; } return make_pi(variable_dup(haystack->var), substitute(from, to, haystack->left), substitute(from, to, haystack->right)); } case APP: return make_app(substitute(from, to, haystack->left), substitute(from, to, haystack->right)); case TYPE: return term_dup(haystack); case DATATYPE: { term* ans = make_datatype_term(variable_dup(haystack->var), haystack->num_params, haystack->num_indices); #define SUB_VEC(dst, src, n) do { \ int __i; \ for (__i = 0; __i < n; __i++) { \ dst[__i] = substitute(from, to, src[__i]); \ } \ } while(0) SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case INTRO: { term* ans = make_intro(variable_dup(haystack->var), substitute(from, to, haystack->left), haystack->num_args, haystack->num_params, haystack->num_indices); SUB_VEC(ans->args, haystack->args, haystack->num_args); SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case ELIM: { term* ans = make_elim(variable_dup(haystack->var), haystack->num_args, haystack->num_params, haystack->num_indices); SUB_VEC(ans->args, haystack->args, haystack->num_args); SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case IMPLICIT: return term_dup(haystack); default: sentinel("malformed term with tag %d", haystack->tag); } error: return NULL; }
int syntactically_identical(term* a, term* b) { if (a == NULL || b == NULL) return a == b; check(term_locally_well_formed(a) && term_locally_well_formed(b), "alpha equiv requires well-formed arguments"); if (a->tag == HOLE) { log_info("Hole should unify with %W", b, print_term); return 1; } if (b->tag == HOLE) { log_info("Hole should unify with %W", a, print_term); return 1; } if (a->tag != b-> tag) return 0; switch (a->tag) { case VAR: return variable_equal(a->var, b->var); case LAM: { if (a->left != NULL && b->left != NULL && !syntactically_identical(a->left, b->left)) return 0; if (variable_equal(a->var, b->var)) return syntactically_identical(a->right, b->right); term* va = make_var(variable_dup(a->var)); term* bsubs = substitute(b->var, va, b->right); free_term(va); term* c = make_lambda(variable_dup(a->var), term_dup(b->left), bsubs); int ans = syntactically_identical(a, c); free_term(c); return ans; } case PI: { if (!syntactically_identical(a->left, b->left)) return 0; if (variable_equal(a->var, b->var)) return syntactically_identical(a->right, b->right); term* va = make_var(variable_dup(a->var)); term* bsubs = substitute(b->var, va, b->right); free_term(va); term* c = make_pi(variable_dup(a->var), term_dup(b->left), bsubs); int ans = syntactically_identical(a, c); free_term(c); return ans; } case APP: return syntactically_identical(a->left, b->left) && syntactically_identical(a->right, b->right); case DATATYPE: { if (!variable_equal(a->var, b->var)) { return 0; } #define EQ_VEC(a, an, b, bn) do { \ if (an != bn) return 0; \ int __i; \ for (__i = 0; __i < an; __i++) { \ if (!syntactically_identical(a[__i], b[__i])) return 0; \ } \ } while(0) EQ_VEC(a->params, a->num_params, b->params, b->num_params); EQ_VEC(a->indices, a->num_indices, b->indices, b->num_indices); return 1; } case INTRO: case ELIM: { if (!variable_equal(a->var, b->var)) { return 0; } EQ_VEC(a->args, a->num_args, b->args, b->num_args); EQ_VEC(a->params, a->num_params, b->params, b->num_params); EQ_VEC(a->indices, a->num_indices, b->indices, b->num_indices); return 1; } case TYPE: return 1; case IMPLICIT: return syntactically_identical(a->right, b->right); default: sentinel("malformed term"); } error: return 0; }