1! RUN: %S/test_errors.sh %s %t %flang_fc1
2! REQUIRES: shell
3! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
4
5module m
6  interface
7    subroutine s(i)
8      integer i
9    end
10  end interface
11  type :: t
12    procedure(s), pointer, nopass :: p
13    real, pointer :: q
14  end type
15contains
16  ! C1027
17  subroutine s1
18    type(t), allocatable :: a(:)
19    type(t), allocatable :: b[:]
20    a(1)%p => s
21    !ERROR: Procedure pointer may not be a coindexed object
22    b[1]%p => s
23  end
24  ! C1028
25  subroutine s2
26    type(t) :: a
27    a%p => s
28    !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
29    a%q => s
30  end
31  ! C1029
32  subroutine s3
33    type(t) :: a
34    a%p => f()  ! OK: pointer-valued function
35    !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
36    a%p => f
37  contains
38    function f()
39      procedure(s), pointer :: f
40      f => s
41    end
42  end
43
44  ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
45  subroutine s4(s_dummy)
46    procedure(s) :: s_dummy
47    procedure(s), pointer :: p, q
48    procedure(), pointer :: r
49    integer :: i
50    external :: s_external
51    p => s_dummy
52    p => s_internal
53    p => s_module
54    q => p
55    r => s_external
56  contains
57    subroutine s_internal(i)
58      integer i
59    end
60  end
61  subroutine s_module(i)
62    integer i
63  end
64
65  ! 10.2.2.4(3)
66  subroutine s5
67    procedure(f_pure), pointer :: p_pure
68    procedure(f_impure), pointer :: p_impure
69    !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
70    procedure(f_elemental), pointer :: p_elemental
71    p_pure => f_pure
72    p_impure => f_impure
73    p_impure => f_pure
74    !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure'
75    p_pure => f_impure
76  contains
77    pure integer function f_pure()
78      f_pure = 1
79    end
80    integer function f_impure()
81      f_impure = 1
82    end
83    elemental integer function f_elemental()
84      f_elemental = 1
85    end
86  end
87
88  ! 10.2.2.4(4)
89  subroutine s6
90    procedure(s), pointer :: p, q
91    procedure(), pointer :: r
92    external :: s_external
93    !ERROR: Procedure pointer 'p' with explicit interface may not be associated with procedure designator 's_external' with implicit interface
94    p => s_external
95    !ERROR: Procedure pointer 'r' with implicit interface may not be associated with procedure designator 's_module' with explicit interface
96    r => s_module
97  end
98
99  ! 10.2.2.4(5)
100  subroutine s7
101    procedure(real) :: f_external
102    external :: s_external
103    procedure(), pointer :: p_s
104    procedure(real), pointer :: p_f
105    p_f => f_external
106    p_s => s_external
107    !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
108    p_s => f_external
109    !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
110    p_f => s_external
111  end
112
113  ! C1017: bounds-spec
114  subroutine s8
115    real, target :: x(10, 10)
116    real, pointer :: p(:, :)
117    p(2:,3:) => x
118    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
119    p(2:) => x
120  end
121
122  ! bounds-remapping
123  subroutine s9
124    real, target :: x(10, 10), y(100)
125    real, pointer :: p(:, :)
126    ! C1018
127    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
128    p(1:100) => x
129    ! 10.2.2.3(9)
130    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
131    p(1:5,1:5) => x(1:10,::2)
132    ! 10.2.2.3(9)
133    !ERROR: Pointer bounds require 25 elements but target has only 20
134    p(1:5,1:5) => x(:,1:2)
135    !OK - rhs has rank 1 and enough elements
136    p(1:5,1:5) => y(1:100:2)
137  end
138
139  subroutine s10
140    integer, pointer :: p(:)
141    type :: t
142      integer :: a(4, 4)
143      integer :: b
144    end type
145    type(t), target :: x
146    type(t), target :: y(10,10)
147    integer :: v(10)
148    p(1:16) => x%a
149    p(1:8) => x%a(:,3:4)
150    p(1:1) => x%b  ! We treat scalars as simply contiguous
151    p(1:1) => x%a(1,1)
152    p(1:1) => y(1,1)%a(1,1)
153    p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
154    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
155    p(1:4) => x%a(::2,::2)
156    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
157    p(1:100) => y(:,:)%b
158    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
159    p(1:100) => y(:,:)%a(1,1)
160    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
161    !ERROR: An array section with a vector subscript may not be a pointer target
162    p(1:4) => x%a(:,v)
163  end
164
165  subroutine s11
166    complex, target :: x(10,10)
167    complex, pointer :: p(:)
168    real, pointer :: q(:)
169    p(1:100) => x(:,:)
170    q(1:10) => x(1,:)%im
171    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
172    q(1:100) => x(:,:)%re
173  end
174
175  ! Check is_contiguous, which is usually the same as when pointer bounds
176  ! remapping is used. If it's not simply contiguous it's not constant so
177  ! an error is reported.
178  subroutine s12
179    integer, pointer :: p(:)
180    type :: t
181      integer :: a(4, 4)
182      integer :: b
183    end type
184    type(t), target :: x
185    type(t), target :: y(10,10)
186    integer :: v(10)
187    logical, parameter :: l1 = is_contiguous(x%a(:,:))
188    logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
189    !ERROR: Must be a constant value
190    logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
191    !ERROR: Must be a constant value
192    logical, parameter :: l4 = is_contiguous(x%a(:,v))
193    !ERROR: Must be a constant value
194    logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
195  end
196  subroutine test3(b)
197    integer, intent(inout) :: b(..)
198    !ERROR: Must be a constant value
199    integer, parameter :: i = rank(b)
200  end subroutine
201
202
203end
204