gcc/testsuite/gfortran.dg/pr55086_1.f90

   1 ! { dg-do run }
   2 !
   3   implicit none
   4   character(len=5), pointer :: a(:), b(:)
   5   character(len=5), pointer :: c, d
   6   allocate (a(2), b(2), c, d)
   7   a = [ "abcde", "ABCDE" ]
   8   call aloct_pointer_copy_4 (b, a)
   9   !print *, b(1)
  10   !print *, b(2)
  11   if (any (a /= b)) stop 'WRONG'
  12
  13   call aloct_copy_4 (b, a)
  14   !print *, b(1)
  15   !print *, b(2)
  16   if (any (a /= b)) stop 'WRONG'
  17
  18   d = '12345'
  19   c = "abcde"
  20   call test2 (d, c)
  21   !print *, d
  22   if (d /= '1cb15') stop 'WRONG'
  23
  24   call test2p (d, c)
  25   !print *, d
  26   if (d /= '1cb15') stop 'WRONG'
  27
  28 contains
  29  subroutine aloct_pointer_copy_4(o, i)
  30   character(len=*), pointer :: o(:), i(:)
  31   integer :: nl1, nu1
  32   integer :: i1
  33   nl1 = lbound(i,dim=1)
  34   nu1 = ubound(i,dim=1)
  35   forall (i1 = nl1:nu1) o(i1) = i(i1)
  36  end subroutine aloct_pointer_copy_4
  37  subroutine aloct_copy_4(o, i)
  38   character(len=*), pointer :: o(:), i(:)
  39   integer :: nl1, nu1
  40   integer :: i1
  41   nl1 = lbound(i,dim=1)
  42   nu1 = ubound(i,dim=1)
  43   forall (i1 = nl1:nu1) o(i1) = i(i1)
  44  end subroutine aloct_copy_4
  45  subroutine test2(o, i)
  46   character(len=*) :: o, i
  47   integer :: nl1, nu1
  48   integer :: i1
  49   nl1 = 2
  50   nu1 = 4
  51   forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
  52   forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
  53  end subroutine test2
  54  subroutine test2p(o, i)
  55   character(len=*), pointer :: o, i
  56   integer :: nl1, nu1
  57   integer :: i1
  58   nl1 = 2
  59   nu1 = 4
  60   forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)   ! <<<< ICE
  61   forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
  62  end subroutine test2p
  63 end