gcc/testsuite/gfortran.dg/PR100103.f90

! { dg-do run }
!
! Test the fix for PR100103
!

program main_p
  implicit none

  integer            :: i
  integer, parameter :: n = 11

  type :: foo_t
    integer :: i
  end type foo_t

  type(foo_t), parameter :: a(*) = [(foo_t(i), i=1,n)]

  type(foo_t),  allocatable :: bar_d(:)
  class(foo_t), allocatable :: bar_p(:)
  class(*),     allocatable :: bar_u(:)


  call foo_d(bar_d)
  if(.not.allocated(bar_d)) stop 1
  if(any(bar_d%i/=a%i)) stop 2
  deallocate(bar_d)
  call foo_p(bar_p)
  if(.not.allocated(bar_p)) stop 3
  if(any(bar_p%i/=a%i)) stop 4
  deallocate(bar_p)
  call foo_u(bar_u)
  if(.not.allocated(bar_u)) stop 5
  select type(bar_u)
  type is(foo_t)
    if(any(bar_u%i/=a%i)) stop 6
  class default
    stop 7
  end select
  deallocate(bar_u)

contains

  subroutine foo_d(that)
    type(foo_t), allocatable, intent(out) :: that(..)

    select rank(that)
    rank(1)
      that = a
    rank default
      stop 8
    end select
  end subroutine foo_d

  subroutine foo_p(that)
    class(foo_t), allocatable, intent(out) :: that(..)

    select rank(that)
    rank(1)
      that = a
    rank default
      stop 9
    end select
  end subroutine foo_p

  subroutine foo_u(that)
    class(*), allocatable, intent(out) :: that(..)

    select rank(that)
    rank(1)
      that = a
    rank default
      stop 10
    end select
  end subroutine foo_u

end program main_p