Mercurial > hg > CbC > CbC_gcc
comparison libgfortran/generated/findloc1_i4.c @ 145:1830386684a0
gcc-9.2.0
author | anatofuz |
---|---|
date | Thu, 13 Feb 2020 11:34:05 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
131:84e7813d76e9 | 145:1830386684a0 |
---|---|
1 /* Implementation of the FINDLOC intrinsic | |
2 Copyright (C) 2018-2020 Free Software Foundation, Inc. | |
3 Contributed by Thomas König <tk@tkoenig.net> | |
4 | |
5 This file is part of the GNU Fortran 95 runtime library (libgfortran). | |
6 | |
7 Libgfortran is free software; you can redistribute it and/or | |
8 modify it under the terms of the GNU General Public | |
9 License as published by the Free Software Foundation; either | |
10 version 3 of the License, or (at your option) any later version. | |
11 | |
12 Libgfortran is distributed in the hope that it will be useful, | |
13 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 GNU General Public License for more details. | |
16 | |
17 Under Section 7 of GPL version 3, you are granted additional | |
18 permissions described in the GCC Runtime Library Exception, version | |
19 3.1, as published by the Free Software Foundation. | |
20 | |
21 You should have received a copy of the GNU General Public License and | |
22 a copy of the GCC Runtime Library Exception along with this program; | |
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
24 <http://www.gnu.org/licenses/>. */ | |
25 | |
26 #include "libgfortran.h" | |
27 #include <assert.h> | |
28 | |
29 #if defined (HAVE_GFC_INTEGER_4) | |
30 extern void findloc1_i4 (gfc_array_index_type * const restrict retarray, | |
31 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
32 const index_type * restrict pdim, GFC_LOGICAL_4 back); | |
33 export_proto(findloc1_i4); | |
34 | |
35 extern void | |
36 findloc1_i4 (gfc_array_index_type * const restrict retarray, | |
37 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
38 const index_type * restrict pdim, GFC_LOGICAL_4 back) | |
39 { | |
40 index_type count[GFC_MAX_DIMENSIONS]; | |
41 index_type extent[GFC_MAX_DIMENSIONS]; | |
42 index_type sstride[GFC_MAX_DIMENSIONS]; | |
43 index_type dstride[GFC_MAX_DIMENSIONS]; | |
44 const GFC_INTEGER_4 * restrict base; | |
45 index_type * restrict dest; | |
46 index_type rank; | |
47 index_type n; | |
48 index_type len; | |
49 index_type delta; | |
50 index_type dim; | |
51 int continue_loop; | |
52 | |
53 /* Make dim zero based to avoid confusion. */ | |
54 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
55 dim = (*pdim) - 1; | |
56 | |
57 if (unlikely (dim < 0 || dim > rank)) | |
58 { | |
59 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " | |
60 "is %ld, should be between 1 and %ld", | |
61 (long int) dim + 1, (long int) rank + 1); | |
62 } | |
63 | |
64 len = GFC_DESCRIPTOR_EXTENT(array,dim); | |
65 if (len < 0) | |
66 len = 0; | |
67 delta = GFC_DESCRIPTOR_STRIDE(array,dim); | |
68 | |
69 for (n = 0; n < dim; n++) | |
70 { | |
71 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); | |
72 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
73 | |
74 if (extent[n] < 0) | |
75 extent[n] = 0; | |
76 } | |
77 for (n = dim; n < rank; n++) | |
78 { | |
79 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); | |
80 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); | |
81 | |
82 if (extent[n] < 0) | |
83 extent[n] = 0; | |
84 } | |
85 | |
86 if (retarray->base_addr == NULL) | |
87 { | |
88 size_t alloc_size, str; | |
89 | |
90 for (n = 0; n < rank; n++) | |
91 { | |
92 if (n == 0) | |
93 str = 1; | |
94 else | |
95 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
96 | |
97 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
98 | |
99 } | |
100 | |
101 retarray->offset = 0; | |
102 retarray->dtype.rank = rank; | |
103 | |
104 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
105 | |
106 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); | |
107 if (alloc_size == 0) | |
108 { | |
109 /* Make sure we have a zero-sized array. */ | |
110 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
111 return; | |
112 } | |
113 } | |
114 else | |
115 { | |
116 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
117 runtime_error ("rank of return array incorrect in" | |
118 " FINDLOC intrinsic: is %ld, should be %ld", | |
119 (long int) (GFC_DESCRIPTOR_RANK (retarray)), | |
120 (long int) rank); | |
121 | |
122 if (unlikely (compile_options.bounds_check)) | |
123 bounds_ifunction_return ((array_t *) retarray, extent, | |
124 "return value", "FINDLOC"); | |
125 } | |
126 | |
127 for (n = 0; n < rank; n++) | |
128 { | |
129 count[n] = 0; | |
130 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
131 if (extent[n] <= 0) | |
132 return; | |
133 } | |
134 | |
135 dest = retarray->base_addr; | |
136 continue_loop = 1; | |
137 | |
138 base = array->base_addr; | |
139 while (continue_loop) | |
140 { | |
141 const GFC_INTEGER_4 * restrict src; | |
142 index_type result; | |
143 | |
144 result = 0; | |
145 if (back) | |
146 { | |
147 src = base + (len - 1) * delta * 1; | |
148 for (n = len; n > 0; n--, src -= delta * 1) | |
149 { | |
150 if (*src == value) | |
151 { | |
152 result = n; | |
153 break; | |
154 } | |
155 } | |
156 } | |
157 else | |
158 { | |
159 src = base; | |
160 for (n = 1; n <= len; n++, src += delta * 1) | |
161 { | |
162 if (*src == value) | |
163 { | |
164 result = n; | |
165 break; | |
166 } | |
167 } | |
168 } | |
169 *dest = result; | |
170 | |
171 count[0]++; | |
172 base += sstride[0] * 1; | |
173 dest += dstride[0]; | |
174 n = 0; | |
175 while (count[n] == extent[n]) | |
176 { | |
177 count[n] = 0; | |
178 base -= sstride[n] * extent[n] * 1; | |
179 dest -= dstride[n] * extent[n]; | |
180 n++; | |
181 if (n >= rank) | |
182 { | |
183 continue_loop = 0; | |
184 break; | |
185 } | |
186 else | |
187 { | |
188 count[n]++; | |
189 base += sstride[n] * 1; | |
190 dest += dstride[n]; | |
191 } | |
192 } | |
193 } | |
194 } | |
195 extern void mfindloc1_i4 (gfc_array_index_type * const restrict retarray, | |
196 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
197 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, | |
198 GFC_LOGICAL_4 back); | |
199 export_proto(mfindloc1_i4); | |
200 | |
201 extern void | |
202 mfindloc1_i4 (gfc_array_index_type * const restrict retarray, | |
203 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
204 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, | |
205 GFC_LOGICAL_4 back) | |
206 { | |
207 index_type count[GFC_MAX_DIMENSIONS]; | |
208 index_type extent[GFC_MAX_DIMENSIONS]; | |
209 index_type sstride[GFC_MAX_DIMENSIONS]; | |
210 index_type mstride[GFC_MAX_DIMENSIONS]; | |
211 index_type dstride[GFC_MAX_DIMENSIONS]; | |
212 const GFC_INTEGER_4 * restrict base; | |
213 const GFC_LOGICAL_1 * restrict mbase; | |
214 index_type * restrict dest; | |
215 index_type rank; | |
216 index_type n; | |
217 index_type len; | |
218 index_type delta; | |
219 index_type mdelta; | |
220 index_type dim; | |
221 int mask_kind; | |
222 int continue_loop; | |
223 | |
224 /* Make dim zero based to avoid confusion. */ | |
225 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
226 dim = (*pdim) - 1; | |
227 | |
228 if (unlikely (dim < 0 || dim > rank)) | |
229 { | |
230 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " | |
231 "is %ld, should be between 1 and %ld", | |
232 (long int) dim + 1, (long int) rank + 1); | |
233 } | |
234 | |
235 len = GFC_DESCRIPTOR_EXTENT(array,dim); | |
236 if (len < 0) | |
237 len = 0; | |
238 | |
239 delta = GFC_DESCRIPTOR_STRIDE(array,dim); | |
240 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); | |
241 | |
242 mbase = mask->base_addr; | |
243 | |
244 mask_kind = GFC_DESCRIPTOR_SIZE (mask); | |
245 | |
246 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 | |
247 #ifdef HAVE_GFC_LOGICAL_16 | |
248 || mask_kind == 16 | |
249 #endif | |
250 ) | |
251 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); | |
252 else | |
253 internal_error (NULL, "Funny sized logical array"); | |
254 | |
255 for (n = 0; n < dim; n++) | |
256 { | |
257 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); | |
258 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); | |
259 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
260 | |
261 if (extent[n] < 0) | |
262 extent[n] = 0; | |
263 } | |
264 for (n = dim; n < rank; n++) | |
265 { | |
266 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); | |
267 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); | |
268 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); | |
269 | |
270 if (extent[n] < 0) | |
271 extent[n] = 0; | |
272 } | |
273 | |
274 if (retarray->base_addr == NULL) | |
275 { | |
276 size_t alloc_size, str; | |
277 | |
278 for (n = 0; n < rank; n++) | |
279 { | |
280 if (n == 0) | |
281 str = 1; | |
282 else | |
283 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
284 | |
285 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
286 | |
287 } | |
288 | |
289 retarray->offset = 0; | |
290 retarray->dtype.rank = rank; | |
291 | |
292 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
293 | |
294 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); | |
295 if (alloc_size == 0) | |
296 { | |
297 /* Make sure we have a zero-sized array. */ | |
298 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
299 return; | |
300 } | |
301 } | |
302 else | |
303 { | |
304 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
305 runtime_error ("rank of return array incorrect in" | |
306 " FINDLOC intrinsic: is %ld, should be %ld", | |
307 (long int) (GFC_DESCRIPTOR_RANK (retarray)), | |
308 (long int) rank); | |
309 | |
310 if (unlikely (compile_options.bounds_check)) | |
311 bounds_ifunction_return ((array_t *) retarray, extent, | |
312 "return value", "FINDLOC"); | |
313 } | |
314 | |
315 for (n = 0; n < rank; n++) | |
316 { | |
317 count[n] = 0; | |
318 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
319 if (extent[n] <= 0) | |
320 return; | |
321 } | |
322 | |
323 dest = retarray->base_addr; | |
324 continue_loop = 1; | |
325 | |
326 base = array->base_addr; | |
327 while (continue_loop) | |
328 { | |
329 const GFC_INTEGER_4 * restrict src; | |
330 const GFC_LOGICAL_1 * restrict msrc; | |
331 index_type result; | |
332 | |
333 result = 0; | |
334 if (back) | |
335 { | |
336 src = base + (len - 1) * delta * 1; | |
337 msrc = mbase + (len - 1) * mdelta; | |
338 for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta) | |
339 { | |
340 if (*msrc && *src == value) | |
341 { | |
342 result = n; | |
343 break; | |
344 } | |
345 } | |
346 } | |
347 else | |
348 { | |
349 src = base; | |
350 msrc = mbase; | |
351 for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta) | |
352 { | |
353 if (*msrc && *src == value) | |
354 { | |
355 result = n; | |
356 break; | |
357 } | |
358 } | |
359 } | |
360 *dest = result; | |
361 | |
362 count[0]++; | |
363 base += sstride[0] * 1; | |
364 mbase += mstride[0]; | |
365 dest += dstride[0]; | |
366 n = 0; | |
367 while (count[n] == extent[n]) | |
368 { | |
369 count[n] = 0; | |
370 base -= sstride[n] * extent[n] * 1; | |
371 mbase -= mstride[n] * extent[n]; | |
372 dest -= dstride[n] * extent[n]; | |
373 n++; | |
374 if (n >= rank) | |
375 { | |
376 continue_loop = 0; | |
377 break; | |
378 } | |
379 else | |
380 { | |
381 count[n]++; | |
382 base += sstride[n] * 1; | |
383 dest += dstride[n]; | |
384 } | |
385 } | |
386 } | |
387 } | |
388 extern void sfindloc1_i4 (gfc_array_index_type * const restrict retarray, | |
389 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
390 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, | |
391 GFC_LOGICAL_4 back); | |
392 export_proto(sfindloc1_i4); | |
393 | |
394 extern void | |
395 sfindloc1_i4 (gfc_array_index_type * const restrict retarray, | |
396 gfc_array_i4 * const restrict array, GFC_INTEGER_4 value, | |
397 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, | |
398 GFC_LOGICAL_4 back) | |
399 { | |
400 index_type count[GFC_MAX_DIMENSIONS]; | |
401 index_type extent[GFC_MAX_DIMENSIONS]; | |
402 index_type dstride[GFC_MAX_DIMENSIONS]; | |
403 index_type * restrict dest; | |
404 index_type rank; | |
405 index_type n; | |
406 index_type len; | |
407 index_type dim; | |
408 bool continue_loop; | |
409 | |
410 if (mask == NULL || *mask) | |
411 { | |
412 findloc1_i4 (retarray, array, value, pdim, back); | |
413 return; | |
414 } | |
415 /* Make dim zero based to avoid confusion. */ | |
416 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
417 dim = (*pdim) - 1; | |
418 | |
419 if (unlikely (dim < 0 || dim > rank)) | |
420 { | |
421 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " | |
422 "is %ld, should be between 1 and %ld", | |
423 (long int) dim + 1, (long int) rank + 1); | |
424 } | |
425 | |
426 len = GFC_DESCRIPTOR_EXTENT(array,dim); | |
427 if (len < 0) | |
428 len = 0; | |
429 | |
430 for (n = 0; n < dim; n++) | |
431 { | |
432 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
433 | |
434 if (extent[n] <= 0) | |
435 extent[n] = 0; | |
436 } | |
437 | |
438 for (n = dim; n < rank; n++) | |
439 { | |
440 extent[n] = | |
441 GFC_DESCRIPTOR_EXTENT(array,n + 1); | |
442 | |
443 if (extent[n] <= 0) | |
444 extent[n] = 0; | |
445 } | |
446 | |
447 | |
448 if (retarray->base_addr == NULL) | |
449 { | |
450 size_t alloc_size, str; | |
451 | |
452 for (n = 0; n < rank; n++) | |
453 { | |
454 if (n == 0) | |
455 str = 1; | |
456 else | |
457 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
458 | |
459 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
460 } | |
461 | |
462 retarray->offset = 0; | |
463 retarray->dtype.rank = rank; | |
464 | |
465 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
466 | |
467 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); | |
468 if (alloc_size == 0) | |
469 { | |
470 /* Make sure we have a zero-sized array. */ | |
471 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
472 return; | |
473 } | |
474 } | |
475 else | |
476 { | |
477 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
478 runtime_error ("rank of return array incorrect in" | |
479 " FINDLOC intrinsic: is %ld, should be %ld", | |
480 (long int) (GFC_DESCRIPTOR_RANK (retarray)), | |
481 (long int) rank); | |
482 | |
483 if (unlikely (compile_options.bounds_check)) | |
484 bounds_ifunction_return ((array_t *) retarray, extent, | |
485 "return value", "FINDLOC"); | |
486 } | |
487 | |
488 for (n = 0; n < rank; n++) | |
489 { | |
490 count[n] = 0; | |
491 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
492 if (extent[n] <= 0) | |
493 return; | |
494 } | |
495 dest = retarray->base_addr; | |
496 continue_loop = 1; | |
497 | |
498 while (continue_loop) | |
499 { | |
500 *dest = 0; | |
501 | |
502 count[0]++; | |
503 dest += dstride[0]; | |
504 n = 0; | |
505 while (count[n] == extent[n]) | |
506 { | |
507 count[n] = 0; | |
508 dest -= dstride[n] * extent[n]; | |
509 n++; | |
510 if (n >= rank) | |
511 { | |
512 continue_loop = 0; | |
513 break; | |
514 } | |
515 else | |
516 { | |
517 count[n]++; | |
518 dest += dstride[n]; | |
519 } | |
520 } | |
521 } | |
522 } | |
523 #endif |