static void
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
{
gfc_component *cmp;
gfc_symbol *vtab;
vtab = gfc_find_derived_vtab (declared);
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
{
if (gfc_find_component (vtype, cmp->name, true, true))
continue;
add_proc_comp (vtype, cmp->name, cmp->tb);
}
}
gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts)
{
gfc_expr *init;
gfc_component *comp;
init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
&ts->u.derived->declared_at);
init->ts = *ts;
for (comp = ts->u.derived->components; comp; comp = comp->next)
{
gfc_constructor *ctor = gfc_constructor_get();
if (strcmp (comp->name, "_vptr") == 0)
ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
}
return init;
}
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_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as, bool delayed_vtab)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
if (attr->class_ok)
/* Class container has already been built. */
return SUCCESS;
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;
if (!attr->class_ok)
/* We can not build the class container yet. */
return SUCCESS;
if (*as)
{
gfc_fatal_error ("Polymorphic array at %C not yet supported");
return FAILURE;
}
/* Determine the name of the encapsulating type. */
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && (*as)->rank && attr->allocatable)
sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
else if ((*as) && (*as)->rank)
sprintf (name, "__class_%s_%d", tname, (*as)->rank);
else if (attr->pointer)
sprintf (name, "__class_%s_p", tname);
else if (attr->allocatable)
sprintf (name, "__class_%s_a", tname);
else
sprintf (name, "__class_%s", tname);
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
if (fclass == NULL)
{
gfc_symtree *st;
/* If not there, create a new symbol. */
fclass = gfc_new_symbol (name, ts->u.derived->ns);
st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
st->n.sym = fclass;
gfc_set_sym_referenced (fclass);
fclass->refs++;
fclass->ts.type = BT_UNKNOWN;
fclass->attr.abstract = ts->u.derived->attr.abstract;
if (ts->u.derived->f2k_derived)
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return FAILURE;
/* Add component '_data'. */
if (gfc_add_component (fclass, "_data", &c) == FAILURE)
return FAILURE;
c->ts = *ts;
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->ts.u.derived = ts->u.derived;
c->attr.class_pointer = attr->pointer;
c->attr.pointer = attr->pointer || attr->dummy;
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
c->attr.codimension = attr->codimension;
c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
c->initializer = 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);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
}
c->attr.access = ACCESS_PRIVATE;
c->attr.pointer = 1;
}
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{
gfc_error ("Maximum extension level reached with type '%s' at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return FAILURE;
}
fclass->attr.extension = ts->u.derived->attr.extension + 1;
fclass->attr.is_class = 1;
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = 0;
(*as) = NULL; /* XXX */
return SUCCESS;
}
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;
}