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