Fix, reorganize, and clarify comparisons of anonymous types/components.

2016-08-29  Fritz Reese  <fritzoreese@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.

From-SVN: r239819

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9ac5721cf8482896673235046c06588cecb0d698..899cd32e93e739637983c1577430971e78f0b6b7 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2016-08-29  Fritz Reese  <fritzoreese@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.
+
 2016-08-27  Steven G. Kargl <kargl@gcc.gnu.org>
 
        PR fortran/77380

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 119c534f17033f3138573797761ddc59547cf737..eba0454458eca0cd0c491412555dbd5b534d3366 100644 (file)
--- 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 13f0282809ac630282a2a2aa6679360c87bc27cf..6d2a1a11f070652e112f7e5a2e74747268e35645 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-08-29  Fritz Reese  <fritzoreese@gmail.com>
+
+       Fix, reorganize, and clarify comparisons of anonymous types/components.
+
+       * gfortran.dg/dec_structure_13.f90: New testcase.
+
 2016-08-29  Janne Blomqvist  <jb@gcc.gnu.org>
 
        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 (file)
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