67f9b5ae7d
This patch is fixing two issue relative to the dynamic dispatch for polymorphic entities. 1. Fix the `requireDispatchCall` function. It was checking for the first symbol of the component but this is not the one to be checked. Instead the last symbol of the base of the component object is the one to check to know if it is polymorphic object with a dispatch call or not. This is demonstrated in the new added test in `flang/test/Lower/dispatch.f90` where the first symbol would point to `q` which is monomorphic and would result in a simple `fir.call` 2. Fix the pass object in a no pass situation. In a no pass situation the pass object is lowered anyway to be able to do the lookup in the binding table. It was previously lowered wrongly an lead to unresolved lookup. The base of the component is the passed object and should be lowered. To achieve this, the `gen(DataRef)` entry point is exposed form `ConvertExprToHLFIR` through a `convertDataRefToValue` function. The same test added in `flang/test/Lower/dispatch.f90` is checking for the correct passed object. In addition couple of tests were updated to HLFIR since the lowering used only works with it.
54 lines
2.0 KiB
Fortran
54 lines
2.0 KiB
Fortran
! RUN: bbc -polymorphic-type -emit-hlfir %s -o - | FileCheck %s
|
|
|
|
module poly
|
|
type p1
|
|
integer :: a
|
|
integer :: b
|
|
contains
|
|
procedure, nopass :: proc1 => proc1_p1
|
|
end type
|
|
|
|
type, extends(p1) :: p2
|
|
integer :: c
|
|
contains
|
|
procedure, nopass :: proc1 => proc1_p2
|
|
end type
|
|
|
|
contains
|
|
|
|
subroutine proc1_p1()
|
|
print*, 'call proc1_p1'
|
|
end subroutine
|
|
|
|
subroutine proc1_p2()
|
|
print*, 'call proc1_p2'
|
|
end subroutine
|
|
|
|
subroutine test_nullify()
|
|
class(p1), pointer :: c
|
|
|
|
allocate(p2::c)
|
|
call c%proc1()
|
|
|
|
nullify(c) ! c dynamic type must be reset to p1
|
|
|
|
call c%proc1()
|
|
end subroutine
|
|
end module
|
|
|
|
program test
|
|
use poly
|
|
call test_nullify()
|
|
end
|
|
|
|
! CHECK-LABEL: func.func @_QMpolyPtest_nullify()
|
|
! CHECK: %[[C_DESC:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>> {bindc_name = "c", uniq_name = "_QMpolyFtest_nullifyEc"}
|
|
! CHECK: %[[C_DESC_DECL:.*]]:2 = hlfir.declare %28 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QMpolyFtest_nullifyEc"} : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>) -> (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>, !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>)
|
|
! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
|
|
! CHECK: %[[DECLARED_TYPE_DESC:.*]] = fir.type_desc !fir.type<_QMpolyTp1{a:i32,b:i32}>
|
|
! CHECK: %[[C_DESC_CAST:.*]] = fir.convert %[[C_DESC_DECL]]#1 : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
|
|
! CHECK: %[[TYPE_DESC_CAST:.*]] = fir.convert %[[DECLARED_TYPE_DESC]] : (!fir.tdesc<!fir.type<_QMpolyTp1{a:i32,b:i32}>>) -> !fir.ref<none>
|
|
! CHECK: %[[RANK:.*]] = arith.constant 0 : i32
|
|
! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32
|
|
! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[C_DESC_CAST]], %[[TYPE_DESC_CAST]], %[[RANK]], %[[CORANK]]) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i32, i32) -> none
|