gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90

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