hppa: Really fix g++.dg/modules/bad-mapper-1.C on hpux
[official-gcc.git] / libgfortran / generated / minval_i8.c
blobc43d13eef4fcbee771a29e3d478ba1b5cdec173c
1 /* Implementation of the MINVAL 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"
29 #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
32 extern void minval_i8 (gfc_array_i8 * const restrict,
33 gfc_array_i8 * const restrict, const index_type * const restrict);
34 export_proto(minval_i8);
36 void
37 minval_i8 (gfc_array_i8 * const restrict retarray,
38 gfc_array_i8 * const restrict array,
39 const index_type * const restrict pdim)
41 index_type count[GFC_MAX_DIMENSIONS];
42 index_type extent[GFC_MAX_DIMENSIONS];
43 index_type sstride[GFC_MAX_DIMENSIONS];
44 index_type dstride[GFC_MAX_DIMENSIONS];
45 const GFC_INTEGER_8 * restrict base;
46 GFC_INTEGER_8 * restrict dest;
47 index_type rank;
48 index_type n;
49 index_type len;
50 index_type delta;
51 index_type dim;
52 int continue_loop;
54 /* Make dim zero based to avoid confusion. */
55 rank = GFC_DESCRIPTOR_RANK (array) - 1;
56 dim = (*pdim) - 1;
58 if (unlikely (dim < 0 || dim > rank))
60 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
61 "is %ld, should be between 1 and %ld",
62 (long int) dim + 1, (long int) rank + 1);
65 len = GFC_DESCRIPTOR_EXTENT(array,dim);
66 if (len < 0)
67 len = 0;
68 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
70 for (n = 0; n < dim; n++)
72 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
73 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
75 if (extent[n] < 0)
76 extent[n] = 0;
78 for (n = dim; n < rank; n++)
80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
81 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
83 if (extent[n] < 0)
84 extent[n] = 0;
87 if (retarray->base_addr == NULL)
89 size_t alloc_size, str;
91 for (n = 0; n < rank; n++)
93 if (n == 0)
94 str = 1;
95 else
96 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
98 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
102 retarray->offset = 0;
103 retarray->dtype.rank = rank;
105 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
107 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
108 if (alloc_size == 0)
109 return;
111 else
113 if (rank != GFC_DESCRIPTOR_RANK (retarray))
114 runtime_error ("rank of return array incorrect in"
115 " MINVAL intrinsic: is %ld, should be %ld",
116 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
117 (long int) rank);
119 if (unlikely (compile_options.bounds_check))
120 bounds_ifunction_return ((array_t *) retarray, extent,
121 "return value", "MINVAL");
124 for (n = 0; n < rank; n++)
126 count[n] = 0;
127 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
128 if (extent[n] <= 0)
129 return;
132 base = array->base_addr;
133 dest = retarray->base_addr;
135 continue_loop = 1;
136 while (continue_loop)
138 const GFC_INTEGER_8 * restrict src;
139 GFC_INTEGER_8 result;
140 src = base;
143 #if defined (GFC_INTEGER_8_INFINITY)
144 result = GFC_INTEGER_8_INFINITY;
145 #else
146 result = GFC_INTEGER_8_HUGE;
147 #endif
148 if (len <= 0)
149 *dest = GFC_INTEGER_8_HUGE;
150 else
152 #if ! defined HAVE_BACK_ARG
153 for (n = 0; n < len; n++, src += delta)
155 #endif
157 #if defined (GFC_INTEGER_8_QUIET_NAN)
158 if (*src <= result)
159 break;
161 if (unlikely (n >= len))
162 result = GFC_INTEGER_8_QUIET_NAN;
163 else for (; n < len; n++, src += delta)
165 #endif
166 if (*src < result)
167 result = *src;
170 *dest = result;
173 /* Advance to the next element. */
174 count[0]++;
175 base += sstride[0];
176 dest += dstride[0];
177 n = 0;
178 while (count[n] == extent[n])
180 /* When we get to the end of a dimension, reset it and increment
181 the next dimension. */
182 count[n] = 0;
183 /* We could precalculate these products, but this is a less
184 frequently used path so probably not worth it. */
185 base -= sstride[n] * extent[n];
186 dest -= dstride[n] * extent[n];
187 n++;
188 if (n >= rank)
190 /* Break out of the loop. */
191 continue_loop = 0;
192 break;
194 else
196 count[n]++;
197 base += sstride[n];
198 dest += dstride[n];
205 extern void mminval_i8 (gfc_array_i8 * const restrict,
206 gfc_array_i8 * const restrict, const index_type * const restrict,
207 gfc_array_l1 * const restrict);
208 export_proto(mminval_i8);
210 void
211 mminval_i8 (gfc_array_i8 * const restrict retarray,
212 gfc_array_i8 * const restrict array,
213 const index_type * const restrict pdim,
214 gfc_array_l1 * const restrict mask)
216 index_type count[GFC_MAX_DIMENSIONS];
217 index_type extent[GFC_MAX_DIMENSIONS];
218 index_type sstride[GFC_MAX_DIMENSIONS];
219 index_type dstride[GFC_MAX_DIMENSIONS];
220 index_type mstride[GFC_MAX_DIMENSIONS];
221 GFC_INTEGER_8 * restrict dest;
222 const GFC_INTEGER_8 * restrict base;
223 const GFC_LOGICAL_1 * restrict mbase;
224 index_type rank;
225 index_type dim;
226 index_type n;
227 index_type len;
228 index_type delta;
229 index_type mdelta;
230 int mask_kind;
232 if (mask == NULL)
234 #ifdef HAVE_BACK_ARG
235 minval_i8 (retarray, array, pdim, back);
236 #else
237 minval_i8 (retarray, array, pdim);
238 #endif
239 return;
242 dim = (*pdim) - 1;
243 rank = GFC_DESCRIPTOR_RANK (array) - 1;
246 if (unlikely (dim < 0 || dim > rank))
248 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
249 "is %ld, should be between 1 and %ld",
250 (long int) dim + 1, (long int) rank + 1);
253 len = GFC_DESCRIPTOR_EXTENT(array,dim);
254 if (len < 0)
255 len = 0;
257 mbase = mask->base_addr;
259 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
261 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
262 #ifdef HAVE_GFC_LOGICAL_16
263 || mask_kind == 16
264 #endif
266 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
267 else
268 runtime_error ("Funny sized logical array");
270 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
271 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
273 for (n = 0; n < dim; n++)
275 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
276 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
277 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
279 if (extent[n] < 0)
280 extent[n] = 0;
283 for (n = dim; n < rank; n++)
285 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
286 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
287 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
289 if (extent[n] < 0)
290 extent[n] = 0;
293 if (retarray->base_addr == NULL)
295 size_t alloc_size, str;
297 for (n = 0; n < rank; n++)
299 if (n == 0)
300 str = 1;
301 else
302 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
304 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
308 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
310 retarray->offset = 0;
311 retarray->dtype.rank = rank;
313 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
314 if (alloc_size == 0)
315 return;
317 else
319 if (rank != GFC_DESCRIPTOR_RANK (retarray))
320 runtime_error ("rank of return array incorrect in MINVAL intrinsic");
322 if (unlikely (compile_options.bounds_check))
324 bounds_ifunction_return ((array_t *) retarray, extent,
325 "return value", "MINVAL");
326 bounds_equal_extents ((array_t *) mask, (array_t *) array,
327 "MASK argument", "MINVAL");
331 for (n = 0; n < rank; n++)
333 count[n] = 0;
334 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
335 if (extent[n] <= 0)
336 return;
339 dest = retarray->base_addr;
340 base = array->base_addr;
342 while (base)
344 const GFC_INTEGER_8 * restrict src;
345 const GFC_LOGICAL_1 * restrict msrc;
346 GFC_INTEGER_8 result;
347 src = base;
348 msrc = mbase;
351 #if defined (GFC_INTEGER_8_INFINITY)
352 result = GFC_INTEGER_8_INFINITY;
353 #else
354 result = GFC_INTEGER_8_HUGE;
355 #endif
356 #if defined (GFC_INTEGER_8_QUIET_NAN)
357 int non_empty_p = 0;
358 #endif
359 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
362 #if defined (GFC_INTEGER_8_INFINITY) || defined (GFC_INTEGER_8_QUIET_NAN)
363 if (*msrc)
365 #if defined (GFC_INTEGER_8_QUIET_NAN)
366 non_empty_p = 1;
367 if (*src <= result)
368 #endif
369 break;
372 if (unlikely (n >= len))
374 #if defined (GFC_INTEGER_8_QUIET_NAN)
375 result = non_empty_p ? GFC_INTEGER_8_QUIET_NAN : GFC_INTEGER_8_HUGE;
376 #else
377 result = GFC_INTEGER_8_HUGE;
378 #endif
380 else for (; n < len; n++, src += delta, msrc += mdelta)
382 #endif
383 if (*msrc && *src < result)
384 result = *src;
386 *dest = result;
388 /* Advance to the next element. */
389 count[0]++;
390 base += sstride[0];
391 mbase += mstride[0];
392 dest += dstride[0];
393 n = 0;
394 while (count[n] == extent[n])
396 /* When we get to the end of a dimension, reset it and increment
397 the next dimension. */
398 count[n] = 0;
399 /* We could precalculate these products, but this is a less
400 frequently used path so probably not worth it. */
401 base -= sstride[n] * extent[n];
402 mbase -= mstride[n] * extent[n];
403 dest -= dstride[n] * extent[n];
404 n++;
405 if (n >= rank)
407 /* Break out of the loop. */
408 base = NULL;
409 break;
411 else
413 count[n]++;
414 base += sstride[n];
415 mbase += mstride[n];
416 dest += dstride[n];
423 extern void sminval_i8 (gfc_array_i8 * const restrict,
424 gfc_array_i8 * const restrict, const index_type * const restrict,
425 GFC_LOGICAL_4 *);
426 export_proto(sminval_i8);
428 void
429 sminval_i8 (gfc_array_i8 * const restrict retarray,
430 gfc_array_i8 * const restrict array,
431 const index_type * const restrict pdim,
432 GFC_LOGICAL_4 * mask)
434 index_type count[GFC_MAX_DIMENSIONS];
435 index_type extent[GFC_MAX_DIMENSIONS];
436 index_type dstride[GFC_MAX_DIMENSIONS];
437 GFC_INTEGER_8 * restrict dest;
438 index_type rank;
439 index_type n;
440 index_type dim;
443 if (mask == NULL || *mask)
445 #ifdef HAVE_BACK_ARG
446 minval_i8 (retarray, array, pdim, back);
447 #else
448 minval_i8 (retarray, array, pdim);
449 #endif
450 return;
452 /* Make dim zero based to avoid confusion. */
453 dim = (*pdim) - 1;
454 rank = GFC_DESCRIPTOR_RANK (array) - 1;
456 if (unlikely (dim < 0 || dim > rank))
458 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
459 "is %ld, should be between 1 and %ld",
460 (long int) dim + 1, (long int) rank + 1);
463 for (n = 0; n < dim; n++)
465 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
467 if (extent[n] <= 0)
468 extent[n] = 0;
471 for (n = dim; n < rank; n++)
473 extent[n] =
474 GFC_DESCRIPTOR_EXTENT(array,n + 1);
476 if (extent[n] <= 0)
477 extent[n] = 0;
480 if (retarray->base_addr == NULL)
482 size_t alloc_size, str;
484 for (n = 0; n < rank; n++)
486 if (n == 0)
487 str = 1;
488 else
489 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
491 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
495 retarray->offset = 0;
496 retarray->dtype.rank = rank;
498 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
500 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
501 if (alloc_size == 0)
502 return;
504 else
506 if (rank != GFC_DESCRIPTOR_RANK (retarray))
507 runtime_error ("rank of return array incorrect in"
508 " MINVAL intrinsic: is %ld, should be %ld",
509 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
510 (long int) rank);
512 if (unlikely (compile_options.bounds_check))
514 for (n=0; n < rank; n++)
516 index_type ret_extent;
518 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
519 if (extent[n] != ret_extent)
520 runtime_error ("Incorrect extent in return value of"
521 " MINVAL intrinsic in dimension %ld:"
522 " is %ld, should be %ld", (long int) n + 1,
523 (long int) ret_extent, (long int) extent[n]);
528 for (n = 0; n < rank; n++)
530 count[n] = 0;
531 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
534 dest = retarray->base_addr;
536 while(1)
538 *dest = GFC_INTEGER_8_HUGE;
539 count[0]++;
540 dest += dstride[0];
541 n = 0;
542 while (count[n] == extent[n])
544 /* When we get to the end of a dimension, reset it and increment
545 the next dimension. */
546 count[n] = 0;
547 /* We could precalculate these products, but this is a less
548 frequently used path so probably not worth it. */
549 dest -= dstride[n] * extent[n];
550 n++;
551 if (n >= rank)
552 return;
553 else
555 count[n]++;
556 dest += dstride[n];
562 #endif