expr mk_app(unsigned n, expr const * as) {
lean_assert(n > 1);
unsigned new_n;
unsigned n0 = 0;
expr const & arg0 = as[0];
bool has_mv = std::any_of(as, as + n, [](expr const & c) { return c.has_metavar(); });
// Remark: we represent ((app a b) c) as (app a b c)
if (is_app(arg0)) {
n0 = num_args(arg0);
new_n = n + n0 - 1;
} else {
new_n = n;
}
char * mem = new char[sizeof(expr_app) + new_n*sizeof(expr)];
expr r(new (mem) expr_app(new_n, has_mv));
expr * m_args = to_app(r)->m_args;
unsigned i = 0;
unsigned j = 0;
if (new_n != n) {
for (; i < n0; i++)
new (m_args+i) expr(arg(arg0, i));
j++;
}
for (; i < new_n; ++i, ++j) {
lean_assert(j < n);
new (m_args+i) expr(as[j]);
}
to_app(r)->m_hash = hash_args(new_n, m_args);
return r;
}
expr copy(expr const & a) {
switch (a.kind()) {
case expr_kind::Var: return mk_var(var_idx(a));
case expr_kind::Constant: return mk_constant(const_name(a));
case expr_kind::Type: return mk_type(ty_level(a));
case expr_kind::Value: return mk_value(static_cast<expr_value*>(a.raw())->m_val);
case expr_kind::App: return mk_app(num_args(a), begin_args(a));
case expr_kind::Eq: return mk_eq(eq_lhs(a), eq_rhs(a));
case expr_kind::Lambda: return mk_lambda(abst_name(a), abst_domain(a), abst_body(a));
case expr_kind::Pi: return mk_pi(abst_name(a), abst_domain(a), abst_body(a));
case expr_kind::Let: return mk_let(let_name(a), let_type(a), let_value(a), let_body(a));
case expr_kind::MetaVar: return mk_metavar(metavar_idx(a), metavar_ctx(a));
}
lean_unreachable();
}
bool is_lt(expr const & a, expr const & b, bool use_hash) {
if (is_eqp(a, b)) return false;
unsigned da = get_depth(a);
unsigned db = get_depth(b);
if (da < db) return true;
if (da > db) return false;
if (a.kind() != b.kind()) return a.kind() < b.kind();
if (use_hash) {
if (a.hash() < b.hash()) return true;
if (a.hash() > b.hash()) return false;
}
if (a == b) return false;
if (is_var(a)) return var_idx(a) < var_idx(b);
switch (a.kind()) {
case expr_kind::Var:
lean_unreachable(); // LCOV_EXCL_LINE
case expr_kind::Constant:
return const_name(a) < const_name(b);
case expr_kind::App:
if (num_args(a) != num_args(b))
return num_args(a) < num_args(b);
for (unsigned i = 0; i < num_args(a); i++) {
if (arg(a, i) != arg(b, i))
return is_lt(arg(a, i), arg(b, i), use_hash);
}
lean_unreachable(); // LCOV_EXCL_LINE
case expr_kind::Lambda: // Remark: we ignore get_abs_name because we want alpha-equivalence
case expr_kind::Pi:
if (abst_domain(a) != abst_domain(b))
return is_lt(abst_domain(a), abst_domain(b), use_hash);
else
return is_lt(abst_body(a), abst_body(b), use_hash);
case expr_kind::Type:
return ty_level(a) < ty_level(b);
case expr_kind::Value:
return to_value(a) < to_value(b);
case expr_kind::Let:
if (let_type(a) != let_type(b)) {
return is_lt(let_type(a), let_type(b), use_hash);
} else if (let_value(a) != let_value(b)){
return is_lt(let_value(a), let_value(b), use_hash);
} else {
return is_lt(let_body(a), let_body(b), use_hash);
}
case expr_kind::MetaVar:
if (metavar_name(a) != metavar_name(b)) {
return metavar_name(a) < metavar_name(b);
} else {
auto it1 = metavar_lctx(a).begin();
auto it2 = metavar_lctx(b).begin();
auto end1 = metavar_lctx(a).end();
auto end2 = metavar_lctx(b).end();
for (; it1 != end1 && it2 != end2; ++it1, ++it2) {
if (it1->kind() != it2->kind()) {
return it1->kind() < it2->kind();
} else if (it1->s() != it2->s()) {
return it1->s() < it2->s();
} else if (it1->is_inst()) {
if (it1->v() != it2->v())
return is_lt(it1->v(), it2->v(), use_hash);
} else {
if (it1->n() != it2->n())
return it1->n() < it2->n();
}
}
return it1 == end1 && it2 != end2;
}
}
lean_unreachable(); // LCOV_EXCL_LINE
}
int rules_to_c_code()
{
char *file_name;
VALUE arg_ptr;
int arg_count, i;
int other_args[5];
/*===========================================*/
/* Initialize parameters for handling array */
/* syntax for empty arrays. */
/*===========================================*/
first_pn = first_join = first_list = TRUE;
first_ptest = first_itest = first_ftest = TRUE;
first_dfact = first_fact = first_elem = TRUE;
/*===========================================*/
/* Initialize counters to determine indices */
/* for setting pointers within arrays. */
/*===========================================*/
mark_pat_count = 0;
list_count = 0;
pnode_count = 0;
icount = fcount = pcount = 0;
join_count = 0;
fact_ct = fact_pct = dfact_ct = 0;
elm_ct = 0;
/*============================================*/
/* Check for appropriate number of arguments. */
/*============================================*/
arg_count = num_args();
if (arg_count < 2)
{
exp_num_error("rules-to-c",AT_LEAST,2);
return (0);
}
else if (arg_count > 6)
{
exp_num_error("rules-to-c",NO_MORE_THAN,6);
return (0);
}
/*====================================*/
/* Get the file name to place C code. */
/*====================================*/
runknown(1,&arg_ptr);
if ((arg_ptr.type) != STRING && (arg_ptr.type) != WORD)
{
exp_type_error("rules-to-c",1,"WORD or STRING");
return (0);
}
file_name = rvalstring(arg_ptr);
#if VMS || IBM_MSC || IBM_LATTICE || IBM_TBC || IBM_ZTC
/*Check for '.' VAX or IBM PC file_name */
for(i=0;*(file_name+i);i++)
{
if(*(file_name+i) == '.')
{
cl_print("werror","Invalid file name ");
cl_print("werror",file_name);
cl_print("werror"," contains \'.\'\n");
return(1);
}
}
#endif
/*==============================*/
/* Get the remaining arguments. */
/*==============================*/
other_args[1] = sizeof(char);
other_args[2] = sizeof(int);
other_args[3] = sizeof(float);
other_args[4] = sizeof(char *);
for (i = 2 ; i <= arg_count ; i++)
{
runknown(i,&arg_ptr);
if ((arg_ptr.type) != NUMBER)
{
cl_print("werror","Function rules-to-c expected a number as argument #");
print_num("werror",(float) i);
cl_print("werror","\n");
return (0);
}
other_args[i-2] = (int) rvalfloat(arg_ptr);
}
return(generate_code(file_name,other_args[0],other_args[1],
other_args[2],other_args[3],other_args[4]));
}
optional<substitution> fo_unify(expr e1, expr e2) {
substitution s;
unsigned i1, i2;
buffer<expr_pair> todo;
todo.emplace_back(e1, e2);
while (!todo.empty()) {
auto p = todo.back();
todo.pop_back();
e1 = find(s, p.first);
e2 = find(s, p.second);
if (e1 != e2) {
if (is_metavar_wo_local_context(e1)) {
assign(s, e1, e2);
} else if (is_metavar_wo_local_context(e2)) {
assign(s, e2, e1);
} else if (is_equality(e1) && is_equality(e2)) {
expr_pair p1 = get_equality_args(e1);
expr_pair p2 = get_equality_args(e2);
todo.emplace_back(p1.second, p2.second);
todo.emplace_back(p1.first, p2.first);
} else {
if (e1.kind() != e2.kind())
return optional<substitution>();
switch (e1.kind()) {
case expr_kind::Var: case expr_kind::Constant: case expr_kind::Type: case expr_kind::Value: case expr_kind::MetaVar:
return optional<substitution>();
case expr_kind::App:
i1 = num_args(e1);
i2 = num_args(e2);
while (i1 > 0 && i2 > 0) {
--i1;
--i2;
if (i1 == 0 && i2 > 0) {
todo.emplace_back(arg(e1, i1), mk_app(i2+1, begin_args(e2)));
} else if (i2 == 0 && i1 > 0) {
todo.emplace_back(mk_app(i1+1, begin_args(e1)), arg(e2, i2));
} else {
todo.emplace_back(arg(e1, i1), arg(e2, i2));
}
}
break;
case expr_kind::Lambda: case expr_kind::Pi:
todo.emplace_back(abst_body(e1), abst_body(e2));
todo.emplace_back(abst_domain(e1), abst_domain(e2));
break;
case expr_kind::Let:
todo.emplace_back(let_body(e1), let_body(e2));
todo.emplace_back(let_value(e1), let_value(e2));
if (static_cast<bool>(let_type(e1)) != static_cast<bool>(let_type(e2)))
return optional<substitution>();
if (let_type(e1)) {
lean_assert(let_type(e2));
todo.emplace_back(*let_type(e1), *let_type(e2));
}
break;
}
}
}
}
return optional<substitution>(s);
}
