flang/test/Lower/host-associated.f90

   1 ! Test internal procedure host association lowering.
   2 ! RUN: bbc %s -o - | FileCheck %s
   3
   4 ! -----------------------------------------------------------------------------
   5 !     Test non character intrinsic scalars
   6 ! -----------------------------------------------------------------------------
   7
   8 !!! Test scalar (with implicit none)
   9
  10 ! CHECK-LABEL: func @_QPtest1(
  11 subroutine test1
  12   implicit none
  13   integer i
  14   ! CHECK-DAG: %[[i:.*]] = fir.alloca i32 {{.*}}uniq_name = "_QFtest1Ei"
  15   ! CHECK-DAG: %[[tup:.*]] = fir.alloca tuple<!fir.ref<i32>>
  16   ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[tup]], %c0
  17   ! CHECK: fir.store %[[i]] to %[[addr]] : !fir.llvm_ptr<!fir.ref<i32>>
  18   ! CHECK: fir.call @_QFtest1Ptest1_internal(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.ref<i32>>>) -> ()
  19   call test1_internal
  20   print *, i
  21 contains
  22   ! CHECK-LABEL: func @_QFtest1Ptest1_internal(
  23   ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
  24   ! CHECK: %[[iaddr:.*]] = fir.coordinate_of %[[arg]], %c0
  25   ! CHECK: %[[i:.*]] = fir.load %[[iaddr]] : !fir.llvm_ptr<!fir.ref<i32>>
  26   ! CHECK: %[[val:.*]] = fir.call @_QPifoo() {{.*}}: () -> i32
  27   ! CHECK: fir.store %[[val]] to %[[i]] : !fir.ref<i32>
  28   subroutine test1_internal
  29     integer, external :: ifoo
  30     i = ifoo()
  31   end subroutine test1_internal
  32 end subroutine test1
  33
  34 !!! Test scalar
  35
  36 ! CHECK-LABEL: func @_QPtest2() {
  37 subroutine test2
  38   a = 1.0
  39   b = 2.0
  40   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<f32>, !fir.ref<f32>>
  41   ! CHECK: %[[a0:.*]] = fir.coordinate_of %[[tup]], %c0
  42   ! CHECK: fir.store %{{.*}} to %[[a0]] : !fir.llvm_ptr<!fir.ref<f32>>
  43   ! CHECK: %[[b0:.*]] = fir.coordinate_of %[[tup]], %c1
  44   ! CHECK: fir.store %{{.*}} to %[[b0]] : !fir.llvm_ptr<!fir.ref<f32>>
  45   ! CHECK: fir.call @_QFtest2Ptest2_internal(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>>) -> ()
  46   call test2_internal
  47   print *, a, b
  48 contains
  49   ! CHECK-LABEL: func @_QFtest2Ptest2_internal(
  50   ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
  51   subroutine test2_internal
  52     ! CHECK: %[[a:.*]] = fir.coordinate_of %[[arg]], %c0
  53     ! CHECK: %[[aa:.*]] = fir.load %[[a]] : !fir.llvm_ptr<!fir.ref<f32>>
  54     ! CHECK: %[[b:.*]] = fir.coordinate_of %[[arg]], %c1
  55     ! CHECK: %{{.*}} = fir.load %[[b]] : !fir.llvm_ptr<!fir.ref<f32>>
  56     ! CHECK: fir.alloca
  57     ! CHECK: fir.load %[[aa]] : !fir.ref<f32>
  58     c = a
  59     a = b
  60     b = c
  61     call test2_inner
  62   end subroutine test2_internal
  63
  64   ! CHECK-LABEL: func @_QFtest2Ptest2_inner(
  65   ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
  66   subroutine test2_inner
  67     ! CHECK: %[[a:.*]] = fir.coordinate_of %[[arg]], %c0
  68     ! CHECK: %[[aa:.*]] = fir.load %[[a]] : !fir.llvm_ptr<!fir.ref<f32>>
  69     ! CHECK: %[[b:.*]] = fir.coordinate_of %[[arg]], %c1
  70     ! CHECK: %[[bb:.*]] = fir.load %[[b]] : !fir.llvm_ptr<!fir.ref<f32>>
  71     ! CHECK-DAG: %[[bd:.*]] = fir.load %[[bb]] : !fir.ref<f32>
  72     ! CHECK-DAG: %[[ad:.*]] = fir.load %[[aa]] : !fir.ref<f32>
  73     ! CHECK: %{{.*}} = arith.cmpf ogt, %[[ad]], %[[bd]] : f32
  74     if (a > b) then
  75        b = b + 2.0
  76     end if
  77   end subroutine test2_inner
  78 end subroutine test2
  79
  80 ! -----------------------------------------------------------------------------
  81 !     Test non character scalars
  82 ! -----------------------------------------------------------------------------
  83
  84 ! CHECK-LABEL: func @_QPtest6(
  85 ! CHECK-SAME: %[[c:.*]]: !fir.boxchar<1>
  86 subroutine test6(c)
  87   character(*) :: c
  88   ! CHECK: %[[cunbox:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
  89   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.boxchar<1>>
  90   ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
  91   ! CHECK: %[[emboxchar:.*]] = fir.emboxchar %[[cunbox]]#0, %[[cunbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
  92   ! CHECK: fir.store %[[emboxchar]] to %[[coor]] : !fir.ref<!fir.boxchar<1>>
  93   ! CHECK: fir.call @_QFtest6Ptest6_inner(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.boxchar<1>>>) -> ()
  94   call test6_inner
  95   print *, c
  96
  97 contains
  98   ! CHECK-LABEL: func @_QFtest6Ptest6_inner(
  99   ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 100   subroutine test6_inner
 101     ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
 102     ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.boxchar<1>>
 103     ! CHECK: fir.unboxchar %[[load]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 104     c = "Hi there"
 105   end subroutine test6_inner
 106 end subroutine test6
 107
 108 ! -----------------------------------------------------------------------------
 109 !     Test non allocatable and pointer arrays
 110 ! -----------------------------------------------------------------------------
 111
 112 ! CHECK-LABEL: func @_QPtest3(
 113 ! CHECK-SAME: %[[p:[^:]+]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[q:.*]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[i:.*]]: !fir.ref<i64>
 114 subroutine test3(p,q,i)
 115   integer(8) :: i
 116   real :: p(i:)
 117   real :: q(:)
 118   ! CHECK: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i64>
 119   ! CHECK: %[[icast:.*]] = fir.convert %[[iload]] : (i64) -> index
 120   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>
 121   ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
 122   ! CHECK: %[[pshift:.*]] = fir.shift %[[icast]] : (index) -> !fir.shift<1>
 123   ! CHECK: %[[pbox:.*]] = fir.rebox %[[p]](%[[pshift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
 124   ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
 125   ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
 126   ! CHECK: %[[qbox:.*]] = fir.rebox %[[q]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xf32>>
 127   ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
 128
 129   i = i + 1
 130   q = -42.0
 131
 132   ! CHECK: fir.call @_QFtest3Ptest3_inner(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>) -> ()
 133   call test3_inner
 134
 135   if (p(2) .ne. -42.0) then
 136      print *, "failed"
 137   end if
 138
 139 contains
 140   ! CHECK-LABEL: func @_QFtest3Ptest3_inner(
 141   ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 142   subroutine test3_inner
 143     ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
 144     ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
 145     ! CHECK: %[[pbounds:.]]:3 = fir.box_dims %[[p]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
 146     ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
 147     ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
 148     ! CHECK: %[[qbounds:.]]:3 = fir.box_dims %[[q]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
 149
 150
 151     ! CHECK: %[[qlb:.*]] = fir.convert %[[qbounds]]#0 : (index) -> i64
 152     ! CHECK: %[[qoffset:.*]] = arith.subi %c1{{.*}}, %[[qlb]] : i64
 153     ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[q]], %[[qoffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
 154     ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
 155     ! CHECK: %[[plb:.*]] = fir.convert %[[pbounds]]#0 : (index) -> i64
 156     ! CHECK: %[[poffset:.*]] = arith.subi %c2{{.*}}, %[[plb]] : i64
 157     ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[p]], %[[poffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
 158     ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
 159     p(2) = q(1)
 160   end subroutine test3_inner
 161 end subroutine test3
 162
 163 ! CHECK-LABEL: func @_QPtest3a(
 164 ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.array<10xf32>>{{.*}}) {
 165 subroutine test3a(p)
 166   real :: p(10)
 167   real :: q(10)
 168   ! CHECK: %[[q:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "q", uniq_name = "_QFtest3aEq"}
 169   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>
 170   ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
 171   ! CHECK: %[[shape:.*]] = fir.shape %c10{{.*}} : (index) -> !fir.shape<1>
 172   ! CHECK: %[[pbox:.*]] = fir.embox %[[p]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
 173   ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
 174   ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
 175   ! CHECK: %[[qbox:.*]] = fir.embox %[[q]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
 176   ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
 177
 178   q = -42.0
 179   ! CHECK: fir.call @_QFtest3aPtest3a_inner(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>) -> ()
 180   call test3a_inner
 181
 182   if (p(1) .ne. -42.0) then
 183      print *, "failed"
 184   end if
 185
 186 contains
 187   ! CHECK: func @_QFtest3aPtest3a_inner(
 188   ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 189   subroutine test3a_inner
 190     ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
 191     ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
 192     ! CHECK: %[[paddr:.*]] = fir.box_addr %[[p]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
 193     ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
 194     ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
 195     ! CHECK: %[[qaddr:.*]] = fir.box_addr %[[q]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
 196
 197     ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[qaddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
 198     ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
 199     ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[paddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
 200     ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
 201     p(1) = q(1)
 202   end subroutine test3a_inner
 203 end subroutine test3a
 204
 205 ! -----------------------------------------------------------------------------
 206 !     Test allocatable and pointer scalars
 207 ! -----------------------------------------------------------------------------
 208
 209 ! CHECK-LABEL: func @_QPtest4() {
 210 subroutine test4
 211   real, pointer :: p
 212   real, allocatable, target :: ally
 213   ! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {bindc_name = "ally", fir.target, uniq_name = "_QFtest4Eally"}
 214   ! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = "p", uniq_name = "_QFtest4Ep"}
 215   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>
 216   ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
 217   ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
 218   ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
 219   ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
 220   ! CHECK: fir.call @_QFtest4Ptest4_inner(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>) -> ()
 221
 222   allocate(ally)
 223   ally = -42.0
 224   call test4_inner
 225
 226   if (p .ne. -42.0) then
 227      print *, "failed"
 228   end if
 229
 230 contains
 231   ! CHECK-LABEL: func @_QFtest4Ptest4_inner(
 232   ! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 233   subroutine test4_inner
 234     ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
 235     ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
 236     ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
 237     ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
 238     ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<f32>>>
 239     ! CHECK: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
 240     ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]] : (!fir.heap<f32>) -> !fir.box<!fir.ptr<f32>>
 241     ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
 242     p => ally
 243   end subroutine test4_inner
 244 end subroutine test4
 245
 246 ! -----------------------------------------------------------------------------
 247 !     Test allocatable and pointer arrays
 248 ! -----------------------------------------------------------------------------
 249
 250 ! CHECK-LABEL: func @_QPtest5() {
 251 subroutine test5
 252   real, pointer :: p(:)
 253   real, allocatable, target :: ally(:)
 254
 255   ! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {bindc_name = "ally", fir.target
 256   ! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>> {bindc_name = "p"
 257   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
 258   ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
 259   ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
 260   ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
 261   ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
 262   ! CHECK: fir.call @_QFtest5Ptest5_inner(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>) -> ()
 263
 264   allocate(ally(10))
 265   ally = -42.0
 266   call test5_inner
 267
 268   if (p(1) .ne. -42.0) then
 269      print *, "failed"
 270   end if
 271
 272 contains
 273   ! CHECK-LABEL: func @_QFtest5Ptest5_inner(
 274   ! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 275   subroutine test5_inner
 276     ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
 277     ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
 278     ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
 279     ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
 280     ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
 281     ! CHECK-DAG: %[[adims:.*]]:3 = fir.box_dims %[[abox]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?xf32>>>, index) -> (index, index, index)
 282     ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.heap<!fir.array<?xf32>>
 283     ! CHECK-DAG: %[[ashape:.*]] = fir.shape_shift %[[adims]]#0, %[[adims]]#1 : (index, index) -> !fir.shapeshift<1>
 284
 285     ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]](%[[ashape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
 286     ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
 287     p => ally
 288   end subroutine test5_inner
 289 end subroutine test5
 290
 291
 292 ! -----------------------------------------------------------------------------
 293 !     Test elemental internal procedure
 294 ! -----------------------------------------------------------------------------
 295
 296 ! CHECK-LABEL: func @_QPtest7(
 297 ! CHECK-SAME: %[[j:.*]]: !fir.ref<i32>{{.*}}, %[[k:.*]]: !fir.box<!fir.array<?xi32>>
 298 subroutine test7(j, k)
 299   implicit none
 300   integer :: j
 301   integer :: k(:)
 302   ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<i32>>
 303   ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
 304   ! CHECK: fir.store %[[j]] to %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
 305
 306   ! CHECK: %[[kelem:.*]] = fir.array_coor %[[k]] %{{.*}} : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
 307   ! CHECK: fir.call @_QFtest7Ptest7_inner(%[[kelem]], %[[tup]]) {{.*}}: (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> i32
 308   k = test7_inner(k)
 309 contains
 310
 311 ! CHECK-LABEL: func @_QFtest7Ptest7_inner(
 312 ! CHECK-SAME: %[[i:.*]]: !fir.ref<i32>{{.*}}, %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) -> i32 attributes {fir.internal_proc} {
 313 elemental integer function test7_inner(i)
 314   implicit none
 315   integer, intent(in) :: i
 316   ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
 317   ! CHECK: %[[jptr:.*]] = fir.load %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
 318   ! CHECK-DAG: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i32>
 319   ! CHECK-DAG: %[[jload:.*]] = fir.load %[[jptr]] : !fir.ref<i32>
 320   ! CHECK: addi %[[iload]], %[[jload]] : i32
 321   test7_inner = i + j
 322 end function
 323 end subroutine
 324
 325 subroutine issue990()
 326   ! Test that host symbols used in statement functions inside an internal
 327   ! procedure are correctly captured from the host.
 328   implicit none
 329   integer :: captured
 330   call bar()
 331 contains
 332 ! CHECK-LABEL: func @_QFissue990Pbar(
 333 ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 334 subroutine bar()
 335   integer :: stmt_func, i
 336   stmt_func(i) = i + captured
 337   ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
 338   ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
 339   ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
 340   ! CHECK: arith.addi %{{.*}}, %[[value]] : i32
 341   print *, stmt_func(10)
 342 end subroutine
 343 end subroutine
 344
 345 subroutine issue990b()
 346   ! Test when an internal procedure uses a statement function from its host
 347   ! which uses host variables that are otherwise not used by the internal
 348   ! procedure.
 349   implicit none
 350   integer :: captured, captured_stmt_func, i
 351   captured_stmt_func(i) = i + captured
 352   call bar()
 353 contains
 354 ! CHECK-LABEL: func @_QFissue990bPbar(
 355 ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 356 subroutine bar()
 357   ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
 358   ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
 359   ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
 360   ! CHECK: arith.addi %{{.*}}, %[[value]] : i32
 361   print *, captured_stmt_func(10)
 362 end subroutine
 363 end subroutine
 364
 365 ! Test capture of dummy procedure functions.
 366 subroutine test8(dummy_proc)
 367  implicit none
 368  interface
 369    real function dummy_proc(x)
 370     real :: x
 371    end function
 372  end interface
 373  call bar()
 374 contains
 375 ! CHECK-LABEL: func @_QFtest8Pbar(
 376 ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 377 subroutine bar()
 378   ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
 379   ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
 380   ! CHECK: %[[dummyProcCast:.*]] = fir.box_addr %[[dummyProc]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
 381   ! CHECK: fir.call %[[dummyProcCast]](%{{.*}}) {{.*}}: (!fir.ref<f32>) -> f32
 382  print *, dummy_proc(42.)
 383 end subroutine
 384 end subroutine
 385
 386 ! Test capture of dummy subroutines.
 387 subroutine test9(dummy_proc)
 388  implicit none
 389  interface
 390    subroutine dummy_proc()
 391    end subroutine
 392  end interface
 393  call bar()
 394 contains
 395 ! CHECK-LABEL: func @_QFtest9Pbar(
 396 ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 397 subroutine bar()
 398   ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
 399   ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
 400   ! CHECK: %[[pa:.*]] = fir.box_addr %[[dummyProc]]
 401   ! CHECK: fir.call %[[pa]]() {{.*}}: () -> ()
 402   call dummy_proc()
 403 end subroutine
 404 end subroutine
 405
 406 ! Test capture of namelist
 407 ! CHECK-LABEL: func @_QPtest10(
 408 ! CHECK-SAME: %[[i:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>{{.*}}) {
 409 subroutine test10(i)
 410  implicit none
 411  integer, pointer :: i(:)
 412  namelist /a_namelist/ i
 413  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup:.*]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
 414  ! CHECK: fir.store %[[i]] to %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
 415  ! CHECK: fir.call @_QFtest10Pbar(%[[tup]]) {{.*}}: (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>) -> ()
 416  call bar()
 417 contains
 418 ! CHECK-LABEL: func @_QFtest10Pbar(
 419 ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 420 subroutine bar()
 421   ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
 422   ! CHECK: fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
 423   read (88, NML = a_namelist)
 424 end subroutine
 425 end subroutine
 426
 427 ! Test passing an internal procedure as a dummy argument.
 428
 429 ! CHECK-LABEL: func @_QPtest_proc_dummy() {
 430 ! CHECK:         %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFtest_proc_dummyEi"}
 431 ! CHECK:         %[[VAL_5:.*]] = fir.alloca tuple<!fir.ref<i32>>
 432 ! CHECK:         %[[VAL_7:.*]] = fir.address_of(@_QFtest_proc_dummyPtest_proc_dummy_a) : (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> ()
 433 ! CHECK:         %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]], %[[VAL_5]] : ((!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> (), !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxproc<() -> ()>
 434 ! CHECK:         fir.call @_QPtest_proc_dummy_other(%[[VAL_8]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
 435
 436 ! CHECK-LABEL: func @_QFtest_proc_dummyPtest_proc_dummy_a(
 437 ! CHECK-SAME:          %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "j"},
 438 ! CHECK-SAME:          %[[VAL_1:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) attributes {fir.internal_proc} {
 439 ! CHECK:         %[[VAL_2:.*]] = arith.constant 0 : i32
 440 ! CHECK:         %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
 441 ! CHECK:         %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<i32>>
 442 ! CHECK:         %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
 443 ! CHECK:         %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
 444 ! CHECK:         %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i32
 445 ! CHECK:         fir.store %[[VAL_7]] to %[[VAL_4]] : !fir.ref<i32>
 446 ! CHECK:         return
 447 ! CHECK:       }
 448
 449 ! CHECK-LABEL: func @_QPtest_proc_dummy_other(
 450 ! CHECK-SAME:           %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
 451 ! CHECK:         %[[VAL_1:.*]] = arith.constant 4 : i32
 452 ! CHECK:         %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref}
 453 ! CHECK:         fir.store %[[VAL_1]] to %[[VAL_2]] : !fir.ref<i32>
 454 ! CHECK:         %[[VAL_3:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<i32>) -> ())
 455 ! CHECK:         fir.call %[[VAL_3]](%[[VAL_2]]) {{.*}}: (!fir.ref<i32>) -> ()
 456 ! CHECK:         return
 457 ! CHECK:       }
 458
 459 subroutine test_proc_dummy
 460   integer i
 461   i = 1
 462   call test_proc_dummy_other(test_proc_dummy_a)
 463   print *, i
 464 contains
 465   subroutine test_proc_dummy_a(j)
 466     i = i + j
 467   end subroutine test_proc_dummy_a
 468 end subroutine test_proc_dummy
 469
 470 subroutine test_proc_dummy_other(proc)
 471   call proc(4)
 472 end subroutine test_proc_dummy_other
 473
 474 ! CHECK-LABEL: func @_QPtest_proc_dummy_char() {
 475 ! CHECK-DAG:         %[[VAL_0:.*]] = arith.constant 10 : index
 476 ! CHECK-DAG:         %[[VAL_1:.*]] = arith.constant 0 : i32
 477 ! CHECK-DAG:         %[[VAL_2:.*]] = arith.constant 9 : index
 478 ! CHECK-DAG:         %[[VAL_3:.*]] = arith.constant false
 479 ! CHECK-DAG:         %[[VAL_4:.*]] = arith.constant 1 : index
 480 ! CHECK-DAG:         %[[VAL_5:.*]] = arith.constant 32 : i8
 481 ! CHECK-DAG:         %[[VAL_6:.*]] = arith.constant -1 : i32
 482 ! CHECK-DAG:         %[[VAL_8:.*]] = arith.constant 10 : i64
 483 ! CHECK-DAG:         %[[VAL_9:.*]] = arith.constant 40 : index
 484 ! CHECK-DAG:         %[[VAL_10:.*]] = arith.constant 0 : index
 485 ! CHECK:         %[[VAL_11:.*]] = fir.alloca !fir.char<1,40> {bindc_name = ".result"}
 486 ! CHECK:         %[[VAL_12:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "message", uniq_name = "_QFtest_proc_dummy_charEmessage"}
 487 ! CHECK:         %[[VAL_13:.*]] = fir.alloca tuple<!fir.boxchar<1>>
 488 ! CHECK:         %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_13]], %[[VAL_1]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
 489 ! CHECK:         %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
 490 ! CHECK:         %[[VAL_16:.*]] = fir.emboxchar %[[VAL_15]], %[[VAL_0]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
 491 ! CHECK:         fir.store %[[VAL_16]] to %[[VAL_14]] : !fir.ref<!fir.boxchar<1>>
 492 ! CHECK:         %[[VAL_17:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,9>>
 493 ! CHECK:         %[[VAL_18:.*]] = fir.convert %[[VAL_2]] : (index) -> i64
 494 ! CHECK:         %[[VAL_19:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
 495 ! CHECK:         %[[VAL_20:.*]] = fir.convert %[[VAL_17]] : (!fir.ref<!fir.char<1,9>>) -> !fir.ref<i8>
 496 ! CHECK:         fir.call @llvm.memmove.p0.p0.i64(%[[VAL_19]], %[[VAL_20]], %[[VAL_18]], %[[VAL_3]]) {{.*}}: (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
 497 ! CHECK:         %[[VAL_21:.*]] = fir.undefined !fir.char<1>
 498 ! CHECK:         %[[VAL_22:.*]] = fir.insert_value %[[VAL_21]], %[[VAL_5]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
 499 ! CHECK:         br ^bb1(%[[VAL_2]], %[[VAL_4]] : index, index)
 500 ! CHECK:       ^bb1(%[[VAL_23:.*]]: index, %[[VAL_24:.*]]: index):
 501 ! CHECK:         %[[VAL_25:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_10]] : index
 502 ! CHECK:         cond_br %[[VAL_25]], ^bb2, ^bb3
 503 ! CHECK:       ^bb2:
 504 ! CHECK:         %[[VAL_26:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.array<10x!fir.char<1>>>
 505 ! CHECK:         %[[VAL_27:.*]] = fir.coordinate_of %[[VAL_26]], %[[VAL_23]] : (!fir.ref<!fir.array<10x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
 506 ! CHECK:         fir.store %[[VAL_22]] to %[[VAL_27]] : !fir.ref<!fir.char<1>>
 507 ! CHECK:         %[[VAL_28:.*]] = arith.addi %[[VAL_23]], %[[VAL_4]] : index
 508 ! CHECK:         %[[VAL_29:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
 509 ! CHECK:         br ^bb1(%[[VAL_28]], %[[VAL_29]] : index, index)
 510 ! CHECK:       ^bb3:
 511 ! CHECK:         %[[VAL_30:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,
 512 ! CHECK:         %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
 513 ! CHECK:         %[[VAL_32:.*]] = fir.call @_FortranAioBeginExternalListOutput(%[[VAL_6]], %[[VAL_31]], %{{.*}}) {{.*}}: (i32, !fir.ref<i8>, i32) -> !fir.ref<i8>
 514 ! CHECK:         %[[VAL_33:.*]] = fir.address_of(@_QFtest_proc_dummy_charPgen_message) : (!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>
 515 ! CHECK:         %[[VAL_34:.*]] = fir.emboxproc %[[VAL_33]], %[[VAL_13]] : ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxproc<() -> ()>
 516 ! CHECK:         %[[VAL_35:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
 517 ! CHECK:         %[[VAL_36:.*]] = fir.insert_value %[[VAL_35]], %[[VAL_34]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
 518 ! CHECK:         %[[VAL_37:.*]] = fir.insert_value %[[VAL_36]], %[[VAL_8]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
 519 ! CHECK:         %[[VAL_38:.*]] = fir.call @llvm.stacksave.p0() {{.*}}: () -> !fir.ref<i8>
 520 ! CHECK:         %[[VAL_39:.*]] = fir.call @_QPget_message(%[[VAL_11]], %[[VAL_9]], %[[VAL_37]]) {{.*}}: (!fir.ref<!fir.char<1,40>>, index, tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxchar<1>
 521 ! CHECK:         %[[VAL_40:.*]] = fir.convert %[[VAL_11]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<i8>
 522 ! CHECK:         %[[VAL_41:.*]] = fir.convert %[[VAL_9]] : (index) -> i64
 523 ! CHECK:         %[[VAL_42:.*]] = fir.call @_FortranAioOutputAscii(%[[VAL_32]], %[[VAL_40]], %[[VAL_41]]) {{.*}}: (!fir.ref<i8>, !fir.ref<i8>, i64) -> i1
 524 ! CHECK:         fir.call @llvm.stackrestore.p0(%[[VAL_38]]) {{.*}}: (!fir.ref<i8>) -> ()
 525 ! CHECK:         %[[VAL_43:.*]] = fir.call @_FortranAioEndIoStatement(%[[VAL_32]]) {{.*}}: (!fir.ref<i8>) -> i32
 526 ! CHECK:         return
 527 ! CHECK:       }
 528
 529 ! CHECK-LABEL: func @_QFtest_proc_dummy_charPgen_message(
 530 ! CHECK-SAME:                                            %[[VAL_0:.*]]: !fir.ref<!fir.char<1,10>>,
 531 ! CHECK-SAME:                                            %[[VAL_1:.*]]: index,
 532 ! CHECK-SAME:                                            %[[VAL_2:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) -> !fir.boxchar<1> attributes {fir.internal_proc} {
 533 ! CHECK-DAG:         %[[VAL_3:.*]] = arith.constant 0 : i32
 534 ! CHECK-DAG:         %[[VAL_4:.*]] = arith.constant 10 : index
 535 ! CHECK-DAG:         %[[VAL_5:.*]] = arith.constant false
 536 ! CHECK-DAG:         %[[VAL_6:.*]] = arith.constant 1 : index
 537 ! CHECK-DAG:         %[[VAL_7:.*]] = arith.constant 32 : i8
 538 ! CHECK-DAG:         %[[VAL_8:.*]] = arith.constant 0 : index
 539 ! CHECK:         %[[VAL_12:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
 540 ! CHECK:         %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
 541 ! CHECK:         %[[VAL_10:.*]] = fir.load %[[VAL_9]] : !fir.ref<!fir.boxchar<1>>
 542 ! CHECK:         %[[VAL_11:.*]]:2 = fir.unboxchar %[[VAL_10]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 543 ! CHECK:         %[[VAL_13:.*]] = arith.cmpi sgt, %[[VAL_11]]#1, %[[VAL_4]] : index
 544 ! CHECK:         %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_4]], %[[VAL_11]]#1 : index
 545 ! CHECK:         %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (index) -> i64
 546 ! CHECK:         %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
 547 ! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_11]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
 548 ! CHECK:         fir.call @llvm.memmove.p0.p0.i64(%[[VAL_16]], %[[VAL_17]], %[[VAL_15]], %[[VAL_5]]) {{.*}}: (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
 549 ! CHECK:         %[[VAL_18:.*]] = fir.undefined !fir.char<1>
 550 ! CHECK:         %[[VAL_19:.*]] = fir.insert_value %[[VAL_18]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
 551 ! CHECK:         %[[VAL_20:.*]] = arith.subi %[[VAL_4]], %[[VAL_14]] : index
 552 ! CHECK:         br ^bb1(%[[VAL_14]], %[[VAL_20]] : index, index)
 553 ! CHECK:       ^bb1(%[[VAL_21:.*]]: index, %[[VAL_22:.*]]: index):
 554 ! CHECK:         %[[VAL_23:.*]] = arith.cmpi sgt, %[[VAL_22]], %[[VAL_8]] : index
 555 ! CHECK:         cond_br %[[VAL_23]], ^bb2, ^bb3
 556 ! CHECK:       ^bb2:
 557 ! CHECK:         %[[VAL_24:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
 558 ! CHECK:         %[[VAL_25:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_21]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
 559 ! CHECK:         fir.store %[[VAL_19]] to %[[VAL_25]] : !fir.ref<!fir.char<1>>
 560 ! CHECK:         %[[VAL_26:.*]] = arith.addi %[[VAL_21]], %[[VAL_6]] : index
 561 ! CHECK:         %[[VAL_27:.*]] = arith.subi %[[VAL_22]], %[[VAL_6]] : index
 562 ! CHECK:         br ^bb1(%[[VAL_26]], %[[VAL_27]] : index, index)
 563 ! CHECK:       ^bb3:
 564 ! CHECK:         %[[VAL_28:.*]] = fir.emboxchar %[[VAL_12]], %[[VAL_4]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
 565 ! CHECK:         return %[[VAL_28]] : !fir.boxchar<1>
 566 ! CHECK:       }
 567
 568 ! CHECK-LABEL: func @_QPget_message(
 569 ! CHECK-SAME:                       %[[VAL_0:.*]]: !fir.ref<!fir.char<1,40>>,
 570 ! CHECK-SAME:                       %[[VAL_1:.*]]: index,
 571 ! CHECK-SAME:                       %[[VAL_2:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) -> !fir.boxchar<1> {
 572 ! CHECK-DAG:     %[[VAL_3:.*]] = arith.constant 40 : index
 573 ! CHECK-DAG:     %[[VAL_4:.*]] = arith.constant 12 : index
 574 ! CHECK-DAG:     %[[VAL_5:.*]] = arith.constant false
 575 ! CHECK-DAG:     %[[VAL_6:.*]] = arith.constant 1 : index
 576 ! CHECK-DAG:     %[[VAL_7:.*]] = arith.constant 32 : i8
 577 ! CHECK-DAG:     %[[VAL_8:.*]] = arith.constant 0 : index
 578 ! CHECK:         %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<!fir.char<1,?>>
 579 ! CHECK:         %[[VAL_10:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,12>>
 580 ! CHECK:         %[[VAL_11:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
 581 ! CHECK:         %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ())
 582 ! CHECK:         %[[VAL_13:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
 583 ! CHECK:         %[[VAL_14:.*]] = fir.call @llvm.stacksave.p0() {{.*}}: () -> !fir.ref<i8>
 584 ! CHECK:         %[[VAL_15:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_13]] : i64) {bindc_name = ".result"}
 585 ! CHECK:         %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
 586 ! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_13]] : (i64) -> index
 587 ! CHECK:         %[[VAL_18:.*]] = fir.call %[[VAL_16]](%[[VAL_15]], %[[VAL_17]]) {{.*}}: (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
 588 ! CHECK:         %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_4]] : index
 589 ! CHECK:         %[[VAL_20:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_19]] : index) {bindc_name = ".chrtmp"}
 590 ! CHECK:         %[[VAL_21:.*]] = fir.convert %[[VAL_4]] : (index) -> i64
 591 ! CHECK:         %[[VAL_22:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
 592 ! CHECK:         %[[VAL_23:.*]] = fir.convert %[[VAL_10]] : (!fir.ref<!fir.char<1,12>>) -> !fir.ref<i8>
 593 ! CHECK:         fir.call @llvm.memmove.p0.p0.i64(%[[VAL_22]], %[[VAL_23]], %[[VAL_21]], %[[VAL_5]]) {{.*}}: (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
 594 ! CHECK:         br ^bb1(%[[VAL_4]], %[[VAL_17]] : index, index)
 595 ! CHECK:       ^bb1(%[[VAL_24:.*]]: index, %[[VAL_25:.*]]: index):
 596 ! CHECK:         %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_25]], %[[VAL_8]] : index
 597 ! CHECK:         cond_br %[[VAL_26]], ^bb2, ^bb3
 598 ! CHECK:       ^bb2:
 599 ! CHECK:         %[[VAL_27:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
 600 ! CHECK:         %[[VAL_28:.*]] = fir.convert %[[VAL_15]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
 601 ! CHECK:         %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_27]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
 602 ! CHECK:         %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref<!fir.char<1>>
 603 ! CHECK:         %[[VAL_31:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
 604 ! CHECK:         %[[VAL_32:.*]] = fir.coordinate_of %[[VAL_31]], %[[VAL_24]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
 605 ! CHECK:         fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ref<!fir.char<1>>
 606 ! CHECK:         %[[VAL_33:.*]] = arith.addi %[[VAL_24]], %[[VAL_6]] : index
 607 ! CHECK:         %[[VAL_34:.*]] = arith.subi %[[VAL_25]], %[[VAL_6]] : index
 608 ! CHECK:         br ^bb1(%[[VAL_33]], %[[VAL_34]] : index, index)
 609 ! CHECK:       ^bb3:
 610 ! CHECK:         %[[VAL_35:.*]] = arith.cmpi sgt, %[[VAL_19]], %[[VAL_3]] : index
 611 ! CHECK:         %[[VAL_36:.*]] = arith.select %[[VAL_35]], %[[VAL_3]], %[[VAL_19]] : index
 612 ! CHECK:         %[[VAL_37:.*]] = fir.convert %[[VAL_36]] : (index) -> i64
 613 ! CHECK:         %[[VAL_38:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
 614 ! CHECK:         fir.call @llvm.memmove.p0.p0.i64(%[[VAL_38]], %[[VAL_22]], %[[VAL_37]], %[[VAL_5]]) {{.*}}: (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
 615 ! CHECK:         %[[VAL_39:.*]] = fir.undefined !fir.char<1>
 616 ! CHECK:         %[[VAL_40:.*]] = fir.insert_value %[[VAL_39]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
 617 ! CHECK:         %[[VAL_41:.*]] = arith.subi %[[VAL_3]], %[[VAL_36]] : index
 618 ! CHECK:         br ^bb4(%[[VAL_36]], %[[VAL_41]] : index, index)
 619 ! CHECK:       ^bb4(%[[VAL_42:.*]]: index, %[[VAL_43:.*]]: index):
 620 ! CHECK:         %[[VAL_44:.*]] = arith.cmpi sgt, %[[VAL_43]], %[[VAL_8]] : index
 621 ! CHECK:         cond_br %[[VAL_44]], ^bb5, ^bb6
 622 ! CHECK:       ^bb5:
 623 ! CHECK:         %[[VAL_45:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
 624 ! CHECK:         %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_42]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
 625 ! CHECK:         fir.store %[[VAL_40]] to %[[VAL_46]] : !fir.ref<!fir.char<1>>
 626 ! CHECK:         %[[VAL_47:.*]] = arith.addi %[[VAL_42]], %[[VAL_6]] : index
 627 ! CHECK:         %[[VAL_48:.*]] = arith.subi %[[VAL_43]], %[[VAL_6]] : index
 628 ! CHECK:         br ^bb4(%[[VAL_47]], %[[VAL_48]] : index, index)
 629 ! CHECK:       ^bb6:
 630 ! CHECK:         fir.call @llvm.stackrestore.p0(%[[VAL_14]]) {{.*}}: (!fir.ref<i8>) -> ()
 631 ! CHECK:         %[[VAL_49:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_3]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
 632 ! CHECK:         return %[[VAL_49]] : !fir.boxchar<1>
 633 ! CHECK:       }
 634
 635 subroutine test_proc_dummy_char
 636   character(40) get_message
 637   external get_message
 638   character(10) message
 639   message = "Hi there!"
 640   print *, get_message(gen_message)
 641 contains
 642   function gen_message
 643     character(10) :: gen_message
 644     gen_message = message
 645   end function gen_message
 646 end subroutine test_proc_dummy_char
 647
 648 function get_message(a)
 649   character(40) :: get_message
 650   character(*) :: a
 651   get_message = "message is: " // a()
 652 end function get_message
 653
 654 ! CHECK-LABEL: func @_QPtest_11a() {
 655 ! CHECK: %[[a:.*]] = fir.address_of(@_QPtest_11b) : () -> ()
 656 ! CHECK: %[[b:.*]] = fir.emboxproc %[[a]] : (() -> ()) -> !fir.boxproc<() -> ()>
 657 ! CHECK: fir.call @_QPtest_11c(%[[b]], %{{.*}}) {{.*}}: (!fir.boxproc<() -> ()>, !fir.ref<i32>) -> ()
 658 ! CHECK: func private @_QPtest_11c(!fir.boxproc<() -> ()>, !fir.ref<i32>)
 659
 660 subroutine test_11a
 661   external test_11b
 662   call test_11c(test_11b, 3)
 663 end subroutine test_11a
 664
 665 subroutine test_PDT_with_init_do_not_crash_host_symbol_analysis()
 666   integer :: i
 667   call sub()
 668 contains
 669   subroutine sub()
 670     ! PDT definition symbols maps to un-analyzed expression,
 671     ! check this does not crash the visit of the internal procedure
 672     ! parse-tree to get the list of captured host variables.
 673     type type1 (k)
 674       integer, KIND :: k
 675       integer :: x = k
 676     end type
 677     type type2 (k, l)
 678       integer, KIND :: k = 4
 679       integer, LEN :: l = 2
 680       integer :: x = 10
 681       real :: y = 20
 682     end type
 683     print *, i
 684   end subroutine
 685 end subroutine