diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -279,10 +279,9 @@ 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 @@ 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 &); }; diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -84,6 +84,18 @@ return IsPureProcedure(scope) ? &scope : nullptr; } +static bool MightHaveCompatibleDerivedtypes( + const std::optional &lhsType, + const std::optional &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 &lhsType, int lhsRank, const std::optional &rhsType, int rhsRank) { @@ -97,15 +109,10 @@ } 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; } } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -189,6 +189,36 @@ const_cast(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 &theseParams{this->parameters()}; + const std::map &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} {} diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90 --- a/flang/test/Semantics/assign04.f90 +++ b/flang/test/Semantics/assign04.f90 @@ -141,3 +141,34 @@ !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