1! RUN: %python %S/test_errors.py %s %flang_fc1
2! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
3
4module m
5  interface
6    subroutine s(i)
7      integer i
8    end
9  end interface
10  type :: t
11    procedure(s), pointer, nopass :: p
12    real, pointer :: q
13  end type
14contains
15  ! C1027
16  subroutine s1
17    type(t), allocatable :: a(:)
18    type(t), allocatable :: b[:]
19    a(1)%p => s
20    !ERROR: Procedure pointer may not be a coindexed object
21    b[1]%p => s
22  end
23  ! C1028
24  subroutine s2
25    type(t) :: a
26    a%p => s
27    !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
28    a%q => s
29  end
30  ! C1029
31  subroutine s3
32    type(t) :: a
33    a%p => f()  ! OK: pointer-valued function
34    !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
35    a%p => f
36  contains
37    function f()
38      procedure(s), pointer :: f
39      f => s
40    end
41  end
42
43  ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
44  subroutine s4(s_dummy)
45    procedure(s) :: s_dummy
46    procedure(s), pointer :: p, q
47    procedure(), pointer :: r
48    integer :: i
49    external :: s_external
50    p => s_dummy
51    p => s_internal
52    p => s_module
53    q => p
54    r => s_external
55  contains
56    subroutine s_internal(i)
57      integer i
58    end
59  end
60  subroutine s_module(i)
61    integer i
62  end
63
64  ! 10.2.2.4(3)
65  subroutine s5
66    procedure(f_impure1), pointer :: p_impure
67    procedure(f_pure1), pointer :: p_pure
68    !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
69    procedure(f_elemental1), pointer :: p_elemental
70    procedure(s_impure1), pointer :: sp_impure
71    procedure(s_pure1), pointer :: sp_pure
72    !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
73    procedure(s_elemental1), pointer :: sp_elemental
74
75    p_impure => f_impure1 ! OK, same characteristics
76    p_impure => f_pure1 ! OK, target may be pure when pointer is not
77    p_impure => f_elemental1 ! OK, target may be pure elemental
78    p_impure => f_ImpureElemental1 ! OK, target may be elemental
79
80    sp_impure => s_impure1 ! OK, same characteristics
81    sp_impure => s_pure1 ! OK, target may be pure when pointer is not
82    sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not
83
84    !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
85    p_pure => f_impure1
86    p_pure => f_pure1 ! OK, same characteristics
87    p_pure => f_elemental1 ! OK, target may be pure
88    !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
89    p_pure => f_impureElemental1
90
91    !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
92    sp_pure => s_impure1
93    sp_pure => s_pure1 ! OK, same characteristics
94    sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
95
96    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2': incompatible dummy argument #1: incompatible dummy data object intents
97    p_impure => f_impure2
98    !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
99    p_pure => f_pure2
100    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible dummy argument #1: incompatible dummy data object attributes
101    p_impure => f_elemental2
102
103    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes
104    sp_impure => s_impure2
105    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2': incompatible dummy argument #1: incompatible dummy data object intents
106    sp_impure => s_pure2
107    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': distinct numbers of dummy arguments
108    sp_pure => s_elemental2
109
110    !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
111    p_impure => s_impure1
112
113    !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
114    sp_impure => f_impure1
115
116  contains
117    integer function f_impure1(n)
118      real, intent(in) :: n
119      f_impure = n
120    end
121    pure integer function f_pure1(n)
122      real, intent(in) :: n
123      f_pure = n
124    end
125    elemental integer function f_elemental1(n)
126      real, intent(in) :: n
127      f_elemental = n
128    end
129    impure elemental integer function f_impureElemental1(n)
130      real, intent(in) :: n
131      f_impureElemental = n
132    end
133
134    integer function f_impure2(n)
135      real, intent(inout) :: n
136      f_impure = n
137    end
138    pure real function f_pure2(n)
139      real, intent(in) :: n
140      f_pure = n
141    end
142    elemental integer function f_elemental2(n)
143      real, value :: n
144      f_elemental = n
145    end
146
147    subroutine s_impure1(n)
148      integer, intent(inout) :: n
149      n = n + 1
150    end
151    pure subroutine s_pure1(n)
152      integer, intent(inout) :: n
153      n = n + 1
154    end
155    elemental subroutine s_elemental1(n)
156      integer, intent(inout) :: n
157      n = n + 1
158    end
159
160    subroutine s_impure2(n) bind(c)
161      integer, intent(inout) :: n
162      n = n + 1
163    end subroutine s_impure2
164    pure subroutine s_pure2(n)
165      integer, intent(out) :: n
166      n = 1
167    end subroutine s_pure2
168    elemental subroutine s_elemental2(m,n)
169      integer, intent(inout) :: m, n
170      n = m + n
171    end subroutine s_elemental2
172  end
173
174  ! 10.2.2.4(4)
175  subroutine s6
176    procedure(s), pointer :: p, q
177    procedure(), pointer :: r
178    external :: s_external
179    p => s_external ! OK for a pointer with an explicit interface to be associated with a procedure with an implicit interface
180    r => s_module ! OK for a pointer with implicit interface to be associated with a procedure with an explicit interface.  See 10.2.2.4 (3)
181  end
182
183  ! 10.2.2.4(5)
184  subroutine s7
185    procedure(real) :: f_external
186    external :: s_external
187    procedure(), pointer :: p_s
188    procedure(real), pointer :: p_f
189    p_f => f_external
190    p_s => s_external
191    !Ok: p_s has no interface
192    p_s => f_external
193    !Ok: s_external has no interface
194    p_f => s_external
195  end
196
197  ! C1017: bounds-spec
198  subroutine s8
199    real, target :: x(10, 10)
200    real, pointer :: p(:, :)
201    p(2:,3:) => x
202    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
203    p(2:) => x
204  end
205
206  ! bounds-remapping
207  subroutine s9
208    real, target :: x(10, 10), y(100)
209    real, pointer :: p(:, :)
210    ! C1018
211    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
212    p(1:100) => x
213    ! 10.2.2.3(9)
214    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
215    p(1:5,1:5) => x(1:10,::2)
216    ! 10.2.2.3(9)
217    !ERROR: Pointer bounds require 25 elements but target has only 20
218    p(1:5,1:5) => x(:,1:2)
219    !OK - rhs has rank 1 and enough elements
220    p(1:5,1:5) => y(1:100:2)
221    !OK - same, but from function result
222    p(1:5,1:5) => f()
223   contains
224    function f()
225      real, pointer :: f(:)
226      f => y
227    end function
228  end
229
230  subroutine s10
231    integer, pointer :: p(:)
232    type :: t
233      integer :: a(4, 4)
234      integer :: b
235    end type
236    type(t), target :: x
237    type(t), target :: y(10,10)
238    integer :: v(10)
239    p(1:16) => x%a
240    p(1:8) => x%a(:,3:4)
241    p(1:1) => x%b  ! We treat scalars as simply contiguous
242    p(1:1) => x%a(1,1)
243    p(1:1) => y(1,1)%a(1,1)
244    p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
245    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
246    p(1:4) => x%a(::2,::2)
247    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
248    p(1:100) => y(:,:)%b
249    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
250    p(1:100) => y(:,:)%a(1,1)
251    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
252    !ERROR: An array section with a vector subscript may not be a pointer target
253    p(1:4) => x%a(:,v)
254  end
255
256  subroutine s11
257    complex, target :: x(10,10)
258    complex, pointer :: p(:)
259    real, pointer :: q(:)
260    p(1:100) => x(:,:)
261    q(1:10) => x(1,:)%im
262    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
263    q(1:100) => x(:,:)%re
264  end
265
266  ! Check is_contiguous, which is usually the same as when pointer bounds
267  ! remapping is used. If it's not simply contiguous it's not constant so
268  ! an error is reported.
269  subroutine s12
270    integer, pointer :: p(:)
271    type :: t
272      integer :: a(4, 4)
273      integer :: b
274    end type
275    type(t), target :: x
276    type(t), target :: y(10,10)
277    integer :: v(10)
278    logical, parameter :: l1 = is_contiguous(x%a(:,:))
279    logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
280    !ERROR: Must be a constant value
281    logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
282    !ERROR: Must be a constant value
283    logical, parameter :: l4 = is_contiguous(x%a(:,v))
284    !ERROR: Must be a constant value
285    logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
286    !ERROR: Must be a constant value
287    logical, parameter :: l6 = is_contiguous(p(:))
288  end
289  subroutine test3(b)
290    integer, intent(inout) :: b(..)
291    !ERROR: Must be a constant value
292    integer, parameter :: i = rank(b)
293  end subroutine
294
295
296end
297