gcc/testsuite/gfortran.dg/class_array_15.f03

   1 ! { dg-do run }
   2 !
   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.
   7 !
   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
  13 !
  14 module G_Nodes
  15   type :: nc
  16     type(tn), pointer :: hostNode
  17   end type nc
  18   type, extends(nc) :: ncBh
  19   end type ncBh
  20   type, public, extends(ncBh) :: ncBhStd
  21     double precision :: massSeedData
  22   end type ncBhStd
  23   type, public :: tn
  24     class (ncBh), allocatable, dimension(:) :: cBh
  25   end type tn
  26   type(ncBhStd) :: defaultBhC
  27 contains
  28   subroutine Node_C_Bh_Move(targetNode)
  29     implicit none
  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
  40     return
  41   end subroutine Node_C_Bh_Move
  42   function bhGet(self,instance)
  43     implicit none
  44     class (ncBh), pointer               :: bhGet
  45     class (tn  ), intent(inout), target :: self
  46     integer     , intent(in   )         :: instance
  47     bhGet => self%cBh(instance)
  48     return
  49   end function bhGet
  50 end module G_Nodes
  51
  52   call pr53876
  53   call pr54990
  54   call pr54992
  55 end
  56
  57 subroutine pr53876
  58   IMPLICIT NONE
  59   TYPE :: individual
  60     integer :: icomp ! Add an extra component to test offset
  61     REAL, DIMENSION(:), ALLOCATABLE :: genes
  62   END TYPE
  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
  67 CONTAINS
  68   SUBROUTINE display_indv(self)
  69     CLASS(individual),  INTENT(IN) :: self
  70     if (any(self%genes .ne. [999,9999]) )call abort
  71   END SUBROUTINE
  72 END
  73
  74 subroutine pr54990
  75   implicit none
  76   type :: ncBhStd
  77     integer :: i
  78   end type
  79   type, extends(ncBhStd) :: ncBhStde
  80     integer :: i2(2)
  81   end type
  82   type :: tn
  83     integer :: i ! Add an extra component to test offset
  84     class (ncBhStd), allocatable, dimension(:) :: cBh
  85   end type
  86   integer :: i
  87   type(tn), target :: a
  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
  90     type is (ncBhStd)
  91       call abort
  92     type is (ncBhStde)
  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
  95 end
  96
  97 subroutine pr54992  ! This test remains as the original.
  98   use G_Nodes
  99   implicit none
 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
 105 ! #1 this worked
 106   if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
 107   call Node_C_Bh_Move(b)
 108 ! #2 this worked
 109   if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
 110   if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
 111 ! #3 this did not
 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
 116 end