1! { dg-do run }
2! { dg-options "-fdump-tree-original" }
3!
4! Tests the fixes for three bugs with the same underlying cause.  All are regressions
5! that come about because class array elements end up with a different tree type
6! to the class array.  In addition, the language specific flag that marks a class
7! container is not being set.
8!
9! PR53876 contributed by Prince Ogunbade  <pogos77@hotmail.com>
10! PR54990 contributed by Janus Weil  <janus@gcc.gnu.org>
11! PR54992 contributed by Tobias Burnus  <burnus@gcc.gnu.org>
12! The two latter bugs were reported by Andrew Benson
13! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
14!
15module G_Nodes
16  type :: nc
17    type(tn), pointer :: hostNode
18  end type nc
19  type, extends(nc) :: ncBh
20  end type ncBh
21  type, public, extends(ncBh) :: ncBhStd
22    double precision :: massSeedData
23  end type ncBhStd
24  type, public :: tn
25    class (ncBh), allocatable, dimension(:) :: cBh
26  end type tn
27  type(ncBhStd) :: defaultBhC
28contains
29  subroutine Node_C_Bh_Move(targetNode)
30    implicit none
31    type (tn  ), intent(inout) , target       :: targetNode
32    class(ncBh), allocatable   , dimension(:) :: instancesTemporary
33! These two lines resulted in the wrong result:
34    allocate(instancesTemporary(2),source=defaultBhC)
35    call Move_Alloc(instancesTemporary,targetNode%cBh)
36! These two lines gave the correct result:
37!!deallocate(targetNode%cBh)
38!!allocate(targetNode%cBh(2))
39    targetNode%cBh(1)%hostNode => targetNode
40    targetNode%cBh(2)%hostNode => targetNode
41    return
42  end subroutine Node_C_Bh_Move
43  function bhGet(self,instance)
44    implicit none
45    class (ncBh), pointer               :: bhGet
46    class (tn  ), intent(inout), target :: self
47    integer     , intent(in   )         :: instance
48    bhGet => self%cBh(instance)
49    return
50  end function bhGet
51end module G_Nodes
52
53  call pr53876
54  call pr54990
55  call pr54992
56end
57
58subroutine pr53876
59  IMPLICIT NONE
60  TYPE :: individual
61    integer :: icomp ! Add an extra component to test offset
62    REAL, DIMENSION(:), ALLOCATABLE :: genes
63  END TYPE
64  CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
65  allocate (indv(2), source = [individual(1, [99,999]), &
66                               individual(2, [999,9999])])
67  CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
68CONTAINS
69  SUBROUTINE display_indv(self)
70    CLASS(individual),  INTENT(IN) :: self
71    if (any(self%genes .ne. [999,9999]) )STOP 1
72  END SUBROUTINE
73END
74
75subroutine pr54990
76  implicit none
77  type :: ncBhStd
78    integer :: i
79  end type
80  type, extends(ncBhStd) :: ncBhStde
81    integer :: i2(2)
82  end type
83  type :: tn
84    integer :: i ! Add an extra component to test offset
85    class (ncBhStd), allocatable, dimension(:) :: cBh
86  end type
87  integer :: i
88  type(tn), target :: a
89  allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
90  select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
91    type is (ncBhStd)
92      STOP 2
93    type is (ncBhStde)
94      if (q%i .ne. 198) STOP 3! This tests that the component really gets the
95  end select                       ! language specific flag denoting a class type
96end
97
98subroutine pr54992  ! This test remains as the original.
99  use G_Nodes
100  implicit none
101  type (tn), target  :: b
102  class(ncBh), pointer :: bh
103  class(ncBh), allocatable, dimension(:) :: t
104  allocate(b%cBh(1),source=defaultBhC)
105  b%cBh(1)%hostNode => b
106! #1 this worked
107  if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 4
108  call Node_C_Bh_Move(b)
109! #2 this worked
110  if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 5
111  if (loc(b) .ne. loc(b%cBh(2)%hostNode)) STOP 6
112! #3 this did not
113  bh => bhGet(b,instance=1)
114  if (loc (b) .ne. loc(bh%hostNode)) STOP 7
115  bh => bhGet(b,instance=2)
116  if (loc (b) .ne. loc(bh%hostNode)) STOP 8
117end
118! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
119