1! Test captured variables instantiation inside internal procedures 2! when lowering to HLFIR. 3! RUN: bbc -emit-hlfir -o - %s | FileCheck %s 4subroutine test_explicit_shape_array(x, n) 5 integer(8) :: n 6 real :: x(n) 7contains 8subroutine internal 9 call takes_array(x) 10end subroutine 11end subroutine 12! CHECK-LABEL: func.func @_QPtest_explicit_shape_array( 13! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}} {fortran_attrs = #fir.var_attrs<internal_assoc>, uniq_name = "_QFtest_explicit_shape_arrayEx"} 14 15! CHECK-LABEL: func.func private @_QFtest_explicit_shape_arrayPinternal( 16! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) attributes {fir.host_symbol = {{.*}}, llvm.linkage = #llvm.linkage<internal>} { 17! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 18! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>> 19! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.array<?xf32>>> 20! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>> 21! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index 22! CHECK: %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_5]] : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index) 23! CHECK: %[[VAL_7:.*]] = fir.shape %[[VAL_6]]#1 : (index) -> !fir.shape<1> 24! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_4]](%[[VAL_7]]) {fortran_attrs = #fir.var_attrs<host_assoc>, uniq_name = "_QFtest_explicit_shape_arrayEx"} : (!fir.ref<!fir.array<?xf32>>, !fir.shape<1>) -> (!fir.box<!fir.array<?xf32>>, !fir.ref<!fir.array<?xf32>>) 25 26subroutine test_assumed_shape(x) 27 real :: x(:) 28contains 29subroutine internal 30 call takes_array(x) 31end subroutine 32end subroutine 33! CHECK-LABEL: func.func @_QPtest_assumed_shape( 34! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}} {fortran_attrs = #fir.var_attrs<internal_assoc>, uniq_name = "_QFtest_assumed_shapeEx"} 35 36! CHECK-LABEL: func.func private @_QFtest_assumed_shapePinternal( 37! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) attributes {fir.host_symbol = {{.*}}, llvm.linkage = #llvm.linkage<internal>} { 38! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 39! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>> 40! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.array<?xf32>>> 41! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index 42! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index) 43! CHECK: %[[VAL_6:.*]] = fir.shift %[[VAL_5]]#0 : (index) -> !fir.shift<1> 44! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_6]]) {fortran_attrs = #fir.var_attrs<host_assoc>, uniq_name = "_QFtest_assumed_shapeEx"} : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> (!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>) 45 46subroutine test_scalar_char(c) 47 character(*) :: c 48contains 49subroutine internal() 50 call bar(c) 51end subroutine 52end subroutine 53! CHECK-LABEL: func.func private @_QFtest_scalar_charPinternal( 54! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) attributes {fir.host_symbol = {{.*}}, llvm.linkage = #llvm.linkage<internal>} { 55! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 56! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>> 57! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.boxchar<1>> 58! CHECK: %[[VAL_4:.*]]:2 = fir.unboxchar %[[VAL_3]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index) 59! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]]#0 typeparams %[[VAL_4]]#1 {fortran_attrs = #fir.var_attrs<host_assoc>, uniq_name = "_QFtest_scalar_charEc"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>) 60! CHECK: fir.call @_QPbar(%[[VAL_5]]#0) {{.*}}: (!fir.boxchar<1>) -> () 61 62subroutine test_proc_pointer(p) 63 real, pointer, external :: p 64 call internal() 65contains 66 subroutine internal() 67 real :: x 68 x = p() 69 end subroutine 70end subroutine 71! CHECK-LABEL: func.func @_QPtest_proc_pointer( 72! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>) { 73! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {fortran_attrs = #fir.var_attrs<pointer, internal_assoc>, uniq_name = "_QFtest_proc_pointerEp"} : (!fir.ref<!fir.boxproc<() -> ()>>, !fir.dscope) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>) 74! CHECK: %[[VAL_2:.*]] = fir.alloca tuple<!fir.ref<!fir.boxproc<() -> ()>>> 75! CHECK: %[[VAL_3:.*]] = arith.constant 0 : i32 76! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.ref<!fir.boxproc<() -> ()>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.boxproc<() -> ()>>> 77! CHECK: fir.store %[[VAL_1]]#1 to %[[VAL_4]] : !fir.llvm_ptr<!fir.ref<!fir.boxproc<() -> ()>>> 78! CHECK: fir.call @_QFtest_proc_pointerPinternal(%[[VAL_2]]) {{.*}}: (!fir.ref<tuple<!fir.ref<!fir.boxproc<() -> ()>>>>) -> () 79! CHECK: return 80! CHECK: } 81 82! CHECK-LABEL: func.func private @_QFtest_proc_pointerPinternal( 83! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.ref<!fir.boxproc<() -> ()>>>> {fir.host_assoc}) attributes {fir.host_symbol = @_QPtest_proc_pointer, llvm.linkage = #llvm.linkage<internal>} { 84! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 85! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.ref<!fir.boxproc<() -> ()>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.boxproc<() -> ()>>> 86! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.llvm_ptr<!fir.ref<!fir.boxproc<() -> ()>>> 87! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {fortran_attrs = #fir.var_attrs<pointer, host_assoc>, uniq_name = "_QFtest_proc_pointerEp"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>) 88 89 90! Verify that all equivalence members gets the internal_assoc flag set if one 91! of them is captured in an internal procedure. 92subroutine test_captured_equiv() 93 real :: x, y 94 equivalence(x,y) 95 call internal() 96contains 97subroutine internal() 98 y = 0. 99end subroutine 100end subroutine 101! CHECK-LABEL: func.func @_QPtest_captured_equiv() { 102! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<internal_assoc>, uniq_name = "_QFtest_captured_equivEx"} 103! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs<internal_assoc>, uniq_name = "_QFtest_captured_equivEy"} 104