flang/test/Lower/polymorphic-types.f90

   1 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
   2
   3 ! Tests the different possible type involving polymorphic entities.
   4
   5 module polymorphic_types
   6   type p1
   7     integer :: a
   8     integer :: b
   9   contains
  10     procedure :: polymorphic_dummy
  11   end type
  12 contains
  13
  14 ! ------------------------------------------------------------------------------
  15 ! Test polymorphic entity types
  16 ! ------------------------------------------------------------------------------
  17
  18   subroutine polymorphic_dummy(p)
  19     class(p1) :: p
  20   end subroutine
  21
  22 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy(
  23 ! CHECK-SAME: %{{.*}}: !fir.class<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>
  24
  25   subroutine polymorphic_dummy_assumed_shape_array(pa)
  26     class(p1) :: pa(:)
  27   end subroutine
  28
  29 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy_assumed_shape_array(
  30 ! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
  31
  32   subroutine polymorphic_dummy_explicit_shape_array(pa)
  33     class(p1) :: pa(10)
  34   end subroutine
  35
  36 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_dummy_explicit_shape_array(
  37 ! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<10x!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
  38
  39   subroutine polymorphic_allocatable(p)
  40     class(p1), allocatable :: p
  41   end subroutine
  42
  43 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_allocatable(
  44 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
  45
  46   subroutine polymorphic_pointer(p)
  47     class(p1), pointer :: p
  48   end subroutine
  49
  50 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_pointer(
  51 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
  52
  53   subroutine polymorphic_allocatable_intentout(p)
  54     class(p1), allocatable, intent(out) :: p
  55   end subroutine
  56
  57 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_allocatable_intentout(
  58 ! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
  59 ! 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>>
  60 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
  61
  62 ! ------------------------------------------------------------------------------
  63 ! Test unlimited polymorphic dummy argument types
  64 ! ------------------------------------------------------------------------------
  65
  66   subroutine unlimited_polymorphic_dummy(u)
  67     class(*) :: u
  68   end subroutine
  69
  70 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_dummy(
  71 ! CHECK-SAME: %{{.*}}: !fir.class<none>
  72
  73   subroutine unlimited_polymorphic_assumed_shape_array(ua)
  74     class(*) :: ua(:)
  75   end subroutine
  76
  77 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_assumed_shape_array(
  78 ! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<?xnone>>
  79
  80   subroutine unlimited_polymorphic_explicit_shape_array(ua)
  81     class(*) :: ua(20)
  82   end subroutine
  83
  84 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_explicit_shape_array(
  85 ! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<20xnone>>
  86
  87   subroutine unlimited_polymorphic_allocatable(p)
  88     class(*), allocatable :: p
  89   end subroutine
  90
  91 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_allocatable(
  92 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.heap<none>>>
  93
  94   subroutine unlimited_polymorphic_pointer(p)
  95     class(*), pointer :: p
  96   end subroutine
  97
  98 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_pointer(
  99 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.class<!fir.ptr<none>>>
 100
 101   subroutine unlimited_polymorphic_allocatable_intentout(p)
 102     class(*), allocatable, intent(out) :: p
 103   end subroutine
 104
 105 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_allocatable_intentout(
 106 ! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.heap<none>>>
 107 ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
 108 ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
 109
 110 ! ------------------------------------------------------------------------------
 111 ! Test polymorphic function return types
 112 ! ------------------------------------------------------------------------------
 113
 114   function ret_polymorphic_allocatable() result(ret)
 115     class(p1), allocatable :: ret
 116   end function
 117
 118 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_polymorphic_allocatable() -> !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
 119 ! 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"}
 120 ! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>
 121 ! 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}>>>
 122 ! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
 123 ! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
 124 ! CHECK: return %[[LOAD]] : !fir.class<!fir.heap<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
 125
 126   function ret_polymorphic_pointer() result(ret)
 127     class(p1), pointer :: ret
 128   end function
 129
 130 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_polymorphic_pointer() -> !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
 131 ! 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"}
 132 ! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>
 133 ! 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}>>>
 134 ! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
 135 ! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>>
 136 ! CHECK: return %[[LOAD]] : !fir.class<!fir.ptr<!fir.type<_QMpolymorphic_typesTp1{a:i32,b:i32}>>>
 137
 138 ! ------------------------------------------------------------------------------
 139 ! Test unlimited polymorphic function return types
 140 ! ------------------------------------------------------------------------------
 141
 142   function ret_unlimited_polymorphic_allocatable() result(ret)
 143     class(*), allocatable :: ret
 144   end function
 145
 146 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_unlimited_polymorphic_allocatable() -> !fir.class<!fir.heap<none>>
 147 ! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.heap<none>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_unlimited_polymorphic_allocatableEret"}
 148 ! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<none>
 149 ! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.heap<none>) -> !fir.class<!fir.heap<none>>
 150 ! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.heap<none>>>
 151 ! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.heap<none>>>
 152 ! CHECK: return %[[LOAD]] : !fir.class<!fir.heap<none>>
 153
 154   function ret_unlimited_polymorphic_pointer() result(ret)
 155     class(*), pointer :: ret
 156   end function
 157
 158 ! CHECK-LABEL: func.func @_QMpolymorphic_typesPret_unlimited_polymorphic_pointer() -> !fir.class<!fir.ptr<none>>
 159 ! CHECK: %[[MEM:.*]] = fir.alloca !fir.class<!fir.ptr<none>> {bindc_name = "ret", uniq_name = "_QMpolymorphic_typesFret_unlimited_polymorphic_pointerEret"}
 160 ! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.ptr<none>
 161 ! CHECK: %[[BOX:.*]] = fir.embox %[[ZERO]] : (!fir.ptr<none>) -> !fir.class<!fir.ptr<none>>
 162 ! CHECK: fir.store %[[BOX]] to %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<none>>>
 163 ! CHECK: %[[LOAD:.*]] = fir.load %[[MEM]] : !fir.ref<!fir.class<!fir.ptr<none>>>
 164 ! CHECK: return %[[LOAD]] : !fir.class<!fir.ptr<none>>
 165
 166 ! ------------------------------------------------------------------------------
 167 ! Test assumed type argument types
 168 ! ------------------------------------------------------------------------------
 169
 170   subroutine assumed_type_dummy(a) bind(c)
 171     type(*) :: a
 172   end subroutine assumed_type_dummy
 173
 174   ! CHECK-LABEL: func.func @assumed_type_dummy(
 175   ! CHECK-SAME: %{{.*}}: !fir.box<none>
 176
 177   subroutine assumed_type_dummy_array(a) bind(c)
 178     type(*) :: a(:)
 179   end subroutine assumed_type_dummy_array
 180
 181   ! CHECK-LABEL: func.func @assumed_type_dummy_array(
 182   ! CHECK-SAME: %{{.*}}: !fir.box<!fir.array<?xnone>>
 183
 184 end module