From 50e2581a199da9702841f103eefca8dca2fc7b4f Mon Sep 17 00:00:00 2001 From: Tom Eccles Date: Mon, 22 Jan 2024 23:16:22 +0000 Subject: [PATCH] [flang] Allow assumed-shape element pass to dummy arg with ignore_tkr (#78196) This is allowed by gfortran and ifort with `![GCC|DEC]$ ATTRIBUTES NO_ARG_CHECK` --- flang/docs/Directives.md | 7 ++++--- flang/include/flang/Common/Fortran.h | 4 ++-- flang/lib/Semantics/check-call.cpp | 6 ++++-- flang/lib/Semantics/check-declarations.cpp | 5 ----- flang/test/Semantics/ignore_tkr01.f90 | 6 ------ flang/test/Semantics/ignore_tkr03.f90 | 21 +++++++++++++++++++++ 6 files changed, 31 insertions(+), 18 deletions(-) create mode 100644 flang/test/Semantics/ignore_tkr03.f90 diff --git a/flang/docs/Directives.md b/flang/docs/Directives.md index c8a2c087dfad..134de36f884d 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 1d3a85e25007..ac1973fdff66 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; // 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 a8927e94481d..c924a817ec7e 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -529,13 +529,15 @@ 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( "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::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 8315864bcb71..31ccc77d0993 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -746,11 +746,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 a8fc9dadc1d8..5d1ce32cf81d 100644 --- a/flang/test/Semantics/ignore_tkr01.f90 +++ b/flang/test/Semantics/ignore_tkr01.f90 @@ -138,12 +138,6 @@ module m 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 new file mode 100644 index 000000000000..4c48308a3996 --- /dev/null +++ b/flang/test/Semantics/ignore_tkr03.f90 @@ -0,0 +1,21 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +module library +contains + subroutine lib_sub(buf) +!dir$ ignore_tkr(c) buf + real :: buf(1:*) + end subroutine +end module + +module user + use library +contains + 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