gcc/testsuite/gfortran.dg/char_pointer_assign.f90

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