From 806c597c0169987a6a93c558980a5e50a851c3b8 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 19 Dec 2024 11:39:32 -0800 Subject: [PATCH] [flang] Better handling of weird pointer assignment case F'2023 C1017 permits the assignment of an unlimited polymorphic data target to a monomorphic LHS pointer when the LHS pointer has a sequence derived type (BIND(C) or SEQUENCE attribute). We allowed for this in pointer assignments that don't have a function reference as their RHS. Extend this support to function references, and also ensure that rank compatibility is still checked. --- flang/lib/Semantics/pointer-assignment.cpp | 55 ++++++++++++++-------- flang/test/Semantics/assign16.f90 | 46 ++++++++++++++++++ 2 files changed, 81 insertions(+), 20 deletions(-) create mode 100644 flang/test/Semantics/assign16.f90 diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 2450ce39215ec..7f4548c7327e3 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -76,6 +76,7 @@ class PointerAssignmentChecker { const Procedure * = nullptr, const evaluate::SpecificIntrinsic *specific = nullptr); bool LhsOkForUnlimitedPoly() const; + std::optional CheckRanks(const TypeAndShape &rhs) const; template parser::Message *Say(A &&...); template parser::Message *Warn(FeatureOrUsageWarning, A &&...); @@ -278,10 +279,19 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef &f) { } else if (lhsType_) { const auto *frTypeAndShape{funcResult->GetTypeAndShape()}; CHECK(frTypeAndShape); - if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), *frTypeAndShape, - "pointer", "function result", - /*omitShapeConformanceCheck=*/isBoundsRemapping_ || isAssumedRank_, - evaluate::CheckConformanceFlags::BothDeferredShape)) { + if (frTypeAndShape->type().IsUnlimitedPolymorphic() && + LhsOkForUnlimitedPoly()) { + // Special case exception to type checking (F'2023 C1017); + // still check rank compatibility. + if (auto msg{CheckRanks(*frTypeAndShape)}) { + Say(*msg); + return false; + } + } else if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), + *frTypeAndShape, "pointer", "function result", + /*omitShapeConformanceCheck=*/isBoundsRemapping_ || + isAssumedRank_, + evaluate::CheckConformanceFlags::BothDeferredShape)) { return false; // IsCompatibleWith() emitted message } } @@ -324,27 +334,17 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator &d) { msg = "Pointer must be VOLATILE when target is a" " VOLATILE coarray"_err_en_US; } + } else if (auto m{CheckRanks(*rhsType)}) { + msg = std::move(*m); } else if (rhsType->type().IsUnlimitedPolymorphic()) { if (!LhsOkForUnlimitedPoly()) { msg = "Pointer type must be unlimited polymorphic or non-extensible" " derived type when target is unlimited polymorphic"_err_en_US; } - } else { - if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) { - msg = MessageFormattedText{ - "Target type %s is not compatible with pointer type %s"_err_en_US, - rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; - - } else if (!isBoundsRemapping_ && - !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) { - int lhsRank{lhsType_->Rank()}; - int rhsRank{rhsType->Rank()}; - if (lhsRank != rhsRank) { - msg = MessageFormattedText{ - "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank, - rhsRank}; - } - } + } else if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) { + msg = MessageFormattedText{ + "Target type %s is not compatible with pointer type %s"_err_en_US, + rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; } } if (msg) { @@ -434,6 +434,21 @@ bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const { } } +std::optional PointerAssignmentChecker::CheckRanks( + const TypeAndShape &rhs) const { + if (!isBoundsRemapping_ && + !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) { + int lhsRank{lhsType_->Rank()}; + int rhsRank{rhs.Rank()}; + if (lhsRank != rhsRank) { + return MessageFormattedText{ + "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank, + rhsRank}; + } + } + return std::nullopt; +} + template parser::Message *PointerAssignmentChecker::Say(A &&...x) { auto *msg{foldingContext_.messages().Say(std::forward(x)...)}; diff --git a/flang/test/Semantics/assign16.f90 b/flang/test/Semantics/assign16.f90 new file mode 100644 index 0000000000000..2e65829ff990c --- /dev/null +++ b/flang/test/Semantics/assign16.f90 @@ -0,0 +1,46 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! The RHS of a pointer assignment can be unlimited polymorphic +! if the LHS is a sequence type. +program main + type nonSeqType + integer j + end type + type seqType + sequence + integer j + end type + type(nonSeqType), target :: xNonSeq = nonSeqType(1) + type(nonSeqType), pointer :: pNonSeq + type(seqType), target :: xSeq = seqType(1), aSeq(1) + type(seqType), pointer :: pSeq, paSeq(:) + !ERROR: function result type 'CLASS(*)' is not compatible with pointer type 'nonseqtype' + pNonSeq => polyPtr(xNonSeq) + pSeq => polyPtr(xSeq) ! ok + !ERROR: Pointer has rank 1 but target has rank 0 + paSeq => polyPtr(xSeq) + !ERROR: Pointer has rank 0 but target has rank 1 + pSeq => polyPtrArr(aSeq) + contains + function polyPtr(target) + class(*), intent(in), target :: target + class(*), pointer :: polyPtr + polyPtr => target + end + function polyPtrArr(target) + class(*), intent(in), target :: target(:) + class(*), pointer :: polyPtrArr(:) + polyPtrArr => target + end + function err1(target) + class(*), intent(in), target :: target(:) + class(*), pointer :: err1 + !ERROR: Pointer has rank 0 but target has rank 1 + err1 => target + end + function err2(target) + class(*), intent(in), target :: target + class(*), pointer :: err2(:) + !ERROR: Pointer has rank 1 but target has rank 0 + err2 => target + end +end