diff options
| author | Harald Anlauf <anlauf@gmx.de> | 2023-03-02 22:37:14 +0100 |
|---|---|---|
| committer | Harald Anlauf <anlauf@gmx.de> | 2023-03-05 21:10:39 +0100 |
| commit | 6aa1f40a3263741d964ef4716e85a0df5cec83b6 (patch) | |
| tree | 4ee01f9ce824da43fcad405312812ffd318ef782 /gcc/fortran/class.cc | |
| parent | ca27d765f1d88a0f9d625b3519b6a8b1f8b19cc7 (diff) | |
| download | gcc-6aa1f40a3263741d964ef4716e85a0df5cec83b6.zip gcc-6aa1f40a3263741d964ef4716e85a0df5cec83b6.tar.gz gcc-6aa1f40a3263741d964ef4716e85a0df5cec83b6.tar.bz2 | |
Fortran: fix CLASS attribute handling [PR106856]
gcc/fortran/ChangeLog:
PR fortran/106856
* class.cc (gfc_build_class_symbol): Handle update of attributes of
existing class container.
(gfc_find_derived_vtab): Fix several memory leaks.
(find_intrinsic_vtab): Ditto.
* decl.cc (attr_decl1): Manage update of symbol attributes from
CLASS attributes.
* primary.cc (gfc_variable_attr): OPTIONAL shall not be taken or
updated from the class container.
* symbol.cc (free_old_symbol): Adjust management of symbol versions
to not prematurely free array specs while working on the declation
of CLASS variables.
gcc/testsuite/ChangeLog:
PR fortran/106856
* gfortran.dg/interface_41.f90: Remove dg-pattern from valid testcase.
* gfortran.dg/class_74.f90: New test.
* gfortran.dg/class_75.f90: New test.
Co-authored-by: Tobias Burnus <tobias@codesourcery.com>
Diffstat (limited to 'gcc/fortran/class.cc')
| -rw-r--r-- | gcc/fortran/class.cc | 25 |
1 files changed, 22 insertions, 3 deletions
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index ae653e7..52235ab 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -638,6 +638,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, { char tname[GFC_MAX_SYMBOL_LEN+1]; char *name; + gfc_typespec *orig_ts = ts; gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; @@ -646,9 +647,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gcc_assert (as); - if (attr->class_ok) - /* Class container has already been built. */ + /* Class container has already been built with same name. */ + if (attr->class_ok + && ts->u.derived->components->attr.dimension >= attr->dimension + && ts->u.derived->components->attr.codimension >= attr->codimension + && ts->u.derived->components->attr.class_pointer >= attr->pointer + && ts->u.derived->components->attr.allocatable >= attr->allocatable) return true; + if (attr->class_ok) + { + attr->dimension |= ts->u.derived->components->attr.dimension; + attr->codimension |= ts->u.derived->components->attr.codimension; + attr->pointer |= ts->u.derived->components->attr.class_pointer; + attr->allocatable |= ts->u.derived->components->attr.allocatable; + ts = &ts->u.derived->components->ts; + } attr->class_ok = attr->dummy || attr->pointer || attr->allocatable || attr->select_type_temporary || attr->associate_var; @@ -790,7 +803,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, } fclass->attr.is_class = 1; - ts->u.derived = fclass; + orig_ts->u.derived = fclass; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; (*as) = NULL; free (name); @@ -2344,6 +2357,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); + free (name); name = xasprintf ("__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); @@ -2447,6 +2461,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) else { /* Construct default initialization variable. */ + free (name); name = xasprintf ("__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target = 1; @@ -2480,6 +2495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ + free (name); name = xasprintf ("__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; @@ -2558,6 +2574,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ + free (name); name = xasprintf ("__deallocate_%s", tname); gfc_get_symbol (name, sub_ns, &dealloc); sub_ns->proc_name = dealloc; @@ -2723,6 +2740,7 @@ find_intrinsic_vtab (gfc_typespec *ts) vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); + free (name); name = xasprintf ("__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); @@ -2801,6 +2819,7 @@ find_intrinsic_vtab (gfc_typespec *ts) c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; + free (name); if (ts->type != BT_CHARACTER) name = xasprintf ("__copy_%s", tname); else |