[flang-commits] [flang] 7c158e3 - [flang] add evaluate::IsAllocatableDesignator helper
Jean Perier via flang-commits
flang-commits at lists.llvm.org
Fri Apr 1 13:35:07 PDT 2022
Author: Jean Perier
Date: 2022-04-01T22:34:19+02:00
New Revision: 7c158e3e554ad7e961480f080571cafab9c5760f
URL: https://github.com/llvm/llvm-project/commit/7c158e3e554ad7e961480f080571cafab9c5760f
DIFF: https://github.com/llvm/llvm-project/commit/7c158e3e554ad7e961480f080571cafab9c5760f.diff
LOG: [flang] add evaluate::IsAllocatableDesignator helper
Previously, some semantic checks that are checking if an entity is an
allocatable were relying on the expression being a designator whose
last symbol has the allocatable attribute.
This is wrong since this was considering substrings and array sections of
allocatables as being allocatable. This is wrong (see NOTE 2 in
Fortran 2018 section 9.5.3.1).
Add evaluate::IsAllocatableDesignator to correctly test this.
Also add some semantic tests for ALLOCATED to test the newly added helper.
Note that ifort and nag are rejecting coindexed-named-object in
ALLOCATED (`allocated(coarray_scalar_alloc[2])`).
I think it is wrong given allocated argument is intent(in) as per
16.2.1 point 3.
So 15.5.2.6 point 4 regarding allocatable dummy is not violated (If the actual
argument is a coindexed object, the dummy argument shall have the INTENT (IN)
attribute.) and I think this is valid. gfortran accepts it.
The need for this helper was exposed in https://reviews.llvm.org/D122779.
Differential Revision: https://reviews.llvm.org/D122899
Co-authored-by: Peixin-Qiao <qiaopeixin at huawei.com>
Added:
flang/test/Semantics/allocated.f90
Modified:
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/call05.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index ae6772a871070..bba446749d12f 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -417,6 +417,27 @@ const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
return nullptr;
}
+// If an expression is a whole symbol or a whole component designator,
+// potentially followed by an image selector, extract and return that symbol,
+// else null.
+template <typename A>
+const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) {
+ if (auto dataRef{ExtractDataRef(x)}) {
+ if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
+ return &p->get();
+ } else if (const Component * c{std::get_if<Component>(&dataRef->u)}) {
+ if (c->base().Rank() == 0) {
+ return &c->GetLastSymbol();
+ }
+ } else if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef->u)}) {
+ if (c->subscript().empty()) {
+ return &c->GetLastSymbol();
+ }
+ }
+ }
+ return nullptr;
+}
+
// GetFirstSymbol(A%B%C[I]%D) -> A
template <typename A> const Symbol *GetFirstSymbol(const A &x) {
if (auto dataRef{ExtractDataRef(x, true)}) {
@@ -893,6 +914,8 @@ template <typename A> bool IsAllocatableOrPointer(const A &x) {
// pointers.
bool IsAllocatableOrPointerObject(const Expr<SomeType> &, FoldingContext &);
+bool IsAllocatableDesignator(const Expr<SomeType> &);
+
// Procedure and pointer detection predicates
bool IsProcedure(const Expr<SomeType> &);
bool IsFunction(const Expr<SomeType> &);
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 42b1a89da9183..c20ccc69ea32e 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2323,9 +2323,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
const auto &arg{call.arguments[0]};
if (arg) {
if (const auto *expr{arg->UnwrapExpr()}) {
- if (const Symbol * symbol{GetLastSymbol(*expr)}) {
- ok = symbol->attrs().test(semantics::Attr::ALLOCATABLE);
- }
+ ok = evaluate::IsAllocatableDesignator(*expr);
}
}
if (!ok) {
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 68b2a40d48c5d..5db7d1f0d4e2f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1094,6 +1094,15 @@ bool IsAllocatableOrPointerObject(
evaluate::IsObjectPointer(expr, context);
}
+bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
+ // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).
+ if (const semantics::Symbol *
+ sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {
+ return semantics::IsAllocatable(*sym);
+ }
+ return false;
+}
+
bool MayBePassedAsAbsentOptional(
const Expr<SomeType> &expr, FoldingContext &context) {
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 3f39e064e6d6e..7c5fb605567cb 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -401,8 +401,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// 15.5.2.6 -- dummy is ALLOCATABLE
bool dummyIsAllocatable{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
- bool actualIsAllocatable{
- actualLastSymbol && IsAllocatable(*actualLastSymbol)};
+ bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
if (dummyIsAllocatable) {
if (!actualIsAllocatable) {
messages.Say(
diff --git a/flang/test/Semantics/allocated.f90 b/flang/test/Semantics/allocated.f90
new file mode 100644
index 0000000000000..82ce7ca7bdb9f
--- /dev/null
+++ b/flang/test/Semantics/allocated.f90
@@ -0,0 +1,66 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests for the ALLOCATED() intrinsic
+subroutine alloc(coarray_alloc, coarray_not_alloc, t2_not_alloc)
+
+ interface
+ function return_allocatable()
+ integer, allocatable :: return_allocatable(:)
+ end function
+ end interface
+
+ type :: t1
+ integer, allocatable :: alloc(:)
+ integer :: not_alloc
+ end type
+
+ type :: t2
+ real, allocatable :: coarray_alloc[:]
+ real, allocatable :: coarray_alloc_array(:)[:]
+ end type
+
+
+ integer :: not_alloc(100)
+ real, allocatable :: x_alloc
+ character(:), allocatable :: char_alloc(:)
+ type(t1) :: dt_not_alloc(100)
+ type(t1), allocatable :: dt_alloc(:)
+
+ real, allocatable :: coarray_alloc[:, :]
+ real, allocatable :: coarray_alloc_array(:)[:, :]
+ real :: coarray_not_alloc(:)[*]
+
+ type(t2) :: t2_not_alloc
+
+
+ ! OK
+ print *, allocated(x_alloc)
+ print *, allocated(char_alloc)
+ print *, allocated(dt_alloc)
+ print *, allocated(dt_not_alloc(3)%alloc)
+ print *, allocated(dt_alloc(3)%alloc)
+ print *, allocated(coarray_alloc)
+ print *, allocated(coarray_alloc[2,3])
+ print *, allocated(t2_not_alloc%coarray_alloc)
+ print *, allocated(t2_not_alloc%coarray_alloc[2])
+
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(not_alloc)
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(dt_not_alloc)
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(dt_alloc%not_alloc)
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(char_alloc(:))
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(char_alloc(1)(1:10))
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(coarray_alloc_array(1:10))
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(coarray_alloc_array(1:10)[2,2])
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(t2_not_alloc%coarray_alloc_array(1))
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(t2_not_alloc%coarray_alloc_array(1)[2])
+ !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component
+ print *, allocated(return_allocatable())
+end subroutine
diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90
index 0aadb6a6b11d8..c97dcd166495d 100644
--- a/flang/test/Semantics/call05.f90
+++ b/flang/test/Semantics/call05.f90
@@ -118,3 +118,79 @@ subroutine test
end subroutine
end module
+
+module m2
+
+ character(len=10), allocatable :: t1, t2, t3, t4
+ character(len=:), allocatable :: t5, t6, t7, t8(:)
+
+ character(len=10), pointer :: p1
+ character(len=:), pointer :: p2
+
+ integer, allocatable :: x(:)
+
+ contains
+
+ subroutine sma(a)
+ character(len=:), allocatable, intent(in) :: a
+ end
+
+ subroutine sma2(a)
+ character(len=10), allocatable, intent(in) :: a
+ end
+
+ subroutine smp(p)
+ character(len=:), pointer, intent(in) :: p
+ end
+
+ subroutine smp2(p)
+ character(len=10), pointer, intent(in) :: p
+ end
+
+ subroutine smb(b)
+ integer, allocatable, intent(in) :: b(:)
+ end
+
+ subroutine test()
+
+ call sma2(t1) ! ok
+
+ call smp2(p1) ! ok
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t2(:))
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t3(1))
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t4(1:2))
+
+ call sma(t5) ! ok
+
+ call smp(p2) ! ok
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t5(:))
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t6(1))
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t7(1:2))
+
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call sma(t8(1))
+
+ !ERROR: ALLOCATABLE dummy argument 'b=' must be associated with an ALLOCATABLE actual argument
+ call smb(x(:))
+
+ !ERROR: ALLOCATABLE dummy argument 'b=' must be associated with an ALLOCATABLE actual argument
+ call smb(x(2))
+
+ !ERROR: ALLOCATABLE dummy argument 'b=' must be associated with an ALLOCATABLE actual argument
+ call smb(x(1:2))
+
+ end subroutine
+
+end module
More information about the flang-commits
mailing list