]>
Commit | Line | Data |
---|---|---|
7adcbafe | 1 | /* Copyright (C) 2009-2022 Free Software Foundation, Inc. |
16bff921 TK |
2 | Contributed by Thomas Koenig |
3 | ||
4 | This file is part of the GNU Fortran runtime library (libgfortran). | |
5 | ||
6 | Libgfortran is free software; you can redistribute it and/or modify | |
7 | it under the terms of the GNU General Public License as published by | |
8 | the Free Software Foundation; either version 3, or (at your option) | |
9 | any later version. | |
10 | ||
11 | Libgfortran is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
16 | Under Section 7 of GPL version 3, you are granted additional | |
17 | permissions described in the GCC Runtime Library Exception, version | |
18 | 3.1, as published by the Free Software Foundation. | |
19 | ||
20 | You should have received a copy of the GNU General Public License and | |
21 | a copy of the GCC Runtime Library Exception along with this program; | |
22 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
23 | <http://www.gnu.org/licenses/>. */ | |
24 | ||
25 | #include "libgfortran.h" | |
26 | #include <assert.h> | |
27 | ||
28 | /* Auxiliary functions for bounds checking, mostly to reduce library size. */ | |
29 | ||
30 | /* Bounds checking for the return values of the iforeach functions (such | |
31 | as maxloc and minloc). The extent of ret_array must | |
32 | must match the rank of array. */ | |
33 | ||
34 | void | |
35 | bounds_iforeach_return (array_t *retarray, array_t *array, const char *name) | |
36 | { | |
37 | index_type rank; | |
38 | index_type ret_rank; | |
39 | index_type ret_extent; | |
40 | ||
41 | ret_rank = GFC_DESCRIPTOR_RANK (retarray); | |
42 | ||
02fdb130 DH |
43 | /* ret_rank should always be 1, otherwise there is an internal error */ |
44 | GFC_ASSERT(ret_rank == 1); | |
16bff921 TK |
45 | |
46 | rank = GFC_DESCRIPTOR_RANK (array); | |
47 | ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); | |
48 | if (ret_extent != rank) | |
49 | runtime_error ("Incorrect extent in return value of" | |
50 | " %s intrinsic: is %ld, should be %ld", | |
51 | name, (long int) ret_extent, (long int) rank); | |
52 | ||
53 | } | |
54 | ||
55 | /* Check the return of functions generated from ifunction.m4. | |
56 | We check the array descriptor "a" against the extents precomputed | |
57 | from ifunction.m4, and complain about the argument a_name in the | |
58 | intrinsic function. */ | |
59 | ||
60 | void | |
61 | bounds_ifunction_return (array_t * a, const index_type * extent, | |
62 | const char * a_name, const char * intrinsic) | |
63 | { | |
64 | int empty; | |
16bff921 TK |
65 | int rank; |
66 | index_type a_size; | |
67 | ||
68 | rank = GFC_DESCRIPTOR_RANK (a); | |
69 | a_size = size0 (a); | |
70 | ||
71 | empty = 0; | |
7a157266 | 72 | for (index_type n = 0; n < rank; n++) |
16bff921 TK |
73 | { |
74 | if (extent[n] == 0) | |
75 | empty = 1; | |
76 | } | |
77 | if (empty) | |
78 | { | |
79 | if (a_size != 0) | |
80 | runtime_error ("Incorrect size in %s of %s" | |
81 | " intrinsic: should be zero-sized", | |
82 | a_name, intrinsic); | |
83 | } | |
84 | else | |
85 | { | |
86 | if (a_size == 0) | |
87 | runtime_error ("Incorrect size of %s in %s" | |
88 | " intrinsic: should not be zero-sized", | |
89 | a_name, intrinsic); | |
90 | ||
7a157266 | 91 | for (index_type n = 0; n < rank; n++) |
16bff921 TK |
92 | { |
93 | index_type a_extent; | |
94 | a_extent = GFC_DESCRIPTOR_EXTENT(a, n); | |
95 | if (a_extent != extent[n]) | |
96 | runtime_error("Incorrect extent in %s of %s" | |
97 | " intrinsic in dimension %ld: is %ld," | |
98 | " should be %ld", a_name, intrinsic, (long int) n + 1, | |
99 | (long int) a_extent, (long int) extent[n]); | |
100 | ||
101 | } | |
102 | } | |
103 | } | |
104 | ||
105 | /* Check that two arrays have equal extents, or are both zero-sized. Abort | |
106 | with a runtime error if this is not the case. Complain that a has the | |
107 | wrong size. */ | |
108 | ||
109 | void | |
110 | bounds_equal_extents (array_t *a, array_t *b, const char *a_name, | |
111 | const char *intrinsic) | |
112 | { | |
113 | index_type a_size, b_size, n; | |
114 | ||
115 | assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b)); | |
116 | ||
117 | a_size = size0 (a); | |
118 | b_size = size0 (b); | |
119 | ||
120 | if (b_size == 0) | |
121 | { | |
122 | if (a_size != 0) | |
123 | runtime_error ("Incorrect size of %s in %s" | |
124 | " intrinsic: should be zero-sized", | |
125 | a_name, intrinsic); | |
126 | } | |
127 | else | |
128 | { | |
129 | if (a_size == 0) | |
130 | runtime_error ("Incorrect size of %s of %s" | |
131 | " intrinsic: Should not be zero-sized", | |
132 | a_name, intrinsic); | |
133 | ||
134 | for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) | |
135 | { | |
136 | index_type a_extent, b_extent; | |
137 | ||
138 | a_extent = GFC_DESCRIPTOR_EXTENT(a, n); | |
139 | b_extent = GFC_DESCRIPTOR_EXTENT(b, n); | |
140 | if (a_extent != b_extent) | |
141 | runtime_error("Incorrect extent in %s of %s" | |
142 | " intrinsic in dimension %ld: is %ld," | |
143 | " should be %ld", a_name, intrinsic, (long int) n + 1, | |
144 | (long int) a_extent, (long int) b_extent); | |
145 | } | |
146 | } | |
147 | } | |
148 | ||
149 | /* Check that the extents of a and b agree, except that a has a missing | |
150 | dimension in argument which. Complain about a if anything is wrong. */ | |
151 | ||
152 | void | |
153 | bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name, | |
154 | const char *intrinsic) | |
155 | { | |
156 | ||
157 | index_type i, n, a_size, b_size; | |
158 | ||
159 | assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1); | |
160 | ||
161 | a_size = size0 (a); | |
162 | b_size = size0 (b); | |
163 | ||
164 | if (b_size == 0) | |
165 | { | |
166 | if (a_size != 0) | |
167 | runtime_error ("Incorrect size in %s of %s" | |
168 | " intrinsic: should not be zero-sized", | |
169 | a_name, intrinsic); | |
170 | } | |
171 | else | |
172 | { | |
173 | if (a_size == 0) | |
174 | runtime_error ("Incorrect size of %s of %s" | |
175 | " intrinsic: should be zero-sized", | |
176 | a_name, intrinsic); | |
177 | ||
178 | i = 0; | |
179 | for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) | |
180 | { | |
181 | index_type a_extent, b_extent; | |
182 | ||
183 | if (n != which) | |
184 | { | |
185 | a_extent = GFC_DESCRIPTOR_EXTENT(a, i); | |
186 | b_extent = GFC_DESCRIPTOR_EXTENT(b, n); | |
187 | if (a_extent != b_extent) | |
188 | runtime_error("Incorrect extent in %s of %s" | |
189 | " intrinsic in dimension %ld: is %ld," | |
190 | " should be %ld", a_name, intrinsic, (long int) i + 1, | |
191 | (long int) a_extent, (long int) b_extent); | |
192 | i++; | |
193 | } | |
194 | } | |
195 | } | |
196 | } | |
8c39b987 TK |
197 | |
198 | /* count_0 - count all the true elements in an array. The front | |
199 | end usually inlines this, we need this for bounds checking | |
200 | for unpack. */ | |
201 | ||
202 | index_type count_0 (const gfc_array_l1 * array) | |
203 | { | |
204 | const GFC_LOGICAL_1 * restrict base; | |
205 | index_type rank; | |
206 | int kind; | |
207 | int continue_loop; | |
208 | index_type count[GFC_MAX_DIMENSIONS]; | |
209 | index_type extent[GFC_MAX_DIMENSIONS]; | |
210 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
211 | index_type result; | |
212 | index_type n; | |
213 | ||
214 | rank = GFC_DESCRIPTOR_RANK (array); | |
215 | kind = GFC_DESCRIPTOR_SIZE (array); | |
216 | ||
21d1335b | 217 | base = array->base_addr; |
8c39b987 TK |
218 | |
219 | if (kind == 1 || kind == 2 || kind == 4 || kind == 8 | |
220 | #ifdef HAVE_GFC_LOGICAL_16 | |
221 | || kind == 16 | |
222 | #endif | |
223 | ) | |
224 | { | |
225 | if (base) | |
226 | base = GFOR_POINTER_TO_L1 (base, kind); | |
227 | } | |
228 | else | |
229 | internal_error (NULL, "Funny sized logical array in count_0"); | |
230 | ||
231 | for (n = 0; n < rank; n++) | |
232 | { | |
233 | sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); | |
234 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
235 | count[n] = 0; | |
236 | ||
01d93568 | 237 | if (extent[n] <= 0) |
8c39b987 TK |
238 | return 0; |
239 | } | |
240 | ||
241 | result = 0; | |
242 | continue_loop = 1; | |
243 | while (continue_loop) | |
244 | { | |
245 | if (*base) | |
246 | result ++; | |
247 | ||
248 | count[0]++; | |
249 | base += sstride[0]; | |
250 | n = 0; | |
251 | while (count[n] == extent[n]) | |
252 | { | |
253 | count[n] = 0; | |
254 | base -= sstride[n] * extent[n]; | |
255 | n++; | |
256 | if (n == rank) | |
257 | { | |
258 | continue_loop = 0; | |
259 | break; | |
260 | } | |
261 | else | |
262 | { | |
263 | count[n]++; | |
264 | base += sstride[n]; | |
265 | } | |
266 | } | |
267 | } | |
268 | return result; | |
269 | } |