gcc/testsuite/gfortran.dg/char_pointer_assign.f90

   1 ! { dg-do run }
   2 ! { dg-options "-std=legacy" }
   3 !
   4 program char_pointer_assign
   5 ! Test character pointer assignments, required
   6 ! to fix PR18890 and PR21297
   7 ! Provided by Paul Thomas pault@gcc.gnu.org
   8   implicit none
   9   character*4, target        :: t1
  10   character*4, target        :: t2(4) =(/"lmno","lmno","lmno","lmno"/)
  11   character*4                :: const
  12   character*4, pointer       :: c1, c3
  13   character*4, pointer       :: c2(:), c4(:)
  14   allocate (c3, c4(4))
  15 ! Scalars first.
  16   c3 = "lmno"          ! pointer = constant
  17   t1 = c3              ! target = pointer
  18   c1 => t1             ! pointer =>target
  19   c1(2:3) = "nm"
  20   c3 = c1              ! pointer = pointer
  21   c3(1:1) = "o"
  22   c3(4:4) = "l"
  23   c1 => c3             ! pointer => pointer
  24   if (t1 /= "lnmo") call abort ()
  25   if (c1 /= "onml") call abort ()
  26
  27 ! Now arrays.
  28   c4 = "lmno"          ! pointer = constant
  29   t2 = c4              ! target = pointer
  30   c2 => t2             ! pointer =>target
  31   const = c2(1)
  32   const(2:3) ="nm"     ! c2(:)(2:3) = "nm" is still broken
  33   c2 = const
  34   c4 = c2              ! pointer = pointer
  35   const = c4(1)
  36   const(1:1) ="o"      ! c4(:)(1:1) = "o" is still broken
  37   const(4:4) ="l"      ! c4(:)(4:4) = "l" is still broken
  38   c4 = const
  39   c2 => c4             ! pointer => pointer
  40   if (any (t2 /= "lnmo")) call abort ()
  41   if (any (c2 /= "onml")) call abort ()
  42   deallocate (c3, c4)
  43 end program char_pointer_assign
  44