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
108
109
110
111
112
113
114
115
116
117
118
119
|
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests the fixes for three bugs with the same underlying cause. All are regressions
! that come about because class array elements end up with a different tree type
! to the class array. In addition, the language specific flag that marks a class
! container is not being set.
!
! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com>
! PR54990 contributed by Janus Weil <janus@gcc.gnu.org>
! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org>
! The two latter bugs were reported by Andrew Benson
! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
!
module G_Nodes
type :: nc
type(tn), pointer :: hostNode
end type nc
type, extends(nc) :: ncBh
end type ncBh
type, public, extends(ncBh) :: ncBhStd
double precision :: massSeedData
end type ncBhStd
type, public :: tn
class (ncBh), allocatable, dimension(:) :: cBh
end type tn
type(ncBhStd) :: defaultBhC
contains
subroutine Node_C_Bh_Move(targetNode)
implicit none
type (tn ), intent(inout) , target :: targetNode
class(ncBh), allocatable , dimension(:) :: instancesTemporary
! These two lines resulted in the wrong result:
allocate(instancesTemporary(2),source=defaultBhC)
call Move_Alloc(instancesTemporary,targetNode%cBh)
! These two lines gave the correct result:
!!deallocate(targetNode%cBh)
!!allocate(targetNode%cBh(2))
targetNode%cBh(1)%hostNode => targetNode
targetNode%cBh(2)%hostNode => targetNode
return
end subroutine Node_C_Bh_Move
function bhGet(self,instance)
implicit none
class (ncBh), pointer :: bhGet
class (tn ), intent(inout), target :: self
integer , intent(in ) :: instance
bhGet => self%cBh(instance)
return
end function bhGet
end module G_Nodes
call pr53876
call pr54990
call pr54992
end
subroutine pr53876
IMPLICIT NONE
TYPE :: individual
integer :: icomp ! Add an extra component to test offset
REAL, DIMENSION(:), ALLOCATABLE :: genes
END TYPE
CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
allocate (indv(2), source = [individual(1, [99,999]), &
individual(2, [999,9999])])
CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
CONTAINS
SUBROUTINE display_indv(self)
CLASS(individual), INTENT(IN) :: self
if (any(self%genes .ne. [999,9999]) )call abort
END SUBROUTINE
END
subroutine pr54990
implicit none
type :: ncBhStd
integer :: i
end type
type, extends(ncBhStd) :: ncBhStde
integer :: i2(2)
end type
type :: tn
integer :: i ! Add an extra component to test offset
class (ncBhStd), allocatable, dimension(:) :: cBh
end type
integer :: i
type(tn), target :: a
allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
type is (ncBhStd)
call abort
type is (ncBhStde)
if (q%i .ne. 198) call abort ! This tests that the component really gets the
end select ! language specific flag denoting a class type
end
subroutine pr54992 ! This test remains as the original.
use G_Nodes
implicit none
type (tn), target :: b
class(ncBh), pointer :: bh
class(ncBh), allocatable, dimension(:) :: t
allocate(b%cBh(1),source=defaultBhC)
b%cBh(1)%hostNode => b
! #1 this worked
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
call Node_C_Bh_Move(b)
! #2 this worked
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
! #3 this did not
bh => bhGet(b,instance=1)
if (loc (b) .ne. loc(bh%hostNode)) call abort
bh => bhGet(b,instance=2)
if (loc (b) .ne. loc(bh%hostNode)) call abort
end
! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
|
