1! { dg-do run }
2! { dg-options "-fdump-tree-original" }
3!
4! PR fortran/48820
5!
6! Ensure that the value of scalars to assumed-rank arrays is
7! copied back, if and only its pointer address could have changed.
8!
9program test
10 implicit none
11 type t
12   integer :: aa
13 end type t
14
15 integer, allocatable :: iia
16 integer, pointer     :: iip
17
18 type(t), allocatable :: jja
19 type(t), pointer     :: jjp
20
21 logical :: is_present
22
23 is_present = .true.
24
25 allocate (iip, jjp)
26
27 iia = 7
28 iip = 7
29 jja = t(88)
30 jjp = t(88)
31
32 call faa(iia, jja) ! Copy back
33 if (iia /= 7 .and. jja%aa /= 88) call abort ()
34 call fai(iia, jja) ! No copy back
35 if (iia /= 7 .and. jja%aa /= 88) call abort ()
36
37 call fpa(iip, jjp) ! Copy back
38 if (iip /= 7 .and. jjp%aa /= 88) call abort ()
39 call fpi(iip, jjp) ! No copy back
40 if (iip /= 7 .and. jjp%aa /= 88) call abort ()
41
42 call fnn(iia, jja) ! No copy back
43 if (iia /= 7 .and. jja%aa /= 88) call abort ()
44 call fno(iia, jja) ! No copy back
45 if (iia /= 7 .and. jja%aa /= 88) call abort ()
46 call fnn(iip, jjp) ! No copy back
47 if (iip /= 7 .and. jjp%aa /= 88) call abort ()
48 call fno(iip, jjp) ! No copy back
49 if (iip /= 7 .and. jjp%aa /= 88) call abort ()
50
51 is_present = .false.
52
53 call fpa(null(), null()) ! No copy back
54 call fpi(null(), null()) ! No copy back
55 call fno(null(), null()) ! No copy back
56
57 call fno() ! No copy back
58
59contains
60
61  subroutine faa (xx1, yy1)
62    integer, allocatable :: xx1(..)
63    type(t), allocatable :: yy1(..)
64    if (.not. allocated (xx1)) call abort ()
65    if (.not. allocated (yy1)) call abort ()
66  end subroutine faa
67  subroutine fai (xx1, yy1)
68    integer, allocatable, intent(in) :: xx1(..)
69    type(t), allocatable, intent(in) :: yy1(..)
70    if (.not. allocated (xx1)) call abort ()
71    if (.not. allocated (yy1)) call abort ()
72  end subroutine fai
73  subroutine fpa (xx1, yy1)
74    integer, pointer :: xx1(..)
75    type(t), pointer :: yy1(..)
76    if (is_present .neqv. associated (xx1)) call abort ()
77    if (is_present .neqv. associated (yy1)) call abort ()
78  end subroutine fpa
79
80  subroutine fpi (xx1, yy1)
81    integer, pointer, intent(in) :: xx1(..)
82    type(t), pointer, intent(in) :: yy1(..)
83    if (is_present .neqv. associated (xx1)) call abort ()
84    if (is_present .neqv. associated (yy1)) call abort ()
85  end subroutine fpi
86
87  subroutine fnn(xx2,yy2)
88    integer  :: xx2(..)
89    type(t)  :: yy2(..)
90  end subroutine fnn
91
92  subroutine fno(xx2,yy2)
93    integer, optional  :: xx2(..)
94    type(t), optional  :: yy2(..)
95    if (is_present .neqv. present (xx2)) call abort ()
96    if (is_present .neqv. present (yy2)) call abort ()
97  end subroutine fno
98end program test
99
100! We should have exactly one copy back per variable
101!
102! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
103! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
104! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
105! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
106! { dg-final { cleanup-tree-dump "original" } }
107