void
gfc_trans_common (gfc_namespace *ns)
{
gfc_common_head *c;
/* Translate the blank common block. */
if (ns->blank_common.head != NULL)
{
c = gfc_get_common_head ();
/* We've lost the real location, so use the location of the
enclosing procedure. */
c->where = ns->proc_name->declared_at;
strcpy (c->name, BLANK_COMMON_NAME);
translate_common (c, ns->blank_common.head);
}
/* Translate all named common blocks. */
gfc_traverse_symtree (ns->common_root, named_common);
/* Commit the newly created symbols for common blocks. */
gfc_commit_symbols ();
/* Translate local equivalence. */
finish_equivalences (ns);
}
void
gfc_trans_common (gfc_namespace *ns)
{
gfc_common_head *c;
/* Translate the blank common block. */
if (ns->blank_common.head != NULL)
{
c = gfc_get_common_head ();
c->where = ns->blank_common.head->common_head->where;
strcpy (c->name, BLANK_COMMON_NAME);
translate_common (c, ns->blank_common.head);
}
/* Translate all named common blocks. */
gfc_traverse_symtree (ns->common_root, named_common);
/* Translate local equivalence. */
finish_equivalences (ns);
/* Commit the newly created symbols for common blocks and module
equivalences. */
gfc_commit_symbols ();
}
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;
}