[flang-commits] [flang] f2dac55 - [flang] Intrinsic assignment of distinct but "same" derived types

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-01-19T10:08:17-08:00
New Revision: f2dac557f574e2d481a8efefdaf6f9b649d314f0

URL: https://github.com/llvm/llvm-project/commit/f2dac557f574e2d481a8efefdaf6f9b649d314f0
DIFF: https://github.com/llvm/llvm-project/commit/f2dac557f574e2d481a8efefdaf6f9b649d314f0.diff

LOG: [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

Added: 
    flang/test/Semantics/assign08.f90

Modified: 
    flang/include/flang/Semantics/type.h
    flang/lib/Semantics/tools.cpp
    flang/lib/Semantics/type.cpp

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index ade8f3d2fb46..ecc7362147b6 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -293,7 +293,6 @@ class DerivedTypeSpec {
       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 72816b7a6d89..cd0fe2a29804 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 3211bdaac3e3..edd87221f636 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 000000000000..48f2976ed5a8
--- /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