From 1bc5aee63eb72b341f506ad058502cd0361f0d10 Mon Sep 17 00:00:00 2001
From: Ben Cheng <bccheng@google.com>
Date: Tue, 25 Mar 2014 22:37:19 -0700
Subject: Initial checkin of GCC 4.9.0 from trunk (r208799).

Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba
---
 .../gcc/testsuite/gfortran.dg/class_array_15.f03   | 116 +++++++++++++++++++++
 1 file changed, 116 insertions(+)
 create mode 100644 gcc-4.9/gcc/testsuite/gfortran.dg/class_array_15.f03

(limited to 'gcc-4.9/gcc/testsuite/gfortran.dg/class_array_15.f03')

diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/class_array_15.f03 b/gcc-4.9/gcc/testsuite/gfortran.dg/class_array_15.f03
new file mode 100644
index 000000000..7d1d4d718
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/gfortran.dg/class_array_15.f03
@@ -0,0 +1,116 @@
+! { dg-do run }
+!
+! 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
-- 
cgit v1.2.3