gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR84546 in which the failing cases would
   4 ! have x%vec = ['foo','b   '].
   5 !
   6 ! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
   7 !
   8 module any_vector_type
   9
  10   type :: any_vector
  11     class(*), allocatable :: vec(:)
  12   end type
  13
  14   interface any_vector
  15     procedure any_vector1
  16   end interface
  17
  18 contains
  19
  20   function any_vector1(vec) result(this)
  21     class(*), intent(in) :: vec(:)
  22     type(any_vector) :: this
  23     allocate(this%vec, source=vec)
  24   end function
  25
  26 end module
  27
  28 program main
  29
  30   use any_vector_type
  31   implicit none
  32
  33   class(*), allocatable :: x
  34   character(*), parameter :: vec(2) = ['foo','bar']
  35   integer :: vec1(3) = [7,8,9]
  36
  37   call foo1
  38   call foo2
  39   call foo3
  40   call foo4
  41
  42 contains
  43
  44   subroutine foo1 ! This always worked
  45     allocate (any_vector :: x)
  46     select type (x)
  47       type is (any_vector)
  48         x = any_vector(vec)
  49     end select
  50     call bar(1)
  51     deallocate (x)
  52   end
  53
  54   subroutine foo2 ! Failure found during diagnosis
  55     x = any_vector (vec)
  56     call bar(2)
  57     deallocate (x)
  58   end
  59
  60   subroutine foo3 ! Original failure
  61     allocate (x, source = any_vector (vec))
  62     call bar(3)
  63     deallocate (x)
  64   end
  65
  66   subroutine foo4 ! This always worked
  67     allocate (x, source = any_vector (vec1))
  68     call bar(4)
  69     deallocate (x)
  70   end
  71
  72   subroutine bar (stop_flag)
  73     integer :: stop_flag
  74     select type (x)
  75       type is (any_vector)
  76         select type (xvec => x%vec)
  77           type is (character(*))
  78             if (any(xvec /= vec)) stop stop_flag
  79           type is (integer)
  80             if (any(xvec /= (vec1))) stop stop_flag
  81         end select
  82     end select
  83   end
  84 end program