[flang] Add one semantic check for allocatable/pointer argument association

[peixin]

Summary

The actual argument shall have deferred the same type parameters as
the dummy argument if the argument is allocatable or pointer variable.
Currently programs not following this get one crash during execution.

[peixin]

If a dummy argument is allocatable, the associated actual argument must be one whole array, not array section or substring.

Actually, I don't find this in F2018 standard. Gfortran and ifort report semantic errors for this. F18 in fir-dev crash during lowering to FIR/MLIR. First, in semantics, passing partial heap seems not reasonable. Second, for FIR lowering, it seems passing a box cannot support parital heap. For a box of ptr, it is ok.

This restriction does not applies to pointer. Check the following example,

program main
  character(:), pointer :: s
  character(5), target :: t = "abcde"
  integer, pointer :: x(:)
  integer, target :: y(5) = 2

  s=>t
  x=>y
  call sub(s(1:2))
  call sub2(x(1:2))
contains
  subroutine sub(ptr)
    character(len=:), pointer, intent(in) :: ptr
    print *, ptr
  end
  subroutine sub2(ptr)
    integer, pointer, intent(in) :: ptr(:)
    print *, ptr
  end
end

This works ok in gfortran, ifort and LLVM Flang in fir-dev. The open-source classic-flang does not support it and I think nvfortran does not, either. This case is used in workload FPM. So it should be ok.

[jeanPerier]

Looks better thanks. The second added error message might still be redundant in some cases, and I dot need you need to add the first one if you fix the determination of the actualIsAllocatable boolean, which I think should be done. See more details inlined.

If a dummy argument is allocatable, the associated actual argument must be one whole array, not array section or substring.

Actually, I don't find this in F2018 standard. Gfortran and ifort report semantic errors for this.

The actual constraint is that if the dummy has the ALLOCATABLE attribute, the actual argument shall be allocatable ( see Fortran 2018 15.5.2.6 point 2 about allocatable dummy variables). It happens that the subojects of allocatable variables are not themselves allocatables (See the NOTE 2 in Fortran 2018 section 9.5.3 NOTE 2: Unless otherwise specified, an array element or array section does not have an attribute of the whole array. In particular, an array element or an array section does not have the POINTER or ALLOCATABLE attribute.). So passing an a section of an allocatable to an allocatable violates 15.5.2.6 point 2.

Regarding pointers, your test is valid because the dummy pointer is INTENT(IN), but if the INTENT(IN) attribute was not present, this would be a violation of Fortran 2018 15.5.2.7 point 2. Flang is already enforcing this correctly though, so you do not need to update anything here.

flang/lib/Semantics/check-call.cpp

410

The issue lies in actualIsAllocatable that is wrong just above, it assumes the actual is a whole symbol. A boolean actualIsAllocatable should not be true for an actual argument like an_allocatable(:) because an_allocatable(:) is not an allocatable.

Instead, actualIsAllocatable should be determined by a more generic infrastructure like evaluate::IsAllocatable(actual). It seems we do not have that yet, and I really think we should.
It would probably require adding a new evaluate::UnwrapWholeSymbolOrComponentOrCoarrayRef to include/Evaluate/tools.h so that you can use it in evaluate::IsAllocatable. If you want, I can add evaluate::IsAllocatable for you, just let me know.

493

For parametrized derived type, this check will be redundant with the one above (line 486 where you added the Standard ref).

module test
  type t(l)
    integer, len :: l
    character(l) :: c
  end type
contains
  subroutine bar(p)
    type(t(:)), allocatable :: p(:)
  end subroutine
  subroutine foo
    type(t(10)), allocatable :: p(:)
    call bar(p)
  end subroutine
end module

Could you move it as an else if of `if (const auto *derived{

evaluate::GetDerivedTypeSpec(actualType.type())}) {` line 487 ? to restrict this message to characters and avoid the duplication ?

flang/test/Lower/allocatable-caller.f90

93

Could you transform that into:

test_char_array_explicit_call(n)
    integer :: n
    ....
    character(n), allocatable :: x2(:)
    ...
    test_char_array_explicit(x2)

