1! { dg-do run }
2!
3! Test that pr72832 is fixed now.
4! Contributed by Daan van Vugt
5
6program allocate_source
7  type :: t
8    integer :: i
9  end type t
10  type, extends(t) :: tt
11  end type tt
12
13  call test_type()
14  call test_class()
15
16contains
17
18subroutine test_class()
19  class(t), allocatable, dimension(:) :: a, b
20  allocate(tt::a(1:2))
21  a(:)%i = [ 1,2 ]
22  if (size(a) /= 2) STOP 1
23  if (any(a(:)%i /= [ 1,2])) STOP 2
24
25  allocate(b(1:4), source=a)
26  ! b is incorrectly initialized here.  This only is diagnosed when compiled
27  ! with -fcheck=bounds.
28  if (size(b) /= 4) STOP 3
29  if (any(b(1:2)%i /= [ 1,2])) STOP 4
30  select type (b1 => b(1))
31    class is (tt)
32      continue
33    class default
34      STOP 5
35  end select
36end subroutine
37
38subroutine test_type()
39  type(t), allocatable, dimension(:) :: a, b
40  allocate(a(1:2))
41  if (size(a) /= 2) STOP 6
42
43  allocate(b(1:4), source=a)
44  if (size(b) /= 4) STOP 7
45end subroutine
46end program allocate_source
47
48
49