gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/55763
   4 !
   5 ! Contributed by Reinhold Bader
   6 !
   7 module mod_alloc_scalar_01
   8 contains
   9   subroutine construct(this)
  10     class(*), allocatable, intent(out) :: this
  11     integer :: this_i
  12     this_i = 4
  13     allocate(this, source=this_i)
  14   end subroutine
  15 end module
  16
  17 program alloc_scalar_01
  18   use mod_alloc_scalar_01
  19   implicit none
  20   class(*), allocatable :: mystuff
  21
  22   call construct(mystuff)
  23   call construct(mystuff)
  24
  25   select type(mystuff)
  26   type is (integer)
  27     if (mystuff == 4) then
  28 !      write(*,*) 'OK'
  29     else
  30       call abort()
  31 !     write(*,*) 'FAIL 1'
  32     end if
  33   class default
  34     call abort()
  35 !    write(*,*) 'FAIL 2'
  36   end select
  37 end program