gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90

   1 ! { dg-do run }
   2 !
   3 ! Test contributed by Valery Weber  <valeryweber@hotmail.com>
   4
   5 module mod
   6
   7   TYPE, PUBLIC :: base_type
   8   END TYPE base_type
   9
  10   TYPE, PUBLIC :: dict_entry_type
  11      CLASS( * ), ALLOCATABLE :: key
  12      CLASS( * ), ALLOCATABLE :: val
  13   END TYPE dict_entry_type
  14
  15
  16 contains
  17
  18   SUBROUTINE dict_put ( this, key, val )
  19     CLASS(dict_entry_type), INTENT(INOUT)     :: this
  20     CLASS(base_type), INTENT(IN)             :: key, val
  21     INTEGER                                  :: istat
  22     ALLOCATE( this%key, SOURCE=key, STAT=istat )
  23   end SUBROUTINE dict_put
  24 end module mod
  25
  26 program test
  27   use mod
  28   type(dict_entry_type) :: t
  29   type(base_type) :: a, b
  30   call dict_put(t, a, b)
  31
  32   if (.NOT. allocated(t%key)) STOP 1
  33   select type (x => t%key)
  34     type is (base_type)
  35     class default
  36       STOP 2
  37   end select
  38   deallocate(t%key)
  39 end
  40