calls-f77.f90 | Explore in Territory

! Test lowering of F77 calls to HLFIR
! RUN: bbc -emit-hlfir -o - %s 2>&1 | FileCheck %s

! -----------------------------------------------------------------------------
!     Test lowering of F77 procedure reference arguments
! -----------------------------------------------------------------------------

subroutine call_no_arg()
  call void()
end subroutine
! CHECK-LABEL: func.func @_QPcall_no_arg() {
! CHECK-NEXT:  fir.call @_QPvoid() fastmath<contract> : () -> ()
! CHECK-NEXT:  return

subroutine call_int_arg_var(n)
  integer :: n
  call take_i4(n)
end subroutine
! CHECK-LABEL: func.func @_QPcall_int_arg_var(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.ref<i32>
! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_int_arg_varEn"} : (!fir.ref<i32>, !fir.dscope) -> (!fir.ref<i32>, !fir.ref<i32>)
! CHECK:  fir.call @_QPtake_i4(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<i32>) -> ()

subroutine call_int_arg_expr()
  call take_i4(42)
end subroutine
! CHECK-LABEL: func.func @_QPcall_int_arg_expr() {
! CHECK:  %[[VAL_0:.*]] = arith.constant 42 : i32
! CHECK:  %[[VAL_1:.*]]:3 = hlfir.associate %[[VAL_0]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
! CHECK:  fir.call @_QPtake_i4(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<i32>) -> ()
! CHECK:  hlfir.end_associate %[[VAL_1]]#1, %[[VAL_1]]#2 : !fir.ref<i32>, i1

subroutine call_real_arg_expr()
  call take_r4(0.42)
end subroutine
! CHECK-LABEL: func.func @_QPcall_real_arg_expr() {
! CHECK:  %[[VAL_0:.*]] = arith.constant 4.200000e-01 : f32
! CHECK:  %[[VAL_1:.*]]:3 = hlfir.associate %[[VAL_0]] {adapt.valuebyref} : (f32) -> (!fir.ref<f32>, !fir.ref<f32>, i1)
! CHECK:  fir.call @_QPtake_r4(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<f32>) -> ()
! CHECK:  hlfir.end_associate %[[VAL_1]]#1, %[[VAL_1]]#2 : !fir.ref<f32>, i1

subroutine call_real_arg_var(x)
  real :: x
  call take_r4(x)
end subroutine
! CHECK-LABEL: func.func @_QPcall_real_arg_var(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.ref<f32>
! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_real_arg_varEx"} : (!fir.ref<f32>, !fir.dscope) -> (!fir.ref<f32>, !fir.ref<f32>)
! CHECK:  fir.call @_QPtake_r4(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<f32>) -> ()

subroutine call_logical_arg_var(x)
  logical :: x
  call take_l4(x)
end subroutine
! CHECK-LABEL: func.func @_QPcall_logical_arg_var(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.ref<!fir.logical<4>>
! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_logical_arg_varEx"} : (!fir.ref<!fir.logical<4>>, !fir.dscope) -> (!fir.ref<!fir.logical<4>>, !fir.ref<!fir.logical<4>>)
! CHECK:  fir.call @_QPtake_l4(%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<!fir.logical<4>>) -> ()

subroutine call_logical_arg_expr()
  call take_l4(.true.)
end subroutine
! CHECK-LABEL: func.func @_QPcall_logical_arg_expr() {
! CHECK:  %[[VAL_0:.*]] = arith.constant true
! CHECK:  %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (i1) -> !fir.logical<4>
! CHECK:  %[[VAL_2:.*]]:3 = hlfir.associate %[[VAL_1]] {adapt.valuebyref} : (!fir.logical<4>) -> (!fir.ref<!fir.logical<4>>, !fir.ref<!fir.logical<4>>, i1)
! CHECK:  fir.call @_QPtake_l4(%[[VAL_2]]#1) fastmath<contract> : (!fir.ref<!fir.logical<4>>) -> ()
! CHECK:  hlfir.end_associate %[[VAL_2]]#1, %[[VAL_2]]#2 : !fir.ref<!fir.logical<4>>, i1

subroutine call_logical_arg_expr_2()
  call take_l8(.true._8)
end subroutine
! CHECK-LABEL: func.func @_QPcall_logical_arg_expr_2() {
! CHECK:  %[[VAL_0:.*]] = arith.constant true
! CHECK:  %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (i1) -> !fir.logical<8>
! CHECK:  %[[VAL_2:.*]]:3 = hlfir.associate %[[VAL_1]] {adapt.valuebyref} : (!fir.logical<8>) -> (!fir.ref<!fir.logical<8>>, !fir.ref<!fir.logical<8>>, i1)
! CHECK:  fir.call @_QPtake_l8(%[[VAL_2]]#1) fastmath<contract> : (!fir.ref<!fir.logical<8>>) -> ()
! CHECK:  hlfir.end_associate %[[VAL_2]]#1, %[[VAL_2]]#2 : !fir.ref<!fir.logical<8>>, i1

subroutine call_char_arg_var(x)
  character(*) :: x
  call take_c(x)
end subroutine
! CHECK-LABEL: func.func @_QPcall_char_arg_var(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.boxchar<1>
! CHECK:  %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK:  %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_char_arg_varEx"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
! CHECK:  fir.call @_QPtake_c(%[[VAL_2]]#0) fastmath<contract> : (!fir.boxchar<1>) -> ()

subroutine call_char_arg_var_expr(x)
  character(*) :: x
  call take_c(x//x)
end subroutine
! CHECK-LABEL: func.func @_QPcall_char_arg_var_expr(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.boxchar<1>
! CHECK:  %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK:  %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_char_arg_var_exprEx"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
! CHECK:  %[[VAL_3:.*]] = arith.addi %[[VAL_1]]#1, %[[VAL_1]]#1 : index
! CHECK:  %[[VAL_4:.*]] = hlfir.concat %[[VAL_2]]#0, %[[VAL_2]]#0 len %[[VAL_3]] : (!fir.boxchar<1>, !fir.boxchar<1>, index) -> !hlfir.expr<!fir.char<1,?>>
! CHECK:  %[[VAL_5:.*]]:3 = hlfir.associate %[[VAL_4]] typeparams %[[VAL_3]] {adapt.valuebyref} : (!hlfir.expr<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>, i1)
! CHECK:  fir.call @_QPtake_c(%[[VAL_5]]#0) fastmath<contract> : (!fir.boxchar<1>) -> ()
! CHECK:  hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref<!fir.char<1,?>>, i1

subroutine call_arg_array_var(n)
  integer :: n(10, 20)
  call take_arr(n)
end subroutine
! CHECK-LABEL: func.func @_QPcall_arg_array_var(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.ref<!fir.array<10x20xi32>>
! CHECK:  %[[VAL_1:.*]] = arith.constant 10 : index
! CHECK:  %[[VAL_2:.*]] = arith.constant 20 : index
! CHECK:  %[[VAL_3:.*]] = fir.shape %[[VAL_1]], %[[VAL_2]] : (index, index) -> !fir.shape<2>
! CHECK:  %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_3]]) dummy_scope %{{[0-9]+}} {uniq_name = "_QFcall_arg_array_varEn"} : (!fir.ref<!fir.array<10x20xi32>>, !fir.shape<2>, !fir.dscope) -> (!fir.ref<!fir.array<10x20xi32>>, !fir.ref<!fir.array<10x20xi32>>)
! CHECK:  fir.call @_QPtake_arr(%[[VAL_4]]#1) fastmath<contract> : (!fir.ref<!fir.array<10x20xi32>>) -> ()

subroutine call_arg_array_2(n)
  integer, contiguous, optional :: n(:, :)
  call take_arr_2(n)
end subroutine
! CHECK-LABEL: func.func @_QPcall_arg_array_2(
! CHECK-SAME:    %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>>
! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {fortran_attrs = #fir.var_attrs<contiguous, optional>, uniq_name = "_QFcall_arg_array_2En"} : (!fir.box<!fir.array<?x?xi32>>, !fir.dscope) -> (!fir.box<!fir.array<?x?xi32>>, !fir.box<!fir.array<?x?xi32>>)
! CHECK:  %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.box<!fir.array<?x?xi32>>) -> !fir.ref<!fir.array<?x?xi32>>
! CHECK:  fir.call @_QPtake_arr_2(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.array<?x?xi32>>) -> ()

! -----------------------------------------------------------------------------
!     Test lowering of function results
! -----------------------------------------------------------------------------

subroutine return_integer()
  integer :: ifoo
  print *, ifoo()
end subroutine
! CHECK-LABEL: func.func @_QPreturn_integer(
! CHECK:  fir.call @_QPifoo() fastmath<contract> : () -> i32


subroutine return_logical()
  logical :: lfoo
  print *, lfoo()
end subroutine
! CHECK-LABEL: func.func @_QPreturn_logical(
! CHECK:  fir.call @_QPlfoo() fastmath<contract> : () -> !fir.logical<4>

subroutine return_complex()
  complex :: cplxfoo
  print *, cplxfoo()
end subroutine
! CHECK-LABEL: func.func @_QPreturn_complex(
! CHECK:  fir.call @_QPcplxfoo() fastmath<contract> : () -> complex<f32>

subroutine return_char(n)
  integer(8) :: n
  character(n) :: c2foo
  print *, c2foo()
end subroutine
! CHECK-LABEL: func.func @_QPreturn_char(
! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}n
! CHECK:  %[[VAL_2:.*]] = arith.constant 6 : i32
! CHECK:  %[[VAL_7:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<i64>
! CHECK:  %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
! CHECK:  %[[VAL_9:.*]] = arith.constant 0 : index
! CHECK:  %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index
! CHECK:  %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index
! CHECK:  %[[VAL_13:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_11]] : index) {bindc_name = ".result"}
! CHECK:  %[[VAL_14:.*]] = fir.call @_QPc2foo(%[[VAL_13]], %[[VAL_11]]) fastmath<contract> : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK:  %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_13]] typeparams %[[VAL_11]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)

! -----------------------------------------------------------------------------
!     Test calls with alternate returns
! -----------------------------------------------------------------------------

! CHECK-LABEL: func.func @_QPalternate_return_call(
subroutine alternate_return_call(n1, n2, k)
  integer :: n1, n2, k
  ! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}k
  ! CHECK:  %[[VAL_4:.*]]:2 = hlfir.declare {{.*}}n1
  ! CHECK:  %[[VAL_5:.*]]:2 = hlfir.declare {{.*}}n2
  ! CHECK:  %[[selector:.*]] = fir.call @_QPalternate_return(%[[VAL_4]]#1, %[[VAL_5]]#1) fastmath<contract> : (!fir.ref<i32>, !fir.ref<i32>) -> index
  ! CHECK-NEXT: fir.select %[[selector]] : index [1, ^[[block1:bb[0-9]+]], 2, ^[[block2:bb[0-9]+]], unit, ^[[blockunit:bb[0-9]+]]
  call alternate_return(n1, *5, n2, *7)
  ! CHECK: ^[[blockunit]]: // pred: ^bb0
  k =  0; return;
  ! CHECK: ^[[block1]]: // pred: ^bb0
5 k = -1; return;
  ! CHECK: ^[[block2]]: // pred: ^bb0
7 k =  1; return
end

! -----------------------------------------------------------------------------
!     Test calls to user procedures with intrinsic interfaces
! -----------------------------------------------------------------------------

! CHECK-NAME: func.func @_QPintrinsic_iface()
subroutine intrinsic_iface()
  intrinsic acos
  real :: x
  procedure(acos) :: proc
  x = proc(1.0)
end subroutine
! CHECK" fir.call @_QPproc(%{{.*}}) {{.*}}: (!fir.ref<f32>) -> f32
llvm/flang/test/Lower/HLFIR/calls-f77.f90
