[flang-commits] [flang] cab9517 - [flang] Disable various semantic checks for descriptor dummy args with ignore_tkr(c) (#179530)
via flang-commits
flang-commits at lists.llvm.org
Wed Feb 4 19:49:29 PST 2026
Author: Eugene Epshteyn
Date: 2026-02-04T22:49:25-05:00
New Revision: cab951718bf0a52e1e4aa034d94720396d09a17c
URL: https://github.com/llvm/llvm-project/commit/cab951718bf0a52e1e4aa034d94720396d09a17c
DIFF: https://github.com/llvm/llvm-project/commit/cab951718bf0a52e1e4aa034d94720396d09a17c.diff
LOG: [flang] Disable various semantic checks for descriptor dummy args with ignore_tkr(c) (#179530)
When descriptor dummy args have ignore_tkr(c), we want to use the
descriptor unchanged. As such, disable various semantic error checks
that are normally performed on descriptor based dummy args without
ignore_tkr(c)
Added:
flang/test/Semantics/ignore_tkr05.f90
Modified:
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/pointer-assignment.cpp
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index d4f406d1ee27c..f041cab64686c 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -986,6 +986,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
messages.Say(
"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
}
+ } else if ((dummy.ignoreTKR.test(common::IgnoreTKR::Type) ||
+ dummy.ignoreTKR.test(common::IgnoreTKR::Kind)) &&
+ dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
+ // Descriptor based dummy args passed with ignore_tkr(tc) or
+ // ignore_tkr(kc) are allowed to have type and kind
diff erences
+ checkTypeCompatibility = false;
}
if (checkTypeCompatibility && !actualIsUnlimited) {
if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index b50b71f28f790..b9c807a63638b 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -961,7 +961,10 @@ void CheckHelper::CheckObjectEntity(
messages_.Say(
"!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
}
- if (IsPassedViaDescriptor(symbol)) {
+ // Descriptor based dummy args passed with ignore_tkr(c) are allowed
+ // to have type/kind/rank
diff erences
+ if (IsPassedViaDescriptor(symbol) &&
+ !ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
if (IsAllocatableOrObjectPointer(&symbol) &&
!ignoreTKR.test(common::IgnoreTKR::Pointer)) {
if (inExplicitExternalInterface) {
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index c1c0b28789cab..97179b4030147 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -60,6 +60,7 @@ class PointerAssignmentChecker {
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
PointerAssignmentChecker &set_isRHSPointerActualArgument(bool);
+ PointerAssignmentChecker &set_ignoreTKR(common::IgnoreTKRSet);
bool CheckLeftHandSide(const SomeExpr &);
bool Check(const SomeExpr &);
@@ -96,6 +97,7 @@ class PointerAssignmentChecker {
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
+ common::IgnoreTKRSet ignoreTKR_;
const Symbol *pointerComponentLHS_{nullptr};
};
@@ -141,6 +143,12 @@ PointerAssignmentChecker::set_isRHSPointerActualArgument(bool isPointerActual) {
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_ignoreTKR(
+ common::IgnoreTKRSet ignoreTKR) {
+ ignoreTKR_ = ignoreTKR;
+ return *this;
+}
+
bool PointerAssignmentChecker::CharacterizeProcedure() {
if (!characterizedProcedure_) {
characterizedProcedure_ = true;
@@ -354,6 +362,9 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
msg = "Pointer type must be unlimited polymorphic or non-extensible"
" derived type when target is unlimited polymorphic"_err_en_US;
}
+ } else if (ignoreTKR_.test(common::IgnoreTKR::Type) &&
+ ignoreTKR_.test(common::IgnoreTKR::Contiguous)) {
+ // Don't check for target type mismatch error if we have ignore_tkr(tc)
} else if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) {
msg = MessageFormattedText{
"Target type %s is not compatible with pointer type %s"_err_en_US,
@@ -467,7 +478,10 @@ std::optional<MessageFormattedText> PointerAssignmentChecker::CheckRanks(
!lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) {
int lhsRank{lhsType_->Rank()};
int rhsRank{rhs.Rank()};
- if (lhsRank != rhsRank) {
+ // Turn off rank mismatch error if we have ignore_tkr(rc)
+ if (lhsRank != rhsRank &&
+ !(ignoreTKR_.test(common::IgnoreTKR::Rank) &&
+ ignoreTKR_.test(common::IgnoreTKR::Contiguous))) {
return MessageFormattedText{
"Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
rhsRank};
@@ -609,6 +623,7 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
+ .set_ignoreTKR(lhs.ignoreTKR)
.Check(rhs);
}
diff --git a/flang/test/Semantics/ignore_tkr05.f90 b/flang/test/Semantics/ignore_tkr05.f90
new file mode 100644
index 0000000000000..006e7a777f42d
--- /dev/null
+++ b/flang/test/Semantics/ignore_tkr05.f90
@@ -0,0 +1,97 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! Tests for ignore_tkr(ac) (allocatable/all + contiguous) with pointers
+! Should suppress warnings about applying to pointer/descriptor
+! and suppress errors about rank/type mismatch.
+
+module m_ptr_tkr
+ interface
+ subroutine s1(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ac) p
+ end subroutine
+
+ subroutine s2(p)
+ real, allocatable :: p(:)
+ !dir$ ignore_tkr(ac) p
+ end subroutine
+
+ subroutine s_ct(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ct) p
+ end subroutine
+
+ subroutine s_c(p)
+ integer, pointer :: p(:)
+ !dir$ ignore_tkr(c) p
+ end subroutine
+
+ subroutine s_ck(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ck) p
+ end subroutine
+
+ subroutine s_cr(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(cr) p
+ end subroutine
+
+ subroutine s_ckr(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ckr) p
+ end subroutine
+
+ subroutine s_ctr(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ctr) p
+ end subroutine
+
+ subroutine s_ctk(p)
+ real, pointer :: p(:)
+ !dir$ ignore_tkr(ctk) p
+ end subroutine
+ end interface
+
+contains
+ subroutine test_ptr_tkr()
+ real(8), pointer :: p3(:,:,:)
+ real(8), allocatable :: a3(:,:,:)
+
+ ! Rank mismatch (1 vs 3), Type mismatch (real(4) vs real(8))
+ ! Should be ignored due to ignore_tkr(ac) which implies TKR + C.
+ call s1(p3)
+ call s2(a3)
+
+ ! ignore_tkr(c): still have type/kind/rank
diff erences
+ !ERROR: Actual argument type 'REAL(8)' is not compatible with dummy argument type 'INTEGER(4)'
+ !ERROR: Pointer has rank 1 but target has rank 3
+ call s_c(p3)
+
+ ! ignore_tkr(ct): ignore type
diff erences, still have kind/rank
diff erences
+ !ERROR: Actual argument type 'REAL(8)' is not compatible with dummy argument type 'REAL(4)'
+ !ERROR: Pointer has rank 1 but target has rank 3
+ call s_ct(p3)
+
+ ! ignore_tkr(ck): ignore kind
diff erences, still have type/rank
diff erences
+ !ERROR: Rank of dummy argument is 1, but actual argument has rank 3
+ !ERROR: Pointer has rank 1 but target has rank 3
+ call s_ck(p3)
+
+ ! ignore_tkr(cr): ignore rank
diff erences, still have type/kind
diff erences
+ !ERROR: Actual argument type 'REAL(8)' is not compatible with dummy argument type 'REAL(4)'
+ !ERROR: Target type REAL(8) is not compatible with pointer type REAL(4)
+ call s_cr(p3)
+
+ ! ignore_tkr(ckr): ignore kind/rank
diff erences, still have type
diff erences
+ !ERROR: Target type REAL(8) is not compatible with pointer type REAL(4)
+ call s_ckr(p3)
+
+ ! ignore_tkr(ctr): ignore type/rank
diff erences, still have kind
diff erences
+ !ERROR: Actual argument type 'REAL(8)' is not compatible with dummy argument type 'REAL(4)'
+ call s_ctr(p3)
+
+ ! ignore_tkr(ctk): ignore type/kind
diff erences, still have rank
diff erences
+ !ERROR: Rank of dummy argument is 1, but actual argument has rank 3
+ !ERROR: Pointer has rank 1 but target has rank 3
+ call s_ctk(p3)
+ end subroutine
+end module
More information about the flang-commits
mailing list