[flang-commits] [flang] 78f19d9 - [flang] Relax two !DIR$ IGNORE_TKR error cases with descriptor arguments
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Apr 20 13:40:23 PDT 2023
Author: Peter Klausler
Date: 2023-04-20T13:40:10-07:00
New Revision: 78f19d9ba5c83cc285a307f7bd74589ff65ac52e
URL: https://github.com/llvm/llvm-project/commit/78f19d9ba5c83cc285a307f7bd74589ff65ac52e
DIFF: https://github.com/llvm/llvm-project/commit/78f19d9ba5c83cc285a307f7bd74589ff65ac52e.diff
LOG: [flang] Relax two !DIR$ IGNORE_TKR error cases with descriptor arguments
Allow two currently erroneous cases of !DIR$ IGNORE_TKR errors: allocatable
and pointers, and IGNORE_TKR(R) on (other) arguments passed via descriptors.
Downgrade these cases to warnings when they appear in external interfaces,
since their implementations may well be in C. But retain the error status
on these cases for module procedures, since the Fortran implementation
probably can't work.
Differential Revision: https://reviews.llvm.org/D148833
Added:
Modified:
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/check-declarations.cpp
flang/test/Semantics/ignore_tkr01.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 936e85b636004..a8d0fca70c0c1 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -48,9 +48,8 @@ static bool IsDescriptor(const ObjectEntityDetails &details) {
}
static bool IsDescriptor(const ProcEntityDetails &details) {
- // A procedure pointer or dummy procedure must be & is a descriptor if
- // and only if it requires a static link.
- // TODO: refine this placeholder
+ // TODO: refine this placeholder; procedure pointers and dummy
+ // procedures should now be simple addresses (possibly of thunks)
return details.HasExplicitInterface();
}
@@ -93,6 +92,9 @@ bool IsPassedViaDescriptor(const Symbol &symbol) {
if (!IsDescriptor(symbol)) {
return false;
}
+ if (IsAllocatableOrPointer(symbol)) {
+ return true;
+ }
if (const auto *object{
symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
if (object->isDummy()) {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 5c40e012b62bf..be9f498519551 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -703,27 +703,47 @@ void CheckHelper::CheckObjectEntity(
}
}
if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
- if (IsAllocatableOrPointer(symbol)) {
+ const Symbol *ownerSymbol{symbol.owner().symbol()};
+ const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
+ bool inInterface{ownerSubp && ownerSubp->isInterface()};
+ bool inExplicitInterface{
+ inInterface && !IsSeparateModuleProcedureInterface(ownerSymbol)};
+ bool inModuleProc{
+ !inInterface && ownerSymbol && IsModuleProcedure(*ownerSymbol)};
+ if (!inExplicitInterface && !inModuleProc) {
messages_.Say(
- "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
- } else if (ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
+ "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
+ }
+ if (ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
!IsAssumedShape(symbol)) {
messages_.Say(
"!DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array"_err_en_US);
- } else if (ignoreTKR.test(common::IgnoreTKR::Rank) &&
- IsPassedViaDescriptor(symbol)) {
+ }
+ if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
+ details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
messages_.Say(
- "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
- } else if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
- if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
- ownerSubp && !ownerSubp->isInterface() &&
- !FindModuleContaining(symbol.owner())) {
- messages_.Say(
- "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
- } else if (ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
- details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
- messages_.Say(
- "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
+ "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
+ }
+ if (IsPassedViaDescriptor(symbol)) {
+ if (IsAllocatableOrPointer(symbol)) {
+ if (inExplicitInterface) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
+ } else {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
+ }
+ } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
+ if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
+ } else if (inExplicitInterface) {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
+ } else {
+ messages_.Say(
+ "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
+ }
}
}
}
diff --git a/flang/test/Semantics/ignore_tkr01.f90 b/flang/test/Semantics/ignore_tkr01.f90
index 6540ba1d394fc..72c6bf3334a5e 100644
--- a/flang/test/Semantics/ignore_tkr01.f90
+++ b/flang/test/Semantics/ignore_tkr01.f90
@@ -53,13 +53,13 @@ subroutine t8(x)
subroutine t9(x)
!dir$ ignore_tkr x
-!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+!WARNING: !DIR$ IGNORE_TKR should not apply to an allocatable or pointer
real, intent(in), allocatable :: x
end
subroutine t10(x)
!dir$ ignore_tkr x
-!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+!WARNING: !DIR$ IGNORE_TKR should not apply to an allocatable or pointer
real, intent(in), pointer :: x
end
@@ -86,24 +86,42 @@ elemental subroutine t13(x)
real, intent(in) :: x
end
+ subroutine t14(x)
+!dir$ ignore_tkr(r) x
+!WARNING: !DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor
+ real x(:)
+ end
+
end interface
contains
- subroutine t14(x)
+ subroutine t15(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+ real, intent(in), allocatable :: x
+ end
+
+ subroutine t16(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+ real, intent(in), pointer :: x
+ end
+
+ subroutine t17(x)
real x
x = x + 1.
!ERROR: !DIR$ IGNORE_TKR directive must appear in the specification part
!dir$ ignore_tkr x
end
- subroutine t15(x)
+ subroutine t18(x)
!ERROR: 'q' is not a valid letter for !DIR$ IGNORE_TKR directive
!dir$ ignore_tkr(q) x
real x
x = x + 1.
end
- subroutine t16(x)
+ subroutine t19(x)
real x
contains
subroutine inner
@@ -112,7 +130,7 @@ subroutine inner
end
end
- subroutine t17(x)
+ subroutine t20(x)
real x
block
!ERROR: 'x' must be local to this subprogram
@@ -120,18 +138,24 @@ subroutine t17(x)
end block
end
- subroutine t18(x)
+ subroutine t21(x)
!dir$ ignore_tkr(c) x
!ERROR: !DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array
real x(1)
end
- subroutine t19(x)
+ subroutine t22(x)
!dir$ ignore_tkr(r) x
-!ERROR: !DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor
+!WARNING: !DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array
real x(..)
end
+ subroutine t23(x)
+!dir$ ignore_tkr(r) x
+!ERROR: !DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor
+ real x(:)
+ end
+
end
subroutine bad1(x)
More information about the flang-commits
mailing list