From f2dac557f574e2d481a8efefdaf6f9b649d314f0 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Mon, 10 Jan 2022 15:59:12 -0800
Subject: [PATCH] [flang] Intrinsic assignment of distinct but "same" derived
 types

Subclause 7.5.2.4 lists conditions under which two distinct derived
types are to be considered the same type for purposes of argument
association, assignment, and so on.  These conditions are implemented
in evaluate::IsTkCompatibleWith(), but assignment semantics doesn't
use it for testing for intrinsic assignment compatibility.  Fix that.

Differential Revision: https://reviews.llvm.org/D117621
---
 flang/include/flang/Semantics/type.h |  1 -
 flang/lib/Semantics/tools.cpp        | 15 +++++------
 flang/lib/Semantics/type.cpp         | 11 ---------
 flang/test/Semantics/assign08.f90    | 48 ++++++++++++++++++++++++++++++++++++
 4 files changed, 54 insertions(+), 21 deletions(-)
 create mode 100644 flang/test/Semantics/assign08.f90

diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index ade8f3d..ecc7362 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -293,7 +293,6 @@ public:
       return nullptr;
     }
   }
-  bool MightBeAssignmentCompatibleWith(const DerivedTypeSpec &) const;
   bool operator==(const DerivedTypeSpec &that) const {
     return RawEquals(that) && parameters_ == that.parameters_;
   }
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 72816b7a..cd0fe2a 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -88,16 +88,13 @@ const Scope *FindPureProcedureContaining(const Scope &start) {
   }
 }
 
-static bool MightHaveCompatibleDerivedtypes(
+// 7.5.2.4 "same derived type" test -- rely on IsTkCompatibleWith() and its
+// infrastructure to detect and handle comparisons on distinct (but "same")
+// sequence/bind(C) derived types
+static bool MightBeSameDerivedType(
     const std::optional<evaluate::DynamicType> &lhsType,
     const std::optional<evaluate::DynamicType> &rhsType) {
-  const DerivedTypeSpec *lhsDerived{evaluate::GetDerivedTypeSpec(lhsType)};
-  const DerivedTypeSpec *rhsDerived{evaluate::GetDerivedTypeSpec(rhsType)};
-  if (!lhsDerived || !rhsDerived) {
-    return false;
-  }
-  return *lhsDerived == *rhsDerived ||
-      lhsDerived->MightBeAssignmentCompatibleWith(*rhsDerived);
+  return lhsType && rhsType && rhsType->IsTkCompatibleWith(*lhsType);
 }
 
 Tristate IsDefinedAssignment(
@@ -113,7 +110,7 @@ Tristate IsDefinedAssignment(
   } else if (lhsCat != TypeCategory::Derived) {
     return ToTristate(lhsCat != rhsCat &&
         (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat)));
-  } else if (MightHaveCompatibleDerivedtypes(lhsType, rhsType)) {
+  } else if (MightBeSameDerivedType(lhsType, rhsType)) {
     return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or intrinsic
   } else {
     return Tristate::Yes;
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 3211bda..edd8722 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -199,17 +199,6 @@ ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
       const_cast<const DerivedTypeSpec *>(this)->FindParameter(target));
 }
 
-// Objects of derived types might be assignment compatible if they are equal
-// with respect to everything other than their instantiated type parameters
-// and their constant instantiated type parameters have the same values.
-bool DerivedTypeSpec::MightBeAssignmentCompatibleWith(
-    const DerivedTypeSpec &that) const {
-  if (!RawEquals(that)) {
-    return false;
-  }
-  return AreTypeParamCompatible(*this, that);
-}
-
 class InstantiateHelper {
 public:
   InstantiateHelper(Scope &scope) : scope_{scope} {}
diff --git a/flang/test/Semantics/assign08.f90 b/flang/test/Semantics/assign08.f90
new file mode 100644
index 0000000..48f2976
--- /dev/null
+++ b/flang/test/Semantics/assign08.f90
@@ -0,0 +1,48 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! "Same type" checking for intrinsic assignment
+module m1
+  type :: nonSeqType
+    integer :: n1
+  end type
+  type :: seqType
+    sequence
+    integer :: n2
+  end type
+  type, bind(c) :: bindCType
+    integer :: n3
+  end type
+end module
+
+program test
+  use m1, modNonSeqType => nonSeqType, modSeqType => seqType, modBindCType => bindCType
+  type :: nonSeqType
+    integer :: n1
+  end type
+  type :: seqType
+    sequence
+    integer :: n2
+  end type
+  type, bind(c) :: bindCType
+    integer :: n3
+  end type
+  type(modNonSeqType) :: mns1, mns2
+  type(modSeqType) :: ms1, ms2
+  type(modBindCType) :: mb1, mb2
+  type(nonSeqType) :: ns1, ns2
+  type(seqType) :: s1, s2
+  type(bindCType) :: b1, b2
+  ! These are trivially ok
+  mns1 = mns2
+  ms1 = ms2
+  mb1 = mb2
+  ns1 = ns2
+  s1 = s2
+  b1 = b2
+  ! These are ok per 7.5.2.4
+  ms1 = s1
+  mb1 = b1
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(modnonseqtype) and TYPE(nonseqtype)
+  mns1 = ns1
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(nonseqtype) and TYPE(modnonseqtype)
+  ns1 = mns1
+end
-- 
2.7.4