1! Test derived type finalization 2! RUN: bbc --use-desc-for-alloc=false -emit-fir -hlfir=false %s -o - | FileCheck %s 3 4! Missing tests: 5! - finalization within BLOCK construct 6 7module derived_type_finalization 8 9 type :: t1 10 integer :: a 11 contains 12 final :: t1_final 13 final :: t1_final_1r 14 end type 15 16 type :: t2 17 integer, allocatable, dimension(:) :: a 18 contains 19 final :: t2_final 20 end type 21 22 type :: t3 23 type(t2) :: t 24 end type 25 26 type t4 27 contains 28 final :: t4_final 29 end type 30 31contains 32 33 subroutine t1_final(this) 34 type(t1) :: this 35 end subroutine 36 37 subroutine t1_final_1r(this) 38 type(t1) :: this(:) 39 end subroutine 40 41 subroutine t2_final(this) 42 type(t2) :: this 43 end subroutine 44 45 ! 7.5.6.3 point 1. Finalization of LHS. 46 subroutine test_lhs() 47 type(t1) :: lhs, rhs 48 lhs = rhs 49 end subroutine 50 51 subroutine test_lhs_allocatable() 52 type(t1), allocatable :: lhs 53 type(t1) :: rhs 54 lhs = rhs 55 end subroutine 56 57! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_lhs() { 58! CHECK: %[[BOXREF:.*]] = fir.alloca !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 59! CHECK: %[[LHS:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "lhs", uniq_name = "_QMderived_type_finalizationFtest_lhsElhs"} 60! CHECK: %[[EMBOX:.*]] = fir.embox %[[LHS]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 61! CHECK: fir.store %[[EMBOX]] to %[[BOXREF]] : !fir.ref<!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> 62! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOXREF]] : (!fir.ref<!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>) -> !fir.ref<!fir.box<none>> 63! CHECK: fir.call @_FortranAAssign(%[[BOX_NONE]], {{.*}} 64 65! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_lhs_allocatable() { 66! CHECK: %[[LHS:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "lhs", uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableElhs"} 67! CHECK: %[[LHS_ADDR:.*]] = fir.alloca !fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> {uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableElhs.addr"} 68! CHECK: %[[RHS:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "rhs", uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableErhs"} 69! CHECK: %[[LHS_ADDR_LOAD:.*]] = fir.load %[[LHS_ADDR]] : !fir.ref<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> 70! CHECK: %[[ADDR_I64:.*]] = fir.convert %[[LHS_ADDR_LOAD]] : (!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> i64 71! CHECK: %[[C0:.*]] = arith.constant 0 : i64 72! CHECK: %[[IS_NULL:.*]] = arith.cmpi ne, %[[ADDR_I64]], %[[C0]] : i64 73! CHECK: fir.if %[[IS_NULL]] { 74! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[LHS]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.box<none> 75! CHECK: fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> () 76! CHECK: } 77 78 ! 7.5.6.3 point 2. Finalization on explicit deallocation. 79 subroutine test_deallocate() 80 type(t1), allocatable :: t 81 allocate(t) 82 deallocate(t) 83 end subroutine 84 85! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_deallocate() { 86! CHECK: %[[LOCAL_T:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_deallocateEt"} 87! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate 88! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[LOCAL_T]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.ref<!fir.box<none>> 89! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32 90 91 ! 7.5.6.3 point 2. Finalization of disassociated target. 92 subroutine test_target_finalization() 93 type(t1), pointer :: p 94 allocate(p, source=t1(a=2)) 95 deallocate(p) 96 end subroutine 97 98! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_target_finalization() { 99! CHECK: %[[P:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "p", uniq_name = "_QMderived_type_finalizationFtest_target_finalizationEp"} 100! CHECK: fir.call @_FortranAInitialize 101! CHECK: fir.call @_FortranAPointerAllocateSource 102! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.ref<!fir.box<none>> 103! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[P_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32 104 105 ! 7.5.6.3 point 3. Finalize on END. 106 subroutine test_end_finalization() 107 type(t1) :: t 108 end subroutine 109 110! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_end_finalization() { 111! CHECK: %[[LOCAL_T:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_end_finalizationEt"} 112! CHECK: %[[EMBOX:.*]] = fir.embox %[[LOCAL_T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 113! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none> 114! CHECK: fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> () 115! CHECK: return 116 117 ! test with multiple return. 118 subroutine test_end_finalization2(a) 119 type(t1) :: t 120 logical :: a 121 if (a) return 122 t%a = 10 123 end subroutine 124 125! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_end_finalization2( 126! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.logical<4>> {fir.bindc_name = "a"}) { 127! CHECK: %[[T:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_end_finalization2Et"} 128! CHECK: %[[LOAD_A:.*]] = fir.load %[[A]] : !fir.ref<!fir.logical<4>> 129! CHECK: %[[CONV_A:.*]] = fir.convert %[[LOAD_A]] : (!fir.logical<4>) -> i1 130! CHECK: cf.cond_br %[[CONV_A]], ^bb1, ^bb2 131! CHECK: ^bb1: 132! CHECK: cf.br ^bb3 133! CHECK: ^bb2: 134! CHECK: %[[C10:.*]] = arith.constant 10 : i32 135! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMderived_type_finalizationTt1{a:i32}> 136! CHECK: %[[COORD_A:.*]] = fir.coordinate_of %[[T]], %[[FIELD_A]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>, !fir.field) -> !fir.ref<i32> 137! CHECK: fir.store %[[C10]] to %[[COORD_A]] : !fir.ref<i32> 138! CHECK: cf.br ^bb3 139! CHECK: ^bb3: 140! CHECK: %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 141! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none> 142! CHECK: fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> () 143! CHECK: return 144! CHECK: } 145 146 function ret_type() result(ty) 147 type(t1) :: ty 148 end function 149 150 ! 7.5.6.3 point 5. Finalization of a function reference on the RHS of an intrinsic assignment. 151 subroutine test_fct_ref() 152 type(t1), allocatable :: ty 153 ty = ret_type() 154 end subroutine 155 156! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_fct_ref() { 157! CHECK: %[[RESULT:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = ".result"} 158! CHECK: %[[CALL_RES:.*]] = fir.call @_QMderived_type_finalizationPret_type() 159! CHECK: fir.save_result %[[CALL_RES]] to %[[RESULT]] : !fir.type<_QMderived_type_finalizationTt1{a:i32}>, !fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 160! CHECK: %[[EMBOX:.*]] = fir.embox %[[RESULT]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 161! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none> 162! CHECK: fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> () 163! CHECK: return 164 165 subroutine test_finalize_intent_out(t) 166 type(t1), intent(out) :: t 167 end subroutine 168 169! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_finalize_intent_out( 170! CHECK-SAME: %[[T:.*]]: !fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> {fir.bindc_name = "t"}) { 171! CHECK: %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> 172! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none> 173! CHECK: fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}}: (!fir.box<none>) -> () 174! CHECK: return 175 176 function get_t1(i) 177 type(t1), pointer :: get_t1 178 allocate(get_t1) 179 get_t1%a = i 180 end function 181 182 subroutine test_nonpointer_function() 183 print*, get_t1(20) 184 end subroutine 185 186! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_nonpointer_function() { 187! CHECK: %[[TMP:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = ".result"} 188! CHECK: %{{.*}} = fir.call @_FortranAioBeginExternalListOutput 189! CHECK: %[[RES:.*]] = fir.call @_QMderived_type_finalizationPget_t1(%{{.*}}) {{.*}} : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> 190! CHECK: fir.save_result %[[RES]] to %[[TMP]] : !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>, !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>> 191! CHECK: %{{.*}} = fir.call @_FortranAioOutputDerivedType 192! CHECK-NOT: fir.call @_FortranADestroy 193! CHECK: %{{.*}} = fir.call @_FortranAioEndIoStatement 194! CHECK: return 195 196 subroutine test_avoid_double_finalization(a) 197 type(t3), intent(inout) :: a 198 type(t3) :: b 199 b = a 200 end subroutine 201 202! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_avoid_double_finalization( 203! CHECK: fir.call @_FortranAInitialize( 204! CHECK-NOT: fir.call @_FortranADestroy 205! CHECK: fir.call @_FortranAAssign( 206! CHECK: fir.call @_FortranADestroy( 207 208 function no_func_ret_finalize() result(ty) 209 type(t1) :: ty 210 ty = t1(10) 211 end function 212 213! CHECK-LABEL: func.func @_QMderived_type_finalizationPno_func_ret_finalize() -> !fir.type<_QMderived_type_finalizationTt1{a:i32}> { 214! CHECK: fir.call @_FortranAAssign 215! CHECK-NOT: fir.call @_FortranADestroy 216! CHECK: return %{{.*}} : !fir.type<_QMderived_type_finalizationTt1{a:i32}> 217 218 function copy(a) result(ty) 219 class(t1), allocatable :: ty(:) 220 integer, intent(in) :: a 221 allocate(t1::ty(a)) 222 ty%a = 1 223 end function 224 225 subroutine test_avoid_double_free() 226 class(*), allocatable :: up(:) 227 allocate(up(10), source=copy(10)) 228 end subroutine 229 230! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_avoid_double_free() { 231! CHECK: %[[RES:.*]] = fir.alloca !fir.class<!fir.heap<!fir.array<?x!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>> {bindc_name = ".result"} 232! CHECK: fir.call @_FortranAAllocatableAllocateSource( 233! CHECK-NOT: fir.freemem %{{.*}} : !fir.heap<!fir.array<?x!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> 234! CHECK: %[[RES_CONV:.*]] = fir.convert %[[RES]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>>) -> !fir.box<none> 235! CHECK: fir.call @_FortranADestroy(%[[RES_CONV]]) {{.*}} : (!fir.box<none>) -> () 236 237 subroutine t4_final(this) 238 type(t4) :: this 239 end subroutine 240 241 subroutine local_t4() 242 type(t4) :: t 243 end subroutine 244 245! CHECK-LABEL: func.func @_QMderived_type_finalizationPlocal_t4() 246! CHECK: fir.call @_FortranADestroy(%2) fastmath<contract> : (!fir.box<none>) -> () 247 248end module 249 250program p 251 use derived_type_finalization 252 type(t1) :: t 253end program 254 255! CHECK-LABEL: func.func @_QQmain() attributes {fir.bindc_name = "p"} { 256! CHECK-NOT: fir.call @_FortranADestroy 257