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

! Now arrays.
  c4 = "lmno"          ! pointer = constant
  t2 = c4              ! target = pointer
  c2 => t2             ! pointer =>target
  const = c2(1)
  const(2:3) ="nm"     ! c2(:)(2:3) = "nm" is still broken
  c2 = const
  c4 = c2              ! pointer = pointer
  const = c4(1)
  const(1:1) ="o"      ! c4(:)(1:1) = "o" is still broken
  const(4:4) ="l"      ! c4(:)(4:4) = "l" is still broken
  c4 = const
  c2 => c4             ! pointer => pointer
  if (any (t2 /= "lnmo")) call abort ()
  if (any (c2 /= "onml")) call abort ()
  deallocate (c3, c4)
end program char_pointer_assign