match
gfc_match_interface (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_symbol *sym;
gfc_intrinsic_op operator;
match m;
m = gfc_match_space ();
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
return MATCH_ERROR;
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
|| (type != INTERFACE_NAMELESS
&& m != MATCH_YES))
{
gfc_error
("Syntax error: Trailing garbage in INTERFACE statement at %C");
return MATCH_ERROR;
}
current_interface.type = type;
switch (type)
{
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
current_interface.sym = gfc_new_block = sym;
break;
case INTERFACE_USER_OP:
current_interface.uop = gfc_get_uop (name);
break;
case INTERFACE_INTRINSIC_OP:
current_interface.op = operator;
break;
case INTERFACE_NAMELESS:
break;
}
return MATCH_YES;
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
/* Create a namespace to store symbols for common blocks. */
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL, 0);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
&& strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size as elsewhere (%lu vs %lu bytes)", com->name,
&com->where,
(unsigned long) TREE_INT_CST_LOW (size),
(unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
DECL_SIZE (decl) = TYPE_SIZE (union_type);
DECL_SIZE_UNIT (decl) = size;
DECL_MODE (decl) = TYPE_MODE (union_type);
TREE_TYPE (decl) = union_type;
layout_decl (decl, 0);
}
}
/* If this common block has been declared in a previous program unit,
and either it is already initialized or there is no new initialization
for it, just return. */
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
decl = build_decl (input_location,
VAR_DECL, get_identifier (com->name), union_type);
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!com->is_bind_c)
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
else
{
/* Do not set the alignment for bind(c) common blocks to
BIGGEST_ALIGNMENT because that won't match what C does. Also,
for common blocks with one element, the alignment must be
that of the field within the common block in order to match
what C will do. */
tree field = NULL_TREE;
field = TYPE_FIELDS (TREE_TYPE (decl));
if (DECL_CHAIN (field) == NULL_TREE)
DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
}
DECL_USER_ALIGN (decl) = 0;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
gfc_set_decl_location (decl, &com->where);
if (com->threadprivate)
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
}
/* Has no initial values. */
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
/* Find the top-level namespace (MODULE or PROGRAM). */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
break;
/* If the type is a class container, use the underlying derived type. */
if (derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
get_unique_hashed_string (tname, derived);
sprintf (name, "__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, derived->ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus) == FAILURE)
goto cleanup;
vtab->attr.target = 1;
vtab->attr.save = SAVE_IMPLICIT;
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
sprintf (name, "__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
goto cleanup;
vtype->attr.access = ACCESS_PUBLIC;
vtype->attr.vtype = 1;
gfc_set_sym_referenced (vtype);
/* Add component '_hash'. */
if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, derived->hash_value);
/* Add component '_size'. */
if (gfc_add_component (vtype, "_size", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0);
/* Add component _extends. */
if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
else
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
if (derived->components == NULL && !derived->attr.zero_comp)
{
/* At this point an error must have occurred.
Prevent further errors on the vtype components. */
found_sym = vtab;
goto have_vtype;
}
/* Add component _def_init. */
if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED;
c->ts.u.derived = derived;
if (derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
/* Construct default initialization variable. */
sprintf (name, "__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
def_init->attr.save = SAVE_IMPLICIT;
def_init->attr.access = ACCESS_PUBLIC;
def_init->attr.flavor = FL_VARIABLE;
gfc_set_sym_referenced (def_init);
def_init->ts.type = BT_DERIVED;
def_init->ts.u.derived = derived;
def_init->value = gfc_default_initializer (&def_init->ts);
c->initializer = gfc_lval_expr_from_sym (def_init);
}
/* Add component _copy. */
if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
if (derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
/* Set up namespace. */
gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
sub_ns->sibling = ns->contained;
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
sprintf (name, "__copy_%s", tname);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
copy->attr.if_source = IFSRC_DECL;
if (ns->proc_name->attr.flavor == FL_MODULE)
copy->module = ns->proc_name->name;
gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
gfc_get_symbol ("src", sub_ns, &src);
src->ts.type = BT_DERIVED;
src->ts.u.derived = derived;
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
gfc_get_symbol ("dst", sub_ns, &dst);
dst->ts.type = BT_DERIVED;
dst->ts.u.derived = derived;
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
/* Set up code. */
sub_ns->code = gfc_get_code ();
sub_ns->code->op = EXEC_INIT_ASSIGN;
sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
/* Set initializer. */
c->initializer = gfc_lval_expr_from_sym (copy);
c->ts.interface = copy;
}
/* Add procedure pointers for type-bound procedures. */
add_procs_to_declared_vtab (derived, vtype);
}
have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
found_sym = vtab;
cleanup:
/* It is unexpected to have some symbols added at resolution or code
generation time. We commit the changes in order to keep a clean state. */
if (found_sym)
{
gfc_commit_symbol (vtab);
if (vtype)
gfc_commit_symbol (vtype);
if (def_init)
gfc_commit_symbol (def_init);
if (copy)
gfc_commit_symbol (copy);
if (src)
gfc_commit_symbol (src);
if (dst)
gfc_commit_symbol (dst);
}
else
gfc_undo_symbols ();
return found_sym;
}
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
ns = gfc_current_ns;
for (; ns; ns = ns->parent)
if (!ns->parent)
break;
if (ns)
{
sprintf (name, "vtab$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
vtab->attr.flavor = FL_VARIABLE;
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "vtype$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
goto cleanup;
vtype->refs++;
gfc_set_sym_referenced (vtype);
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, derived->hash_value);
/* Add component '$size'. */
if (gfc_add_component (vtype, "$size", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0);
/* Add component $extends. */
if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
else
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
add_procs_to_declared_vtab (derived, vtype);
vtype->attr.vtype = 1;
}
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
found_sym = vtab;
cleanup:
/* It is unexpected to have some symbols added at resolution or code
generation time. We commit the changes in order to keep a clean state. */
if (found_sym)
gfc_commit_symbols ();
else
gfc_undo_symbols ();
return found_sym;
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
/* Create a namespace to store symbols for common blocks. */
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size", com->name, &com->where);
DECL_SIZE_UNIT (decl) = size;
}
}
/* If this common block has been declared in a previous program unit,
and either it is already initialized or there is no new initialization
for it, just return. */
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
DECL_USER_ALIGN (decl) = 0;
gfc_set_decl_location (decl, &com->where);
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
}
/* Has no initial values. */
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
