[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@huawei.com>

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> &);

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) {

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)};

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(

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

flang/test/Semantics/call05.f90

@@ -118,3 +118,79 @@ module m
   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