gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90

! { dg-do run }
!
! Test the fix for PR84546 in which the failing cases would
! have x%vec = ['foo','b   '].
!
! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
!
module any_vector_type

  type :: any_vector
    class(*), allocatable :: vec(:)
  end type

  interface any_vector
    procedure any_vector1
  end interface

contains

  function any_vector1(vec) result(this)
    class(*), intent(in) :: vec(:)
    type(any_vector) :: this
    allocate(this%vec, source=vec)
  end function

end module

program main

  use any_vector_type
  implicit none

  class(*), allocatable :: x
  character(*), parameter :: vec(2) = ['foo','bar']
  integer :: vec1(3) = [7,8,9]

  call foo1
  call foo2
  call foo3
  call foo4

contains

  subroutine foo1 ! This always worked
    allocate (any_vector :: x)
    select type (x)
      type is (any_vector)
        x = any_vector(vec)
    end select
    call bar(1)
    deallocate (x)
  end

  subroutine foo2 ! Failure found during diagnosis
    x = any_vector (vec)
    call bar(2)
    deallocate (x)
  end

  subroutine foo3 ! Original failure
    allocate (x, source = any_vector (vec))
    call bar(3)
    deallocate (x)
  end

  subroutine foo4 ! This always worked
    allocate (x, source = any_vector (vec1))
    call bar(4)
    deallocate (x)
  end

  subroutine bar (stop_flag)
    integer :: stop_flag
    select type (x)
      type is (any_vector)
        select type (xvec => x%vec)
          type is (character(*))
            if (any(xvec /= vec)) stop stop_flag
          type is (integer)
            if (any(xvec /= (vec1))) stop stop_flag
        end select
    end select
  end
end program