That way, we can test that lowering insert the type cast when needed.

flang/test/Lower/pointer-args-caller.f90

51

Can you update this to being:

subroutine test_ptr_to_non_deferred_char_array_ptr(p, n)
   integer :: n
   character(n), pointer :: p(:)
   call non_deferred_char_array_ptr(p)
end subroutine

So that we have a test that passes a non deferred length pointer to another non deferred length pointer ?

[peixin]

Regarding pointers, your test is valid because the dummy pointer is INTENT(IN), but if the INTENT(IN) attribute was not present, this would be a violation of Fortran 2018 15.5.2.7 point 2. Flang is already enforcing this correctly though, so you do not need to update anything here.

Got it. Thanks for this. This is pointer association, not argument association.

flang/lib/Semantics/check-call.cpp

410

It would probably require adding a new evaluate::UnwrapWholeSymbolOrComponentOrCoarrayRef to include/Evaluate/tools.h so that you can use it in evaluate::IsAllocatable. If you want, I can add evaluate::IsAllocatable for you, just let me know.

Agree, adding these two sounds more resonable to me. Please add it as you want. I am really grateful.

493

Sure. Will also add this test case.

flang/test/Lower/allocatable-caller.f90

93

Sure, will change this.

flang/test/Lower/pointer-args-caller.f90

51

Sure, will change this.

[peixin]

Addressed all the comments and fix the summary. Waiting for @jeanPerier 's new functions to override checking if one symbol is allocatable.

[jeanPerier]

Waiting for @jeanPerier 's new functions to override checking if one symbol is allocatable.

New helper for review in: https://reviews.llvm.org/D122899

[peixin]

Remove the IsAllocatableDesignator check.

[jeanPerier]

