gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/55763
   4 !
   5 ! Based on Reinhold Bader's test case
   6 !
   7
   8 program mvall_03
   9   implicit none
  10   integer, parameter :: n1 = 100, n2 = 200
  11   class(*), allocatable :: i1(:), i3(:)
  12   integer, allocatable :: i2(:)
  13
  14   allocate(real :: i1(n1))
  15   allocate(i2(n2))
  16   i2 = 2
  17   call move_alloc(i2, i1)
  18   if (size(i1) /= n2 .or. allocated(i2)) then
  19     call abort
  20 !   write(*,*) 'FAIL'
  21   else
  22 !    write(*,*) 'OK'
  23   end if
  24
  25   select type (i1)
  26     type is (integer)
  27       if (any (i1 /= 2)) call abort
  28     class default
  29       call abort()
  30   end select
  31   call move_alloc (i1, i3)
  32   if (size(i3) /= n2 .or. allocated(i1)) then
  33     call abort()
  34   end if
  35   select type (i3)
  36     type is (integer)
  37       if (any (i3 /= 2)) call abort
  38     class default
  39       call abort()
  40   end select
  41 end program