[flang] add evaluate::IsAllocatableDesignator helper

[jeanPerier]

Summary

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

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.

[peixin]

flang/include/flang/Evaluate/tools.h

917

Nit: Remove expr to be consistent with others.

flang/lib/Evaluate/tools.cpp

1097

Should you add one comment (2018 9.5.3 NOTE 2) here?

[peixin]

flang/lib/Semantics/check-call.cpp

404

This fix is not tested in this patch. So can you move the test case in call05.f90 in D122779 to this case? D122779 will focus on the other check (The actual argument shall have deferred the same type parameters as the dummy argument if the argument is allocatable or pointer variable). It's better to keep one patch as complete.

[klausler]

There is a naming clash with semantics::IsAllocatable().

[schweitz]

LGTM.

[jeanPerier]

In D122899#3422673, @klausler wrote:

There is a naming clash with semantics::IsAllocatable().

I see. Would evaluate::IsAllocatableEntity() sounds good to you ?

[klausler]

In D122899#3423067, @jeanPerier wrote:

In D122899#3422673, @klausler wrote:

There is a naming clash with semantics::IsAllocatable().

I see. Would evaluate::IsAllocatableEntity() sounds good to you ?

"Designator" seems best. "Variable" would also work, but the only variables that aren't designators are the returned values of pointer-valued functions, and they cannot be allocatable.

[jeanPerier]

Rename evaluate::IsAllocatable to evaluate::IsAllocatableDesignator.
Add Call05.f90 relevant tests from https://reviews.llvm.org/D122779.
Remove arg name in declaration and add reference to standard.

[jeanPerier]

This fix is not tested in this patch. So can you move the test case in call05.f90 in D122779 to this case?

Sure, done. I will add you as a contributor to this patch.

[peixin]

In D122899#3423177, @jeanPerier wrote:

This fix is not tested in this patch. So can you move the test case in call05.f90 in D122779 to this case?

Sure, done. I will add you as a contributor to this patch.

Thanks, @jeanPerier .

[peixin]

Cherry-pick this and D122779 to fir-dev in https://github.com/flang-compiler/f18-llvm-project/pull/1557 since D122779 made some changes in lowering test cases in case that it affects the upstreaming work.

flang/include/flang/Evaluate/tools.h

if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
       if (c->base().Rank() == 0) {
         return &c->GetLastSymbol();
       }
     }
   }
   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)}) {
     return &dataRef->GetFirstSymbol();
   } else {
     return nullptr;
   }
 }
template <typename A> bool IsAllocatableOrPointer(const A &x) {
   return GetAttrs(x).HasAny(
       semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
 }
 
 // Like IsAllocatableOrPointer, but accepts pointer function results as being
 // 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> &);
 bool IsProcedurePointerTarget(const Expr<SomeType> &);
 bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD=
 bool IsNullPointer(const Expr<SomeType> &);
 bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
 

flang/lib/Evaluate/intrinsics.cpp

 // Applies any semantic checks peculiar to an intrinsic.
 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {
     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) {
       context.messages().Say(
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } else if (name == "associated") {

flang/lib/Evaluate/tools.cpp

 
 bool IsAllocatableOrPointerObject(
     const Expr<SomeType> &expr, FoldingContext &context) {
   const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
   return (sym && semantics::IsAllocatableOrPointer(*sym)) ||
       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)};
   // 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
   // may be passed to a non-allocatable/non-pointer optional dummy. Note that
   // other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
   // ignore this point in intrinsic contexts (e.g CMPLX argument).
   return (sym && semantics::IsOptional(*sym)) ||

flang/lib/Semantics/check-call.cpp

if (actualRank > 0 && !actualIsContiguous) {
             dummyName);
       }
     }
   }
 
   // 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(
           "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
           dummyName);
     }
     if (actualIsAllocatable && actualIsCoindexed &&
         dummy.intent != common::Intent::In) {

flang/test/Semantics/allocated.f90

+! 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

subroutine test
     call snma(dma)
     !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
     call samp(dmp)
     !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
     call sama(dma)
   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