1! { dg-do compile }
2! { dg-options -std=f2003 }
3!
4! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard.
5!
6! Contributed by Paul Thomas  <pault@gcc.gnu.org>
7!
8module fcn_bar
9contains
10  function bar (arg, idx) result (res)
11    integer, pointer :: res
12    integer, target :: arg(:)
13    integer :: idx
14    res => arg (idx)
15    res = 99
16  end function
17end module
18
19module fcn_mydt
20  type mydt
21    integer, allocatable, dimension (:) :: i
22  contains
23    procedure, pass :: create
24    procedure, pass :: delete
25    procedure, pass :: fill
26    procedure, pass :: elem_fill
27  end type
28contains
29  subroutine create (this, sz)
30    class(mydt) :: this
31    integer :: sz
32    if (allocated (this%i)) deallocate (this%i)
33    allocate (this%i(sz))
34    this%i = 0
35  end subroutine
36  subroutine delete (this)
37    class(mydt) :: this
38    if (allocated (this%i)) deallocate (this%i)
39  end subroutine
40  function fill (this, idx) result (res)
41    integer, pointer :: res(:)
42    integer :: lb, ub
43    class(mydt), target :: this
44    integer :: idx
45    lb = idx
46    ub = lb + size(this%i) - 1
47    res => this%i(lb:ub)
48  end function
49  function elem_fill (this, idx) result (res)
50    integer, pointer :: res
51    class(mydt), target :: this
52    integer :: idx
53    res => this%i(idx)
54  end function
55end module
56
57  use fcn_bar
58  use fcn_mydt
59  integer, target :: a(3) = [1,2,3]
60  integer, pointer :: b
61  integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
62  type(mydt) :: dt
63  foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
64  if (any (a .ne. [1,2,3])) STOP 1
65
66! Assignment to pointer result is after procedure call.
67  foo (a) = 77 ! { dg-error "Pointer procedure assignment" }
68
69! Assignment within procedure applies.
70  b => foo (a)
71  if (b .ne. 99) STOP 2
72
73! Use of index for assignment.
74  bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
75  if (any (a .ne. [99,99,3])) STOP 3
76
77! Make sure that statement function still works!
78  if (foobar (10) .ne. 100) STOP 4
79
80  bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" }
81  if (any (a .ne. [99,99,81])) STOP 5
82
83! Try typebound procedure
84  call dt%create (6)
85  dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" }
86  if (dt%i(3) .ne. 42) STOP 6
87  dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
88  if (dt%i(3) .ne. 84) STOP 7
89  dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
90  if (dt%i(3) .ne. 0) STOP 8
91! Array is now reset
92  dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" }
93  dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" }
94  if (any (dt%i .ne. [2,1,ifill])) STOP 9
95  dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" }
96  if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10
97  dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" }
98  if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11
99  call dt%delete
100
101contains
102  function foo (arg)
103    integer, pointer :: foo
104    integer, target :: arg(:)
105    foo => arg (1)
106    foo = 99
107  end function
108  function footoo (arg) result(res)
109    integer :: arg
110    integer :: res(arg)
111    res = [(arg - i, i = 0, arg - 1)]
112  end function
113end
114