Skip gnat.dg/prot7.adb on hppa.
[official-gcc.git] / libgfortran / generated / maxloc1_8_i4.c
blob57a001fefc696c49fd5db819334026cd0c78d567
1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
27 #include <assert.h>
30 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
32 #define HAVE_BACK_ARG 1
35 extern void maxloc1_8_i4 (gfc_array_i8 * const restrict,
36 gfc_array_i4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
37 export_proto(maxloc1_8_i4);
39 void
40 maxloc1_8_i4 (gfc_array_i8 * const restrict retarray,
41 gfc_array_i4 * const restrict array,
42 const index_type * const restrict pdim, GFC_LOGICAL_4 back)
44 index_type count[GFC_MAX_DIMENSIONS];
45 index_type extent[GFC_MAX_DIMENSIONS];
46 index_type sstride[GFC_MAX_DIMENSIONS];
47 index_type dstride[GFC_MAX_DIMENSIONS];
48 const GFC_INTEGER_4 * restrict base;
49 GFC_INTEGER_8 * restrict dest;
50 index_type rank;
51 index_type n;
52 index_type len;
53 index_type delta;
54 index_type dim;
55 int continue_loop;
57 /* Make dim zero based to avoid confusion. */
58 rank = GFC_DESCRIPTOR_RANK (array) - 1;
59 dim = (*pdim) - 1;
61 if (unlikely (dim < 0 || dim > rank))
63 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
64 "is %ld, should be between 1 and %ld",
65 (long int) dim + 1, (long int) rank + 1);
68 len = GFC_DESCRIPTOR_EXTENT(array,dim);
69 if (len < 0)
70 len = 0;
71 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
73 for (n = 0; n < dim; n++)
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
78 if (extent[n] < 0)
79 extent[n] = 0;
81 for (n = dim; n < rank; n++)
83 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
84 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
86 if (extent[n] < 0)
87 extent[n] = 0;
90 if (retarray->base_addr == NULL)
92 size_t alloc_size, str;
94 for (n = 0; n < rank; n++)
96 if (n == 0)
97 str = 1;
98 else
99 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
101 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
105 retarray->offset = 0;
106 retarray->dtype.rank = rank;
108 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
110 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
111 if (alloc_size == 0)
113 /* Make sure we have a zero-sized array. */
114 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
115 return;
119 else
121 if (rank != GFC_DESCRIPTOR_RANK (retarray))
122 runtime_error ("rank of return array incorrect in"
123 " MAXLOC intrinsic: is %ld, should be %ld",
124 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
125 (long int) rank);
127 if (unlikely (compile_options.bounds_check))
128 bounds_ifunction_return ((array_t *) retarray, extent,
129 "return value", "MAXLOC");
132 for (n = 0; n < rank; n++)
134 count[n] = 0;
135 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
136 if (extent[n] <= 0)
137 return;
140 base = array->base_addr;
141 dest = retarray->base_addr;
143 continue_loop = 1;
144 while (continue_loop)
146 const GFC_INTEGER_4 * restrict src;
147 GFC_INTEGER_8 result;
148 src = base;
151 GFC_INTEGER_4 maxval;
152 #if defined (GFC_INTEGER_4_INFINITY)
153 maxval = -GFC_INTEGER_4_INFINITY;
154 #else
155 maxval = (-GFC_INTEGER_4_HUGE-1);
156 #endif
157 result = 1;
158 if (len <= 0)
159 *dest = 0;
160 else
162 #if ! defined HAVE_BACK_ARG
163 for (n = 0; n < len; n++, src += delta)
165 #endif
167 #if defined (GFC_INTEGER_4_QUIET_NAN)
168 for (n = 0; n < len; n++, src += delta)
170 if (*src >= maxval)
172 maxval = *src;
173 result = (GFC_INTEGER_8)n + 1;
174 break;
177 #else
178 n = 0;
179 #endif
180 for (; n < len; n++, src += delta)
182 if (back ? *src >= maxval : *src > maxval)
184 maxval = *src;
185 result = (GFC_INTEGER_8)n + 1;
189 *dest = result;
192 /* Advance to the next element. */
193 count[0]++;
194 base += sstride[0];
195 dest += dstride[0];
196 n = 0;
197 while (count[n] == extent[n])
199 /* When we get to the end of a dimension, reset it and increment
200 the next dimension. */
201 count[n] = 0;
202 /* We could precalculate these products, but this is a less
203 frequently used path so probably not worth it. */
204 base -= sstride[n] * extent[n];
205 dest -= dstride[n] * extent[n];
206 n++;
207 if (n >= rank)
209 /* Break out of the loop. */
210 continue_loop = 0;
211 break;
213 else
215 count[n]++;
216 base += sstride[n];
217 dest += dstride[n];
224 extern void mmaxloc1_8_i4 (gfc_array_i8 * const restrict,
225 gfc_array_i4 * const restrict, const index_type * const restrict,
226 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
227 export_proto(mmaxloc1_8_i4);
229 void
230 mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray,
231 gfc_array_i4 * const restrict array,
232 const index_type * const restrict pdim,
233 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
235 index_type count[GFC_MAX_DIMENSIONS];
236 index_type extent[GFC_MAX_DIMENSIONS];
237 index_type sstride[GFC_MAX_DIMENSIONS];
238 index_type dstride[GFC_MAX_DIMENSIONS];
239 index_type mstride[GFC_MAX_DIMENSIONS];
240 GFC_INTEGER_8 * restrict dest;
241 const GFC_INTEGER_4 * restrict base;
242 const GFC_LOGICAL_1 * restrict mbase;
243 index_type rank;
244 index_type dim;
245 index_type n;
246 index_type len;
247 index_type delta;
248 index_type mdelta;
249 int mask_kind;
251 if (mask == NULL)
253 #ifdef HAVE_BACK_ARG
254 maxloc1_8_i4 (retarray, array, pdim, back);
255 #else
256 maxloc1_8_i4 (retarray, array, pdim);
257 #endif
258 return;
261 dim = (*pdim) - 1;
262 rank = GFC_DESCRIPTOR_RANK (array) - 1;
265 if (unlikely (dim < 0 || dim > rank))
267 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
268 "is %ld, should be between 1 and %ld",
269 (long int) dim + 1, (long int) rank + 1);
272 len = GFC_DESCRIPTOR_EXTENT(array,dim);
273 if (len <= 0)
274 return;
276 mbase = mask->base_addr;
278 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
280 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
281 #ifdef HAVE_GFC_LOGICAL_16
282 || mask_kind == 16
283 #endif
285 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
286 else
287 runtime_error ("Funny sized logical array");
289 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
290 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
292 for (n = 0; n < dim; n++)
294 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
295 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
296 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
298 if (extent[n] < 0)
299 extent[n] = 0;
302 for (n = dim; n < rank; n++)
304 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
305 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
306 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
308 if (extent[n] < 0)
309 extent[n] = 0;
312 if (retarray->base_addr == NULL)
314 size_t alloc_size, str;
316 for (n = 0; n < rank; n++)
318 if (n == 0)
319 str = 1;
320 else
321 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
323 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
327 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
329 retarray->offset = 0;
330 retarray->dtype.rank = rank;
332 if (alloc_size == 0)
334 /* Make sure we have a zero-sized array. */
335 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
336 return;
338 else
339 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
342 else
344 if (rank != GFC_DESCRIPTOR_RANK (retarray))
345 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
347 if (unlikely (compile_options.bounds_check))
349 bounds_ifunction_return ((array_t *) retarray, extent,
350 "return value", "MAXLOC");
351 bounds_equal_extents ((array_t *) mask, (array_t *) array,
352 "MASK argument", "MAXLOC");
356 for (n = 0; n < rank; n++)
358 count[n] = 0;
359 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
360 if (extent[n] <= 0)
361 return;
364 dest = retarray->base_addr;
365 base = array->base_addr;
367 while (base)
369 const GFC_INTEGER_4 * restrict src;
370 const GFC_LOGICAL_1 * restrict msrc;
371 GFC_INTEGER_8 result;
372 src = base;
373 msrc = mbase;
376 GFC_INTEGER_4 maxval;
377 #if defined (GFC_INTEGER_4_INFINITY)
378 maxval = -GFC_INTEGER_4_INFINITY;
379 #else
380 maxval = (-GFC_INTEGER_4_HUGE-1);
381 #endif
382 #if defined (GFC_INTEGER_4_QUIET_NAN)
383 GFC_INTEGER_8 result2 = 0;
384 #endif
385 result = 0;
386 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
389 if (*msrc)
391 #if defined (GFC_INTEGER_4_QUIET_NAN)
392 if (!result2)
393 result2 = (GFC_INTEGER_8)n + 1;
394 if (*src >= maxval)
395 #endif
397 maxval = *src;
398 result = (GFC_INTEGER_8)n + 1;
399 break;
403 #if defined (GFC_INTEGER_4_QUIET_NAN)
404 if (unlikely (n >= len))
405 result = result2;
406 else
407 #endif
408 if (back)
409 for (; n < len; n++, src += delta, msrc += mdelta)
411 if (*msrc && unlikely (*src >= maxval))
413 maxval = *src;
414 result = (GFC_INTEGER_8)n + 1;
417 else
418 for (; n < len; n++, src += delta, msrc += mdelta)
420 if (*msrc && unlikely (*src > maxval))
422 maxval = *src;
423 result = (GFC_INTEGER_8)n + 1;
426 *dest = result;
428 /* Advance to the next element. */
429 count[0]++;
430 base += sstride[0];
431 mbase += mstride[0];
432 dest += dstride[0];
433 n = 0;
434 while (count[n] == extent[n])
436 /* When we get to the end of a dimension, reset it and increment
437 the next dimension. */
438 count[n] = 0;
439 /* We could precalculate these products, but this is a less
440 frequently used path so probably not worth it. */
441 base -= sstride[n] * extent[n];
442 mbase -= mstride[n] * extent[n];
443 dest -= dstride[n] * extent[n];
444 n++;
445 if (n >= rank)
447 /* Break out of the loop. */
448 base = NULL;
449 break;
451 else
453 count[n]++;
454 base += sstride[n];
455 mbase += mstride[n];
456 dest += dstride[n];
463 extern void smaxloc1_8_i4 (gfc_array_i8 * const restrict,
464 gfc_array_i4 * const restrict, const index_type * const restrict,
465 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
466 export_proto(smaxloc1_8_i4);
468 void
469 smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray,
470 gfc_array_i4 * const restrict array,
471 const index_type * const restrict pdim,
472 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
474 index_type count[GFC_MAX_DIMENSIONS];
475 index_type extent[GFC_MAX_DIMENSIONS];
476 index_type dstride[GFC_MAX_DIMENSIONS];
477 GFC_INTEGER_8 * restrict dest;
478 index_type rank;
479 index_type n;
480 index_type dim;
483 if (mask == NULL || *mask)
485 #ifdef HAVE_BACK_ARG
486 maxloc1_8_i4 (retarray, array, pdim, back);
487 #else
488 maxloc1_8_i4 (retarray, array, pdim);
489 #endif
490 return;
492 /* Make dim zero based to avoid confusion. */
493 dim = (*pdim) - 1;
494 rank = GFC_DESCRIPTOR_RANK (array) - 1;
496 if (unlikely (dim < 0 || dim > rank))
498 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
499 "is %ld, should be between 1 and %ld",
500 (long int) dim + 1, (long int) rank + 1);
503 for (n = 0; n < dim; n++)
505 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
507 if (extent[n] <= 0)
508 extent[n] = 0;
511 for (n = dim; n < rank; n++)
513 extent[n] =
514 GFC_DESCRIPTOR_EXTENT(array,n + 1);
516 if (extent[n] <= 0)
517 extent[n] = 0;
520 if (retarray->base_addr == NULL)
522 size_t alloc_size, str;
524 for (n = 0; n < rank; n++)
526 if (n == 0)
527 str = 1;
528 else
529 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
531 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
535 retarray->offset = 0;
536 retarray->dtype.rank = rank;
538 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
540 if (alloc_size == 0)
542 /* Make sure we have a zero-sized array. */
543 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
544 return;
546 else
547 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
549 else
551 if (rank != GFC_DESCRIPTOR_RANK (retarray))
552 runtime_error ("rank of return array incorrect in"
553 " MAXLOC intrinsic: is %ld, should be %ld",
554 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
555 (long int) rank);
557 if (unlikely (compile_options.bounds_check))
559 for (n=0; n < rank; n++)
561 index_type ret_extent;
563 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
564 if (extent[n] != ret_extent)
565 runtime_error ("Incorrect extent in return value of"
566 " MAXLOC intrinsic in dimension %ld:"
567 " is %ld, should be %ld", (long int) n + 1,
568 (long int) ret_extent, (long int) extent[n]);
573 for (n = 0; n < rank; n++)
575 count[n] = 0;
576 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
579 dest = retarray->base_addr;
581 while(1)
583 *dest = 0;
584 count[0]++;
585 dest += dstride[0];
586 n = 0;
587 while (count[n] == extent[n])
589 /* When we get to the end of a dimension, reset it and increment
590 the next dimension. */
591 count[n] = 0;
592 /* We could precalculate these products, but this is a less
593 frequently used path so probably not worth it. */
594 dest -= dstride[n] * extent[n];
595 n++;
596 if (n >= rank)
597 return;
598 else
600 count[n]++;
601 dest += dstride[n];
607 #endif