gcc/testsuite/gfortran.dg/allocate_with_source_23.f03

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=bounds" }
   3 ! { dg-shouldfail "Array bounds mismatch" }
   4 !
   5 ! Test that pr72832 is fixed now.
   6 ! Contributed by Daan van Vugt
   7
   8 program allocate_source
   9   type :: t
  10     integer :: i
  11   end type t
  12   type, extends(t) :: tt
  13   end type tt
  14
  15   call test_type()
  16   call test_class_correct()
  17   call test_class_fail()
  18
  19 contains
  20
  21 subroutine test_class_correct()
  22   class(t), allocatable, dimension(:) :: a, b
  23   allocate(tt::a(1:2))
  24   a(:)%i = [ 1,2 ]
  25   if (size(a) /= 2) STOP 1
  26   if (any(a(:)%i /= [ 1,2])) STOP 2
  27
  28   allocate(b(1:4), source=a(1))
  29   if (size(b) /= 4) STOP 3
  30   if (any(b(:)%i /= [ 1,1,1,1])) STOP 4
  31   select type (b1 => b(1))
  32     class is (tt)
  33       continue
  34     class default
  35       STOP 5
  36   end select
  37 end subroutine
  38
  39 subroutine test_class_fail()
  40   class(t), allocatable, dimension(:) :: a, b
  41   allocate(tt::a(1:2))
  42   a(:)%i = [ 1,2 ]
  43   if (size(a) /= 2) STOP 6
  44   if (any(a(:)%i /= [ 1,2])) STOP 7
  45
  46   allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
  47   if (size(b) /= 4) STOP 8
  48   if (any(b(1:2)%i /= [ 1,2])) STOP 9
  49   select type (b1 => b(1))
  50     class is (tt)
  51       continue
  52     class default
  53       STOP 10
  54   end select
  55 end subroutine
  56
  57 subroutine test_type()
  58   type(t), allocatable, dimension(:) :: a, b
  59   allocate(a(1:2))
  60   if (size(a) /= 2) STOP 11
  61
  62   allocate(b(1:4), source=a)
  63   if (size(b) /= 4) STOP 12
  64 end subroutine
  65 end program allocate_source
  66
  67