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
107
108
109
110
111
112
113
|
! { dg-do compile }
! { dg-options -std=f2003 }
!
! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module fcn_bar
contains
function bar (arg, idx) result (res)
integer, pointer :: res
integer, target :: arg(:)
integer :: idx
res => arg (idx)
res = 99
end function
end module
module fcn_mydt
type mydt
integer, allocatable, dimension (:) :: i
contains
procedure, pass :: create
procedure, pass :: delete
procedure, pass :: fill
procedure, pass :: elem_fill
end type
contains
subroutine create (this, sz)
class(mydt) :: this
integer :: sz
if (allocated (this%i)) deallocate (this%i)
allocate (this%i(sz))
this%i = 0
end subroutine
subroutine delete (this)
class(mydt) :: this
if (allocated (this%i)) deallocate (this%i)
end subroutine
function fill (this, idx) result (res)
integer, pointer :: res(:)
integer :: lb, ub
class(mydt), target :: this
integer :: idx
lb = idx
ub = lb + size(this%i) - 1
res => this%i(lb:ub)
end function
function elem_fill (this, idx) result (res)
integer, pointer :: res
class(mydt), target :: this
integer :: idx
res => this%i(idx)
end function
end module
use fcn_bar
use fcn_mydt
integer, target :: a(3) = [1,2,3]
integer, pointer :: b
integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
type(mydt) :: dt
foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
if (any (a .ne. [1,2,3])) STOP 1
! Assignment to pointer result is after procedure call.
foo (a) = 77 ! { dg-error "Pointer procedure assignment" }
! Assignment within procedure applies.
b => foo (a)
if (b .ne. 99) STOP 2
! Use of index for assignment.
bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
if (any (a .ne. [99,99,3])) STOP 3
! Make sure that statement function still works!
if (foobar (10) .ne. 100) STOP 4
bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" }
if (any (a .ne. [99,99,81])) STOP 5
! Try typebound procedure
call dt%create (6)
dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 42) STOP 6
dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 84) STOP 7
dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 0) STOP 8
! Array is now reset
dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" }
dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [2,1,ifill])) STOP 9
dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10
dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11
call dt%delete
contains
function foo (arg)
integer, pointer :: foo
integer, target :: arg(:)
foo => arg (1)
foo = 99
end function
function footoo (arg) result(res)
integer :: arg
integer :: res(arg)
res = [(arg - i, i = 0, arg - 1)]
end function
end
|
