gcc/testsuite/gfortran.dg/allocate_with_source_7.f08

   1 ! { dg-do run }
   2 !
   3 ! Check that allocate with source for arrays without array-spec
   4 ! works.
   5 ! PR fortran/44672
   6 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   7 !                Antony Lewis  <antony@cosmologist.info>
   8 !                Andre Vehreschild  <vehre@gcc.gnu.org>
   9 !
  10
  11 program allocate_with_source_6
  12
  13   type P
  14     class(*), allocatable :: X(:,:)
  15   end type
  16
  17   type t
  18   end type t
  19
  20   type(t), allocatable :: a(:), b, c(:)
  21   integer :: num_params_used = 6
  22   integer, allocatable :: m(:)
  23
  24   allocate(b,c(5))
  25   allocate(a(5), source=b)
  26   deallocate(a)
  27   allocate(a, source=c)
  28   allocate(m, source=[(I, I=1, num_params_used)])
  29   if (any(m /= [(I, I=1, num_params_used)])) STOP 1
  30   deallocate(a,b,m)
  31   call testArrays()
  32
  33 contains
  34   subroutine testArrays()
  35     type L
  36       class(*), allocatable :: v(:)
  37     end type
  38     Type(P) Y
  39     type(L) o
  40     real arr(3,5)
  41     real, allocatable :: v(:)
  42
  43     arr = 5
  44     allocate(Y%X, source=arr)
  45     select type (R => Y%X)
  46       type is (real)
  47         if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) &
  48           STOP 2
  49       class default
  50         STOP 3
  51     end select
  52     deallocate(Y%X)
  53
  54     allocate(Y%X, source=arr(2:3,3:4))
  55     select type (R => Y%X)
  56       type is (real)
  57         if (any(reshape(R, [4]) /= [5,5,5,5])) &
  58           STOP 4
  59       class default
  60         STOP 5
  61     end select
  62     deallocate(Y%X)
  63
  64     allocate(o%v, source=arr(2,3:4))
  65     select type (R => o%v)
  66       type is (real)
  67         if (any(R /= [5,5])) &
  68           STOP 6
  69       class default
  70         STOP 7
  71     end select
  72     deallocate(o%v)
  73
  74     allocate(v, source=arr(2,1:5))
  75     if (any(v /= [5,5,5,5,5])) STOP 8
  76     deallocate(v)
  77   end subroutine testArrays
  78 end
  79