[flang] Derived type structural equivalence (#69376)

F'202X 7.5.2.4 describes conditions under which two derived type
definitions are to be considered equivalent. These rules are already
implemented in Evaluate/type.cpp but not exposed for general use;
rearrange the code a little so that the compatibility checking of
separate module procedure interfaces and explicit definitions can use it
to avoid emitting a bogus error message.

Fixes #67946.

Author: klausler

flang/include/flang/Evaluate/type.h

@@ -208,6 +208,10 @@ class DynamicType {
   // SAME_TYPE_AS (16.9.165); ignores type parameter values
   std::optional<bool> SameTypeAs(const DynamicType &) const;
 
+  // 7.5.2.4 type equivalence; like operator==(), but SEQUENCE/BIND(C)
+  // derived types can be structurally equivalent.
+  bool IsEquivalentTo(const DynamicType &) const;
+
   // Result will be missing when a symbol is absent or
   // has an erroneous type, e.g., REAL(KIND=666).
   static std::optional<DynamicType> From(const semantics::DeclTypeSpec &);

flang/lib/Evaluate/type.cpp

@@ -293,7 +293,7 @@ const semantics::DerivedTypeSpec *GetParentTypeSpec(
 }
 
 // Compares two derived type representations to see whether they both
-// represent the "same type" in the sense of section 7.5.2.4.
+// represent the "same type" in the sense of section F'2023 7.5.2.4.
 using SetOfDerivedTypePairs =
     std::set<std::pair<const semantics::DerivedTypeSpec *,
         const semantics::DerivedTypeSpec *>>;
@@ -513,6 +513,19 @@ bool AreSameDerivedType(
   return AreSameDerivedType(x, y, false, false, inProgress);
 }
 
+bool AreSameDerivedType(
+    const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
+  return x == y || (x && y && AreSameDerivedType(*x, *y));
+}
+
+bool DynamicType::IsEquivalentTo(const DynamicType &that) const {
+  return category_ == that.category_ && kind_ == that.kind_ &&
+      PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
+      knownLength().has_value() == that.knownLength().has_value() &&
+      (!knownLength() || *knownLength() == *that.knownLength()) &&
+      AreSameDerivedType(derived_, that.derived_);
+}
+
 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
     const semantics::DerivedTypeSpec *y, bool isPolymorphic,
     bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {

flang/lib/Semantics/check-declarations.cpp

@@ -3354,10 +3354,9 @@ void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
     const DummyDataObject &obj2) {
   if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
   } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
-  } else if (obj1.type.type() != obj2.type.type()) {
+  } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
     Say(symbol1, symbol2,
-        "Dummy argument '%s' has type %s; the corresponding argument in the"
-        " interface body has type %s"_err_en_US,
+        "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
         obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
   } else if (!ShapesAreCompatible(obj1, obj2)) {
     Say(symbol1, symbol2,

flang/test/Semantics/separate-mp02.f90

@@ -51,9 +51,9 @@ module subroutine s5(x, y)
     real :: y
   end
   module subroutine s6(x, y)
-    !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has type REAL(4)
+    !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has distinct type REAL(4)
     integer :: x
-    !ERROR: Dummy argument 'y' has type REAL(8); the corresponding argument in the interface body has type REAL(4)
+    !ERROR: Dummy argument 'y' has type REAL(8); the corresponding argument in the interface body has distinct type REAL(4)
     real(8) :: y
   end
   module subroutine s7(x, y, z)
@@ -72,10 +72,10 @@ module subroutine s8(x, y, z)
   end
   module subroutine s9(x, y, z, w)
     character(len=4) :: x
-    !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=4_8)
+    !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=4_8)
     character(len=5) :: y
     character(len=*) :: z
-    !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=*)
+    !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=*)
     character(len=4) :: w
   end
 end
@@ -330,7 +330,7 @@ module subroutine sub1(s)
     character(len=-1) s ! ok
   end subroutine
   module subroutine sub2(s)
-    !ERROR: Dummy argument 's' has type CHARACTER(KIND=1,LEN=1_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=0_8)
+    !ERROR: Dummy argument 's' has type CHARACTER(KIND=1,LEN=1_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=0_8)
     character(len=1) s
   end subroutine
 end submodule

flang/test/Semantics/separate-mp03.f90

@@ -74,7 +74,7 @@ pure module subroutine s2
   end interface
  contains
   integer module function f1(x)
-    !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has type REAL(4)
+    !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has distinct type REAL(4)
     integer, intent(in) :: x
     f1 = x
   end function

flang/test/Semantics/separate-mp06.f90

@@ -0,0 +1,98 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Structural equivalence of derived type definitions
+module m
+  interface
+    module subroutine s1(x)
+      type :: nonseq
+        integer :: n
+      end type
+      type(nonseq), intent(in) :: x
+    end subroutine
+    module subroutine s2(x)
+      type :: seq
+        sequence
+        integer :: n
+      end type
+      type(seq), intent(in) :: x
+    end subroutine
+    module subroutine s3(x)
+      type :: chlen
+        sequence
+        character(2) :: s
+      end type
+      type(chlen), intent(in) :: x
+    end subroutine
+    module subroutine s4(x)
+      !ERROR: A sequence type may not have type parameters
+      type :: pdt(k)
+        integer, kind :: k
+        sequence
+        real(k) :: a
+      end type
+      type(pdt(4)), intent(in) :: x
+    end subroutine
+  end interface
+end module
+
+submodule(m) sm
+ contains
+  module subroutine s1(x)
+    type :: nonseq
+      integer :: n
+    end type
+    !ERROR: Dummy argument 'x' has type nonseq; the corresponding argument in the interface body has distinct type nonseq
+    type(nonseq), intent(in) :: x
+  end subroutine
+  module subroutine s2(x) ! ok
+    type :: seq
+      sequence
+      integer :: n
+    end type
+    type(seq), intent(in) :: x
+  end subroutine
+  module subroutine s3(x)
+    type :: chlen
+      sequence
+      character(3) :: s ! note: length is 3, not 2
+    end type
+    !ERROR: Dummy argument 'x' has type chlen; the corresponding argument in the interface body has distinct type chlen
+    type(chlen), intent(in) :: x
+  end subroutine
+  module subroutine s4(x)
+    !ERROR: A sequence type may not have type parameters
+    type :: pdt(k)
+      integer, kind :: k
+      sequence
+      real(k) :: a
+    end type
+    !ERROR: Dummy argument 'x' has type pdt(k=4_4); the corresponding argument in the interface body has distinct type pdt(k=4_4)
+    type(pdt(4)), intent(in) :: x
+  end subroutine
+end submodule
+
+program main
+  use m
+  type :: nonseq
+    integer :: n
+  end type
+  type :: seq
+    sequence
+    integer :: n
+  end type
+  type :: chlen
+    sequence
+    character(2) :: s
+  end type
+  !ERROR: A sequence type may not have type parameters
+  type :: pdt(k)
+    integer, kind :: k
+    sequence
+    real(k) :: a
+  end type
+  !ERROR: Actual argument type 'nonseq' is not compatible with dummy argument type 'nonseq'
+  call s1(nonseq(1))
+  call s2(seq(1)) ! ok
+  call s3(chlen('ab')) ! ok, matches interface
+  !ERROR: Actual argument type 'pdt(k=4_4)' is not compatible with dummy argument type 'pdt(k=4_4)'
+  call s4(pdt(4)(3.14159))
+end program