gcc/testsuite/gfortran.dg/class_array_15.f03

   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 !
  15 module 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
  28 contains
  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
  51 end module G_Nodes
  52
  53   call pr53876
  54   call pr54990
  55   call pr54992
  56 end
  57
  58 subroutine 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
  68 CONTAINS
  69   SUBROUTINE display_indv(self)
  70     CLASS(individual),  INTENT(IN) :: self
  71     if (any(self%genes .ne. [999,9999]) )call abort
  72   END SUBROUTINE
  73 END
  74
  75 subroutine 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       call abort
  93     type is (ncBhStde)
  94       if (q%i .ne. 198) call abort ! This tests that the component really gets the
  95   end select                       ! language specific flag denoting a class type
  96 end
  97
  98 subroutine 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)) call abort
 108   call Node_C_Bh_Move(b)
 109 ! #2 this worked
 110   if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
 111   if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
 112 ! #3 this did not
 113   bh => bhGet(b,instance=1)
 114   if (loc (b) .ne. loc(bh%hostNode)) call abort
 115   bh => bhGet(b,instance=2)
 116   if (loc (b) .ne. loc(bh%hostNode)) call abort
 117 end
 118 ! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }