gcc/testsuite/gfortran.dg/PR100103.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR100103
   4 !
   5
   6 program main_p
   7   implicit none
   8
   9   integer            :: i
  10   integer, parameter :: n = 11
  11
  12   type :: foo_t
  13     integer :: i
  14   end type foo_t
  15
  16   type(foo_t), parameter :: a(*) = [(foo_t(i), i=1,n)]
  17
  18   type(foo_t),  allocatable :: bar_d(:)
  19   class(foo_t), allocatable :: bar_p(:)
  20   class(*),     allocatable :: bar_u(:)
  21
  22
  23   call foo_d(bar_d)
  24   if(.not.allocated(bar_d)) stop 1
  25   if(any(bar_d%i/=a%i)) stop 2
  26   deallocate(bar_d)
  27   call foo_p(bar_p)
  28   if(.not.allocated(bar_p)) stop 3
  29   if(any(bar_p%i/=a%i)) stop 4
  30   deallocate(bar_p)
  31   call foo_u(bar_u)
  32   if(.not.allocated(bar_u)) stop 5
  33   select type(bar_u)
  34   type is(foo_t)
  35     if(any(bar_u%i/=a%i)) stop 6
  36   class default
  37     stop 7
  38   end select
  39   deallocate(bar_u)
  40
  41 contains
  42
  43   subroutine foo_d(that)
  44     type(foo_t), allocatable, intent(out) :: that(..)
  45
  46     select rank(that)
  47     rank(1)
  48       that = a
  49     rank default
  50       stop 8
  51     end select
  52   end subroutine foo_d
  53
  54   subroutine foo_p(that)
  55     class(foo_t), allocatable, intent(out) :: that(..)
  56
  57     select rank(that)
  58     rank(1)
  59       that = a
  60     rank default
  61       stop 9
  62     end select
  63   end subroutine foo_p
  64
  65   subroutine foo_u(that)
  66     class(*), allocatable, intent(out) :: that(..)
  67
  68     select rank(that)
  69     rank(1)
  70       that = a
  71     rank default
  72       stop 10
  73     end select
  74   end subroutine foo_u
  75
  76 end program main_p