1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
! { dg-do run }
! Tests the fix for PR59414, comment #3, in which the allocate
! expressions were not correctly being stripped to provide the
! vpointer as an lhs to the pointer assignment of the vptr from
! the SOURCE expression.
!
! Contributed by Antony Lewis <antony@cosmologist.info>
!
module ObjectLists
implicit none
type :: t
integer :: i
end type
type Object_array_pointer
class(t), pointer :: p(:)
end type
contains
subroutine AddArray1 (P, Pt)
class(t) :: P(:)
class(Object_array_pointer) :: Pt
select type (Pt)
class is (Object_array_pointer)
if (associated (Pt%P)) deallocate (Pt%P)
allocate(Pt%P(1:SIZE(P)), source=P)
end select
end subroutine
subroutine AddArray2 (P, Pt)
class(t) :: P(:)
class(Object_array_pointer) :: Pt
select type (Pt)
type is (Object_array_pointer)
if (associated (Pt%P)) deallocate (Pt%P)
allocate(Pt%P(1:SIZE(P)), source=P)
end select
end subroutine
subroutine AddArray3 (P, Pt)
class(t) :: P
class(Object_array_pointer) :: Pt
select type (Pt)
class is (Object_array_pointer)
if (associated (Pt%P)) deallocate (Pt%P)
allocate(Pt%P(1:4), source=P)
end select
end subroutine
subroutine AddArray4 (P, Pt)
type(t) :: P(:)
class(Object_array_pointer) :: Pt
select type (Pt)
class is (Object_array_pointer)
if (associated (Pt%P)) deallocate (Pt%P)
allocate(Pt%P(1:SIZE(P)), source=P)
end select
end subroutine
end module
use ObjectLists
type(Object_array_pointer), pointer :: Pt
class(t), pointer :: P(:)
allocate (P(2), source = [t(1),t(2)])
allocate (Pt, source = Object_array_pointer(NULL()))
call AddArray1 (P, Pt)
select type (x => Pt%p)
type is (t)
if (any (x%i .ne. [1,2])) call abort
end select
deallocate (P)
deallocate (pt)
allocate (P(3), source = [t(3),t(4),t(5)])
allocate (Pt, source = Object_array_pointer(NULL()))
call AddArray2 (P, Pt)
select type (x => Pt%p)
type is (t)
if (any (x%i .ne. [3,4,5])) call abort
end select
deallocate (P)
deallocate (pt)
allocate (Pt, source = Object_array_pointer(NULL()))
call AddArray3 (t(6), Pt)
select type (x => Pt%p)
type is (t)
if (any (x%i .ne. [6,6,6,6])) call abort
end select
deallocate (pt)
allocate (Pt, source = Object_array_pointer(NULL()))
call AddArray4 ([t(7), t(8)], Pt)
select type (x => Pt%p)
type is (t)
if (any (x%i .ne. [7,8])) call abort
end select
deallocate (pt)
end
|
