void
gfc_add_component_ref (gfc_expr *e, const char *name)
{
gfc_ref **tail = &(e->ref);
gfc_ref *next = NULL;
gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
while (*tail != NULL)
{
if ((*tail)->type == REF_COMPONENT)
derived = (*tail)->u.c.component->ts.u.derived;
if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
break;
tail = &((*tail)->next);
}
if (*tail != NULL && strcmp (name, "_data") == 0)
next = *tail;
(*tail) = gfc_get_ref();
(*tail)->next = next;
(*tail)->type = REF_COMPONENT;
(*tail)->u.c.sym = derived;
(*tail)->u.c.component = gfc_find_component (derived, name, true, true);
gcc_assert((*tail)->u.c.component);
if (!next)
e->ts = (*tail)->u.c.component->ts;
}
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);
}
}
static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
c = gfc_find_component (vtype, name, true, true);
if (c == NULL)
{
/* Add procedure component. */
if (gfc_add_component (vtype, name, &c) == FAILURE)
return;
if (tb->u.specific)
c->ts.interface = tb->u.specific->n.sym;
if (!c->tb)
c->tb = XCNEW (gfc_typebound_proc);
*c->tb = *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;
}
else if (c->attr.proc_pointer && c->tb)
{
*c->tb = *tb;
c->tb->ppc = 1;
c->ts.interface = tb->u.specific->n.sym;
}
}
static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
c = gfc_find_component (vtype, name, true, true);
if (c == NULL)
{
/* Add procedure component. */
if (gfc_add_component (vtype, name, &c) == FAILURE)
return;
if (!c->tb)
c->tb = XCNEW (gfc_typebound_proc);
*c->tb = *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;
}
else if (c->attr.proc_pointer && c->tb)
{
*c->tb = *tb;
c->tb->ppc = 1;
}
if (tb->u.specific)
{
c->ts.interface = tb->u.specific->n.sym;
if (!tb->deferred)
c->initializer = gfc_get_variable_expr (tb->u.specific);
}
}
