flang/test/Lower/dummy-procedure.f90

   1 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
   2
   3 ! Test dummy procedures
   4
   5 ! Test of dummy procedure call
   6 ! CHECK-LABEL: func @_QPfoo(
   7 ! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
   8 real function foo(bar)
   9   real :: bar, x
  10   ! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
  11   x = 42.
  12   ! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
  13   ! CHECK: fir.call %[[funccast]](%[[x]]) {{.*}}: (!fir.ref<f32>) -> f32
  14   foo = bar(x)
  15 end function
  16
  17 ! Test case where dummy procedure is only transiting.
  18 ! CHECK-LABEL: func @_QPprefoo(
  19 ! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
  20 real function prefoo(bar)
  21   external :: bar
  22   ! CHECK: fir.call @_QPfoo(%arg0) {{.*}}: (!fir.boxproc<() -> ()>) -> f32
  23   prefoo = foo(bar)
  24 end function
  25
  26 ! Function that will be passed as dummy argument
  27 ! CHECK-LABEL: func @_QPfunc(
  28 ! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32
  29 real function func(x)
  30   real :: x
  31   func = x + 0.5
  32 end function
  33
  34 ! Test passing functions as dummy procedure arguments
  35 ! CHECK-LABEL: func @_QPtest_func
  36 real function test_func()
  37   real :: func, prefoo
  38   external :: func
  39   !CHECK: %[[f:.*]] = fir.address_of(@_QPfunc) : (!fir.ref<f32>) -> f32
  40   !CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
  41   !CHECK: fir.call @_QPprefoo(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> f32
  42   test_func = prefoo(func)
  43 end function
  44
  45 ! Repeat test with dummy subroutine
  46
  47 ! CHECK-LABEL: func @_QPfoo_sub(
  48 ! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
  49 subroutine foo_sub(bar_sub)
  50   ! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
  51   x = 42.
  52   ! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> ())
  53   ! CHECK: fir.call %[[funccast]](%[[x]]) {{.*}}: (!fir.ref<f32>)
  54   call bar_sub(x)
  55 end subroutine
  56
  57 ! Test case where dummy procedure is only transiting.
  58 ! CHECK-LABEL: func @_QPprefoo_sub(
  59 ! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
  60 subroutine prefoo_sub(bar_sub)
  61   external :: bar_sub
  62   ! CHECK: fir.call @_QPfoo_sub(%arg0) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
  63   call foo_sub(bar_sub)
  64 end subroutine
  65
  66 ! Subroutine that will be passed as dummy argument
  67 ! CHECK-LABEL: func @_QPsub(
  68 ! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}})
  69 subroutine sub(x)
  70   real :: x
  71   print *, x
  72 end subroutine
  73
  74 ! Test passing functions as dummy procedure arguments
  75 ! CHECK-LABEL: func @_QPtest_sub
  76 subroutine test_sub()
  77   external :: sub
  78   !CHECK: %[[f:.*]] = fir.address_of(@_QPsub) : (!fir.ref<f32>) -> ()
  79   !CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> ()) -> !fir.boxproc<() -> ()>
  80   !CHECK: fir.call @_QPprefoo_sub(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
  81   call prefoo_sub(sub)
  82 end subroutine
  83
  84 ! CHECK-LABEL: func @_QPpassing_not_defined_in_file()
  85 subroutine passing_not_defined_in_file()
  86   external proc_not_defined_in_file
  87   ! CHECK: %[[addr:.*]] = fir.address_of(@_QPproc_not_defined_in_file) : () -> ()
  88   ! CHECK: %[[ep:.*]] = fir.emboxproc %[[addr]]
  89   ! CHECK: fir.call @_QPprefoo_sub(%[[ep]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
  90   call prefoo_sub(proc_not_defined_in_file)
  91 end subroutine
  92
  93 ! Test passing unrestricted intrinsics
  94
  95 ! Intrinsic using runtime
  96 ! CHECK-LABEL: func @_QPtest_acos
  97 subroutine test_acos(x)
  98   intrinsic :: acos
  99   !CHECK: %[[f:.*]] = fir.address_of(@fir.acos.f32.ref_f32) : (!fir.ref<f32>) -> f32
 100   !CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
 101   !CHECK: fir.call @_QPfoo_acos(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 102   call foo_acos(acos)
 103 end subroutine
 104
 105 ! CHECK-LABEL: func @_QPtest_atan2
 106 subroutine test_atan2()
 107   intrinsic :: atan2
 108   ! CHECK: %[[f:.*]] = fir.address_of(@fir.atan2.f32.ref_f32.ref_f32) : (!fir.ref<f32>, !fir.ref<f32>) -> f32
 109   ! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>, !fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
 110   ! CHECK: fir.call @_QPfoo_atan2(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 111   call foo_atan2(atan2)
 112 end subroutine
 113
 114 ! Intrinsic implemented inlined
 115 ! CHECK-LABEL: func @_QPtest_aimag
 116 subroutine test_aimag()
 117   intrinsic :: aimag
 118   !CHECK: %[[f:.*]] = fir.address_of(@fir.aimag.f32.ref_z4) : (!fir.ref<!fir.complex<4>>) -> f32
 119   !CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<!fir.complex<4>>) -> f32) -> !fir.boxproc<() -> ()>
 120   !CHECK: fir.call @_QPfoo_aimag(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 121   call foo_aimag(aimag)
 122 end subroutine
 123
 124 ! Character Intrinsic implemented inlined
 125 ! CHECK-LABEL: func @_QPtest_len
 126 subroutine test_len()
 127   intrinsic :: len
 128   ! CHECK: %[[f:.*]] = fir.address_of(@fir.len.i32.bc1) : (!fir.boxchar<1>) -> i32
 129   ! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.boxchar<1>) -> i32) -> !fir.boxproc<() -> ()>
 130   !CHECK: fir.call @_QPfoo_len(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 131   call foo_len(len)
 132 end subroutine
 133
 134 ! Intrinsic implemented inlined with specific name different from generic
 135 ! CHECK-LABEL: func @_QPtest_iabs
 136 subroutine test_iabs()
 137   intrinsic :: iabs
 138   ! CHECK: %[[f:.*]] = fir.address_of(@fir.abs.i32.ref_i32) : (!fir.ref<i32>) -> i32
 139   ! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<i32>) -> i32) -> !fir.boxproc<() -> ()>
 140   ! CHECK: fir.call @_QPfoo_iabs(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 141   call foo_iabs(iabs)
 142 end subroutine
 143
 144 ! TODO: exhaustive test of unrestricted intrinsic table 16.2
 145
 146 ! TODO: improve dummy procedure types when interface is given.
 147 ! CHECK: func @_QPtodo3(
 148 ! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
 149 ! SHOULD-CHECK: func @_QPtodo3(%arg0: (!fir.ref<f32>) -> f32)
 150 subroutine todo3(dummy_proc)
 151   intrinsic :: acos
 152   procedure(acos) :: dummy_proc
 153 end subroutine
 154
 155 ! CHECK-LABEL: func private @fir.acos.f32.ref_f32(%arg0: !fir.ref<f32>) -> f32
 156   !CHECK: %[[load:.*]] = fir.load %arg0
 157   !CHECK: %[[res:.*]] = fir.call @acosf(%[[load]]) fastmath<contract> : (f32) -> f32
 158   !CHECK: return %[[res]] : f32
 159
 160 ! CHECK-LABEL: func private @fir.atan2.f32.ref_f32.ref_f32(
 161 ! CHECK-SAME: %[[x:.*]]: !fir.ref<f32>, %[[y:.*]]: !fir.ref<f32>) -> f32
 162   ! CHECK-DAG: %[[xload:.*]] = fir.load %[[x]] : !fir.ref<f32>
 163   ! CHECK-DAG: %[[yload:.*]] = fir.load %[[y]] : !fir.ref<f32>
 164   ! CHECK: %[[atan2:.*]] = math.atan2 %[[xload]], %[[yload]] fastmath<contract> : f32
 165   ! CHECK: return %[[atan2]] : f32
 166
 167 !CHECK-LABEL: func private @fir.aimag.f32.ref_z4(%arg0: !fir.ref<!fir.complex<4>>)
 168   !CHECK: %[[load:.*]] = fir.load %arg0
 169   !CHECK: %[[imag:.*]] = fir.extract_value %[[load]], [1 : index] : (!fir.complex<4>) -> f32
 170   !CHECK: return %[[imag]] : f32
 171
 172 !CHECK-LABEL: func private @fir.len.i32.bc1(%arg0: !fir.boxchar<1>)
 173   !CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 174   !CHECK: %[[len:.*]] = fir.convert %[[unboxed]]#1 : (index) -> i32
 175   !CHECK: return %[[len]] : i32