[flang] Fix assignment of parameterized derived types

We were erroneously emitting error messages for assignments of derived types
where the associated objects were instantiated with non-constant LEN type
parameters.

I fixed this by adding the member function MightBeAssignmentCompatibleWith() to
the class DerivedTypeSpec and calling it to determine whether it's possible
that objects of parameterized derived types can be assigned to each other.  Its
implementation first compares the uninstantiated values of the types.  If they
are equal, it then compares the values of the constant instantiated type
parameters.

I added tests to assign04.f90 to exercise this new code.

Differential Revision: https://reviews.llvm.org/D100868

flang/include/flang/Semantics/type.h

@@ -279,10 +279,9 @@ public:
       return nullptr;
     }
   }
+  bool MightBeAssignmentCompatibleWith(const DerivedTypeSpec &) const;
   bool operator==(const DerivedTypeSpec &that) const {
-    return &typeSymbol_ == &that.typeSymbol_ && cooked_ == that.cooked_ &&
-        parameters_ == that.parameters_ &&
-        rawParameters_ == that.rawParameters_;
+    return RawEquals(that) && parameters_ == that.parameters_;
   }
   std::string AsFortran() const;
 
@@ -295,6 +294,10 @@ private:
   bool instantiated_{false};
   RawParameters rawParameters_;
   ParameterMapType parameters_;
+  bool RawEquals(const DerivedTypeSpec &that) const {
+    return &typeSymbol_ == &that.typeSymbol_ && cooked_ == that.cooked_ &&
+        rawParameters_ == that.rawParameters_;
+  }
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const DerivedTypeSpec &);
 };

flang/lib/Semantics/tools.cpp

@@ -84,6 +84,18 @@ const Scope *FindPureProcedureContaining(const Scope &start) {
   return IsPureProcedure(scope) ? &scope : nullptr;
 }
 
+static bool MightHaveCompatibleDerivedtypes(
+    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);
+}
+
 Tristate IsDefinedAssignment(
     const std::optional<evaluate::DynamicType> &lhsType, int lhsRank,
     const std::optional<evaluate::DynamicType> &rhsType, int rhsRank) {
@@ -97,15 +109,10 @@ Tristate IsDefinedAssignment(
   } else if (lhsCat != TypeCategory::Derived) {
     return ToTristate(lhsCat != rhsCat &&
         (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat)));
+  } else if (MightHaveCompatibleDerivedtypes(lhsType, rhsType)) {
+    return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or intrinsic
   } else {
-    const auto *lhsDerived{evaluate::GetDerivedTypeSpec(lhsType)};
-    const auto *rhsDerived{evaluate::GetDerivedTypeSpec(rhsType)};
-    if (lhsDerived && rhsDerived && *lhsDerived == *rhsDerived) {
-      return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or
-                              // intrinsic
-    } else {
-      return Tristate::Yes;
-    }
+    return Tristate::Yes;
   }
 }
 

flang/lib/Semantics/type.cpp

@@ -189,6 +189,36 @@ 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;
+  }
+  const std::map<SourceName, ParamValue> &theseParams{this->parameters()};
+  const std::map<SourceName, ParamValue> &thoseParams{that.parameters()};
+  auto thatIter{thoseParams.begin()};
+  for (const auto &[thisName, thisValue] : theseParams) {
+    CHECK(thatIter != thoseParams.end());
+    const ParamValue &thatValue{thatIter->second};
+    if (MaybeIntExpr thisExpr{thisValue.GetExplicit()}) {
+      if (evaluate::IsConstantExpr(*thisExpr)) {
+        if (MaybeIntExpr thatExpr{thatValue.GetExplicit()}) {
+          if (evaluate::IsConstantExpr(*thatExpr)) {
+            if (evaluate::ToInt64(*thisExpr) != evaluate::ToInt64(*thatExpr)) {
+              return false;
+            }
+          }
+        }
+      }
+    }
+    thatIter++;
+  }
+  return true;
+}
+
 class InstantiateHelper {
 public:
   InstantiateHelper(Scope &scope) : scope_{scope} {}

flang/test/Semantics/assign04.f90

@@ -141,3 +141,34 @@ subroutine s11
   !ERROR: Subroutine name is not allowed here
   a = s11
 end
+
+subroutine s12()
+  type dType(l1, k1, l2, k2)
+    integer, len :: l1
+    integer, kind :: k1
+    integer, len :: l2
+    integer, kind :: k2
+  end type
+
+  contains
+    subroutine sub(arg1, arg2, arg3)
+      integer :: arg1
+      type(dType(arg1, 2, *, 4)) :: arg2
+      type(dType(*, 2, arg1, 4)) :: arg3
+      type(dType(1, 2, 3, 4)) :: local1
+      type(dType(1, 2, 3, 4)) :: local2
+      type(dType(1, 2, arg1, 4)) :: local3
+      type(dType(9, 2, 3, 4)) :: local4
+      type(dType(1, 9, 3, 4)) :: local5
+
+      arg2 = arg3
+      arg2 = local1
+      arg3 = local1
+      local1 = local2
+      local2 = local3
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(dtype(k1=2_4,k2=4_4,l1=1_4,l2=3_4)) and TYPE(dtype(k1=2_4,k2=4_4,l1=9_4,l2=3_4))
+      local1 = local4 ! mismatched constant KIND type parameter
+      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(dtype(k1=2_4,k2=4_4,l1=1_4,l2=3_4)) and TYPE(dtype(k1=9_4,k2=4_4,l1=1_4,l2=3_4))
+      local1 = local5 ! mismatched constant LEN type parameter
+    end subroutine sub
+end subroutine s12