gcc/testsuite/gfortran.dg/pr113363.f90

   1 ! { dg-do run }
   2 ! Test the fix for comment 1 in PR113363, which failed as in comments below.
   3 ! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
   4 program p
   5   implicit none
   6   class(*), allocatable :: x(:), y
   7   character(*), parameter :: arr(2) = ["hello ","bye   "], &
   8                              sca = "Have a nice day"
   9   character(10) :: const
  10
  11 ! Bug was detected in polymorphic array function results
  12   allocate(x, source = foo ())
  13   call check1 (x, arr)              ! Wrong output "6 hello e"
  14   deallocate (x)
  15   x = foo ()
  16   call check1 (x, arr)              ! Wrong output "0  "
  17   associate (var => foo ())         ! OK after r14-9489-g3fd46d859cda10
  18     call check1 (var, arr)          ! Now OK - outputs: "6 hello bye   "
  19   end associate
  20
  21 ! Check scalar function results     ! All OK
  22   allocate (y, source = bar())
  23   call check2 (y, sca)
  24   deallocate (y)
  25   y = bar ()
  26   call check2 (y, sca)
  27   deallocate (y)
  28   associate (var => bar ())
  29     call check2 (var, sca)
  30   end associate
  31
  32 ! Finally variable expressions...
  33   allocate (y, source = x(1))       ! Gave zero length here
  34   call check2 (y, "hello")
  35   y = x(2)                          ! Segfaulted here
  36   call check2 (y, "bye   ")
  37   associate (var => x(2))           ! Gave zero length here
  38     call check2 (var, "bye   ")
  39   end associate
  40
  41 ! ...and constant expressions       ! All OK
  42   deallocate(y)
  43   allocate (y, source = "abcde")
  44   call check2 (y, "abcde")
  45   const = "hijklmnopq"
  46   y = const
  47   call check2 (y, "hijklmnopq")
  48   associate (var => "mnopq")
  49     call check2 (var, "mnopq")
  50   end associate
  51   deallocate (x, y)
  52
  53 contains
  54
  55   function foo() result(res)
  56     class(*), allocatable :: res(:)
  57     res = arr
  58   end function foo
  59
  60   function bar() result(res)
  61     class(*), allocatable :: res
  62     res = sca
  63   end function bar
  64
  65   subroutine check1 (x, carg)
  66     class(*), intent(in) :: x(:)
  67     character(*) :: carg(:)
  68     select type (x)
  69     type is (character(*))
  70       if (any (x .ne. carg)) stop 1
  71     class default
  72        stop 2
  73     end select
  74   end subroutine check1
  75
  76   subroutine check2 (x, carg)
  77     class(*), intent(in) :: x
  78     character(*) :: carg
  79     select type (x)
  80     type is (character(*))
  81       if (x .ne. carg) stop 3
  82     class default
  83        stop 4
  84     end select
  85   end subroutine check2
  86 end