flang/test/Lower/HLFIR/calls-assumed-shape.f90

   1 ! Test lowering of calls involving assumed shape arrays or arrays with
   2 ! VALUE attribute.
   3 ! RUN: bbc -emit-fir -hlfir -polymorphic-type -o - %s | FileCheck %s
   4
   5 subroutine test_assumed_to_assumed(x)
   6   interface
   7     subroutine takes_assumed(x)
   8       real :: x(:)
   9     end subroutine
  10   end interface
  11   real :: x(:)
  12   call takes_assumed(x)
  13 end subroutine
  14 ! CHECK-LABEL: func.func @_QPtest_assumed_to_assumed(
  15 ! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {uniq_name = "_QFtest_assumed_to_assumedEx"} : (!fir.box<!fir.array<?xf32>>) -> (!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>)
  16 ! CHECK:  fir.call @_QPtakes_assumed(%[[VAL_1]]#0) {{.*}} : (!fir.box<!fir.array<?xf32>>) -> ()
  17
  18 subroutine test_ptr_to_assumed(p)
  19   interface
  20     subroutine takes_assumed(x)
  21       real :: x(:)
  22     end subroutine
  23   end interface
  24   real, pointer :: p(:)
  25   call takes_assumed(p)
  26 end subroutine
  27 ! CHECK-LABEL: func.func @_QPtest_ptr_to_assumed(
  28 ! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_ptr_to_assumedEp"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>)
  29 ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  30 ! CHECK:  %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<!fir.array<?xf32>>
  31 ! CHECK:  fir.call @_QPtakes_assumed(%[[VAL_3]]) {{.*}} : (!fir.box<!fir.array<?xf32>>) -> ()
  32
  33 subroutine test_ptr_to_contiguous_assumed(p)
  34   interface
  35     subroutine takes_contiguous_assumed(x)
  36       real, contiguous :: x(:)
  37     end subroutine
  38   end interface
  39   real, pointer :: p(:)
  40   call takes_contiguous_assumed(p)
  41 end subroutine
  42 ! CHECK-LABEL: func.func @_QPtest_ptr_to_contiguous_assumed(
  43 ! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_ptr_to_contiguous_assumedEp"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>)
  44 ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  45 ! CHECK:  %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i1)
  46 ! CHECK:  %[[VAL_4:.*]] = fir.rebox %[[VAL_3]]#0 : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<!fir.array<?xf32>>
  47 ! CHECK:  fir.call @_QPtakes_contiguous_assumed(%[[VAL_4]]) {{.*}} : (!fir.box<!fir.array<?xf32>>) -> ()
  48 ! CHECK:  hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i1, !fir.box<!fir.ptr<!fir.array<?xf32>>>) -> ()
  49
  50 subroutine test_ptr_to_contiguous_assumed_classstar(p)
  51   interface
  52     subroutine takes_contiguous_assumed_classstar(x)
  53       class(*), contiguous :: x(:)
  54     end subroutine
  55   end interface
  56   real, pointer :: p(:)
  57   call takes_contiguous_assumed_classstar(p)
  58 end subroutine
  59 ! CHECK-LABEL: func.func @_QPtest_ptr_to_contiguous_assumed_classstar(
  60 ! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_ptr_to_contiguous_assumed_classstarEp"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>)
  61 ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  62 ! CHECK:  %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i1)
  63 ! CHECK:  %[[VAL_4:.*]] = fir.rebox %[[VAL_3]]#0 : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.class<!fir.array<?xnone>>
  64 ! CHECK:  fir.call @_QPtakes_contiguous_assumed_classstar(%[[VAL_4]]) {{.*}} : (!fir.class<!fir.array<?xnone>>) -> ()
  65 ! CHECK:  hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i1, !fir.box<!fir.ptr<!fir.array<?xf32>>>) -> ()
  66
  67 subroutine test_ptr_to_assumed_typestar(p)
  68   interface
  69     subroutine takes_assumed_typestar(x)
  70       type(*) :: x(:)
  71     end subroutine
  72   end interface
  73   real, pointer :: p(:)
  74   call takes_assumed_typestar(p)
  75 end subroutine
  76 ! CHECK-LABEL: func.func @_QPtest_ptr_to_assumed_typestar(
  77 ! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_ptr_to_assumed_typestarEp"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>)
  78 ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  79 ! CHECK:  %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<!fir.array<?xnone>>
  80 ! CHECK:  fir.call @_QPtakes_assumed_typestar(%[[VAL_3]]) {{.*}} : (!fir.box<!fir.array<?xnone>>) -> ()
  81
  82 subroutine test_explicit_char_to_box(e)
  83   interface
  84     subroutine takes_assumed_character(x)
  85       character(*) :: x(:)
  86     end subroutine
  87   end interface
  88   character(10) :: e(20)
  89   call takes_assumed_character(e)
  90 end subroutine
  91 ! CHECK-LABEL: func.func @_QPtest_explicit_char_to_box(
  92 ! CHECK:  %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
  93 ! CHECK:  %[[VAL_2:.*]] = arith.constant 10 : index
  94 ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<20x!fir.char<1,10>>>
  95 ! CHECK:  %[[VAL_4:.*]] = arith.constant 20 : index
  96 ! CHECK:  %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1>
  97 ! CHECK:  %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]] {uniq_name = "_QFtest_explicit_char_to_boxEe"} : (!fir.ref<!fir.array<20x!fir.char<1,10>>>, !fir.shape<1>, index) -> (!fir.ref<!fir.array<20x!fir.char<1,10>>>, !fir.ref<!fir.array<20x!fir.char<1,10>>>)
  98 ! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_6]]#0(%[[VAL_5]]) : (!fir.ref<!fir.array<20x!fir.char<1,10>>>, !fir.shape<1>) -> !fir.box<!fir.array<20x!fir.char<1,10>>>
  99 ! CHECK:  %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<20x!fir.char<1,10>>>) -> !fir.box<!fir.array<?x!fir.char<1,?>>>
 100 ! CHECK:  fir.call @_QPtakes_assumed_character(%[[VAL_8]]) {{.*}} : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> ()
 101
 102 subroutine test_explicit_by_val(x)
 103   interface
 104     subroutine takes_explicit_by_value(x)
 105       real, value :: x(10)
 106     end subroutine
 107   end interface
 108   real :: x(10)
 109   call takes_explicit_by_value(x)
 110 end subroutine
 111 ! CHECK-LABEL: func.func @_QPtest_explicit_by_val(
 112 ! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_2:[a-z0-9]*]]) {uniq_name = "_QFtest_explicit_by_valEx"} : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> (!fir.ref<!fir.array<10xf32>>, !fir.ref<!fir.array<10xf32>>)
 113 ! CHECK:  %[[VAL_4:.*]] = hlfir.as_expr %[[VAL_3]]#0 : (!fir.ref<!fir.array<10xf32>>) -> !hlfir.expr<10xf32>
 114 ! CHECK:  %[[VAL_5:.*]]:3 = hlfir.associate %[[VAL_4]](%[[VAL_2]]) {uniq_name = "adapt.valuebyref"} : (!hlfir.expr<10xf32>, !fir.shape<1>) -> (!fir.ref<!fir.array<10xf32>>, !fir.ref<!fir.array<10xf32>>, i1)
 115 ! CHECK:  fir.call @_QPtakes_explicit_by_value(%[[VAL_5]]#1) {{.*}} : (!fir.ref<!fir.array<10xf32>>) -> ()
 116 ! CHECK:  hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref<!fir.array<10xf32>>, i1