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