From 5f88e9b2593ea9bff34c1e4940607a8de1c93592 Mon Sep 17 00:00:00 2001 From: Fritz Reese Date: Mon, 29 Aug 2016 12:24:25 +0000 Subject: [PATCH] Fix, reorganize, and clarify comparisons of anonymous types/components. 2016-08-29 Fritz Reese Fix, reorganize, and clarify comparisons of anonymous types/components. PR fortran/77327 * interface.c (is_anonymous_component, is_anonymous_dt): New functions. * interface.c (compare_components, gfc_compare_derived_types): Use new functions. * gfortran.dg/dec_structure_13.f90: New testcase. From-SVN: r239819 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/interface.c | 62 ++++++++------ gcc/testsuite/ChangeLog | 6 ++ .../gfortran.dg/dec_structure_13.f90 | 81 +++++++++++++++++++ 4 files changed, 133 insertions(+), 25 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dec_structure_13.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9ac5721cf84..899cd32e93e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2016-08-29 Fritz Reese + + Fix, reorganize, and clarify comparisons of anonymous types/components. + + PR fortran/77327 + * interface.c (is_anonymous_component, is_anonymous_dt): New functions. + * interface.c (compare_components, gfc_compare_derived_types): Use new + functions. + 2016-08-27 Steven G. Kargl PR fortran/77380 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 119c534f170..eba0454458e 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -387,26 +387,46 @@ gfc_match_end_interface (void) } +/* Return whether the component was defined anonymously. */ + +static bool +is_anonymous_component (gfc_component *cmp) +{ + /* Only UNION and MAP components are anonymous. In the case of a MAP, + the derived type symbol is FL_STRUCT and the component name looks like mM*. + This is the only case in which the second character of a component name is + uppercase. */ + return cmp->ts.type == BT_UNION + || (cmp->ts.type == BT_DERIVED + && cmp->ts.u.derived->attr.flavor == FL_STRUCT + && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1])); +} + + +/* Return whether the derived type was defined anonymously. */ + +static bool +is_anonymous_dt (gfc_symbol *derived) +{ + /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE + types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT + and the type name looks like XX*. This is the only case in which the + second character of a type name is uppercase. */ + return derived->attr.flavor == FL_UNION + || (derived->attr.flavor == FL_STRUCT + && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1])); +} + + /* Compare components according to 4.4.2 of the Fortran standard. */ static int compare_components (gfc_component *cmp1, gfc_component *cmp2, gfc_symbol *derived1, gfc_symbol *derived2) { - gfc_symbol *d1, *d2; - bool anonymous = false; - - /* Unions, maps, and anonymous structures all have names like "[xX]X$\d+" - which should not be compared. */ - d1 = cmp1->ts.u.derived; - d2 = cmp2->ts.u.derived; - if ( (d1 && (d1->attr.flavor == FL_STRUCT || d1->attr.flavor == FL_UNION) - && ISUPPER (cmp1->name[1])) - || (d2 && (d2->attr.flavor == FL_STRUCT || d2->attr.flavor == FL_UNION) - && ISUPPER (cmp2->name[1]))) - anonymous = true; - - if (!anonymous && strcmp (cmp1->name, cmp2->name) != 0) + /* Compare names, but not for anonymous components such as UNION or MAP. */ + if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2) + && strcmp (cmp1->name, cmp2->name) != 0) return 0; if (cmp1->attr.access != cmp2->attr.access) @@ -512,22 +532,12 @@ int gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) { gfc_component *cmp1, *cmp2; - bool anonymous = false; if (derived1 == derived2) return 1; gcc_assert (derived1 && derived2); - /* MAP and anonymous STRUCTURE types have internal names of the form - mM* and sS* (we can get away this this because source names are converted - to lowerase). Compare anonymous type names specially because each - gets a unique name when it is declared. */ - anonymous = (derived1->name[0] == derived2->name[0] - && derived1->name[1] && derived2->name[1] && derived2->name[2] - && derived1->name[1] == (char) TOUPPER (derived1->name[0]) - && derived2->name[2] == (char) TOUPPER (derived2->name[0])); - /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is nonnull, then they are equal. */ @@ -541,7 +551,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) because they can be anonymous; therefore two structures with different names may be equal. */ - if (strcmp (derived1->name, derived2->name) != 0 && !anonymous) + /* Compare names, but not for anonymous types such as UNION or MAP. */ + if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) + && strcmp (derived1->name, derived2->name) != 0) return 0; if (derived1->component_access == ACCESS_PRIVATE diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 13f0282809a..6d2a1a11f07 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2016-08-29 Fritz Reese + + Fix, reorganize, and clarify comparisons of anonymous types/components. + + * gfortran.dg/dec_structure_13.f90: New testcase. + 2016-08-29 Janne Blomqvist PR fortran/77261 diff --git a/gcc/testsuite/gfortran.dg/dec_structure_13.f90 b/gcc/testsuite/gfortran.dg/dec_structure_13.f90 new file mode 100644 index 00000000000..6963ddc3c26 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_13.f90 @@ -0,0 +1,81 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Verify that the comparisons in gfc_compare_derived_types can correctly +! match nested anonymous subtypes. +! + +subroutine sub0 (u) + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + u.sub.i = 0 +end subroutine sub0 + +subroutine sub1 () + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + + interface + subroutine sub0 (u) ! regression: Interface mismatch.*Type mismatch + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + end subroutine + end interface + + call sub0(u) ! regression: Type mismatch in argument +end subroutine + +subroutine sub2(u) + structure /tu/ + union + map + integer i + end map + map + real r + end map + end union + end structure + record /tu/ u + u.r = 1.0 +end subroutine + +implicit none + +structure /t/ + structure sub + integer i + end structure +endstructure + +structure /tu/ + union + map + integer i + end map + map + real r + end map + end union +end structure + +record /t/ u +record /tu/ u2 + +call sub0(u) ! regression: Type mismatch in argument +call sub1() +call sub2(u2) + +end -- 2.30.2