gcc/testsuite/gfortran.dg/allocate_with_source_16.f90

   1 ! { dg-do run }
   2 ! Test the fix for pr69011, preventing an ICE and making sure
   3 ! that the correct dynamic type is used.
   4 !
   5 ! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
   6 !                Andre Vehreschild  <vehre@gcc.gnu.org>
   7 !
   8
   9 module m1
  10 implicit none
  11 private
  12 public :: basetype
  13
  14 type:: basetype
  15   integer :: i
  16   contains
  17 endtype basetype
  18
  19 abstract interface
  20 endinterface
  21
  22 endmodule m1
  23
  24 module m2
  25 use m1, only : basetype
  26 implicit none
  27 integer, parameter :: I_P = 4
  28
  29 private
  30 public :: factory, exttype
  31
  32 type, extends(basetype) :: exttype
  33   integer :: i2
  34   contains
  35 endtype exttype
  36
  37 type :: factory
  38   integer(I_P) :: steps=-1
  39   contains
  40     procedure, pass(self), public :: construct
  41 endtype factory
  42 contains
  43
  44   function construct(self, previous)
  45   class(basetype), intent(INOUT) :: previous(1:)
  46   class(factory), intent(IN) :: self
  47   class(basetype), pointer :: construct
  48   allocate(construct, source=previous(self%steps))
  49   endfunction construct
  50 endmodule m2
  51
  52   use m2
  53   use m1
  54   class(factory), allocatable :: c1
  55   class(exttype), allocatable :: prev(:)
  56   class(basetype), pointer :: d
  57
  58   allocate(c1)
  59   allocate(prev(2))
  60   prev(:)%i = [ 2, 3]
  61   prev(:)%i2 = [ 5, 6]
  62   c1%steps= 1
  63   d=> c1%construct(prev)
  64
  65   if (.not. associated(d) ) call abort()
  66   select type (d)
  67     class is (exttype)
  68       if (d%i2 /= 5) call abort()
  69     class default
  70       call abort()
  71   end select
  72   if (d%i /= 2) call abort()
  73   deallocate(c1)
  74   deallocate(prev)
  75   deallocate(d)
  76 end