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); } }