gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f03

   1 ! { dg-do run }
   2 !
   3 ! Test the fix of the test case referenced in comment 17 of PR83118.
   4 !
   5 ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
   6 !
   7   implicit none
   8   type Wrapper
   9     class(*), allocatable :: elements(:)
  10   end type
  11   type Mytype
  12     real(4) :: r = 42.0
  13   end type
  14
  15   call driver
  16 contains
  17   subroutine driver
  18     class(*), allocatable :: obj
  19     type(Wrapper) w
  20     integer(4) :: expected4(2) = [42_4, 43_4]
  21     integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
  22
  23     w = new_wrapper (expected4)
  24     obj = w
  25     call test (obj, 0)
  26     obj =  new_wrapper (expected8) ! Used to generate a linker error
  27     call test (obj, 10)
  28     obj = new_wrapper ([mytype (99.0)])
  29     call test (obj, 100)
  30     obj = Mytype (42.0) ! Used to generate a linker error
  31     call test (obj, 1000)
  32   end subroutine
  33   function new_wrapper(array) result (res)
  34     class(*) :: array(:)
  35     type(Wrapper) :: res
  36     res%elements = array ! Used to runtime segfault
  37   end function
  38   subroutine test (arg, idx)
  39     class(*) :: arg
  40     integer :: idx
  41     select type (arg)
  42       type is (wrapper)
  43         select type (z => arg%elements)
  44           type is (integer(4))
  45             if (any (z .ne. [42_4, 43_4])) stop 1 + idx
  46           type is (integer(8))
  47             if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
  48           type is (Mytype)
  49             if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
  50         class default
  51           stop 2 + idx
  52         end select
  53       type is (Mytype)
  54         if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
  55       class default
  56         stop 3 + idx
  57     end select
  58   end subroutine
  59 end