diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -417,6 +417,27 @@ 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 +const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) { + if (auto dataRef{ExtractDataRef(x)}) { + if (const SymbolRef * p{std::get_if(&dataRef->u)}) { + return &p->get(); + } else if (const Component * c{std::get_if(&dataRef->u)}) { + if (c->base().Rank() == 0) { + return &c->GetLastSymbol(); + } + } else if (const CoarrayRef * c{std::get_if(&dataRef->u)}) { + if (c->subscript().empty()) { + return &c->GetLastSymbol(); + } + } + } + return nullptr; +} + // GetFirstSymbol(A%B%C[I]%D) -> A template const Symbol *GetFirstSymbol(const A &x) { if (auto dataRef{ExtractDataRef(x, true)}) { @@ -893,6 +914,8 @@ // pointers. bool IsAllocatableOrPointerObject(const Expr &, FoldingContext &); +bool IsAllocatableDesignator(const Expr &); + // Procedure and pointer detection predicates bool IsProcedure(const Expr &); bool IsFunction(const Expr &); diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2323,9 +2323,7 @@ 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 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1094,6 +1094,15 @@ evaluate::IsObjectPointer(expr, context); } +bool IsAllocatableDesignator(const Expr &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 &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 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -401,8 +401,7 @@ // 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 --- /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 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -118,3 +118,79 @@ 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