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

[klausler]

Summary

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.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/include/flang/Semantics/type.h

public:
   const ParamValue *FindParameter(SourceName target) const {
     auto iter{parameters_.find(target)};
     if (iter != parameters_.end()) {
       return &iter->second;
     } else {
       return nullptr;
     }
   }
-  bool MightBeAssignmentCompatibleWith(const DerivedTypeSpec &) const;
   bool operator==(const DerivedTypeSpec &that) const {
     return RawEquals(that) && parameters_ == that.parameters_;
   }
   bool operator!=(const DerivedTypeSpec &that) const {
     return !(*this == that);
   }
   std::string AsFortran() const;
 

flang/lib/Semantics/tools.cpp

const Scope *FindPureProcedureContaining(const Scope &start) {
   if (start.IsGlobal()) {
     return nullptr;
   } else {
     const Scope &scope{GetProgramUnitContaining(start)};
     return IsPureProcedure(scope) ? &scope : nullptr;
   }
 }
 
-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(
     const std::optional<evaluate::DynamicType> &lhsType, int lhsRank,
     const std::optional<evaluate::DynamicType> &rhsType, int rhsRank) {
   if (!lhsType || !rhsType) {
     return Tristate::No; // error or rhs is untyped
   }
   TypeCategory lhsCat{lhsType->category()};
   TypeCategory rhsCat{rhsType->category()};
   if (rhsRank > 0 && lhsRank != rhsRank) {
     return Tristate::Yes;
   } 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;
   }
 }
 
 bool IsIntrinsicRelational(common::RelationalOperator opr,
     const evaluate::DynamicType &type0, int rank0,

flang/lib/Semantics/type.cpp

return bool{std::find_if(
       })};
 }
 
 ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
   return const_cast<ParamValue *>(
       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} {}
   // Instantiate components from fromScope into scope_
   void InstantiateComponents(const Scope &);
 
 private:
   SemanticsContext &context() const { return scope_.context(); }

flang/test/Semantics/assign08.f90

+! 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