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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/48820
!
! Ensure that the value of scalars to assumed-rank arrays is
! copied back, if and only its pointer address could have changed.
!
program test
implicit none
type t
integer :: aa
end type t
integer, allocatable :: iia
integer, pointer :: iip
type(t), allocatable :: jja
type(t), pointer :: jjp
logical :: is_present
is_present = .true.
allocate (iip, jjp)
iia = 7
iip = 7
jja = t(88)
jjp = t(88)
call faa(iia, jja) ! Copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fai(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fpa(iip, jjp) ! Copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fpi(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fnn(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fno(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fnn(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fno(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
is_present = .false.
call fpa(null(), null()) ! No copy back
call fpi(null(), null()) ! No copy back
call fno(null(), null()) ! No copy back
call fno() ! No copy back
contains
subroutine faa (xx1, yy1)
integer, allocatable :: xx1(..)
type(t), allocatable :: yy1(..)
if (.not. allocated (xx1)) call abort ()
if (.not. allocated (yy1)) call abort ()
end subroutine faa
subroutine fai (xx1, yy1)
integer, allocatable, intent(in) :: xx1(..)
type(t), allocatable, intent(in) :: yy1(..)
if (.not. allocated (xx1)) call abort ()
if (.not. allocated (yy1)) call abort ()
end subroutine fai
subroutine fpa (xx1, yy1)
integer, pointer :: xx1(..)
type(t), pointer :: yy1(..)
if (is_present .neqv. associated (xx1)) call abort ()
if (is_present .neqv. associated (yy1)) call abort ()
end subroutine fpa
subroutine fpi (xx1, yy1)
integer, pointer, intent(in) :: xx1(..)
type(t), pointer, intent(in) :: yy1(..)
if (is_present .neqv. associated (xx1)) call abort ()
if (is_present .neqv. associated (yy1)) call abort ()
end subroutine fpi
subroutine fnn(xx2,yy2)
integer :: xx2(..)
type(t) :: yy2(..)
end subroutine fnn
subroutine fno(xx2,yy2)
integer, optional :: xx2(..)
type(t), optional :: yy2(..)
if (is_present .neqv. present (xx2)) call abort ()
if (is_present .neqv. present (yy2)) call abort ()
end subroutine fno
end program test
! We should have exactly one copy back per variable
!
! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
|
