mirrors/llvm-project
0
0
Fork 0
mirror of https://github.com/llvm/llvm-project.git synced 2025-04-18 19:06:44 +00:00
Code Issues Projects Releases Wiki Activity

[flang] Better handling of weird pointer assignment case (#120628)

Browse Source 
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.
This commit is contained in:
Peter Klausler 2025-01-08 13:12:00 -08:00 committed by GitHub
parent 7453d7645c
commit b8513e4393
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
2 changed files with 81 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
flang/lib/Semantics/pointer-assignment.cpp
View File

@ -76,6 +76,7 @@ private:
const Procedure * = nullptr,
const evaluate::SpecificIntrinsic *specific = nullptr);
bool LhsOkForUnlimitedPoly() const;
std::optional<MessageFormattedText> CheckRanks(const TypeAndShape &rhs) const;
template <typename... A> parser::Message *Say(A &&...);
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning, A &&...);
@ -278,10 +279,19 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &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<T> &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<MessageFormattedText> 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 <typename... A>
parser::Message *PointerAssignmentChecker::Say(A &&...x) {
auto *msg{foldingContext_.messages().Say(std::forward<A>(x)...)};

46
flang/test/Semantics/assign16.f90 Normal file
View File

@ -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