1! RUN: bbc -emit-fir -hlfir=false %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 8real 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) 15end function 16 17! Test case where dummy procedure is only transiting. 18! CHECK-LABEL: func @_QPprefoo( 19! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32 20real function prefoo(bar) 21 external :: bar 22 ! CHECK: fir.call @_QPfoo(%arg0) {{.*}}: (!fir.boxproc<() -> ()>) -> f32 23 prefoo = foo(bar) 24end function 25 26! Function that will be passed as dummy argument 27! CHECK-LABEL: func @_QPfunc( 28! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32 29real function func(x) 30 real :: x 31 func = x + 0.5 32end function 33 34! Test passing functions as dummy procedure arguments 35! CHECK-LABEL: func @_QPtest_func 36real 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) 43end function 44 45! Repeat test with dummy subroutine 46 47! CHECK-LABEL: func @_QPfoo_sub( 48! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) 49subroutine 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) 55end subroutine 56 57! Test case where dummy procedure is only transiting. 58! CHECK-LABEL: func @_QPprefoo_sub( 59! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) 60subroutine prefoo_sub(bar_sub) 61 external :: bar_sub 62 ! CHECK: fir.call @_QPfoo_sub(%arg0) {{.*}}: (!fir.boxproc<() -> ()>) -> () 63 call foo_sub(bar_sub) 64end subroutine 65 66! Subroutine that will be passed as dummy argument 67! CHECK-LABEL: func @_QPsub( 68! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) 69subroutine sub(x) 70 real :: x 71 print *, x 72end subroutine 73 74! Test passing functions as dummy procedure arguments 75! CHECK-LABEL: func @_QPtest_sub 76subroutine 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) 82end subroutine 83 84! CHECK-LABEL: func @_QPpassing_not_defined_in_file() 85subroutine 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) 91end subroutine 92 93! Test passing unrestricted intrinsics 94 95! Intrinsic using runtime 96! CHECK-LABEL: func @_QPtest_acos 97subroutine 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) 103end subroutine 104 105! CHECK-LABEL: func @_QPtest_atan2 106subroutine 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) 112end subroutine 113 114! Intrinsic implemented inlined 115! CHECK-LABEL: func @_QPtest_aimag 116subroutine test_aimag() 117 intrinsic :: aimag 118 !CHECK: %[[f:.*]] = fir.address_of(@fir.aimag.f32.ref_z32) : (!fir.ref<complex<f32>>) -> f32 119 !CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<complex<f32>>) -> f32) -> !fir.boxproc<() -> ()> 120 !CHECK: fir.call @_QPfoo_aimag(%[[fcast]]) {{.*}}: (!fir.boxproc<() -> ()>) -> () 121 call foo_aimag(aimag) 122end subroutine 123 124! Character Intrinsic implemented inlined 125! CHECK-LABEL: func @_QPtest_len 126subroutine 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) 132end subroutine 133 134! Intrinsic implemented inlined with specific name different from generic 135! CHECK-LABEL: func @_QPtest_iabs 136subroutine 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) 142end 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) 150subroutine todo3(dummy_proc) 151 intrinsic :: acos 152 procedure(acos) :: dummy_proc 153end 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:.*]] = math.acos %[[load]] fastmath<contract> : 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_z32(%arg0: !fir.ref<complex<f32>>) 168 !CHECK: %[[load:.*]] = fir.load %arg0 169 !CHECK: %[[imag:.*]] = fir.extract_value %[[load]], [1 : index] : (complex<f32>) -> 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 176