gcc/testsuite/gfortran.dg/associate_61.f90

   1 ! { dg-do run }
   2 ! Test fixes for PR109451
   3 ! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
   4 !
   5 program p
   6    implicit none
   7    character(4) :: c(2) = ["abcd","efgh"]
   8    call dcs3 (c)
   9    call dcs0 (c)
  10 contains
  11   subroutine dcs3 (a)
  12     character(len=*), intent(in)  :: a(:)
  13     character(:),     allocatable :: b(:)
  14     b = a(:)
  15     call test (b, a, 1)
  16     associate (q => b(:))    ! no ICE but print repeated first element
  17       call test (q, a, 2)
  18       print *, q             ! Checked with dg-output
  19       q = q(:)(2:3)
  20     end associate
  21     call test (b, ["bc  ","fg  "], 4)
  22     b = a(:)
  23     associate (q => b(:)(:)) ! ICE
  24       call test (q, a, 3)
  25       associate (r => q(:)(1:3))
  26         call test (r, a(:)(1:3), 5)
  27       end associate
  28     end associate
  29     associate (q => b(:)(2:3))
  30       call test (q, a(:)(2:3), 6)
  31     end associate
  32   end subroutine dcs3
  33
  34 ! The associate vars in dsc0 had string length not set
  35   subroutine dcs0 (a)
  36     character(len=*), intent(in) :: a(:)
  37     associate (q => a)
  38       call test (q, a, 7)
  39     end associate
  40     associate (q => a(:))
  41       call test (q, a, 8)
  42     end associate
  43     associate (q => a(:)(:))
  44       call test (q, a, 9)
  45     end associate
  46   end subroutine dcs0
  47
  48   subroutine test (x, y, i)
  49     character(len=*), intent(in) :: x(:), y(:)
  50     integer, intent(in) :: i
  51     if (any (x .ne. y)) stop i
  52   end subroutine test
  53 end program p
  54 ! { dg-output " abcdefgh" }