From d667b96c98438edcc00ec85a3b151ac2dae862f3 Mon Sep 17 00:00:00 2001 From: Peter Steinfeld Date: Tue, 20 Apr 2021 10:11:03 -0700 Subject: [PATCH] [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 | 9 ++++++--- flang/lib/Semantics/tools.cpp | 23 +++++++++++++++-------- flang/lib/Semantics/type.cpp | 30 ++++++++++++++++++++++++++++++ flang/test/Semantics/assign04.f90 | 31 +++++++++++++++++++++++++++++++ 4 files changed, 82 insertions(+), 11 deletions(-) diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h index 6840f5b..eb506d1 100644 --- a/flang/include/flang/Semantics/type.h +++ b/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 &); }; diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 68db3e1..a633ecbe1 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/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 &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 @@ 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; } } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 99c48b3..16625c0 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -189,6 +189,36 @@ ParamValue *DerivedTypeSpec::FindParameter(SourceName target) { 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 index 8887b4d..806256f 100644 --- a/flang/test/Semantics/assign04.f90 +++ b/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 -- 2.7.4