llvm/flang/test/Lower/polymorphic-types.f90

! RUN: bbc -emit-fir -hlfir=false %s -o - | FileCheck %s

! Tests the different possible type involving polymorphic entities. 

module polymorphic_types
  type p1
    integer :: a
    integer :: b
  contains
    procedure :: polymorphic_dummy
  end type
contains

! ------------------------------------------------------------------------------
! Test polymorphic entity types
! ------------------------------------------------------------------------------

  subroutine polymorphic_dummy(p)
    class(p1) :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy(
! CHECK-SAME: %{{.*}}: !fir.class<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>

  subroutine polymorphic_dummy_assumed_shape_array(pa)
    class(p1) :: pa(:)
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy_assumed_shape_array(
! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>

  subroutine polymorphic_dummy_explicit_shape_array(pa)
    class(p1) :: pa(10)
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy_explicit_shape_array(
! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<10x!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>

  subroutine polymorphic_allocatable(p)
    class(p1), allocatable :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_allocatable(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>

  subroutine polymorphic_pointer(p)
    class(p1), pointer :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_pointer(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>

  subroutine polymorphic_allocatable_intentout(p)
    class(p1), allocatable, intent(out) :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_allocatable_intentout(
! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32

! ------------------------------------------------------------------------------
! Test unlimited polymorphic dummy argument types
! ------------------------------------------------------------------------------

  subroutine unlimited_polymorphic_dummy(u)
    class(*) :: u
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_dummy(
! CHECK-SAME: %{{.*}}: !fir.class<none>

  subroutine unlimited_polymorphic_assumed_shape_array(ua)
    class(*) :: ua(:)
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_assumed_shape_array(
! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<?xnone>>

  subroutine unlimited_polymorphic_explicit_shape_array(ua)
    class(*) :: ua(20)
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_explicit_shape_array(
! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<20xnone>>

  subroutine unlimited_polymorphic_allocatable(p)
    class(*), allocatable :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_allocatable(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.heap<none>>>

  subroutine unlimited_polymorphic_pointer(p)
    class(*), pointer :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_pointer(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.ptr<none>>>

  subroutine unlimited_polymorphic_allocatable_intentout(p)
    class(*), allocatable, intent(out) :: p
  end subroutine

! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_allocatable_intentout(
! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.heap<none>>>
! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32

! ------------------------------------------------------------------------------
! Test polymorphic function return types
! ------------------------------------------------------------------------------

  function ret_polymorphic_allocatable() result(ret)
    class(p1), allocatable :: ret
  end function

! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_polymorphic_allocatable() -> !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_polymorphic_allocatableEret"}
! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>
! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>) -> !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
! CHECK: return %[[LOAD]] : !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>

  function ret_polymorphic_pointer() result(ret)
    class(p1), pointer :: ret
  end function

! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_polymorphic_pointer() -> !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_polymorphic_pointerEret"}
! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>
! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>) -> !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
! CHECK: return %[[LOAD]] : !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>

! ------------------------------------------------------------------------------
! Test unlimited polymorphic function return types
! ------------------------------------------------------------------------------

  function ret_unlimited_polymorphic_allocatable() result(ret)
    class(*), allocatable :: ret
  end function

! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_unlimited_polymorphic_allocatable() -> !fir.class<!fir.heap<none>>
! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.heap<none>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_unlimited_polymorphic_allocatableEret"}
! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<none>
! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.heap<none>) -> !fir.class<!fir.heap<none>>
! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.heap<none>>>
! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.heap<none>>>
! CHECK: return %[[LOAD]] : !fir.class<!fir.heap<none>>

  function ret_unlimited_polymorphic_pointer() result(ret)
    class(*), pointer :: ret
  end function

! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_unlimited_polymorphic_pointer() -> !fir.class<!fir.ptr<none>>
! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.ptr<none>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_unlimited_polymorphic_pointerEret"}
! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr<none>
! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.ptr<none>) -> !fir.class<!fir.ptr<none>>
! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<none>>>
! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<none>>>
! CHECK: return %[[LOAD]] : !fir.class<!fir.ptr<none>>

! ------------------------------------------------------------------------------
! Test assumed type argument types
! ------------------------------------------------------------------------------

  subroutine assumed_type_dummy(a) bind(c)
    type(*) :: a
  end subroutine assumed_type_dummy

  ! CHECK-LABEL: func.func @assumed_type_dummy(
  ! CHECK-SAME: %{{.*}}: !fir.ref<none>

  subroutine assumed_type_dummy_array(a) bind(c)
    type(*) :: a(:)
  end subroutine assumed_type_dummy_array

  ! CHECK-LABEL: func.func @assumed_type_dummy_array(
  ! CHECK-SAME: %{{.*}}: !fir.box<!fir.array<?xnone>>

end module