https://gcc.gnu.org/ml/fortran/2016-08/msg00145.html
On Wed, Aug 24, 2016 at 5:32 PM, Fritz Reese <fritzore...@gmail.com> wrote:
> https://gcc.gnu.org/ml/fortran/2016-08/msg00144.html
>
> On Wed, Aug 24, 2016 at 5:14 PM, Fritz Reese <fritzore...@gmail.com> wrote:
>> With a few recent notes by others, I have identified that the
>> comparison logic I used in interface.c (compare_components,
>> gfc_compare_derived_types) was faulty in a few ways.
> (snip)
>> tl;dr: The attached patch fixes PR 77327 and another bug which is
>> demonstrated in the included testcase.
FYI-
Committed the patch (as attached) as r239819. Note that PR 77327 is
exhibited by the existing testcase gfortran.dg/import4.f90.
Nb. there was one final typo fixed before committing since the
previously posted version:
>>>>
--- a/gcc/testsuite/gfortran.dg/dec_structure_13.f90
+++ b/gcc/testsuite/gfortran.dg/dec_structure_13.f90
@@ -37,7 +37,7 @@ subroutine sub1 ()
call sub0(u) ! regression: Type mismatch in argument
end subroutine
-subroutine sub3(u)
+subroutine sub2(u)
structure /tu/
union
map
<<<<
---
Fritz Reese
2016-08-29 Fritz Reese <fritzore...@gmail.com>
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.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 17500c9..f082464 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/gfortran.dg/dec_structure_13.f90 b/gcc/testsuite/gfortran.dg/dec_structure_13.f90
new file mode 100644
index 0000000..6963ddc
--- /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
