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         call abort ()
  26       type is(extended_type)
  27         if (tmp%i /= 2 .or. tmp%j /= 77) call abort()
  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) call abort()
  35         a%i = -99
  36       class default
  37         call abort ()
  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) call abort()
  45         if (a%j /= 88) call abort()
  46         a%i = 123
  47         a%j = 9498
  48       class default
  49         call abort ()
  50     end select
  51
  52     if (allocated (tmp)) call abort()
  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) call abort()
  66       a%i = -44
  67     class default
  68       call abort ()
  69   end select
  70
  71   call myallocate (a)
  72
  73   select type(a)
  74     type is(extended_type)
  75       if (a%i /= 123) call abort()
  76       if (a%j /= 9498) call abort()
  77     class default
  78       call abort ()
  79   end select
  80 end program main