diff options
Diffstat (limited to 'gcc/fortran/symbol.c')
| -rw-r--r-- | gcc/fortran/symbol.c | 159 |
1 files changed, 134 insertions, 25 deletions
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8efd12c..0ee7dec 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -40,6 +40,7 @@ const mstring flavors[] = minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), + minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), minit (NULL, -1) }; @@ -444,7 +445,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: - case FL_DERIVED: + case_fl_struct: case FL_PARAMETER: a1 = gfc_code2string (flavors, attr->flavor); a2 = save; @@ -740,7 +741,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; - case FL_DERIVED: + case_fl_struct: conf2 (dummy); conf2 (pointer); conf2 (target); @@ -1579,7 +1580,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, { if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE - || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED + || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) || f == FL_NAMELIST) && check_used (attr, name, where)) return false; @@ -2048,6 +2049,11 @@ gfc_add_component (gfc_symbol *sym, const char *name, { gfc_component *p, *tail; + /* Check for existing components with the same name, but not for union + components or containers. Unions and maps are anonymous so they have + unique internal names which will never conflict. + Don't use gfc_find_component here because it calls gfc_use_derived, + but the derived type may not be fully defined yet. */ tail = NULL; for (p = sym->components; p; p = p->next) @@ -2063,7 +2069,8 @@ gfc_add_component (gfc_symbol *sym, const char *name, } if (sym->attr.extension - && gfc_find_component (sym->components->ts.u.derived, name, true, true)) + && gfc_find_component (sym->components->ts.u.derived, + name, true, true, NULL)) { gfc_error ("Component %qs at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); @@ -2154,7 +2161,7 @@ gfc_use_derived (gfc_symbol *sym) return NULL; } - if (s == NULL || s->attr.flavor != FL_DERIVED) + if (s == NULL || !gfc_fl_struct (s->attr.flavor)) goto bad; /* Get rid of symbol sym, translating all references to s. */ @@ -2188,28 +2195,113 @@ bad: } +/* Find the component with the given name in the union type symbol. + If ref is not NULL it will be set to the chain of components through which + the component can actually be accessed. This is necessary for unions because + intermediate structures may be maps, nested structures, or other unions, + all of which may (or must) be 'anonymous' to user code. */ + +static gfc_component * +find_union_component (gfc_symbol *un, const char *name, + bool noaccess, gfc_ref **ref) +{ + gfc_component *m, *check; + gfc_ref *sref, *tmp; + + for (m = un->components; m; m = m->next) + { + check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); + if (check == NULL) + continue; + + /* Found component somewhere in m; chain the refs together. */ + if (ref) + { + /* Map ref. */ + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = m; + sref->u.c.sym = m->ts.u.derived; + sref->next = tmp; + + *ref = sref; + } + /* Other checks (such as access) were done in the recursive calls. */ + return check; + } + return NULL; +} + + /* Given a derived type node and a component name, try to locate the component structure. Returns the NULL pointer if the component is not found or the components are private. If noaccess is set, no access - checks are done. */ + checks are done. If silent is set, an error will not be generated if + the component cannot be found or accessed. + + If ref is not NULL, *ref is set to represent the chain of components + required to get to the ultimate component. + + If the component is simply a direct subcomponent, or is inherited from a + parent derived type in the given derived type, this is a single ref with its + component set to the returned component. + + Otherwise, *ref is constructed as a chain of subcomponents. This occurs + when the component is found through an implicit chain of nested union and + map components. Unions and maps are "anonymous" substructures in FORTRAN + which cannot be explicitly referenced, but the reference chain must be + considered as in C for backend translation to correctly compute layouts. + (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ gfc_component * gfc_find_component (gfc_symbol *sym, const char *name, - bool noaccess, bool silent) + bool noaccess, bool silent, gfc_ref **ref) { - gfc_component *p; + gfc_component *p, *check; + gfc_ref *sref = NULL, *tmp = NULL; if (name == NULL || sym == NULL) return NULL; - sym = gfc_use_derived (sym); + if (sym->attr.flavor == FL_DERIVED) + sym = gfc_use_derived (sym); + else + gcc_assert (gfc_fl_struct (sym->attr.flavor)); if (sym == NULL) return NULL; + /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ + if (sym->attr.flavor == FL_UNION) + return find_union_component (sym, name, noaccess, ref); + + if (ref) *ref = NULL; for (p = sym->components; p; p = p->next) - if (strcmp (p->name, name) == 0) - break; + { + /* Nest search into union's maps. */ + if (p->ts.type == BT_UNION) + { + check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); + if (check != NULL) + { + /* Union ref. */ + if (ref) + { + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = p; + sref->u.c.sym = p->ts.u.derived; + sref->next = tmp; + *ref = sref; + } + return check; + } + } + else if (strcmp (p->name, name) == 0) + break; + + continue; + } if (p && sym->attr.use_assoc && !noaccess) { @@ -2231,7 +2323,7 @@ gfc_find_component (gfc_symbol *sym, const char *name, && sym->components->ts.type == BT_DERIVED) { p = gfc_find_component (sym->components->ts.u.derived, name, - noaccess, silent); + noaccess, silent, ref); /* Do not overwrite the error. */ if (p == NULL) return p; @@ -2241,6 +2333,25 @@ gfc_find_component (gfc_symbol *sym, const char *name, gfc_error ("%qs at %C is not a member of the %qs structure", name, sym->name); + /* Component was found; build the ultimate component reference. */ + if (p != NULL && ref) + { + tmp = gfc_get_ref (); + tmp->type = REF_COMPONENT; + tmp->u.c.component = p; + tmp->u.c.sym = sym; + /* Link the final component ref to the end of the chain of subrefs. */ + if (sref) + { + *ref = sref; + for (; sref->next; sref = sref->next) + ; + sref->next = tmp; + } + else + *ref = tmp; + } + return p; } @@ -3338,11 +3449,9 @@ gfc_restore_last_undo_checkpoint (void) /* The derived type is saved in the symtree with the first letter capitalized; the all lower-case version to the derived type contains its associated generic function. */ - if (p->attr.flavor == FL_DERIVED) - gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) p->name[0]), - &p->name[1])); - else + if (gfc_fl_struct (p->attr.flavor)) + gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); + else gfc_delete_symtree (&p->ns->sym_root, p->name); gfc_release_symbol (p); @@ -4526,10 +4635,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, const char *hidden_name; gfc_interface *intr, *head; - hidden_name = gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) - tmp_sym->name[0]), - &tmp_sym->name[1]); + hidden_name = gfc_dt_upper_string (tmp_sym->name); tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, hidden_name); gcc_assert (tmp_symtree == NULL); @@ -4740,6 +4846,8 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) bool is_class2 = (ts2->type == BT_CLASS); bool is_derived1 = (ts1->type == BT_DERIVED); bool is_derived2 = (ts2->type == BT_DERIVED); + bool is_union1 = (ts1->type == BT_UNION); + bool is_union2 = (ts2->type == BT_UNION); if (is_class1 && ts1->u.derived->components @@ -4749,10 +4857,11 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) || ts1->u.derived->attr.unlimited_polymorphic)) return 1; - if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 + && !is_union1 && !is_union2) return (ts1->type == ts2->type); - if (is_derived1 && is_derived2) + if ((is_derived1 && is_derived2) || (is_union1 && is_union1)) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); if (is_derived1 && is_class2) @@ -4821,12 +4930,12 @@ gfc_find_dt_in_generic (gfc_symbol *sym) { gfc_interface *intr = NULL; - if (!sym || sym->attr.flavor == FL_DERIVED) + if (!sym || gfc_fl_struct (sym->attr.flavor)) return sym; if (sym->attr.generic) for (intr = sym->generic; intr; intr = intr->next) - if (intr->sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (intr->sym->attr.flavor)) break; return intr ? intr->sym : NULL; } |