gcc/testsuite/gfortran.dg/move_alloc_10.f90

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