1 /* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2023 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_UINTEGER_4)
30 extern void findloc1_s4 (gfc_array_index_type * const restrict retarray,
31 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
32 const index_type * restrict pdim, GFC_LOGICAL_4 back,
33 gfc_charlen_type len_array, gfc_charlen_type len_value);
34 export_proto(findloc1_s4);
35
36 extern void
37 findloc1_s4 (gfc_array_index_type * const restrict retarray,
38 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
39 const index_type * restrict pdim, GFC_LOGICAL_4 back,
40 gfc_charlen_type len_array, gfc_charlen_type len_value)
41 {
42 index_type count[GFC_MAX_DIMENSIONS];
43 index_type extent[GFC_MAX_DIMENSIONS];
44 index_type sstride[GFC_MAX_DIMENSIONS];
45 index_type dstride[GFC_MAX_DIMENSIONS];
46 const GFC_UINTEGER_4 * restrict base;
47 index_type * restrict dest;
48 index_type rank;
49 index_type n;
50 index_type len;
51 index_type delta;
52 index_type dim;
53 int continue_loop;
54
55 /* Make dim zero based to avoid confusion. */
56 rank = GFC_DESCRIPTOR_RANK (array) - 1;
57 dim = (*pdim) - 1;
58
59 if (unlikely (dim < 0 || dim > rank))
60 {
61 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
62 "is %ld, should be between 1 and %ld",
63 (long int) dim + 1, (long int) rank + 1);
64 }
65
66 len = GFC_DESCRIPTOR_EXTENT(array,dim);
67 if (len < 0)
68 len = 0;
69 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
70
71 for (n = 0; n < dim; n++)
72 {
73 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
74 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
75
76 if (extent[n] < 0)
77 extent[n] = 0;
78 }
79 for (n = dim; n < rank; n++)
80 {
81 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
82 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
83
84 if (extent[n] < 0)
85 extent[n] = 0;
86 }
87
88 if (retarray->base_addr == NULL)
89 {
90 size_t alloc_size, str;
91
92 for (n = 0; n < rank; n++)
93 {
94 if (n == 0)
95 str = 1;
96 else
97 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
98
99 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
100
101 }
102
103 retarray->offset = 0;
104 retarray->dtype.rank = rank;
105
106 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
107
108 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
109 if (alloc_size == 0)
110 {
111 /* Make sure we have a zero-sized array. */
112 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
113 return;
114 }
115 }
116 else
117 {
118 if (rank != GFC_DESCRIPTOR_RANK (retarray))
119 runtime_error ("rank of return array incorrect in"
120 " FINDLOC intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
122 (long int) rank);
123
124 if (unlikely (compile_options.bounds_check))
125 bounds_ifunction_return ((array_t *) retarray, extent,
126 "return value", "FINDLOC");
127 }
128
129 for (n = 0; n < rank; n++)
130 {
131 count[n] = 0;
132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
133 if (extent[n] <= 0)
134 return;
135 }
136
137 dest = retarray->base_addr;
138 continue_loop = 1;
139
140 base = array->base_addr;
141 while (continue_loop)
142 {
143 const GFC_UINTEGER_4 * restrict src;
144 index_type result;
145
146 result = 0;
147 if (back)
148 {
149 src = base + (len - 1) * delta * len_array;
150 for (n = len; n > 0; n--, src -= delta * len_array)
151 {
152 if (compare_string_char4 (len_array, src, len_value, value) == 0)
153 {
154 result = n;
155 break;
156 }
157 }
158 }
159 else
160 {
161 src = base;
162 for (n = 1; n <= len; n++, src += delta * len_array)
163 {
164 if (compare_string_char4 (len_array, src, len_value, value) == 0)
165 {
166 result = n;
167 break;
168 }
169 }
170 }
171 *dest = result;
172
173 count[0]++;
174 base += sstride[0] * len_array;
175 dest += dstride[0];
176 n = 0;
177 while (count[n] == extent[n])
178 {
179 count[n] = 0;
180 base -= sstride[n] * extent[n] * len_array;
181 dest -= dstride[n] * extent[n];
182 n++;
183 if (n >= rank)
184 {
185 continue_loop = 0;
186 break;
187 }
188 else
189 {
190 count[n]++;
191 base += sstride[n] * len_array;
192 dest += dstride[n];
193 }
194 }
195 }
196 }
197 extern void mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
198 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
199 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
200 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
201 export_proto(mfindloc1_s4);
202
203 extern void
204 mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
205 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
206 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
207 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
208 {
209 index_type count[GFC_MAX_DIMENSIONS];
210 index_type extent[GFC_MAX_DIMENSIONS];
211 index_type sstride[GFC_MAX_DIMENSIONS];
212 index_type mstride[GFC_MAX_DIMENSIONS];
213 index_type dstride[GFC_MAX_DIMENSIONS];
214 const GFC_UINTEGER_4 * restrict base;
215 const GFC_LOGICAL_1 * restrict mbase;
216 index_type * restrict dest;
217 index_type rank;
218 index_type n;
219 index_type len;
220 index_type delta;
221 index_type mdelta;
222 index_type dim;
223 int mask_kind;
224 int continue_loop;
225
226 /* Make dim zero based to avoid confusion. */
227 rank = GFC_DESCRIPTOR_RANK (array) - 1;
228 dim = (*pdim) - 1;
229
230 if (unlikely (dim < 0 || dim > rank))
231 {
232 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
233 "is %ld, should be between 1 and %ld",
234 (long int) dim + 1, (long int) rank + 1);
235 }
236
237 len = GFC_DESCRIPTOR_EXTENT(array,dim);
238 if (len < 0)
239 len = 0;
240
241 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
242 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
243
244 mbase = mask->base_addr;
245
246 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
247
248 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
249 #ifdef HAVE_GFC_LOGICAL_16
250 || mask_kind == 16
251 #endif
252 )
253 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
254 else
255 internal_error (NULL, "Funny sized logical array");
256
257 for (n = 0; n < dim; n++)
258 {
259 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
260 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
261 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
262
263 if (extent[n] < 0)
264 extent[n] = 0;
265 }
266 for (n = dim; n < rank; n++)
267 {
268 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
269 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
270 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
271
272 if (extent[n] < 0)
273 extent[n] = 0;
274 }
275
276 if (retarray->base_addr == NULL)
277 {
278 size_t alloc_size, str;
279
280 for (n = 0; n < rank; n++)
281 {
282 if (n == 0)
283 str = 1;
284 else
285 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
286
287 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
288
289 }
290
291 retarray->offset = 0;
292 retarray->dtype.rank = rank;
293
294 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
295
296 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
297 if (alloc_size == 0)
298 {
299 /* Make sure we have a zero-sized array. */
300 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
301 return;
302 }
303 }
304 else
305 {
306 if (rank != GFC_DESCRIPTOR_RANK (retarray))
307 runtime_error ("rank of return array incorrect in"
308 " FINDLOC intrinsic: is %ld, should be %ld",
309 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
310 (long int) rank);
311
312 if (unlikely (compile_options.bounds_check))
313 bounds_ifunction_return ((array_t *) retarray, extent,
314 "return value", "FINDLOC");
315 }
316
317 for (n = 0; n < rank; n++)
318 {
319 count[n] = 0;
320 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
321 if (extent[n] <= 0)
322 return;
323 }
324
325 dest = retarray->base_addr;
326 continue_loop = 1;
327
328 base = array->base_addr;
329 while (continue_loop)
330 {
331 const GFC_UINTEGER_4 * restrict src;
332 const GFC_LOGICAL_1 * restrict msrc;
333 index_type result;
334
335 result = 0;
336 if (back)
337 {
338 src = base + (len - 1) * delta * len_array;
339 msrc = mbase + (len - 1) * mdelta;
340 for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta)
341 {
342 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
343 {
344 result = n;
345 break;
346 }
347 }
348 }
349 else
350 {
351 src = base;
352 msrc = mbase;
353 for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta)
354 {
355 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
356 {
357 result = n;
358 break;
359 }
360 }
361 }
362 *dest = result;
363
364 count[0]++;
365 base += sstride[0] * len_array;
366 mbase += mstride[0];
367 dest += dstride[0];
368 n = 0;
369 while (count[n] == extent[n])
370 {
371 count[n] = 0;
372 base -= sstride[n] * extent[n] * len_array;
373 mbase -= mstride[n] * extent[n];
374 dest -= dstride[n] * extent[n];
375 n++;
376 if (n >= rank)
377 {
378 continue_loop = 0;
379 break;
380 }
381 else
382 {
383 count[n]++;
384 base += sstride[n] * len_array;
385 dest += dstride[n];
386 }
387 }
388 }
389 }
390 extern void sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
391 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
392 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
393 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
394 export_proto(sfindloc1_s4);
395
396 extern void
397 sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
398 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
399 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
400 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
401 {
402 index_type count[GFC_MAX_DIMENSIONS];
403 index_type extent[GFC_MAX_DIMENSIONS];
404 index_type dstride[GFC_MAX_DIMENSIONS];
405 index_type * restrict dest;
406 index_type rank;
407 index_type n;
408 index_type len;
409 index_type dim;
410 bool continue_loop;
411
412 if (mask == NULL || *mask)
413 {
414 findloc1_s4 (retarray, array, value, pdim, back, len_array, len_value);
415 return;
416 }
417 /* Make dim zero based to avoid confusion. */
418 rank = GFC_DESCRIPTOR_RANK (array) - 1;
419 dim = (*pdim) - 1;
420
421 if (unlikely (dim < 0 || dim > rank))
422 {
423 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
424 "is %ld, should be between 1 and %ld",
425 (long int) dim + 1, (long int) rank + 1);
426 }
427
428 len = GFC_DESCRIPTOR_EXTENT(array,dim);
429 if (len < 0)
430 len = 0;
431
432 for (n = 0; n < dim; n++)
433 {
434 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
435
436 if (extent[n] <= 0)
437 extent[n] = 0;
438 }
439
440 for (n = dim; n < rank; n++)
441 {
442 extent[n] =
443 GFC_DESCRIPTOR_EXTENT(array,n + 1);
444
445 if (extent[n] <= 0)
446 extent[n] = 0;
447 }
448
449
450 if (retarray->base_addr == NULL)
451 {
452 size_t alloc_size, str;
453
454 for (n = 0; n < rank; n++)
455 {
456 if (n == 0)
457 str = 1;
458 else
459 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
460
461 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
462 }
463
464 retarray->offset = 0;
465 retarray->dtype.rank = rank;
466
467 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
468
469 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
470 if (alloc_size == 0)
471 {
472 /* Make sure we have a zero-sized array. */
473 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
474 return;
475 }
476 }
477 else
478 {
479 if (rank != GFC_DESCRIPTOR_RANK (retarray))
480 runtime_error ("rank of return array incorrect in"
481 " FINDLOC intrinsic: is %ld, should be %ld",
482 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
483 (long int) rank);
484
485 if (unlikely (compile_options.bounds_check))
486 bounds_ifunction_return ((array_t *) retarray, extent,
487 "return value", "FINDLOC");
488 }
489
490 for (n = 0; n < rank; n++)
491 {
492 count[n] = 0;
493 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
494 if (extent[n] <= 0)
495 return;
496 }
497 dest = retarray->base_addr;
498 continue_loop = 1;
499
500 while (continue_loop)
501 {
502 *dest = 0;
503
504 count[0]++;
505 dest += dstride[0];
506 n = 0;
507 while (count[n] == extent[n])
508 {
509 count[n] = 0;
510 dest -= dstride[n] * extent[n];
511 n++;
512 if (n >= rank)
513 {
514 continue_loop = 0;
515 break;
516 }
517 else
518 {
519 count[n]++;
520 dest += dstride[n];
521 }
522 }
523 }
524 }
525 #endif