gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as, bool delayed_vtab)
+ gfc_array_spec **as)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
/* Determine the name of the encapsulating type. */
if ((*as) && (*as)->rank && attr->allocatable)
- sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
+ sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
else if ((*as) && (*as)->rank)
- sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
- else if (attr->pointer)
- sprintf (name, "class$%s_p", ts->u.derived->name);
+ sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
else if (attr->allocatable)
- sprintf (name, "class$%s_a", ts->u.derived->name);
+ sprintf (name, ".class.%s.a", ts->u.derived->name);
else
- sprintf (name, "class$%s", ts->u.derived->name);
+ sprintf (name, ".class.%s", ts->u.derived->name);
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
if (fclass == NULL)
c->attr.codimension = attr->codimension;
c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
- c->initializer = NULL;
+ c->initializer = gfc_get_null_expr (NULL);
/* Add component '$vptr'. */
if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_DERIVED;
- if (delayed_vtab)
- c->ts.u.derived = NULL;
- else
- {
- vtab = gfc_find_derived_vtab (ts->u.derived, false);
- gcc_assert (vtab);
- c->ts.u.derived = vtab->ts.u.derived;
- }
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ c->ts.u.derived = vtab->ts.u.derived;
c->attr.pointer = 1;
}
}
-static void
-add_proc_component (gfc_component *c, gfc_symbol *vtype,
- gfc_symtree *st, gfc_symbol *specific,
- bool is_generic, bool is_generic_specific)
-{
- /* Add procedure component. */
- if (is_generic)
- {
- if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
- return;
- c->ts.interface = specific;
- }
- else if (c && is_generic_specific)
- {
- c->ts.interface = st->n.tb->u.specific->n.sym;
- }
- else
- {
- c = gfc_find_component (vtype, st->name, true, true);
- if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
- return;
- c->ts.interface = st->n.tb->u.specific->n.sym;
- }
-
- if (!c->tb)
- c->tb = XCNEW (gfc_typebound_proc);
- *c->tb = *st->n.tb;
- c->tb->ppc = 1;
- c->attr.procedure = 1;
- c->attr.proc_pointer = 1;
- c->attr.flavor = FL_PROCEDURE;
- c->attr.access = ACCESS_PRIVATE;
- c->attr.external = 1;
- c->attr.untyped = 1;
- c->attr.if_source = IFSRC_IFBODY;
-
- /* A static initializer cannot be used here because the specific
- function is not a constant; internal compiler error: in
- output_constant, at varasm.c:4623 */
- c->initializer = NULL;
-}
-
-
-static void
-add_proc_comps (gfc_component *c, gfc_symbol *vtype,
- gfc_symtree *st, bool is_generic)
-{
- if (c == NULL && !is_generic)
- {
- add_proc_component (c, vtype, st, NULL, false, false);
- }
- else if (is_generic && st->n.tb && vtype->components == NULL)
- {
- gfc_tbp_generic* g;
- gfc_symbol * specific;
- for (g = st->n.tb->u.generic; g; g = g->next)
- {
- if (!g->specific)
- continue;
- specific = g->specific->u.specific->n.sym;
- add_proc_component (NULL, vtype, st, specific, true, false);
- }
- }
- else if (c->attr.proc_pointer && c->tb)
- {
- *c->tb = *st->n.tb;
- c->tb->ppc = 1;
- c->ts.interface = st->n.tb->u.specific->n.sym;
- }
-}
-
-static void
-add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
- bool resolved)
-{
- gfc_component *c;
- gfc_symbol *generic;
- char name[3 * GFC_MAX_SYMBOL_LEN + 10];
-
- if (!st)
- return;
-
- if (st->left)
- add_procs_to_declared_vtab1 (st->left, vtype, resolved);
-
- if (st->right)
- add_procs_to_declared_vtab1 (st->right, vtype, resolved);
-
- if (!st->n.tb)
- return;
-
- if (!st->n.tb->is_generic && st->n.tb->u.specific)
- {
- c = gfc_find_component (vtype, st->name, true, true);
- add_proc_comps (c, vtype, st, false);
- }
- else if (st->n.tb->is_generic)
- {
- c = gfc_find_component (vtype, st->name, true, true);
-
- if (c == NULL)
- {
- /* Add derived type component with generic name. */
- if (gfc_add_component (vtype, st->name, &c) == FAILURE)
- return;
- c->ts.type = BT_DERIVED;
- c->attr.flavor = FL_VARIABLE;
- c->attr.pointer = 1;
-
- /* Add a special empty derived type as a placeholder. */
- sprintf (name, "$empty");
- gfc_find_symbol (name, vtype->ns, 0, &generic);
- if (generic == NULL)
- {
- gfc_get_symbol (name, vtype->ns, &generic);
- generic->attr.flavor = FL_DERIVED;
- generic->refs++;
- gfc_set_sym_referenced (generic);
- generic->ts.type = BT_UNKNOWN;
- generic->attr.zero_comp = 1;
- }
-
- c->ts.u.derived = generic;
- }
- }
-}
-
-
-static void
-copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
- bool resolved)
-{
- gfc_component *c, *cmp;
- gfc_symbol *vtab;
-
- vtab = gfc_find_derived_vtab (declared, resolved);
-
- for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
- {
- if (gfc_find_component (vtype, cmp->name, true, true))
- continue;
-
- if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
- return;
-
- if (cmp->ts.type == BT_DERIVED)
- {
- c->ts = cmp->ts;
- c->ts.u.derived = cmp->ts.u.derived;
- c->attr.flavor = FL_VARIABLE;
- c->attr.pointer = 1;
- c->initializer = NULL;
- continue;
- }
-
- c->tb = XCNEW (gfc_typebound_proc);
- *c->tb = *cmp->tb;
- c->attr.procedure = 1;
- c->attr.proc_pointer = 1;
- c->attr.flavor = FL_PROCEDURE;
- c->attr.access = ACCESS_PRIVATE;
- c->attr.external = 1;
- c->ts.interface = cmp->ts.interface;
- c->attr.untyped = 1;
- c->attr.if_source = IFSRC_IFBODY;
- c->initializer = NULL;
- }
-}
-
-static void
-add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
- gfc_symbol *derived, bool resolved)
-{
- gfc_symbol* super_type;
-
- super_type = gfc_get_derived_super_type (declared);
-
- if (super_type && (super_type != declared))
- add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
-
- if (declared != derived)
- copy_vtab_proc_comps (declared, vtype, resolved);
-
- if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
- add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
- vtype, resolved);
-
- if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
- add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
- vtype, resolved);
-}
-
-
-static
-void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
- const char *name)
-{
- gfc_tbp_generic* g;
- gfc_symbol * specific1;
- gfc_symbol * specific2;
- gfc_symtree *st = NULL;
- gfc_component *c;
-
- /* Find the generic procedure using the component name. */
- st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
- if (st == NULL)
- st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
-
- if (st == NULL)
- return;
-
- /* Add procedure pointer components for the specific procedures. */
- for (g = st->n.tb->u.generic; g; g = g->next)
- {
- if (!g->specific)
- continue;
- specific1 = g->specific_st->n.tb->u.specific->n.sym;
-
- c = vtab->ts.u.derived->components;
- specific2 = NULL;
-
- /* Override identical specific interface. */
- if (vtab->ts.u.derived->components)
- {
- for (; c; c= c->next)
- {
- specific2 = c->ts.interface;
- if (gfc_compare_interfaces (specific2, specific1,
- specific1->name, 0, 0, NULL, 0))
- break;
- }
- }
-
- add_proc_component (c, vtab->ts.u.derived, g->specific_st,
- NULL, false, true);
- vtab->ts.u.derived->attr.zero_comp = 0;
- }
-}
-
-
-static void
-add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
- gfc_symbol *derived, bool resolved)
-{
- gfc_component *cmp;
- gfc_symtree *st = NULL;
- gfc_symbol * vtab;
- char name[2 * GFC_MAX_SYMBOL_LEN + 8];
- gfc_symbol* super_type;
-
- gcc_assert (resolved);
-
- for (cmp = vtype->components; cmp; cmp = cmp->next)
- {
- if (cmp->ts.type != BT_DERIVED)
- continue;
-
- /* The only derived type that does not represent a generic
- procedure is the pointer to the parent vtab. */
- if (cmp->ts.u.derived
- && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
- continue;
-
- /* Find the generic procedure using the component name. */
- st = gfc_find_typebound_proc (declared, NULL, cmp->name,
- true, NULL);
- if (st == NULL)
- st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
- true, NULL);
-
- /* Should be an error but we pass on it for now. */
- if (st == NULL || !st->n.tb->is_generic)
- continue;
-
- vtab = NULL;
-
- /* Build a vtab and a special vtype, with only the procedure
- pointer fields, to carry the pointers to the specific
- procedures. Should this name ever be changed, the same
- should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
- sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
- gfc_find_symbol (name, derived->ns, 0, &vtab);
- if (vtab == NULL)
- {
- gfc_get_symbol (name, derived->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, "%s$%s", vtype->name, cmp->name);
-
- gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
- if (cmp->ts.u.derived == NULL
- || (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
- {
- gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
- if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
- return;
- cmp->ts.u.derived->refs++;
- gfc_set_sym_referenced (cmp->ts.u.derived);
- cmp->ts.u.derived->attr.vtype = 1;
- cmp->ts.u.derived->attr.zero_comp = 1;
- }
- vtab->ts.u.derived = cmp->ts.u.derived;
- }
-
- /* Store this for later use in setting the pointer. */
- cmp->ts.interface = vtab;
-
- if (vtab->ts.u.derived->components)
- continue;
-
- super_type = gfc_get_derived_super_type (declared);
-
- if (super_type && (super_type != declared))
- add_generic_specifics (super_type, vtab, cmp->name);
-
- add_generic_specifics (declared, vtab, cmp->name);
- }
-}
-
-
-/* Find the symbol for a derived type's vtab. A vtab has the following
- fields:
- $hash a hash value used to identify the derived type
- $size the size in bytes of the derived type
- $extends a pointer to the vtable of the parent derived type
- then:
- procedure pointer components for the specific typebound procedures
- structure pointers to reduced vtabs that contain procedure
- pointers to the specific procedures. */
+/* Find the symbol for a derived type's vtab. */
gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
+gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL;
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
+ vtab->attr.access = ACCESS_PRIVATE;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "vtype$%s", derived->name);
return NULL;
vtype->refs++;
gfc_set_sym_referenced (vtype);
+ vtype->attr.access = ACCESS_PRIVATE;
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
parent = gfc_get_derived_super_type (derived);
if (parent)
{
- parent_vtab = gfc_find_derived_vtab (parent, resolved);
+ 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);
+ gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
+ &c->initializer->symtree);
}
else
{
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
-
- add_procs_to_declared_vtab (derived, vtype, derived, resolved);
- vtype->attr.vtype = 1;
}
-
vtab->ts.u.derived = vtype;
+
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
- /* Catch the call just before the backend declarations are built, so that
- the generic procedures have been resolved and the specific procedures
- have formal interfaces that can be compared. */
- if (resolved
- && vtab->ts.u.derived
- && vtab->ts.u.derived->backend_decl == NULL)
- add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
- derived, resolved);
-
return vtab;
}
OSDN Git Service
