ast_t* control_type_add_branch(ast_t* control_type, ast_t* branch)
{
assert(branch != NULL);
ast_t* branch_type = ast_type(branch);
if(is_typecheck_error(branch_type))
return branch_type;
if(is_type_literal(branch_type))
{
// The new branch is a literal
if(control_type == NULL)
control_type = ast_from(branch, TK_LITERAL);
if(ast_id(control_type) != TK_LITERAL)
{
// The current control type is not a literal, fix that
ast_t* old_control = control_type;
control_type = ast_from(branch, TK_LITERAL);
ast_settype(control_type, old_control);
}
assert(ast_id(control_type) == TK_LITERAL);
// Add a literal branch reference to the new branch
ast_t* member = ast_from(branch, TK_LITERALBRANCH);
ast_setdata(member, (void*)branch);
ast_append(control_type, member);
ast_t* branch_non_lit = ast_type(branch_type);
if(branch_non_lit != NULL)
{
// The branch's literal type has a non-literal component
ast_t* non_literal_type = ast_type(control_type);
ast_settype(control_type, type_union(non_literal_type, branch_non_lit));
}
return control_type;
}
if(control_type != NULL && ast_id(control_type) == TK_LITERAL)
{
// New branch is not literal, but the control structure is
// Add new branch type to the control structure's non-literal aspect
ast_t* non_literal_type = ast_type(control_type);
non_literal_type = type_union(non_literal_type, branch_type);
ast_settype(control_type, non_literal_type);
return control_type;
}
// No literals here, just union the types
return type_union(control_type, branch_type);
}
static void incomplete_type_error(expression e, type t)
{
/* Avoid duplicate error message. */
if (t == error_type)
return;
if (e && is_identifier(e))
error("`%s' has an incomplete type", CAST(identifier, e)->cstring.data);
else
{
while (type_array(t) && type_array_size(t))
t = type_array_of(t);
if (type_struct(t))
error("invalid use of undefined type `struct %s'", type_tag(t)->name);
else if (type_union(t))
error("invalid use of undefined type `union %s'", type_tag(t)->name);
else if (type_enum(t))
error("invalid use of undefined type `enum %s'", type_tag(t)->name);
else if (type_void(t))
error("invalid use of void expression");
else if (type_array(t))
error("invalid use of array with unspecified bounds");
else
assert(0);
/* XXX: Missing special message for typedef's */
}
}
PRIVATE void or_fun(def d1, def d2, env v, tree cxt)
{
if (d1 == NULL) {
d2->d_type = super_expand(d2->d_type, arid);
push_def(d2, v);
}
else if (d2 == NULL) {
d1->d_type = super_expand(d1->d_type, arid);
push_def(d1, v);
}
else {
if (check_types(d1->d_type, d2->d_type, d1->d_name,
cxt, cxt->x_loc))
d1->d_type = type_union(d1->d_type, arid, d2->d_type, arid);
push_def(d1, v);
}
}
// Coerce a literal control block to be the specified target type
static bool coerce_control_block(ast_t** astp, ast_t* target_type,
lit_chain_t* chain, pass_opt_t* options, bool report_errors)
{
assert(astp != NULL);
ast_t* literal_expr = *astp;
assert(literal_expr != NULL);
ast_t* lit_type = ast_type(literal_expr);
assert(lit_type != NULL);
assert(ast_id(lit_type) == TK_LITERAL);
ast_t* block_type = ast_type(lit_type);
for(ast_t* p = ast_child(lit_type); p != NULL; p = ast_sibling(p))
{
assert(ast_id(p) == TK_LITERALBRANCH);
ast_t* branch = (ast_t*)ast_data(p);
assert(branch != NULL);
if(!coerce_literal_to_type(&branch, target_type, chain, options,
report_errors))
{
ast_free_unattached(block_type);
return false;
}
block_type = type_union(block_type, ast_type(branch));
}
if(is_typecheck_error(block_type))
return false;
// block_type may be a sub-tree of the current type of literal_expr.
// This means we must copy it before setting it as the type since ast_settype
// will first free the existing type of literal_expr, which may include
// block_type.
if(ast_parent(block_type) != NULL)
block_type = ast_dup(block_type);
ast_settype(literal_expr, block_type);
return true;
}
static void dump_type(type t)
{
if (type_complex(t))
{
printf("C");
t = make_base_type(t);
}
if (type_network_base_type(t))
printf("N%s", type_networkdef(t)->name);
/* Enums treated as ints for now */
else if (type_integer(t))
if (type_unsigned(t))
printf("U");
else
printf("I");
else if (type_float(t))
printf("F");
else if (type_double(t))
printf("D");
else if (type_long_double(t))
printf("LD");
else if (type_union(t))
if (type_network(t))
printf("ANU");
else
printf("AU");
else if (type_struct(t))
if (type_network(t))
printf("ANS");
else
printf("AS");
else if (type_pointer(t))
printf("U");
else
assert(0);
}
static ast_t* find_infer_type(ast_t* type, infer_path_t* path)
{
assert(type != NULL);
switch(ast_id(type))
{
case TK_TUPLETYPE:
if(path == NULL) // End of path, infer the whole tuple
return type;
if(path->index >= ast_childcount(type)) // Cardinality mismatch
return NULL;
return find_infer_type(ast_childidx(type, path->index), path->next);
case TK_UNIONTYPE:
{
// Infer all children
ast_t* u_type = NULL;
for(ast_t* p = ast_child(type); p != NULL; p = ast_sibling(p))
{
ast_t* t = find_infer_type(p, path);
if(t == NULL)
{
// Propogate error
ast_free_unattached(u_type);
return NULL;
}
u_type = type_union(u_type, t);
}
return u_type;
}
case TK_ISECTTYPE:
{
// Infer all children
ast_t* i_type = NULL;
for(ast_t* p = ast_child(type); p != NULL; p = ast_sibling(p))
{
ast_t* t = find_infer_type(p, path);
if(t == NULL)
{
// Propogate error
ast_free_unattached(i_type);
return NULL;
}
i_type = type_isect(i_type, t);
}
return i_type;
}
default:
if(path != NULL) // Type doesn't match path
return NULL;
// Just return whatever this type is
return type;
}
}
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;
}
}
expression make_cast(location loc, asttype t, expression e)
{
expression result = CAST(expression, new_cast(parse_region, loc, e, t));
type castto = t->type;
if (castto == error_type || type_void(castto))
; /* Do nothing */
else if (type_array(castto))
{
error("cast specifies array type");
castto = error_type;
}
else if (type_function(castto))
{
error("cast specifies function type");
castto = error_type;
}
else if (type_equal_unqualified(castto, e->type))
{
if (pedantic && type_aggregate(castto))
pedwarn("ANSI C forbids casting nonscalar to the same type");
}
else
{
type etype = e->type;
/* Convert functions and arrays to pointers,
but don't convert any other types. */
if (type_function(etype) || type_array(etype))
etype = default_conversion(e);
if (type_union(castto))
{
tag_declaration utag = type_tag(castto);
field_declaration ufield;
/* Look for etype as a field of the union */
for (ufield = utag->fieldlist; ufield; ufield = ufield->next)
if (ufield->name && type_equal_unqualified(ufield->type, etype))
{
if (pedantic)
pedwarn("ANSI C forbids casts to union type");
break;
}
if (!ufield)
error("cast to union type from type not present in union");
}
else
{
/* Optionally warn about potentially worrisome casts. */
if (warn_cast_qual && type_pointer(etype) && type_pointer(castto))
{
type ep = type_points_to(etype), cp = type_points_to(castto);
if (type_volatile(ep) && !type_volatile(cp))
pedwarn("cast discards `volatile' from pointer target type");
if (type_const(ep) && !type_const(cp))
pedwarn("cast discards `const' from pointer target type");
}
/* This warning is weird */
if (warn_bad_function_cast && is_function_call(e) &&
!type_equal_unqualified(castto, etype))
warning ("cast does not match function type");
#if 0
/* Warn about possible alignment problems. */
if (STRICT_ALIGNMENT && warn_cast_align
&& TREE_CODE (type) == POINTER_TYPE
&& TREE_CODE (otype) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (otype)) != VOID_TYPE
&& TREE_CODE (TREE_TYPE (otype)) != FUNCTION_TYPE
/* Don't warn about opaque types, where the actual alignment
restriction is unknown. */
&& !((TREE_CODE (TREE_TYPE (otype)) == UNION_TYPE
|| TREE_CODE (TREE_TYPE (otype)) == RECORD_TYPE)
&& TYPE_MODE (TREE_TYPE (otype)) == VOIDmode)
&& TYPE_ALIGN (TREE_TYPE (type)) > TYPE_ALIGN (TREE_TYPE (otype)))
warning ("cast increases required alignment of target type");
if (TREE_CODE (type) == INTEGER_TYPE
&& TREE_CODE (otype) == POINTER_TYPE
&& TYPE_PRECISION (type) != TYPE_PRECISION (otype)
&& !TREE_CONSTANT (value))
warning ("cast from pointer to integer of different size");
if (TREE_CODE (type) == POINTER_TYPE
&& TREE_CODE (otype) == INTEGER_TYPE
&& TYPE_PRECISION (type) != TYPE_PRECISION (otype)
#if 0
/* Don't warn about converting 0 to pointer,
provided the 0 was explicit--not cast or made by folding. */
&& !(TREE_CODE (value) == INTEGER_CST && integer_zerop (value))
#endif
/* Don't warn about converting any constant. */
&& !TREE_CONSTANT (value))
warning ("cast to pointer from integer of different size");
#endif
check_conversion(castto, etype);
}
}
result->lvalue = !pedantic && e->lvalue;
result->isregister = e->isregister;
result->bitfield = e->bitfield;
result->static_address = e->static_address;
result->type = castto;
result->cst = fold_cast(result);
return result;
}
