[flang-commits] [flang] [flang] Allow assumed-shape element pass to dummy arg with ignore_tkr (PR #78196)
Tom Eccles via flang-commits
flang-commits at lists.llvm.org
Tue Jan 16 09:44:24 PST 2024
https://github.com/tblah updated https://github.com/llvm/llvm-project/pull/78196
>From ee28f45482b1478eff70b2a2e3149d1ea6e75145 Mon Sep 17 00:00:00 2001
From: Tom Eccles <tom.eccles at arm.com>
Date: Mon, 15 Jan 2024 17:47:27 +0000
Subject: [PATCH 1/3] [flang] Allow assumed-shape element pass to dummy arg
with ignore_tkr
This is allowed by gfortran and ifort with
![GCC|DEC]$ ATTRIBUTES NO_ARG_CHECK
I'm not sure if 'r' is the right specifier for this, maybe there should
be a new one?
---
flang/lib/Semantics/check-call.cpp | 3 ++-
flang/test/Semantics/ignore_tkr03.f90 | 18 ++++++++++++++++++
2 files changed, 20 insertions(+), 1 deletion(-)
create mode 100644 flang/test/Semantics/ignore_tkr03.f90
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index ec8f99ca6bf48ed..ba8903089f836dd 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -535,7 +535,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
messages.Say(
"Element of pointer array may not be associated with a %s array"_err_en_US,
dummyName);
- } else if (IsAssumedShape(*actualLastSymbol)) {
+ } else if (IsAssumedShape(*actualLastSymbol) &&
+ !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
basicError = true;
messages.Say(
"Element of assumed-shape array may not be associated with a %s array"_err_en_US,
diff --git a/flang/test/Semantics/ignore_tkr03.f90 b/flang/test/Semantics/ignore_tkr03.f90
new file mode 100644
index 000000000000000..25182d879e10977
--- /dev/null
+++ b/flang/test/Semantics/ignore_tkr03.f90
@@ -0,0 +1,18 @@
+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+module library
+contains
+ subroutine lib_sub(buf)
+!dir$ ignore_tkr(r) buf
+ real :: buf(1:*)
+ end subroutine
+end module
+
+module user
+ use library
+contains
+ subroutine sub(var)
+ real :: var(:,:,:)
+! CHECK: CALL lib_sub
+ call lib_sub(var(1, 2, 3))
+ end subroutine
+end module
>From 88825f88e633cb745a2efc010f75232c5c006c59 Mon Sep 17 00:00:00 2001
From: Tom Eccles <tom.eccles at arm.com>
Date: Tue, 16 Jan 2024 17:28:10 +0000
Subject: [PATCH 2/3] Use ignore_tkr(c)
---
flang/docs/Directives.md | 7 ++++---
flang/include/flang/Common/Fortran.h | 4 ++--
flang/lib/Semantics/check-call.cpp | 2 +-
flang/lib/Semantics/check-declarations.cpp | 5 -----
flang/test/Semantics/ignore_tkr01.f90 | 6 ------
flang/test/Semantics/ignore_tkr03.f90 | 2 +-
6 files changed, 8 insertions(+), 18 deletions(-)
diff --git a/flang/docs/Directives.md b/flang/docs/Directives.md
index c8a2c087dfad14c..134de36f884d705 100644
--- a/flang/docs/Directives.md
+++ b/flang/docs/Directives.md
@@ -18,9 +18,10 @@ A list of non-standard directives supported by Flang
The directive allow actual arguments that would otherwise be diagnosed
as incompatible in type (T), kind (K), rank (R), CUDA device (D), or
managed (M) status. The letter (A) is a shorthand for all of these,
- and is the default when no letters appear. The letter (C) is a legacy
- no-op. For example, if one wanted to call a "set all bytes to zero"
- utility that could be applied to arrays of any type or rank:
+ and is the default when no letters appear. The letter (C) checks for
+ contiguity for example allowing an element of an assumed-shape array to be
+ passed as a dummy argument. For example, if one wanted to call a "set all
+ bytes to zero" utility that could be applied to arrays of any type or rank:
```
interface
subroutine clear(arr,bytes)
diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h
index 1d3a85e2500733f..ac1973fdff667a4 100644
--- a/flang/include/flang/Common/Fortran.h
+++ b/flang/include/flang/Common/Fortran.h
@@ -105,8 +105,8 @@ ENUM_CLASS(IgnoreTKR,
Rank, // R - don't check ranks
Device, // D - don't check host/device residence
Managed, // M - don't check managed storage
- Contiguous) // C - legacy; disabled NVFORTRAN's convention that leading
- // dimension of assumed-shape was contiguous
+ Contiguous) // C - don't check for storage sequence association with a
+ // potentially non-contiguous object
using IgnoreTKRSet = EnumSet<IgnoreTKR, 8>;
// IGNORE_TKR(A) = IGNORE_TKR(TKRDM)
static constexpr IgnoreTKRSet ignoreTKRAll{IgnoreTKR::Type, IgnoreTKR::Kind,
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index ba8903089f836dd..23c0f5242020c8a 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -536,7 +536,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"Element of pointer array may not be associated with a %s array"_err_en_US,
dummyName);
} else if (IsAssumedShape(*actualLastSymbol) &&
- !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
+ !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
basicError = true;
messages.Say(
"Element of assumed-shape array may not be associated with a %s array"_err_en_US,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 777e6a9f23fbf87..b5ce8ccd361007f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -742,11 +742,6 @@ void CheckHelper::CheckObjectEntity(
messages_.Say(
"!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);
- }
if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
messages_.Say(
diff --git a/flang/test/Semantics/ignore_tkr01.f90 b/flang/test/Semantics/ignore_tkr01.f90
index a8fc9dadc1d83e7..5d1ce32cf81d012 100644
--- a/flang/test/Semantics/ignore_tkr01.f90
+++ b/flang/test/Semantics/ignore_tkr01.f90
@@ -138,12 +138,6 @@ subroutine t20(x)
end block
end
- 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 t22(x)
!dir$ ignore_tkr(r) x
!WARNING: !DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array
diff --git a/flang/test/Semantics/ignore_tkr03.f90 b/flang/test/Semantics/ignore_tkr03.f90
index 25182d879e10977..9c3873106efe5c9 100644
--- a/flang/test/Semantics/ignore_tkr03.f90
+++ b/flang/test/Semantics/ignore_tkr03.f90
@@ -2,7 +2,7 @@
module library
contains
subroutine lib_sub(buf)
-!dir$ ignore_tkr(r) buf
+!dir$ ignore_tkr(c) buf
real :: buf(1:*)
end subroutine
end module
>From 4d38e6f80efaa3c28669b5b578018a0412237e2a Mon Sep 17 00:00:00 2001
From: Tom Eccles <tom.eccles at arm.com>
Date: Tue, 16 Jan 2024 17:42:02 +0000
Subject: [PATCH 3/3] Allow non-contiguous pointers
---
flang/lib/Semantics/check-call.cpp | 3 ++-
flang/test/Semantics/ignore_tkr03.f90 | 5 ++++-
2 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 23c0f5242020c8a..6a95a26d09620c8 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -529,7 +529,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummyName);
}
if (actualIsArrayElement && actualLastSymbol &&
- !evaluate::IsContiguous(*actualLastSymbol, foldingContext)) {
+ !evaluate::IsContiguous(*actualLastSymbol, foldingContext) &&
+ !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
if (IsPointer(*actualLastSymbol)) {
basicError = true;
messages.Say(
diff --git a/flang/test/Semantics/ignore_tkr03.f90 b/flang/test/Semantics/ignore_tkr03.f90
index 9c3873106efe5c9..4c48308a39964d1 100644
--- a/flang/test/Semantics/ignore_tkr03.f90
+++ b/flang/test/Semantics/ignore_tkr03.f90
@@ -10,9 +10,12 @@ subroutine lib_sub(buf)
module user
use library
contains
- subroutine sub(var)
+ subroutine sub(var, ptr)
real :: var(:,:,:)
+ real, pointer :: ptr(:)
! CHECK: CALL lib_sub
call lib_sub(var(1, 2, 3))
+! CHECK: CALL lib_sub
+ call lib_sub(ptr(1))
end subroutine
end module
More information about the flang-commits
mailing list