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) STOP 1
  26    tmp%i = 5
  27    tmp%j = 88
  28
  29    select type(a)
  30      type is(base_type)
  31        if (a%i /= -44) STOP 2
  32        a%i = -99
  33      class default
  34        STOP 3
  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) STOP 4
  42        if (a%j /= 88) STOP 5
  43        a%i = 123
  44        a%j = 9498
  45      class default
  46        STOP 6
  47    end select
  48
  49    if (allocated (tmp)) STOP 7
  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) STOP 8
  63       a%i = -44
  64     class default
  65       STOP 9
  66   end select
  67
  68   call myallocate (a)
  69
  70   select type(a)
  71     type is(extended_type)
  72       if (a%i /= 123) STOP 10
  73       if (a%j /= 9498) STOP 11
  74     class default
  75       STOP 12
  76   end select
  77 end program main