diff --git a/flang/test/Lower/explicit-interface-results-2.f90 b/flang/test/Lower/explicit-interface-results-2.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/explicit-interface-results-2.f90 @@ -0,0 +1,244 @@ +! Test lowering of internal procedures returning arrays or characters. +! This test allocation on the caller side of the results that may depend on +! host associated symbols. +! RUN: bbc %s -o - | FileCheck %s + +module some_module + integer :: n_module +end module + +! Test host calling array internal procedure. +! Result depends on host variable. +! CHECK-LABEL: func @_QPhost1 +subroutine host1() + implicit none + integer :: n +! CHECK: %[[VAL_1:.*]] = fir.alloca i32 + call takes_array(return_array()) +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.array, %[[VAL_5]] {bindc_name = ".result"} +contains + function return_array() + real :: return_array(n) + end function +end subroutine + +! Test host calling array internal procedure. +! Result depends on module variable with the use statement inside the host. +! CHECK-LABEL: func @_QPhost2 +subroutine host2() + use :: some_module + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QMsome_moduleEn_module) : !fir.ref +! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (i32) -> index +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.array, %[[VAL_2]] {bindc_name = ".result"} +contains + function return_array() + real :: return_array(n_module) + end function +end subroutine + +! Test host calling array internal procedure. +! Result depends on module variable with the use statement inside the internal procedure. +! CHECK-LABEL: func @_QPhost3 +subroutine host3() + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QMsome_moduleEn_module) : !fir.ref +! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (i32) -> index +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.array, %[[VAL_2]] {bindc_name = ".result"} +contains + function return_array() + use :: some_module + real :: return_array(n_module) + end function +end subroutine + +! Test internal procedure A calling array internal procedure B. +! Result depends on host variable not directly used in A. +subroutine host4() + implicit none + integer :: n + call internal_proc_a() +contains +! CHECK-LABEL: func @_QFhost4Pinternal_proc_a +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>> {fir.host_assoc}) { + subroutine internal_proc_a() + call takes_array(return_array()) +! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref>>, i32) -> !fir.llvm_ptr> +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.llvm_ptr> +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.array, %[[VAL_5]] {bindc_name = ".result"} + end subroutine + function return_array() + real :: return_array(n) + end function +end subroutine + +! Test internal procedure A calling array internal procedure B. +! Result depends on module variable with use statement in the host. +subroutine host5() + use :: some_module + implicit none + call internal_proc_a() +contains +! CHECK-LABEL: func @_QFhost5Pinternal_proc_a() { + subroutine internal_proc_a() + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QMsome_moduleEn_module) : !fir.ref +! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (i32) -> index +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.array, %[[VAL_2]] {bindc_name = ".result"} + end subroutine + function return_array() + real :: return_array(n_module) + end function +end subroutine + +! Test internal procedure A calling array internal procedure B. +! Result depends on module variable with use statement in B. +subroutine host6() + implicit none + call internal_proc_a() +contains +! CHECK-LABEL: func @_QFhost6Pinternal_proc_a + subroutine internal_proc_a() + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QMsome_moduleEn_module) : !fir.ref +! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (i32) -> index +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.array, %[[VAL_2]] {bindc_name = ".result"} + end subroutine + function return_array() + use :: some_module + real :: return_array(n_module) + end function +end subroutine + +! Test host calling array internal procedure. +! Result depends on a common block variable declared in the host. +! CHECK-LABEL: func @_QPhost7 +subroutine host7() + implicit none + integer :: n_common + common /mycom/ n_common + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref) -> !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> index +! CHECK: %[[VAL_10:.*]] = fir.alloca !fir.array, %[[VAL_9]] {bindc_name = ".result"} +contains + function return_array() + real :: return_array(n_common) + end function +end subroutine + +! Test host calling array internal procedure. +! Result depends on a common block variable declared in the internal procedure. +! CHECK-LABEL: func @_QPhost8 +subroutine host8() + implicit none + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.array, %[[VAL_6]] {bindc_name = ".result"} +contains + function return_array() + integer :: n_common + common /mycom/ n_common + real :: return_array(n_common) + end function +end subroutine + +! Test internal procedure A calling array internal procedure B. +! Result depends on a common block variable declared in the host. +! Note that the current implementation captures the common block variable +! address, even though it could recompute it in the internal procedure. +subroutine host9() + implicit none + integer :: n_common + common /mycom/ n_common + call internal_proc_a() +contains +! CHECK-LABEL: func @_QFhost9Pinternal_proc_a +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>> {fir.host_assoc}) { + subroutine internal_proc_a() +! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref>>, i32) -> !fir.llvm_ptr> +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.llvm_ptr> +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.array, %[[VAL_5]] {bindc_name = ".result"} + call takes_array(return_array()) + end subroutine + function return_array() + use :: some_module + real :: return_array(n_common) + end function +end subroutine + +! Test internal procedure A calling array internal procedure B. +! Result depends on a common block variable declared in B. +subroutine host10() + implicit none + call internal_proc_a() +contains +! CHECK-LABEL: func @_QFhost10Pinternal_proc_a + subroutine internal_proc_a() + call takes_array(return_array()) +! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.array, %[[VAL_6]] {bindc_name = ".result"} + end subroutine + function return_array() + integer :: n_common + common /mycom/ n_common + real :: return_array(n_common) + end function +end subroutine + + +! Test call to a function returning an array where the interface is use +! associated from a module. +module define_interface +contains +function foo() + real :: foo(100) + foo = 42 +end function +end module +! CHECK-LABEL: func @_QPtest_call_to_used_interface( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) { +subroutine test_call_to_used_interface(dummy_proc) + use define_interface + procedure(foo) :: dummy_proc + call takes_array(dummy_proc()) +! CHECK: %[[VAL_1:.*]] = arith.constant 100 : index +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<100xf32> {bindc_name = ".result"} +! CHECK: %[[VAL_3:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref +! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> (() -> !fir.array<100xf32>) +! CHECK: %[[VAL_6:.*]] = fir.call %[[VAL_5]]() : () -> !fir.array<100xf32> +! CHECK: fir.save_result %[[VAL_6]] to %[[VAL_2]](%[[VAL_4]]) : !fir.array<100xf32>, !fir.ref>, !fir.shape<1> +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>) -> !fir.ref> +! CHECK: fir.call @_QPtakes_array(%[[VAL_7]]) : (!fir.ref>) -> () +! CHECK: fir.call @llvm.stackrestore(%[[VAL_3]]) : (!fir.ref) -> () +end subroutine diff --git a/flang/test/Lower/explicit-interface-results.f90 b/flang/test/Lower/explicit-interface-results.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/explicit-interface-results.f90 @@ -0,0 +1,408 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +module callee +implicit none +contains +! CHECK-LABEL: func @_QMcalleePreturn_cst_array() -> !fir.array<20x30xf32> +function return_cst_array() + real :: return_cst_array(20, 30) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_dyn_array( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}, %{{.*}}: !fir.ref{{.*}}) -> !fir.array +function return_dyn_array(m, n) + integer :: m, n + real :: return_dyn_array(m, n) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_cst_char_cst_array() -> !fir.array<20x30x!fir.char<1,10>> +function return_cst_char_cst_array() + character(10) :: return_cst_char_cst_array(20, 30) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_dyn_char_cst_array( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}) -> !fir.array<20x30x!fir.char<1,?>> +function return_dyn_char_cst_array(l) + integer :: l + character(l) :: return_dyn_char_cst_array(20, 30) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_cst_char_dyn_array( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}, %{{.*}}: !fir.ref{{.*}}) -> !fir.array> +function return_cst_char_dyn_array(m, n) + integer :: m, n + character(10) :: return_cst_char_dyn_array(m, n) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_dyn_char_dyn_array( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}, %{{.*}}: !fir.ref{{.*}}, %{{.*}}: !fir.ref{{.*}}) -> !fir.array> +function return_dyn_char_dyn_array(l, m, n) + integer :: l, m, n + character(l) :: return_dyn_char_dyn_array(m, n) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_alloc() -> !fir.box>> +function return_alloc() + real, allocatable :: return_alloc(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_cst_char_alloc() -> !fir.box>>> +function return_cst_char_alloc() + character(10), allocatable :: return_cst_char_alloc(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_dyn_char_alloc( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}) -> !fir.box>>> +function return_dyn_char_alloc(l) + integer :: l + character(l), allocatable :: return_dyn_char_alloc(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_def_char_alloc() -> !fir.box>>> +function return_def_char_alloc() + character(:), allocatable :: return_def_char_alloc(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_pointer() -> !fir.box>> +function return_pointer() + real, pointer :: return_pointer(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_cst_char_pointer() -> !fir.box>>> +function return_cst_char_pointer() + character(10), pointer :: return_cst_char_pointer(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_dyn_char_pointer( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}) -> !fir.box>>> +function return_dyn_char_pointer(l) + integer :: l + character(l), pointer :: return_dyn_char_pointer(:) +end function + +! CHECK-LABEL: func @_QMcalleePreturn_def_char_pointer() -> !fir.box>>> +function return_def_char_pointer() + character(:), pointer :: return_def_char_pointer(:) +end function +end module + +module caller + use callee +contains + +! CHECK-LABEL: func @_QMcallerPcst_array() +subroutine cst_array() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.array<20x30xf32> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[shape:.*]] = fir.shape %{{.*}}, {{.*}} : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_cst_array() : () -> !fir.array<20x30xf32> + ! CHECK: fir.save_result %[[res]] to %[[alloc]](%[[shape]]) : !fir.array<20x30xf32>, !fir.ref>, !fir.shape<2> + print *, return_cst_array() +end subroutine + +! CHECK-LABEL: func @_QMcallerPcst_char_cst_array() +subroutine cst_char_cst_array() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.array<20x30x!fir.char<1,10>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[shape:.*]] = fir.shape %{{.*}}, {{.*}} : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_cst_char_cst_array() : () -> !fir.array<20x30x!fir.char<1,10>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]](%[[shape]]) typeparams %{{.*}} : !fir.array<20x30x!fir.char<1,10>>, !fir.ref>>, !fir.shape<2>, index + print *, return_cst_char_cst_array() +end subroutine + +! CHECK-LABEL: func @_QMcallerPalloc() +subroutine alloc() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_alloc() : () -> !fir.box>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>, !fir.ref>>> + print *, return_alloc() + ! CHECK: _FortranAioOutputDescriptor + ! CHECK: %[[load:.*]] = fir.load %[[alloc]] : !fir.ref>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[cmpi:.*]] = arith.cmpi + ! CHECK: fir.if %[[cmpi]] + ! CHECK: fir.freemem %[[addr]] +end subroutine + +! CHECK-LABEL: func @_QMcallerPcst_char_alloc() +subroutine cst_char_alloc() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_cst_char_alloc() : () -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_cst_char_alloc() + ! CHECK: _FortranAioOutputDescriptor + ! CHECK: %[[load:.*]] = fir.load %[[alloc]] : !fir.ref>>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box>>>) -> !fir.heap>> + ! CHECK: %[[cmpi:.*]] = arith.cmpi + ! CHECK: fir.if %[[cmpi]] + ! CHECK: fir.freemem %[[addr]] +end subroutine + +! CHECK-LABEL: func @_QMcallerPdef_char_alloc() +subroutine def_char_alloc() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_def_char_alloc() : () -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_def_char_alloc() + ! CHECK: _FortranAioOutputDescriptor + ! CHECK: %[[load:.*]] = fir.load %[[alloc]] : !fir.ref>>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box>>>) -> !fir.heap>> + ! CHECK: %[[cmpi:.*]] = arith.cmpi + ! CHECK: fir.if %[[cmpi]] + ! CHECK: fir.freemem %[[addr]] +end subroutine + +! CHECK-LABEL: func @_QMcallerPpointer_test() +subroutine pointer_test() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_pointer() : () -> !fir.box>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>, !fir.ref>>> + print *, return_pointer() + ! CHECK-NOT: fir.freemem +end subroutine + +! CHECK-LABEL: func @_QMcallerPcst_char_pointer() +subroutine cst_char_pointer() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_cst_char_pointer() : () -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_cst_char_pointer() + ! CHECK-NOT: fir.freemem +end subroutine + +! CHECK-LABEL: func @_QMcallerPdef_char_pointer() +subroutine def_char_pointer() + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_def_char_pointer() : () -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_def_char_pointer() + ! CHECK-NOT: fir.freemem +end subroutine + +! CHECK-LABEL: func @_QMcallerPdyn_array( +! CHECK-SAME: %[[m:.*]]: !fir.ref{{.*}}, %[[n:.*]]: !fir.ref{{.*}}) { +subroutine dyn_array(m, n) + integer :: m, n + ! CHECK-DAG: %[[mload:.*]] = fir.load %[[m]] : !fir.ref + ! CHECK-DAG: %[[mcast:.*]] = fir.convert %[[mload]] : (i32) -> i64 + ! CHECK-DAG: %[[msub:.*]] = arith.subi %[[mcast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[madd:.*]] = arith.addi %[[msub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[mcast2:.*]] = fir.convert %[[madd]] : (i64) -> index + ! CHECK-DAG: %[[nload:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK-DAG: %[[ncast:.*]] = fir.convert %[[nload]] : (i32) -> i64 + ! CHECK-DAG: %[[nsub:.*]] = arith.subi %[[ncast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[nadd:.*]] = arith.addi %[[nsub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[nadd]] : (i64) -> index + ! CHECK: %[[tmp:.*]] = fir.alloca !fir.array, %[[mcast2]], %[[ncast2]] + ! CHECK: %[[shape:.*]] = fir.shape %[[mcast2]], %[[ncast2]] : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_dyn_array(%[[m]], %[[n]]) : (!fir.ref, !fir.ref) -> !fir.array + ! CHECK: fir.save_result %[[res]] to %[[tmp]](%[[shape]]) : !fir.array, !fir.ref>, !fir.shape<2> + print *, return_dyn_array(m, n) +end subroutine + +! CHECK-LABEL: func @_QMcallerPdyn_char_cst_array( +! CHECK-SAME: %[[l:.*]]: !fir.ref{{.*}}) { +subroutine dyn_char_cst_array(l) + integer :: l + ! CHECK: %[[lload:.*]] = fir.load %[[l]] : !fir.ref + ! CHECK: %[[lcast:.*]] = fir.convert %[[lload]] : (i32) -> i64 + ! CHECK: %[[lcast2:.*]] = fir.convert %[[lcast]] : (i64) -> index + ! CHECK: %[[tmp:.*]] = fir.alloca !fir.array<20x30x!fir.char<1,?>>(%[[lcast2]] : index) + ! CHECK: %[[shape:.*]] = fir.shape %{{.*}}, %{{.*}} : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_dyn_char_cst_array(%[[l]]) : (!fir.ref) -> !fir.array<20x30x!fir.char<1,?>> + ! CHECK: fir.save_result %[[res]] to %[[tmp]](%[[shape]]) typeparams %[[lcast2]] : !fir.array<20x30x!fir.char<1,?>>, !fir.ref>>, !fir.shape<2>, index + print *, return_dyn_char_cst_array(l) +end subroutine + +! CHECK-LABEL: func @_QMcallerPcst_char_dyn_array( +! CHECK-SAME: %[[m:.*]]: !fir.ref{{.*}}, %[[n:.*]]: !fir.ref{{.*}}) { +subroutine cst_char_dyn_array(m, n) + integer :: m, n + ! CHECK-DAG: %[[mload:.*]] = fir.load %[[m]] : !fir.ref + ! CHECK-DAG: %[[mcast:.*]] = fir.convert %[[mload]] : (i32) -> i64 + ! CHECK-DAG: %[[msub:.*]] = arith.subi %[[mcast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[madd:.*]] = arith.addi %[[msub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[mcast2:.*]] = fir.convert %[[madd]] : (i64) -> index + ! CHECK-DAG: %[[nload:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK-DAG: %[[ncast:.*]] = fir.convert %[[nload]] : (i32) -> i64 + ! CHECK-DAG: %[[nsub:.*]] = arith.subi %[[ncast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[nadd:.*]] = arith.addi %[[nsub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[nadd]] : (i64) -> index + ! CHECK: %[[tmp:.*]] = fir.alloca !fir.array>, %[[mcast2]], %[[ncast2]] + ! CHECK: %[[shape:.*]] = fir.shape %[[mcast2]], %[[ncast2]] : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_cst_char_dyn_array(%[[m]], %[[n]]) : (!fir.ref, !fir.ref) -> !fir.array> + ! CHECK: fir.save_result %[[res]] to %[[tmp]](%[[shape]]) typeparams {{.*}} : !fir.array>, !fir.ref>>, !fir.shape<2>, index + print *, return_cst_char_dyn_array(m, n) +end subroutine + +! CHECK-LABEL: func @_QMcallerPdyn_char_dyn_array( +! CHECK-SAME: %[[l:.*]]: !fir.ref{{.*}}, %[[m:.*]]: !fir.ref{{.*}}, %[[n:.*]]: !fir.ref{{.*}}) { +subroutine dyn_char_dyn_array(l, m, n) + ! CHECK-DAG: %[[mload:.*]] = fir.load %[[m]] : !fir.ref + ! CHECK-DAG: %[[mcast:.*]] = fir.convert %[[mload]] : (i32) -> i64 + ! CHECK-DAG: %[[msub:.*]] = arith.subi %[[mcast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[madd:.*]] = arith.addi %[[msub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[mcast2:.*]] = fir.convert %[[madd]] : (i64) -> index + + ! CHECK-DAG: %[[nload:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK-DAG: %[[ncast:.*]] = fir.convert %[[nload]] : (i32) -> i64 + ! CHECK-DAG: %[[nsub:.*]] = arith.subi %[[ncast]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[nadd:.*]] = arith.addi %[[nsub]], %c1{{.*}} : i64 + ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[nadd]] : (i64) -> index + + ! CHECK-DAG: %[[lload:.*]] = fir.load %[[l]] : !fir.ref + ! CHECK-DAG: %[[lcast:.*]] = fir.convert %[[lload]] : (i32) -> i64 + ! CHECK-DAG: %[[lcast2:.*]] = fir.convert %[[lcast]] : (i64) -> index + ! CHECK: %[[tmp:.*]] = fir.alloca !fir.array>(%[[lcast2]] : index), %[[mcast2]], %[[ncast2]] + ! CHECK: %[[shape:.*]] = fir.shape %[[mcast2]], %[[ncast2]] : (index, index) -> !fir.shape<2> + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_dyn_char_dyn_array(%[[l]], %[[m]], %[[n]]) : (!fir.ref, !fir.ref, !fir.ref) -> !fir.array> + ! CHECK: fir.save_result %[[res]] to %[[tmp]](%[[shape]]) typeparams {{.*}} : !fir.array>, !fir.ref>>, !fir.shape<2>, index + integer :: l, m, n + print *, return_dyn_char_dyn_array(l, m, n) +end subroutine + +! CHECK-LABEL: @_QMcallerPdyn_char_alloc +subroutine dyn_char_alloc(l) + integer :: l + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_dyn_char_alloc({{.*}}) : (!fir.ref) -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_dyn_char_alloc(l) + ! CHECK: _FortranAioOutputDescriptor + ! CHECK: %[[load:.*]] = fir.load %[[alloc]] : !fir.ref>>>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box>>>) -> !fir.heap>> + ! CHECK: %[[cmpi:.*]] = arith.cmpi + ! CHECK: fir.if %[[cmpi]] + ! CHECK: fir.freemem %[[addr]] +end subroutine + +! CHECK-LABEL: @_QMcallerPdyn_char_pointer +subroutine dyn_char_pointer(l) + integer :: l + ! CHECK: %[[alloc:.*]] = fir.alloca !fir.box>>> {{{.*}}bindc_name = ".result"} + ! CHECK: %[[res:.*]] = fir.call @_QMcalleePreturn_dyn_char_pointer({{.*}}) : (!fir.ref) -> !fir.box>>> + ! CHECK: fir.save_result %[[res]] to %[[alloc]] : !fir.box>>>, !fir.ref>>>> + print *, return_dyn_char_pointer(l) + ! CHECK-NOT: fir.freemem +end subroutine + +end module + + +! Test more complex symbol dependencies in the result specification expression + +module m_with_equiv + integer(8) :: l + integer(8) :: array(3) + equivalence (array(2), l) +contains + function result_depends_on_equiv_sym() + character(l) :: result_depends_on_equiv_sym + call set_result_with_some_value(result_depends_on_equiv_sym) + end function +end module + +! CHECK-LABEL: func @_QPtest_result_depends_on_equiv_sym +subroutine test_result_depends_on_equiv_sym() + use m_with_equiv, only : result_depends_on_equiv_sym + ! CHECK: %[[equiv:.*]] = fir.address_of(@_QMm_with_equivEarray) : !fir.ref> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[equiv]], %c{{.*}} : (!fir.ref>, index) -> !fir.ref + ! CHECK: %[[l:.*]] = fir.convert %[[coor]] : (!fir.ref) -> !fir.ptr + ! CHECK: %[[load:.*]] = fir.load %[[l]] : !fir.ptr + ! CHECK: %[[lcast:.*]] = fir.convert %[[load]] : (i64) -> index + ! CHECK: fir.alloca !fir.char<1,?>(%[[lcast]] : index) + print *, result_depends_on_equiv_sym() +end subroutine + +! CHECK-LABEL: func @_QPtest_depends_on_descriptor( +! CHECK-SAME: %[[x:.*]]: !fir.box>{{.*}}) { +subroutine test_depends_on_descriptor(x) + interface + function depends_on_descriptor(x) + real :: x(:) + character(size(x,1, KIND=8)) :: depends_on_descriptor + end function + end interface + real :: x(:) + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %arg0, %c0 : (!fir.box>, index) -> (index, index, index) + ! CHECK: %[[extentCast:.*]] = fir.convert %[[dims]]#1 : (index) -> i64 + ! CHECK: %[[extent:.*]] = fir.convert %[[extentCast]] : (i64) -> index + ! CHECK: fir.alloca !fir.char<1,?>(%[[extent]] : index) + print *, depends_on_descriptor(x) +end subroutine + +! CHECK-LABEL: func @_QPtest_symbol_indirection( +! CHECK-SAME: %[[n:.*]]: !fir.ref{{.*}}) { +subroutine test_symbol_indirection(n) + interface + function symbol_indirection(c, n) + integer(8) :: n + character(n) :: c + character(len(c, KIND=8)) :: symbol_indirection + end function + end interface + integer(8) :: n + character(n) :: c + ! CHECK: BeginExternalListOutput + ! CHECK: %[[nload:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK: %[[n_is_positive:.*]] = arith.cmpi sgt, %[[nload]], %c0{{.*}} : i64 + ! CHECK: %[[len:.*]] = arith.select %[[n_is_positive]], %[[nload]], %c0{{.*}} : i64 + ! CHECK: %[[len_cast:.*]] = fir.convert %[[len]] : (i64) -> index + ! CHECK: fir.alloca !fir.char<1,?>(%[[len_cast]] : index) + print *, symbol_indirection(c, n) +end subroutine + +! CHECK-LABEL: func @_QPtest_recursion( +! CHECK-SAME: %[[res:.*]]: !fir.ref>{{.*}}, %[[resLen:.*]]: index{{.*}}, %[[n:.*]]: !fir.ref{{.*}}) -> !fir.boxchar<1> { +function test_recursion(n) result(res) + integer(8) :: n + character(n) :: res + ! some_local is here to verify that local symbols that are visible in the + ! function interface are not instantiated by accident (that only the + ! symbols needed for the result are instantiated before the call). + ! CHECK: fir.alloca !fir.array, {{.*}}some_local + ! CHECK-NOT: fir.alloca !fir.array + integer :: some_local(n) + some_local(0) = n + 64 + if (n.eq.1) then + res = char(some_local(0)) + ! CHECK: else + else + ! CHECK-NOT: fir.alloca !fir.array + + ! verify that the actual argument for symbol n ("n-1") is used to allocate + ! the result, and not the local value of symbol n. + + ! CHECK: %[[nLoad:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK: %[[sub:.*]] = arith.subi %[[nLoad]], %c1{{.*}} : i64 + ! CHECK: fir.store %[[sub]] to %[[nInCall:.*]] : !fir.ref + + ! CHECK-NOT: fir.alloca !fir.array + + ! CHECK: %[[nInCallLoad:.*]] = fir.load %[[nInCall]] : !fir.ref + ! CHECK: %[[nInCallCast:.*]] = fir.convert %[[nInCallLoad]] : (i64) -> index + ! CHECK: %[[tmp:.*]] = fir.alloca !fir.char<1,?>(%[[nInCallCast]] : index) + + ! CHECK-NOT: fir.alloca !fir.array + ! CHECK: fir.call @_QPtest_recursion(%[[tmp]], {{.*}} + res = char(some_local(0)) // test_recursion(n-1) + + ! Verify that symbol n was not remapped to the actual argument passed + ! to n in the call (that the temporary mapping was cleaned-up). + + ! CHECK: %[[nLoad2:.*]] = fir.load %[[n]] : !fir.ref + ! CHECK: OutputInteger64(%{{.*}}, %[[nLoad2]]) + print *, n + end if +end function + +! Test call to character function for which only the result type is explicit +! CHECK-LABEL:func @_QPtest_not_entirely_explicit_interface( +! CHECK-SAME: %[[n_arg:.*]]: !fir.ref{{.*}}) { +subroutine test_not_entirely_explicit_interface(n) + integer(8) :: n + character(n) :: return_dyn_char_2 + print *, return_dyn_char_2(10) + ! CHECK: %[[n:.*]] = fir.load %[[n_arg]] : !fir.ref + ! CHECK: %[[len:.*]] = fir.convert %[[n]] : (i64) -> index + ! CHECK: %[[result:.*]] = fir.alloca !fir.char<1,?>(%[[len]] : index) {bindc_name = ".result"} + ! CHECK: fir.call @_QPreturn_dyn_char_2(%[[result]], %[[len]], %{{.*}}) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> +end subroutine diff --git a/flang/test/Lower/implicit-interface.f90 b/flang/test/Lower/implicit-interface.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/implicit-interface.f90 @@ -0,0 +1,29 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: func @_QPchar_return_callee( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}, %{{.*}}: index{{.*}}, %{{.*}}: !fir.ref{{.*}}) -> !fir.boxchar<1> { +function char_return_callee(i) + character(10) :: char_return_callee + integer :: i +end function + +! CHECK-LABEL: @_QPtest_char_return_caller() +subroutine test_char_return_caller + character(10) :: char_return_caller + ! CHECK: fir.call @_QPchar_return_caller({{.*}}) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> + print *, char_return_caller(5) +end subroutine + +! CHECK-LABEL: func @_QPtest_passing_char_array() +subroutine test_passing_char_array + character(len=3) :: x(4) + call sub_taking_a_char_array(x) + ! CHECK-DAG: %[[xarray:.*]] = fir.alloca !fir.array<4x!fir.char<1,3>> + ! CHECK-DAG: %[[c3:.*]] = arith.constant 3 : index + ! CHECK-DAG: %[[xbuff:.*]] = fir.convert %[[xarray]] : (!fir.ref>>) -> !fir.ref> + ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[xbuff]], %[[c3]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPsub_taking_a_char_array(%[[boxchar]]) : (!fir.boxchar<1>) -> () +end subroutine + +! TODO more implicit interface cases with/without explicit interface +