[flang] Fix assignment of parameterized derived types

[PeteSteinfeld]

Summary

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.

[klausler]

flang/lib/Semantics/tools.cpp

114–115

Minor: you can decrease the amount of block nesting here now, if you like, with an else if.

[PeteSteinfeld]

flang/lib/Semantics/tools.cpp

114–115

Thanks! I'll do it.

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 &typeSymbol_ == &that.typeSymbol_ && cooked_ == that.cooked_ &&
-        parameters_ == that.parameters_ &&
-        rawParameters_ == that.rawParameters_;
+    return RawEquals(that) && parameters_ == that.parameters_;
   }
   std::string AsFortran() const;
 
 private:
   SourceName name_;
   const Symbol &typeSymbol_;
   const Scope *scope_{nullptr}; // same as typeSymbol_.scope() unless PDT
   bool cooked_{false};
   bool evaluated_{false};
   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 &);
 };
 
 class DeclTypeSpec {
 public:
   enum Category {
     Numeric,

flang/lib/Semantics/tools.cpp

 const Scope *FindPureProcedureContaining(const Scope &start) {
   // N.B. We only need to examine the innermost containing program unit
   // because an internal subprogram of a pure subprogram must also
   // be pure (C1592).
   const Scope &scope{GetProgramUnitContaining(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) {
   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 {
-    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;
-    }
-  }
-}
+  } else if (MightHaveCompatibleDerivedtypes(lhsType, rhsType)) {
+    return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or intrinsic
 
 bool IsIntrinsicRelational(common::RelationalOperator opr,
     const evaluate::DynamicType &type0, int rank0,
     const evaluate::DynamicType &type1, int rank1) {
   if (!evaluate::AreConformable(rank0, rank1)) {
     return false;
   } else {
     auto cat0{type0.category()};

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;
+  }
+  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} {}
   // Instantiate components from fromScope into scope_
   void InstantiateComponents(const Scope &);
 
 private:
   SemanticsContext &context() const { return scope_.context(); }

flang/test/Semantics/assign04.f90

 subroutine s11
   intrinsic :: sin
   real :: a
   !ERROR: Function call must have argument list
   a = sin
   !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