gcc/testsuite/gfortran.dg/move_alloc_6.f90

   1 ! { dg-do run }
   2 !
   3 ! Test move_alloc for polymorphic scalars
   4 !
   5 !
   6 module myalloc
   7   implicit none
   8
   9   type :: base_type
  10      integer :: i  =2
  11   end type base_type
  12
  13   type, extends(base_type) :: extended_type
  14      integer :: j = 77
  15   end type extended_type
  16 contains
  17   subroutine myallocate (a)
  18     class(base_type), allocatable, intent(inout) :: a
  19     class(base_type), allocatable :: tmp
  20
  21     allocate (extended_type :: tmp)
  22
  23     select type(tmp)
  24       type is(base_type)
  25         STOP 1
  26       type is(extended_type)
  27         if (tmp%i /= 2 .or. tmp%j /= 77) STOP 2
  28         tmp%i = 5
  29         tmp%j = 88
  30     end select
  31
  32     select type(a)
  33       type is(base_type)
  34         if (a%i /= -44) STOP 3
  35         a%i = -99
  36       class default
  37         STOP 4
  38     end select
  39
  40     call move_alloc (from=tmp, to=a)
  41
  42     select type(a)
  43       type is(extended_type)
  44         if (a%i /= 5) STOP 5
  45         if (a%j /= 88) STOP 6
  46         a%i = 123
  47         a%j = 9498
  48       class default
  49         STOP 7
  50     end select
  51
  52     if (allocated (tmp)) STOP 8
  53   end subroutine myallocate
  54 end module myalloc
  55
  56 program main
  57   use myalloc
  58   implicit none
  59   class(base_type), allocatable :: a
  60
  61   allocate (a)
  62
  63   select type(a)
  64     type is(base_type)
  65       if (a%i /= 2) STOP 9
  66       a%i = -44
  67     class default
  68       STOP 10
  69   end select
  70
  71   call myallocate (a)
  72
  73   select type(a)
  74     type is(extended_type)
  75       if (a%i /= 123) STOP 11
  76       if (a%j /= 9498) STOP 12
  77     class default
  78       STOP 13
  79   end select
  80 end program main