Thanks @peixin, LGTM.

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)};
+      actualLastSymbol && IsAllocatable(*actualLastSymbol) &&
+      (evaluate::IsCoarray(*actualLastSymbol) ||
+       evaluate::UnwrapWholeSymbolOrComponentDataRef(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) {
       messages.Say(
           "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
           dummyName);
if (actualIsUnlimited != dummyIsUnlimited) {
           // extension: allow with warning, rule is only relevant for definables
           messages.Say(
               "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
         } else {
           messages.Say(
               "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
         }
       }
+      // 15.5.2.5(4)
       if (const auto *derived{
               evaluate::GetDerivedTypeSpec(actualType.type())}) {
         if (!DefersSameTypeParameters(
                 *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
           messages.Say(
               "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
         }
+      } else if (dummy.type.type().HasDeferredTypeParameter() !=
+                 actualType.type().HasDeferredTypeParameter()) {
+          messages.Say(
+              "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
       }
     }
   }
 
   // 15.5.2.8 -- coarray dummy arguments
   if (dummy.type.corank() > 0) {
     if (actualType.corank() == 0) {
       messages.Say(
           "Actual argument associated with coarray %s must be a coarray"_err_en_US,
           dummyName);
     }
     if (dummyIsVolatile) {
       if (!actualIsVolatile) {

flang/test/Lower/allocatable-caller.f90

 ! CHECK-LABEL: func @_QPtest_char_scalar_deferred_call(
 subroutine test_char_scalar_deferred_call()
   interface
   subroutine test_char_scalar_deferred(x)
     character(:), allocatable :: x
   end subroutine
   end interface
   character(:), allocatable :: x
-  character(10), allocatable :: x2
-  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFtest_char_scalar_deferred_callEx"}
-  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFtest_char_scalar_deferred_callEx2"}
+  ! CHECK: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFtest_char_scalar_deferred_callEx"}
   call test_char_scalar_deferred(x)
   ! CHECK: fir.call @_QPtest_char_scalar_deferred(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> ()
-  call test_char_scalar_deferred(x2)
-  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
-  ! CHECK: fir.call @_QPtest_char_scalar_deferred(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> ()
 end subroutine
 
 ! CHECK-LABEL: func @_QPtest_char_scalar_explicit_call(
-subroutine test_char_scalar_explicit_call()
+subroutine test_char_scalar_explicit_call(n)
+  integer :: n
   interface
   subroutine test_char_scalar_explicit(x)
     character(10), allocatable :: x
   end subroutine
   end interface
   character(10), allocatable :: x
-  character(:), allocatable :: x2
+  character(n), allocatable :: x2
   ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFtest_char_scalar_explicit_callEx"}
   ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFtest_char_scalar_explicit_callEx2"}
   call test_char_scalar_explicit(x)
   ! CHECK: fir.call @_QPtest_char_scalar_explicit(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> ()
   call test_char_scalar_explicit(x2)
   ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
   ! CHECK: fir.call @_QPtest_char_scalar_explicit(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> ()
 end subroutine
 
 ! CHECK-LABEL: func @_QPtest_char_array_deferred_call(
 subroutine test_char_array_deferred_call()
   interface
   subroutine test_char_array_deferred(x)
     character(:), allocatable :: x(:)
   end subroutine
   end interface
   character(:), allocatable :: x(:)
-  character(10), allocatable :: x2(:)
-  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFtest_char_array_deferred_callEx"}
-  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFtest_char_array_deferred_callEx2"}
+  ! CHECK: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFtest_char_array_deferred_callEx"}
   call test_char_array_deferred(x)
   ! CHECK: fir.call @_QPtest_char_array_deferred(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> ()
-  call test_char_array_deferred(x2)
-  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
-  ! CHECK: fir.call @_QPtest_char_array_deferred(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> ()
 end subroutine
 
 ! CHECK-LABEL: func @_QPtest_char_array_explicit_call(
-subroutine test_char_array_explicit_call()
+subroutine test_char_array_explicit_call(n)
+  integer :: n
   interface
   subroutine test_char_array_explicit(x)
     character(10), allocatable :: x(:)
   end subroutine
   end interface
   character(10), allocatable :: x(:)
-  character(:), allocatable :: x2(:)
+  character(n), allocatable :: x2(:)
   ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFtest_char_array_explicit_callEx"}
   ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFtest_char_array_explicit_callEx2"}
   call test_char_array_explicit(x)
   ! CHECK: fir.call @_QPtest_char_array_explicit(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> ()
   call test_char_array_explicit(x2)
   ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
   ! CHECK: fir.call @_QPtest_char_array_explicit(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> ()
 end subroutine

flang/test/Lower/pointer-args-caller.f90

 ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "p"}) {
 subroutine test_ptr_to_char_array_ptr(p)
   character(:), pointer :: p(:)
 ! CHECK:  fir.call @_QPchar_array_ptr(%[[VAL_0]]) : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> ()
   call char_array_ptr(p)
 end subroutine
 
 ! CHECK-LABEL: func @_QMcall_defsPtest_ptr_to_non_deferred_char_array_ptr(
-! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "p"}) {
-subroutine test_ptr_to_non_deferred_char_array_ptr(p)
-  character(:), pointer :: p(:)
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "p"}
+subroutine test_ptr_to_non_deferred_char_array_ptr(p, n)
+  integer :: n
+  character(n), pointer :: p(:)
 ! CHECK:  %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,10>>>>>
 ! CHECK:  fir.call @_QPnon_deferred_char_array_ptr(%[[VAL_1]]) : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,10>>>>>) -> ()
   call non_deferred_char_array_ptr(p)
 end subroutine
 
 ! -----------------------------------------------------------------------------
 !     Test passing non-POINTER actual arguments (implicit pointer assignment)
 ! -----------------------------------------------------------------------------

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()
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call sma(t1)
+
+    call sma2(t1) ! ok
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call smp(p1)
+
+    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
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call sma2(t5)
+
+    call smp(p2) ! ok
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call smp2(p2)
+
+    !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
+
+module test
+  type t(l)
+    integer, len :: l
+    character(l) :: c
+  end type
+
+ contains
+
+  subroutine bar(p)
+    type(t(:)), allocatable :: p(:)
+  end subroutine
+
+  subroutine foo
+    type(t(10)), allocatable :: p(:)
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call bar(p)
+
+  end subroutine
+
+end module