gcc/testsuite/gfortran.dg/allocate_with_source_15.f03

   1 ! { dg-do run }
   2 !
   3 ! Tests the fix for PR67933, which was a side effect of the fix for PR67171.
   4 !
   5 ! Contributed by Andrew  <mandrew9@vt.edu>
   6 !
   7 module test_mod
   8   implicit none
   9
  10   type :: class_t
  11     integer :: i
  12   end type class_t
  13
  14   type, extends(class_t) :: class_e
  15     real :: r
  16   end type class_e
  17
  18   type :: wrapper_t
  19     class(class_t), allocatable  :: class_var
  20 !    type(class_t), allocatable  :: class_var
  21 !    integer,       allocatable  :: class_id
  22   end type wrapper_t
  23
  24   type :: list_t
  25     type(wrapper_t) :: classes(20)
  26   contains
  27     procedure :: Method
  28     procedure :: Typeme
  29     procedure :: Dealloc
  30   end type list_t
  31
  32 contains
  33   subroutine Method(this)
  34     class(list_t) :: this
  35     integer :: i
  36     do i = 1, 20
  37       if (i .gt. 10) then
  38         allocate (this%classes(i)%class_var, source = class_t (i))
  39       else
  40         allocate (this%classes(i)%class_var, source = class_e (i, real (2 * i)))
  41       end if
  42     end do
  43   end subroutine Method
  44   subroutine Dealloc(this)
  45     class(list_t) :: this
  46     integer :: i
  47     do i = 1, 20
  48       if (allocated (this%classes(i)%class_var)) &
  49          deallocate (this%classes(i)%class_var)
  50     end do
  51   end subroutine Dealloc
  52   subroutine Typeme(this)
  53     class(list_t) :: this
  54     integer :: i, j(20)
  55     real :: r(20)
  56     real :: zero = 0.0
  57     do i = 1, 20
  58       j(i) = this%classes(i)%class_var%i
  59       select type (p => this%classes(i)%class_var)
  60         type is (class_e)
  61           r(i) = p%r
  62         class default
  63           r(i) = zero
  64       end select
  65     end do
  66 !    print "(10i6,/)", j
  67     if (any (j .ne. [(i, i = 1,20)])) STOP 1
  68 !    print "(10f6.2,/)", r
  69     if (any (r(1:10) .ne. [(real (2 * i), i = 1,10)])) STOP 2
  70     if (any (r(11:20) .ne. zero)) STOP 3
  71   end subroutine Typeme
  72 end module test_mod
  73
  74   use test_mod
  75   type(list_t) :: x
  76   call x%Method
  77   call x%Typeme
  78   call x%dealloc
  79 end