3 ! Tests the fixes for three bugs with the same underlying cause. All are regressions
4 ! that come about because class array elements end up with a different tree type
5 ! to the class array. In addition, the language specific flag that marks a class
6 ! container is not being set.
8 ! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com>
9 ! PR54990 contributed by Janus Weil <janus@gcc.gnu.org>
10 ! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org>
11 ! The two latter bugs were reported by Andrew Benson
12 ! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
16 type(tn), pointer :: hostNode
18 type, extends(nc) :: ncBh
20 type, public, extends(ncBh) :: ncBhStd
21 double precision :: massSeedData
24 class (ncBh), allocatable, dimension(:) :: cBh
26 type(ncBhStd) :: defaultBhC
28 subroutine Node_C_Bh_Move(targetNode)
30 type (tn ), intent(inout) , target :: targetNode
31 class(ncBh), allocatable , dimension(:) :: instancesTemporary
32 ! These two lines resulted in the wrong result:
33 allocate(instancesTemporary(2),source=defaultBhC)
34 call Move_Alloc(instancesTemporary,targetNode%cBh)
35 ! These two lines gave the correct result:
36 !!deallocate(targetNode%cBh)
37 !!allocate(targetNode%cBh(2))
38 targetNode%cBh(1)%hostNode => targetNode
39 targetNode%cBh(2)%hostNode => targetNode
41 end subroutine Node_C_Bh_Move
42 function bhGet(self,instance)
44 class (ncBh), pointer :: bhGet
45 class (tn ), intent(inout), target :: self
46 integer , intent(in ) :: instance
47 bhGet => self%cBh(instance)
60 integer :: icomp ! Add an extra component to test offset
61 REAL, DIMENSION(:), ALLOCATABLE :: genes
63 CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
64 allocate (indv(2), source = [individual(1, [99,999]), &
65 individual(2, [999,9999])])
66 CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
68 SUBROUTINE display_indv(self)
69 CLASS(individual), INTENT(IN) :: self
70 if (any(self%genes .ne. [999,9999]) )call abort
79 type, extends(ncBhStd) :: ncBhStde
83 integer :: i ! Add an extra component to test offset
84 class (ncBhStd), allocatable, dimension(:) :: cBh
88 allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
89 select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
93 if (q%i .ne. 198) call abort ! This tests that the component really gets the
94 end select ! language specific flag denoting a class type
97 subroutine pr54992 ! This test remains as the original.
100 type (tn), target :: b
101 class(ncBh), pointer :: bh
102 class(ncBh), allocatable, dimension(:) :: t
103 allocate(b%cBh(1),source=defaultBhC)
104 b%cBh(1)%hostNode => b
106 if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
107 call Node_C_Bh_Move(b)
109 if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
110 if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
112 bh => bhGet(b,instance=1)
113 if (loc (b) .ne. loc(bh%hostNode)) call abort
114 bh => bhGet(b,instance=2)
115 if (loc (b) .ne. loc(bh%hostNode)) call abort