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_COMPLEX_10)
30 extern void findloc1_c10 (gfc_array_index_type * const restrict retarray,
31 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 value,
32 const index_type * restrict pdim, GFC_LOGICAL_4 back);
33 export_proto(findloc1_c10);
34
35 extern void
36 findloc1_c10 (gfc_array_index_type * const restrict retarray,
37 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 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_COMPLEX_10 * 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_COMPLEX_10 * 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_c10 (gfc_array_index_type * const restrict retarray,
196 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 value,
197 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
198 GFC_LOGICAL_4 back);
199 export_proto(mfindloc1_c10);
200
201 extern void
202 mfindloc1_c10 (gfc_array_index_type * const restrict retarray,
203 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 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_COMPLEX_10 * 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_COMPLEX_10 * 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_c10 (gfc_array_index_type * const restrict retarray,
389 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 value,
390 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
391 GFC_LOGICAL_4 back);
392 export_proto(sfindloc1_c10);
393
394 extern void
395 sfindloc1_c10 (gfc_array_index_type * const restrict retarray,
396 gfc_array_c10 * const restrict array, GFC_COMPLEX_10 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_c10 (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