|
111
|
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) call abort()
|
|
|
26 if (any(a(:)%i /= [ 1,2])) call abort()
|
|
|
27
|
|
|
28 allocate(b(1:4), source=a(1))
|
|
|
29 if (size(b) /= 4) call abort()
|
|
|
30 if (any(b(:)%i /= [ 1,1,1,1])) call abort()
|
|
|
31 select type (b(1))
|
|
|
32 class is (tt)
|
|
|
33 continue
|
|
|
34 class default
|
|
|
35 call abort()
|
|
|
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) call abort()
|
|
|
44 if (any(a(:)%i /= [ 1,2])) call abort()
|
|
|
45
|
|
|
46 allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
|
|
|
47 if (size(b) /= 4) call abort()
|
|
|
48 if (any(b(1:2)%i /= [ 1,2])) call abort()
|
|
|
49 select type (b(1))
|
|
|
50 class is (tt)
|
|
|
51 continue
|
|
|
52 class default
|
|
|
53 call abort()
|
|
|
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) call abort()
|
|
|
61
|
|
|
62 allocate(b(1:4), source=a)
|
|
|
63 if (size(b) /= 4) call abort()
|
|
|
64 end subroutine
|
|
|
65 end program allocate_source
|
|
|
66
|
|
|
67
|
