gcc/testsuite/gfortran.dg/allocate_with_source_8.f08

   1 ! { dg-do run }
   2 !
   3 ! Contributed by Reinhold Bader
   4 !
   5 program assumed_shape_01
   6   implicit none
   7   type :: cstruct
   8      integer :: i
   9      real :: r(2)
  10   end type cstruct
  11
  12   type(cstruct), pointer :: u(:)
  13   integer, allocatable :: iv(:), iv2(:)
  14   integer, allocatable :: im(:,:)
  15   integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3])
  16   integer :: i
  17   integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10])
  18
  19   allocate(iv, source= [ 1, 2, 3, 4])
  20   if (any(iv /= [ 1, 2, 3, 4])) call abort()
  21   deallocate(iv)
  22
  23   allocate(iv, source=(/(i, i=1,10)/))
  24   if (any(iv /= (/(i, i=1,10)/))) call abort()
  25
  26   ! Now 2D
  27   allocate(im, source= cim)
  28   if (any(im /= cim)) call abort()
  29   deallocate(im)
  30
  31   allocate(im, source= reshape([iv, iv], [2, size(iv, 1)]))
  32   if (any(im /= lcim)) call abort()
  33   deallocate(im)
  34   deallocate(iv)
  35
  36   allocate(u, source=[cstruct( 4, [1.1,2.2] )] )
  37   if (any(u(:)%i /= 4) .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
  38   deallocate (u)
  39
  40   allocate(iv, source= arrval())
  41   if (any(iv /= [ 1, 2, 4, 5, 6])) call abort()
  42   ! Check simple array assign
  43   allocate(iv2, source=iv)
  44   if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort()
  45   deallocate(iv, iv2)
  46
  47   ! Now check for mold=
  48   allocate(iv, mold= [ 1, 2, 3, 4])
  49   if (any(shape(iv) /= [4])) call abort()
  50   deallocate(iv)
  51
  52   allocate(iv, mold=(/(i, i=1,10)/))
  53   if (any(shape(iv) /= [10])) call abort()
  54
  55   ! Now 2D
  56   allocate(im, mold= cim)
  57   if (any(shape(im) /= shape(cim))) call abort()
  58   deallocate(im)
  59
  60   allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)]))
  61   if (any(shape(im) /= shape(lcim))) call abort()
  62   deallocate(im)
  63   deallocate(iv)
  64
  65   allocate(u, mold=[cstruct( 4, [1.1,2.2] )] )
  66   if (any(shape(u(1)%r(:)) /= 2)) call abort()
  67   deallocate (u)
  68
  69   allocate(iv, mold= arrval())
  70   if (any(shape(iv) /= [5])) call abort()
  71   ! Check simple array assign
  72   allocate(iv2, mold=iv)
  73   if (any(shape(iv2) /= [5])) call abort()
  74   deallocate(iv, iv2)
  75
  76   call addData([4, 5])
  77   call addData(["foo", "bar"])
  78 contains
  79   function arrval()
  80     integer, dimension(5) :: arrval
  81     arrval = [ 1, 2, 4, 5, 6]
  82   end function
  83
  84   subroutine addData(P)
  85     class(*), intent(in) :: P(:)
  86     class(*), allocatable :: cP(:)
  87     allocate (cP, source= P)
  88     select type (cP)
  89       type is (integer)
  90         if (any(cP /= [4,5])) call abort()
  91       type is (character(*))
  92         if (len(cP) /= 3) call abort()
  93         if (any(cP /= ["foo", "bar"])) call abort()
  94       class default
  95         call abort()
  96     end select
  97     deallocate (cP)
  98     allocate (cP, mold= P)
  99     select type (cP)
 100       type is (integer)
 101         if (any(size(cP) /= [2])) call abort()
 102       type is (character(*))
 103         if (len(cP) /= 3) call abort()
 104         if (any(size(cP) /= [2])) call abort()
 105       class default
 106         call abort()
 107     end select
 108     deallocate (cP)
 109   end subroutine
 110 end program assumed_shape_01