/*
Value calculation
Note: coercion of int -> real on adding real + int?
*/
value concatenate_values (value_list vl)
{ int ix;
switch (vl -> array[0] -> tag)
{ case string_value:
{ register char *dptr = strstore;
for (ix = 0; ix < vl -> size; ix++)
{ register char *sptr = vl -> array[ix] -> u.str;
while (*sptr) *dptr++ = *sptr++;
};
*dptr = '\0';
return (new_string_value (strstore));
};
case integer_value:
{ int sum = 0;
for (ix = 0; ix < vl -> size; ix++)
sum += vl -> array[ix] -> u.inum;
return (new_integer_value (sum));
};
case real_value:
{ real sum = 0.0;
for (ix = 0; ix < vl -> size; ix++)
sum += vl -> array[ix] -> u.rnum;
return (new_real_value (sum));
};
default: bad_tag (vl -> array[0] -> tag, "concatenate_values");
};
return (value_nil);
};
/*
Nullability of rules in a context free grammar is usually detected
by the following fixed point algorithm:
mark all members that directly derive empty;
do
mark all rules that have right hand sides,
consisting entirely of marked members
until no more marking is possible.
When no more information is needed, the initial marking can also be
done by the loop. We will use this algorithm for the empty detection
in meta rules. For the classification of the rules we must also detect
which rules always produce empty by a second fixed point calculation.
Marking in rules and meta rules is always one of 4:
unknown (U), may_produce_empty (m),
always_produces_empty (A), never_produces_empty (N).
*/
static int affix_nullability (affix a)
{ switch (a -> tag)
{ case tag_affix_variable:
{ meta_rule def = a -> u.var.def;
return (def -> empty); /* U, m, N */
};
case tag_affix_terminal:
if (strlen (a -> u.str)) return (never_produces_empty);
else return (may_produce_empty); /* actually A */
case tag_affix_integer: /* check this one */
if (a -> u.inum <= 0) return (may_produce_empty);
else return (never_produces_empty);
case tag_affix_real:
if (a -> u.rnum == 0.0) return (may_produce_empty);
else return (never_produces_empty); /* sowieso checken */
case tag_affix_semi:
{ cset set = a -> u.semi;
if (set -> kind & star) return (may_produce_empty);
else return (never_produces_empty);
};
case tag_affix_element: return (never_produces_empty);
default: bad_tag (a -> tag, "affix_may_produce_empty");
};
return (unknown);
};
value join_lattice_values (value_list vl)
{ int ix;
string *lnames = (string *) vl -> array[0] -> dptr;
switch (vl -> array[0] -> tag)
{ case small_lattice_value:
{ int uni = 0;
for (ix = 0; ix < vl -> size; ix++)
uni |= vl -> array[ix] -> u.slat;
return (new_small_lattice_value (uni, lnames));
};
case large_lattice_value:
{ int size = vl -> array[0] -> u.elat -> size;
value nv = new_large_lattice_value (size, NULL, lnames);
for (ix = 0; ix < vl -> size; ix++)
{ int_list il = vl -> array[ix] -> u.elat;
int iy;
for (iy = 0; iy < size; iy++)
nv -> u.elat -> array[iy] |= il -> array[iy];
};
return (nv);
};
default: bad_tag (vl -> array[0] -> tag, "join_lattice_values");
};
return (value_nil);
};
int load_value (FILE *f, value *v, string *lnames)
{ value nv;
int tag;
if (!load_int (f, &tag)) return (0);
nv = new_value (tag);
nv -> dptr = (void *) lnames;
switch (tag)
{ case string_value:
if (!load_string (f, &nv -> u.str)) return (0);
break;
case integer_value:
if (!load_int (f, &nv -> u.inum)) return (0);
break;
case real_value:
if (!load_real(f, &nv -> u.rnum)) return (0);
break;
case tuple_value:
if (!load_value_list (f, &nv -> u.tuple, lnames)) return (0);
break;
case small_lattice_value:
if (!load_int (f, &nv -> u.slat)) return (0);
break;
case large_lattice_value:
if (!load_int_list (f, &nv -> u.elat)) return (0);
break;
default:
bad_tag (tag, "load_value");
};
*v = nv;
return (1);
};
/*
type checking positions
*/
static int typecheck_position (rule srule, int altnr, pos p, int dtype)
{ expr ex = p -> ex;
int rtype = 0;
int ctype = balance_type (srule, altnr, dtype, p -> type);
switch (ex -> tag)
{ case tag_single:
rtype = typecheck_affix (srule, altnr, ex -> u.single, ctype);
break;
case tag_compos:
rtype = typecheck_compos(srule, altnr, ex -> u.compos, ctype);
break;
case tag_concat:
rtype = typecheck_concat(srule, altnr, ex -> u.concat, ctype);
break;
case tag_union:
rtype = typecheck_union (srule, altnr, ex -> u.uni, ctype);
break;
default: bad_tag (ex -> tag, "typecheck_position");
};
if (p -> type != rtype)
{ p -> type = rtype;
change = 1;
};
return (rtype);
};
/* type_equal -- test two types for equality */
PUBLIC bool type_equal(type t1, frame f1, type t2, frame f2)
{
unpack(&t1, &f1, FALSE);
unpack(&t2, &f2, FALSE);
if (t1 == t2 && f1 == f2)
return TRUE;
else if (t1->t_kind != t2->t_kind)
return FALSE;
else {
switch (t1->t_kind) {
case GIVENT: return (t1->t_given == t2->t_given);
case TYPEVAR: return (t1->t_typevar == t2->t_typevar);
case POWERT: return (type_equal(t1->t_base, f1,
t2->t_base, f2));
case CPRODUCT:
if (t1->t_nfields != t2->t_nfields)
return FALSE;
else {
int i;
for (i = 0; i < t1->t_nfields; i++)
if (! type_equal(t1->t_field[i], f1,
t2->t_field[i], f2))
return FALSE;
return TRUE;
}
case SPRODUCT: {
schema s1 = t1->t_schema, s2 = t2->t_schema;
int i;
if (s1->z_ncomps != s2->z_ncomps)
return FALSE;
for (i = 0; i < s1->z_ncomps; i++)
if (s1->z_comp[i].z_name != s2->z_comp[i].z_name
|| ! type_equal(s1->z_comp[i].z_type, f1,
s2->z_comp[i].z_type, f2))
return FALSE;
return TRUE;
}
case ABBREV:
if (t1->t_def != t2->t_def)
return FALSE;
else {
int i;
for (i = 0; i < t1->t_def->d_nparams; i++)
if (! type_equal(t1->t_params->f_var[i], f1,
t2->t_params->f_var[i], f2))
return FALSE;
return TRUE;
}
default:
bad_tag("type_equal", t1->t_kind);
return FALSE;
}
}
}
static void typecheck_member (rule srule, int altnr, member m)
{ switch (m -> tag)
{ case tag_call: typecheck_call (srule, altnr, m); break;
case tag_terminal: break;
case tag_semiterminal: typecheck_semiterminal (srule, altnr, m);
case tag_cut: break;
default: bad_tag (m -> tag, "typecheck_member");
};
};
static element_set construct_lattice_in_affix (affix a, element_set mset)
{ switch (a -> tag)
{ case tag_affix_variable:
return (construct_lattice_from_variable (a, mset));
case tag_affix_element:
return (construct_lattice_from_element (a, mset));
default: bad_tag (a -> tag, "construct_lattice_in_affix");
};
return (element_set_nil);
};
/* tc_sexp -- check a schema expression */
PUBLIC env tc_sexp(tree t, env e)
{
env e1, e2;
tree u;
def d;
switch (t->x_kind) {
case TEXT:
return tc_schema(t->x_text, e);
case SREF:
e1 = new_env(e);
do_sref(t, e, e1);
return e1;
case SNOT:
e1 = tc_sexp(t->x_arg, e);
for (d = e1->e_defs; d != NULL; d = d->d_next)
d->d_type = super_expand(d->d_type, arid);
return e1;
case SAND: return binary_sexp(and_fun, t, e);
case SOR: return binary_sexp(or_fun, t, e);
case SIMPLIES: case SEQUIV:
return binary_sexp(implies_fun, t, e);
case PROJECT: return binary_sexp(project_fun, t, e);
case FATSEMI:
return compose(t, e, prime, empty, "sequential composition");
case PIPE:
return compose(t, e, pling, query, "piping");
case HIDE:
e1 = tc_sexp(t->x_arg1, e);
for (u = t->x_arg2; u != nil; u = cdr(u))
hide_var((sym) car(u), (type) NULL, e1, t, t->x_loc);
return e1;
case SFORALL: case SEXISTS: case SEXISTS1:
e2 = tc_schema(t->x_bvar, e);
e1 = tc_sexp(t->x_body, e);
for (d = e2->e_defs; d != NULL; d = d->d_next)
hide_var(d->d_name, d->d_type, e1, t, t->x_loc);
return e1;
case PRE:
return precond(t, e);
default:
bad_tag("get_sexp", t->x_kind);
return NULL;
}
}
static void mark_recbup_in_expr (expr e)
{ if (e == expr_nil) return;
switch (e -> tag)
{ case tag_single: mark_recbup_in_affix (e -> u.single); break;
case tag_concat:
mark_recbup_in_affix_list (e -> u.concat); break;
case tag_compos:
case tag_union: internal_error ("mark_rec_in_expr");
default: bad_tag (e -> tag, "mark_rec_in_expr");
};
};
static int expr_nullability (expr e)
{ if (e == expr_nil) /* empty meta alt */
return (may_produce_empty);
switch (e -> tag)
{ case tag_single: return (affix_nullability (e -> u.single));
case tag_concat: return (concat_nullability (e -> u.concat));
case tag_compos: return (never_produces_empty);
case tag_union: return (never_produces_empty);
default: bad_tag (e -> tag, "expr_nullability");
};
return (unknown);
};
static element_set construct_lattices_in_expr (expr e, element_set mset)
{ if (e == expr_nil)
internal_error ("construct_lattices_in_expr");
switch (e -> tag)
{ case tag_single:
return (construct_lattice_in_affix (e -> u.single, mset));
case tag_union:
return (construct_lattices_in_affixes (e -> u.uni, mset));
default: bad_tag (e -> tag, "construct_lattices_in_expr");
};
return (element_set_nil);
};
void save_value (FILE *f, value v)
{ save_int (f, v -> tag);
switch (v -> tag)
{ case string_value: save_string (f, v -> u.str); break;
case integer_value: save_int (f, v -> u.inum); break;
case real_value: save_real (f, v -> u.rnum); break;
case tuple_value: save_value_list (f, v -> u.tuple); break;
case small_lattice_value: save_int (f, v -> u.slat); break;
case large_lattice_value: save_int_list (f, v -> u.elat); break;
default: bad_tag (v -> tag, "save_value");
};
};
static int analyze_affix (affix a)
{ switch (a -> tag)
{ case tag_affix_variable: return (a -> u.var.def -> type);
case tag_affix_terminal: return (string_type);
case tag_affix_integer: return (integer_type);
case tag_affix_real: return (real_type);
case tag_affix_semi: return (string_type);
case tag_affix_element: return (lattice_type);
default: bad_tag (a -> tag, "analyze_affix");
};
return (0);
};
static void initial_member_classification (rule srule, member m)
{ switch (m -> tag)
{ case tag_call: return;
case tag_terminal:
initial_terminal_classification (m); break;
case tag_semiterminal:
initial_semiterminal_classification (m); break;
case tag_cut:
initial_cut_classification (m); break;
default: bad_tag (m -> tag, "initial_member_classification");
};
if (m -> empty != always_produces_empty)
srule -> kind = rule_nonpredicate;
};
static int analyze_alt (meta_rule mrule, int altnr, expr e)
{ if (e == expr_nil) return (string_type);
switch (e -> tag)
{ case tag_single: return (analyze_affix (e -> u.single));
case tag_compos:
return (analyze_composition (mrule, altnr, e -> u.compos));
case tag_concat:
return (analyze_concatenation (mrule, altnr, e -> u.concat));
case tag_union:
return (analyze_union (mrule, altnr, e -> u.uni));
default: bad_tag (e -> tag, "analyze_alt");
};
return (unknown);
};
static int typecheck_affix (rule srule, int altnr, affix a, int dtype)
{ int affix_type = 0;
switch (a -> tag)
{ case tag_affix_variable: return (typecheck_affix_variable (srule, altnr, a, dtype));
case tag_affix_terminal: affix_type = string_type; break;
case tag_affix_integer: affix_type = integer_type; break;
case tag_affix_real: affix_type = real_type; break;
case tag_affix_semi: affix_type = string_type; break;
case tag_affix_element: affix_type = lattice_type; break;
default: bad_tag (a -> tag, "typecheck_affix");
};
a -> type = affix_type;
return (balance_type (srule, altnr, affix_type, dtype));
};
static int member_may_produce_empty (member m)
{ switch (m -> tag)
{ case tag_call:
{ int empty = m -> u.call.def -> empty;
if (empty == may_produce_empty) return (1);
return (empty == always_produces_empty); /* ext */
};
case tag_terminal:
case tag_semiterminal:
case tag_cut:
return (m -> empty != never_produces_empty);
default: bad_tag (m -> tag, "member_may_produce_empty");
};
return (0);
};
/* ref_type -- find type of a reference */
PUBLIC type ref_type(sym x, tree p, env e, tree cxt)
{
def d = find_def(x, e);
frame f;
if (d == NULL) {
#ifdef ASSUME
type t;
if (qflag && p == nil && (t = assume_type(x)) != NULL)
return t;
#endif
if (! partial_env(e)) {
tc_error(cxt->x_loc, "Identifier %n is not declared", x);
if (cxt->x_kind != REF)
tc_e_etc("Expression: %z", cxt);
tc_e_end();
}
return err_type;
}
f = new_frame(d->d_nparams, cxt);
if (p != nil)
switch (d->d_kind) {
case GSET:
case VAR:
tc_error(cxt->x_loc, "%s %n cannot have parameters",
d->d_kind == GSET ? "Basic type" : "Variable", x);
tc_e_etc("Expression: %z", cxt);
tc_e_end();
return err_type;
case GENCONST:
get_params("Generic constant", x, p, e, f, cxt->x_loc);
break;
default:
bad_tag("ref_type", d->d_kind);
}
if (! aflag && d->d_abbrev)
return mk_power(mk_abbrev(d, (p != nil ? f : alias(f))));
else
return seal(d->d_type, f);
}
int equal_value (value v1, value v2)
{ if (v1 == value_nil) return (0);
if (v2 == value_nil) return (0);
if (v1 == v2) return (1);
if (v1 -> tag != v2 -> tag) return (0);
switch (v1 -> tag)
{ case undefined_value: return (0);
case string_value: return (!strcmp (v1 -> u.str, v2 -> u.str));
case integer_value: return (v1 -> u.inum == v2 -> u.inum);
case real_value: return (v1 -> u.rnum == v2 -> u.rnum);
case tuple_value: return (equal_value_list (v1 -> u.tuple, v2 -> u.tuple));
case small_lattice_value: return (v1 -> u.slat == v2 -> u.slat);
case large_lattice_value: return (equal_int_list (v1 -> u.elat, v2 -> u.elat));
default: bad_tag (v1 -> tag, "equal_value");
};
return (0);
};
/* do_sref -- add the variables of a schema reference to an env */
PUBLIC void do_sref(tree t, env e, env v)
{
tok dec = (tok) t->x_sref_decor;
tree renames = t->x_sref_renames;
def d;
schema s;
frame params;
int i;
if (t->x_kind != SREF) bad_tag("do_sref", t->x_kind);
if (! open_sref(t, e, &d, ¶ms)) {
v->e_partial = TRUE;
return;
}
s = d->d_schema;
check_rename(d->d_schema, dec, renames, t);
for (i = 0; i < s->z_ncomps; i++)
merge_def(VAR, get_rename(s->z_comp[i].z_name, dec, renames),
seal(s->z_comp[i].z_type, params), v, t, t->x_loc);
}
/*
Define a total order for values
*/
int less_value (value v1, value v2)
{ if (v1 == value_nil) return (0);
if (v2 == value_nil) return (0);
if (v1 == v2) return (0);
if (v1 -> tag != v2 -> tag) return (v1 -> tag < v2 -> tag);
switch (v1 -> tag)
{ case undefined_value: return (0);
case string_value: return (strcmp (v1 -> u.str, v2 -> u.str) < 0);
case integer_value: return (v1 -> u.inum < v2 -> u.inum);
case real_value: return (v1 -> u.rnum < v2 -> u.rnum);
case tuple_value: return (less_value_list (v1 -> u.tuple, v2 -> u.tuple));
case small_lattice_value:
if (v1 -> u.slat < v2 -> u.slat) return (1);
if (v2 -> u.slat < v1 -> u.slat) return (0);
break;
case large_lattice_value:
if (less_int_list (v1 -> u.elat, v2 -> u.elat)) return (1);
if (less_int_list (v2 -> u.elat, v1 -> u.elat)) return (0);
break;
default: bad_tag (v1 -> tag, "less_value");
};
return (v1 -> admin_nr < v2 -> admin_nr);
};
/*
unformatted output for affix output at end of parse etc.
*/
void output_value (FILE *out, value val)
{ if (val == value_nil)
{ fputs ("<value_nil>", out);
return;
};
switch (val -> tag)
{ case undefined_value: break;
case string_value:
fputs (val -> u.str, out);
break;
case integer_value:
fprintf (out, "%d", val -> u.inum);
break;
case real_value:
fprintf (out, "%g", val -> u.rnum);
break;
case tuple_value:
{ value_list vl = val -> u.tuple;
fputc ('<', out);
if (vl != value_list_nil)
{ int ix;
for (ix = 0; ix < vl -> size; ix++)
{ if (ix != 0) fputs (" * ", out);
output_value (out, vl -> array[ix]);
};
};
fputc ('>', out);
}; break;
case small_lattice_value:
if (val -> dptr == NULL) fprintf (out, "{ %08x }", val -> u.slat);
else
{ string *lnames = (string *) val -> dptr;
int nfirst = 0;
int ix;
fprintf (out, "{ ");
for (ix = 0; ix < 32; ix++)
if (val -> u.slat & (1 << ix))
{ fprintf (out, "%s%s", (nfirst)?", ":"", lnames[ix]);
nfirst = 1;
};
fprintf (out, " }");
};
break;
case large_lattice_value:
{ string *lnames = (string *) val -> dptr;
int nfirst = 0;
int lidx = 0;
int_list il = val -> u.elat;
int ix;
fprintf (out, "{ ");
if (lnames == NULL)
for (ix = 0; ix < il -> size; ix++)
eprint_log ("%08x", il -> array[ix]);
else
for (ix = il -> size - 1; 0 <= ix; ix--)
{ int iy;
for (iy = 0; iy < 32; iy++, lidx++)
if (il -> array[ix] & (1 << iy))
{ fprintf (out, "%s%s", (nfirst)?", ":"", lnames [lidx]);
nfirst = 1;
};
};
fprintf (out, " }");
}; break;
default: bad_tag (val -> tag, "output_value");
};
};
/*
Formatted output for value logging and tracing
*/
void dump_value (value val)
{ if (val == value_nil)
{ eprint_log ("nil");
return;
};
switch (val -> tag)
{ case undefined_value:
eprint_log ("\bot");
break;
case string_value:
output_string (stderr, val -> u.str);
break;
case integer_value:
eprint_log ("%d", val -> u.inum);
break;
case real_value:
eprint_log ("%g", val -> u.rnum);
break;
case tuple_value:
{ value_list vl = val -> u.tuple;
eprint_log ("<");
if (vl != value_list_nil)
{ int ix;
for (ix = 0; ix < vl -> size; ix++)
{ if (ix != 0) eprint_log (" * ");
dump_value (vl -> array[ix]);
};
};
eprint_log (">");
}; break;
case small_lattice_value:
if (val -> dptr == NULL)
eprint_log ("{ %08x }", val -> u.slat);
else
{ string *lnames = (string *) val -> dptr;
int nfirst = 0;
int ix;
eprint_log ("{ ");
for (ix = 0; ix < 32; ix++)
if (val -> u.slat & (1 << ix))
{ eprint_log ("%s%s", (nfirst)?", ":"", lnames[ix]);
nfirst = 1;
};
eprint_log (" }");
};
break;
case large_lattice_value:
{ string *lnames = (string *) val -> dptr;
int nfirst = 0;
int lidx = 0;
int_list il = val -> u.elat;
int ix;
eprint_log ("{ ");
if (lnames == NULL)
for (ix = 0; ix < il -> size; ix++)
eprint_log ("%08x", il -> array[ix]);
else
for (ix = il -> size - 1; 0 <= ix; ix--)
{ int iy;
for (iy = 0; iy < 32; iy++, lidx++)
if (il -> array[ix] & (1 << iy))
{ eprint_log ("%s%s", (nfirst)?", ":"", lnames [lidx]);
nfirst = 1;
};
};
eprint_log (" }");
}; break;
default: bad_tag (val -> tag, "dump_value");
};
};
PUBLIC type tc_expr(tree t, env e)
#endif
{
switch (t->x_kind) {
case REF:
return ref_type((sym) t->x_tag, t->x_params, e, t);
case INGEN:
return ref_type((sym) t->x_tag,
list2(t->x_param1, t->x_param2), e, t);
case PREGEN:
return ref_type((sym) t->x_tag, list1(t->x_param), e, t);
case NUMBER:
return nat_type;
case SEXPR: {
def d;
frame params;
if (! open_sref(t->x_ref, e, &d, ¶ms))
return err_type;
if ((tok) t->x_ref->x_sref_decor != empty) {
tc_error(t->x_loc, "Decoration ignored in schema reference");
tc_e_etc("Expression: %z", t);
tc_e_end();
}
if (t->x_ref->x_sref_renames != nil) {
tc_error(t->x_loc, "Renaming ignored in schema reference");
tc_e_etc("Expression: %z", t);
tc_e_end();
}
if (! aflag && d->d_abbrev)
return mk_power(mk_abbrev(d, params));
else
return mk_power(seal(mk_sproduct(d->d_schema), params));
}
case POWER: {
type tt1, tt2;
if (! anal_power(tt1 = tc_expr(t->x_arg, e), &tt2, t->x_arg)) {
tc_error(t->x_loc, "Argument of \\power must be a set");
tc_e_etc("Expression: %z", t);
tc_e_etc("Arg type: %t", tt1);
tc_e_end();
}
return mk_power(mk_power(tt2));
}
case TUPLE : {
type a[MAX_ARGS];
int n = 0;
tree u;
for (u = t->x_elements; u != nil; u = cdr(u)) {
if (n >= MAX_ARGS)
panic("tc_expr - tuple too big");
a[n++] = tc_expr(car(u), e);
}
return mk_cproduct(n, a);
}
case CROSS: {
type a[MAX_ARGS];
type tt1, tt2;
int n = 0;
tree u;
for (u = t->x_factors; u != nil; u = cdr(u)) {
if (n >= MAX_ARGS)
panic("tc_expr - product too big");
tt1 = tc_expr(car(u), e);
if (! anal_power(tt1, &tt2, car(u))) {
tc_error(t->x_loc,
"Argument %d of \\cross must be a set", n+1);
tc_e_etc("Expression: %z", t);
tc_e_etc("Arg %d type: %t", n+1, tt1);
tc_e_end();
}
a[n++] = tt2;
}
return mk_power(mk_cproduct(n, a));
}
case EXT:
case SEQ:
case BAG: {
type elem_type;
type tt;
tree u;
if (t->x_elements == nil)
elem_type = new_typevar(t);
else {
elem_type = tc_expr(car(t->x_elements), e);
for (u = cdr(t->x_elements); u != nil; u = cdr(u)) {
if (unify(elem_type, tt = tc_expr(car(u), e)))
elem_type = type_union(elem_type, arid, tt, arid);
else {
tc_error(t->x_loc, "Type mismatch in %s display",
(t->x_kind == EXT ? "set" :
t->x_kind == SEQ ? "sequence" : "bag"));
tc_e_etc("Expression: %z", car(u));
tc_e_etc("Has type: %t", tt);
tc_e_etc("Expected: %t", elem_type);
tc_e_end();
}
}
}
switch (t->x_kind) {
case EXT:
return mk_power(elem_type);
case SEQ:
return (aflag ? rel_type(num_type, elem_type)
: mk_seq(elem_type));
case BAG:
return (aflag ? rel_type(elem_type, num_type)
: mk_bag(elem_type));
}
}
case THETA:
return theta_type(t, e, (type) NULL, t);
case BINDING: {
tree u;
env e1 = new_env(e);
for (u = t->x_elements; u != nil; u = cdr(u))
add_def(VAR, (sym) car(u)->x_lhs,
tc_expr(car(u)->x_rhs, e), e1);
return mk_sproduct(mk_schema(e1));
}
case SELECT: {
type a = tc_expr(t->x_arg, e);
if (type_kind(a) != SPRODUCT) {
tc_error(t->x_loc,
"Argument of selection must have schema type");
tc_e_etc("Expression: %z", t);
tc_e_etc("Arg type: %t", a);
tc_e_end();
mark_error();
return err_type;
}
switch (t->x_field->x_kind) {
case IDENT:
return (comp_type(a, (sym) t->x_field, t, t->x_loc));
case THETA:
return (theta_type(t->x_field, e, a, t));
default:
bad_tag("tc_expr.SELECT", t->x_field->x_kind);
return (type) NULL;
}
}
case APPLY:
return tc_apply(APPLY, t, t->x_arg1, t->x_arg2, e);
case INOP:
return tc_apply(INOP, t, simply(t->x_op, t->x_loc),
pair(t->x_rand1, t->x_rand2), e);
case POSTOP:
return tc_apply(POSTOP, t, simply(t->x_op, t->x_loc),
t->x_rand, e);
case LAMBDA: {
env e1 = tc_schema(t->x_bvar, e);
type dom = tc_expr(char_tuple(t->x_bvar), e1);
type ran = tc_expr(t->x_body, e1);
return (aflag ? rel_type(dom, ran) : mk_pfun(dom, ran));
}
case COMP:
case MU: {
env e1 = tc_schema(t->x_bvar, e);
type a = tc_expr(exists(t->x_body) ? the(t->x_body) :
char_tuple(t->x_bvar), e1);
return (t->x_kind == COMP ? mk_power(a) : a);
}
case LETEXPR:
return tc_expr(t->x_body, tc_letdefs(t->x_defs, e));
case IF: {
type a, b;
tc_pred(t->x_if, e);
a = tc_expr(t->x_then, e);
b = tc_expr(t->x_else, e);
if (unify(a, b))
return type_union(a, arid, b, arid);
else {
tc_error(t->x_loc,
"Type mismatch in conditional expression");
tc_e_etc("Expression: %z", t);
tc_e_etc("Then type: %t", a);
tc_e_etc("Else type: %t", b);
tc_e_end();
return err_type;
}
}
default:
bad_tag("tc_expr", t->x_kind);
/* dummy */ return (type) NULL;
}
}
PRIVATE type lambda_ty(env bv, type t, frame f)
{
#ifdef DEBUG
if (debug('t'))
grind(stdout, "lambda_ty(%x)\n", t);
#endif
if (t == NULL) panic("lambda_ty");
if (f == arid && is_perm((univ) t)) {
/* It's lambda bv . t[NULL] where t is already permanent.
This means that t contains no bound vars: return t */
#ifdef DEBUG
if (debug('t'))
grind(stdout, "Reused type %t\n", t);
#endif
return t;
}
switch (t->t_kind) {
case GIVENT:
/* lambda bv . v[f] -- look for v among the bv's */
return var_rep(bv, t);
case TYPEVAR:
/* lambda bv . Vi[f] = lambda bv. fi[NULL] */
return lambda_ty(bv, tv_val(t, f), arid);
case POWERT:
/* lambda bv . (P t)[f] = P (lambda bv . t[f]) */
return mk_power(lambda_ty(bv, t->t_base, f));
case CPRODUCT: {
/* lambda bv . (t1 x ... x tn)[f]
= (lambda bv . t1[f]) x ... x (lambda bv . tn[f]) */
type a[MAX_ARGS];
int i;
if (t->t_nfields > MAX_ARGS)
panic("lambda_ty - too many fields");
for (i = 0; i < t->t_nfields; i++)
a[i] = lambda_ty(bv, t->t_field[i], f);
return mk_cproduct(t->t_nfields, a);
}
case SPRODUCT: {
/* lambda bv . <| x1: t1; ... |>[f]
= <| x1: lambda bv. t1[f]; ... |> */
schema s = t->t_schema;
int n = s->z_ncomps;
schema s1 = alloc_schema(n);
int i;
for (i = 0; i < n; i++) {
s1->z_comp[i].z_name = s->z_comp[i].z_name;
s1->z_comp[i].z_type
= lambda_ty(bv, s->z_comp[i].z_type, f);
}
return mk_sproduct(s1);
}
case MOLECULE:
/* lambda bv . (MOLECULE t f')[f] = lambda bv . t[f'] */
return lambda_ty(bv, t->t_mtype, t->t_mframe);
case ABBREV: {
/* lambda bv . (ABBREV d {t1 t2 ... tn})[f]
= ABBREV d {(lambda bv . t1[f]) ... } */
frame p = t->t_params;
frame pp = mk_frame(fsize(p));
int i;
for (i = 0; i < fsize(p); i++)
pp->f_var[i] = lambda_ty(bv, p->f_var[i], f);
return mk_abbrev(t->t_def, pp);
}
default:
bad_tag("lambda_ty", t->t_kind);
return (type) NULL;
}
}