gcc/testsuite/gfortran.dg/allocate_class_3.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR59414, comment #3, in which the allocate
   3 ! expressions were not correctly being stripped to provide the
   4 ! vpointer as an lhs to the pointer assignment of the vptr from
   5 ! the SOURCE expression.
   6 !
   7 ! Contributed by Antony Lewis  <antony@cosmologist.info>
   8 !
   9 module ObjectLists
  10   implicit none
  11
  12   type :: t
  13     integer :: i
  14   end type
  15
  16   type Object_array_pointer
  17     class(t), pointer :: p(:)
  18   end type
  19
  20 contains
  21
  22   subroutine AddArray1 (P, Pt)
  23     class(t) :: P(:)
  24     class(Object_array_pointer) :: Pt
  25
  26     select type (Pt)
  27     class is (Object_array_pointer)
  28       if (associated (Pt%P)) deallocate (Pt%P)
  29       allocate(Pt%P(1:SIZE(P)), source=P)
  30     end select
  31   end subroutine
  32
  33   subroutine AddArray2 (P, Pt)
  34     class(t) :: P(:)
  35     class(Object_array_pointer) :: Pt
  36
  37     select type (Pt)
  38     type is (Object_array_pointer)
  39       if (associated (Pt%P)) deallocate (Pt%P)
  40       allocate(Pt%P(1:SIZE(P)), source=P)
  41     end select
  42   end subroutine
  43
  44   subroutine AddArray3 (P, Pt)
  45     class(t) :: P
  46     class(Object_array_pointer) :: Pt
  47
  48     select type (Pt)
  49     class is (Object_array_pointer)
  50       if (associated (Pt%P)) deallocate (Pt%P)
  51       allocate(Pt%P(1:4), source=P)
  52     end select
  53   end subroutine
  54
  55   subroutine AddArray4 (P, Pt)
  56     type(t) :: P(:)
  57     class(Object_array_pointer) :: Pt
  58
  59     select type (Pt)
  60     class is (Object_array_pointer)
  61       if (associated (Pt%P)) deallocate (Pt%P)
  62       allocate(Pt%P(1:SIZE(P)), source=P)
  63     end select
  64   end subroutine
  65 end module
  66
  67   use ObjectLists
  68   type(Object_array_pointer), pointer :: Pt
  69   class(t), pointer :: P(:)
  70
  71   allocate (P(2), source = [t(1),t(2)])
  72   allocate (Pt, source = Object_array_pointer(NULL()))
  73   call AddArray1 (P, Pt)
  74   select type (x => Pt%p)
  75     type is (t)
  76       if (any (x%i .ne. [1,2])) STOP 1
  77   end select
  78   deallocate (P)
  79   deallocate (pt)
  80
  81   allocate (P(3), source = [t(3),t(4),t(5)])
  82   allocate (Pt, source = Object_array_pointer(NULL()))
  83   call AddArray2 (P, Pt)
  84   select type (x => Pt%p)
  85     type is (t)
  86       if (any (x%i .ne. [3,4,5])) STOP 2
  87   end select
  88   deallocate (P)
  89   deallocate (pt)
  90
  91   allocate (Pt, source = Object_array_pointer(NULL()))
  92   call AddArray3 (t(6), Pt)
  93   select type (x => Pt%p)
  94     type is (t)
  95       if (any (x%i .ne. [6,6,6,6])) STOP 3
  96   end select
  97   deallocate (pt)
  98
  99   allocate (Pt, source = Object_array_pointer(NULL()))
 100   call AddArray4 ([t(7), t(8)], Pt)
 101   select type (x => Pt%p)
 102     type is (t)
 103       if (any (x%i .ne. [7,8])) STOP 4
 104   end select
 105   deallocate (pt)
 106  end
 107