Daily bump.
[official-gcc.git] / libgfortran / generated / maxval_i4.c
blobae36fd4aa3ee20398a340abe210ba9a16f96383f
1 /* Implementation of the MAXVAL intrinsic
2 Copyright (C) 2002-2018 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_4) && defined (HAVE_GFC_INTEGER_4)
32 extern void maxval_i4 (gfc_array_i4 * const restrict,
33 gfc_array_i4 * const restrict, const index_type * const restrict);
34 export_proto(maxval_i4);
36 void
37 maxval_i4 (gfc_array_i4 * const restrict retarray,
38 gfc_array_i4 * 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_4 * restrict base;
46 GFC_INTEGER_4 * 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 MAXVAL 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_4));
108 if (alloc_size == 0)
110 /* Make sure we have a zero-sized array. */
111 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
112 return;
116 else
118 if (rank != GFC_DESCRIPTOR_RANK (retarray))
119 runtime_error ("rank of return array incorrect in"
120 " MAXVAL intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
122 (long int) rank);
124 if (unlikely (compile_options.bounds_check))
125 bounds_ifunction_return ((array_t *) retarray, extent,
126 "return value", "MAXVAL");
129 for (n = 0; n < rank; n++)
131 count[n] = 0;
132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
133 if (extent[n] <= 0)
134 return;
137 base = array->base_addr;
138 dest = retarray->base_addr;
140 continue_loop = 1;
141 while (continue_loop)
143 const GFC_INTEGER_4 * restrict src;
144 GFC_INTEGER_4 result;
145 src = base;
148 #if defined (GFC_INTEGER_4_INFINITY)
149 result = -GFC_INTEGER_4_INFINITY;
150 #else
151 result = (-GFC_INTEGER_4_HUGE-1);
152 #endif
153 if (len <= 0)
154 *dest = (-GFC_INTEGER_4_HUGE-1);
155 else
157 #if ! defined HAVE_BACK_ARG
158 for (n = 0; n < len; n++, src += delta)
160 #endif
162 #if defined (GFC_INTEGER_4_QUIET_NAN)
163 if (*src >= result)
164 break;
166 if (unlikely (n >= len))
167 result = GFC_INTEGER_4_QUIET_NAN;
168 else for (; n < len; n++, src += delta)
170 #endif
171 if (*src > result)
172 result = *src;
175 *dest = result;
178 /* Advance to the next element. */
179 count[0]++;
180 base += sstride[0];
181 dest += dstride[0];
182 n = 0;
183 while (count[n] == extent[n])
185 /* When we get to the end of a dimension, reset it and increment
186 the next dimension. */
187 count[n] = 0;
188 /* We could precalculate these products, but this is a less
189 frequently used path so probably not worth it. */
190 base -= sstride[n] * extent[n];
191 dest -= dstride[n] * extent[n];
192 n++;
193 if (n >= rank)
195 /* Break out of the loop. */
196 continue_loop = 0;
197 break;
199 else
201 count[n]++;
202 base += sstride[n];
203 dest += dstride[n];
210 extern void mmaxval_i4 (gfc_array_i4 * const restrict,
211 gfc_array_i4 * const restrict, const index_type * const restrict,
212 gfc_array_l1 * const restrict);
213 export_proto(mmaxval_i4);
215 void
216 mmaxval_i4 (gfc_array_i4 * const restrict retarray,
217 gfc_array_i4 * const restrict array,
218 const index_type * const restrict pdim,
219 gfc_array_l1 * const restrict mask)
221 index_type count[GFC_MAX_DIMENSIONS];
222 index_type extent[GFC_MAX_DIMENSIONS];
223 index_type sstride[GFC_MAX_DIMENSIONS];
224 index_type dstride[GFC_MAX_DIMENSIONS];
225 index_type mstride[GFC_MAX_DIMENSIONS];
226 GFC_INTEGER_4 * restrict dest;
227 const GFC_INTEGER_4 * restrict base;
228 const GFC_LOGICAL_1 * restrict mbase;
229 index_type rank;
230 index_type dim;
231 index_type n;
232 index_type len;
233 index_type delta;
234 index_type mdelta;
235 int mask_kind;
237 dim = (*pdim) - 1;
238 rank = GFC_DESCRIPTOR_RANK (array) - 1;
241 if (unlikely (dim < 0 || dim > rank))
243 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
244 "is %ld, should be between 1 and %ld",
245 (long int) dim + 1, (long int) rank + 1);
248 len = GFC_DESCRIPTOR_EXTENT(array,dim);
249 if (len <= 0)
250 return;
252 mbase = mask->base_addr;
254 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
256 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
257 #ifdef HAVE_GFC_LOGICAL_16
258 || mask_kind == 16
259 #endif
261 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
262 else
263 runtime_error ("Funny sized logical array");
265 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
266 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
268 for (n = 0; n < dim; n++)
270 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
271 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
272 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
274 if (extent[n] < 0)
275 extent[n] = 0;
278 for (n = dim; n < rank; n++)
280 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
281 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
282 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
284 if (extent[n] < 0)
285 extent[n] = 0;
288 if (retarray->base_addr == NULL)
290 size_t alloc_size, str;
292 for (n = 0; n < rank; n++)
294 if (n == 0)
295 str = 1;
296 else
297 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
299 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
303 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
305 retarray->offset = 0;
306 retarray->dtype.rank = rank;
308 if (alloc_size == 0)
310 /* Make sure we have a zero-sized array. */
311 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
312 return;
314 else
315 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
318 else
320 if (rank != GFC_DESCRIPTOR_RANK (retarray))
321 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
323 if (unlikely (compile_options.bounds_check))
325 bounds_ifunction_return ((array_t *) retarray, extent,
326 "return value", "MAXVAL");
327 bounds_equal_extents ((array_t *) mask, (array_t *) array,
328 "MASK argument", "MAXVAL");
332 for (n = 0; n < rank; n++)
334 count[n] = 0;
335 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
336 if (extent[n] <= 0)
337 return;
340 dest = retarray->base_addr;
341 base = array->base_addr;
343 while (base)
345 const GFC_INTEGER_4 * restrict src;
346 const GFC_LOGICAL_1 * restrict msrc;
347 GFC_INTEGER_4 result;
348 src = base;
349 msrc = mbase;
352 #if defined (GFC_INTEGER_4_INFINITY)
353 result = -GFC_INTEGER_4_INFINITY;
354 #else
355 result = (-GFC_INTEGER_4_HUGE-1);
356 #endif
357 #if defined (GFC_INTEGER_4_QUIET_NAN)
358 int non_empty_p = 0;
359 #endif
360 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
363 #if defined (GFC_INTEGER_4_INFINITY) || defined (GFC_INTEGER_4_QUIET_NAN)
364 if (*msrc)
366 #if defined (GFC_INTEGER_4_QUIET_NAN)
367 non_empty_p = 1;
368 if (*src >= result)
369 #endif
370 break;
373 if (unlikely (n >= len))
375 #if defined (GFC_INTEGER_4_QUIET_NAN)
376 result = non_empty_p ? GFC_INTEGER_4_QUIET_NAN : (-GFC_INTEGER_4_HUGE-1);
377 #else
378 result = (-GFC_INTEGER_4_HUGE-1);
379 #endif
381 else for (; n < len; n++, src += delta, msrc += mdelta)
383 #endif
384 if (*msrc && *src > result)
385 result = *src;
387 *dest = result;
389 /* Advance to the next element. */
390 count[0]++;
391 base += sstride[0];
392 mbase += mstride[0];
393 dest += dstride[0];
394 n = 0;
395 while (count[n] == extent[n])
397 /* When we get to the end of a dimension, reset it and increment
398 the next dimension. */
399 count[n] = 0;
400 /* We could precalculate these products, but this is a less
401 frequently used path so probably not worth it. */
402 base -= sstride[n] * extent[n];
403 mbase -= mstride[n] * extent[n];
404 dest -= dstride[n] * extent[n];
405 n++;
406 if (n >= rank)
408 /* Break out of the loop. */
409 base = NULL;
410 break;
412 else
414 count[n]++;
415 base += sstride[n];
416 mbase += mstride[n];
417 dest += dstride[n];
424 extern void smaxval_i4 (gfc_array_i4 * const restrict,
425 gfc_array_i4 * const restrict, const index_type * const restrict,
426 GFC_LOGICAL_4 *);
427 export_proto(smaxval_i4);
429 void
430 smaxval_i4 (gfc_array_i4 * const restrict retarray,
431 gfc_array_i4 * const restrict array,
432 const index_type * const restrict pdim,
433 GFC_LOGICAL_4 * mask)
435 index_type count[GFC_MAX_DIMENSIONS];
436 index_type extent[GFC_MAX_DIMENSIONS];
437 index_type dstride[GFC_MAX_DIMENSIONS];
438 GFC_INTEGER_4 * restrict dest;
439 index_type rank;
440 index_type n;
441 index_type dim;
444 if (*mask)
446 #ifdef HAVE_BACK_ARG
447 maxval_i4 (retarray, array, pdim, back);
448 #else
449 maxval_i4 (retarray, array, pdim);
450 #endif
451 return;
453 /* Make dim zero based to avoid confusion. */
454 dim = (*pdim) - 1;
455 rank = GFC_DESCRIPTOR_RANK (array) - 1;
457 if (unlikely (dim < 0 || dim > rank))
459 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
460 "is %ld, should be between 1 and %ld",
461 (long int) dim + 1, (long int) rank + 1);
464 for (n = 0; n < dim; n++)
466 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
468 if (extent[n] <= 0)
469 extent[n] = 0;
472 for (n = dim; n < rank; n++)
474 extent[n] =
475 GFC_DESCRIPTOR_EXTENT(array,n + 1);
477 if (extent[n] <= 0)
478 extent[n] = 0;
481 if (retarray->base_addr == NULL)
483 size_t alloc_size, str;
485 for (n = 0; n < rank; n++)
487 if (n == 0)
488 str = 1;
489 else
490 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
492 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
496 retarray->offset = 0;
497 retarray->dtype.rank = rank;
499 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
501 if (alloc_size == 0)
503 /* Make sure we have a zero-sized array. */
504 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
505 return;
507 else
508 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
510 else
512 if (rank != GFC_DESCRIPTOR_RANK (retarray))
513 runtime_error ("rank of return array incorrect in"
514 " MAXVAL intrinsic: is %ld, should be %ld",
515 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
516 (long int) rank);
518 if (unlikely (compile_options.bounds_check))
520 for (n=0; n < rank; n++)
522 index_type ret_extent;
524 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
525 if (extent[n] != ret_extent)
526 runtime_error ("Incorrect extent in return value of"
527 " MAXVAL intrinsic in dimension %ld:"
528 " is %ld, should be %ld", (long int) n + 1,
529 (long int) ret_extent, (long int) extent[n]);
534 for (n = 0; n < rank; n++)
536 count[n] = 0;
537 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
540 dest = retarray->base_addr;
542 while(1)
544 *dest = (-GFC_INTEGER_4_HUGE-1);
545 count[0]++;
546 dest += dstride[0];
547 n = 0;
548 while (count[n] == extent[n])
550 /* When we get to the end of a dimension, reset it and increment
551 the next dimension. */
552 count[n] = 0;
553 /* We could precalculate these products, but this is a less
554 frequently used path so probably not worth it. */
555 dest -= dstride[n] * extent[n];
556 n++;
557 if (n >= rank)
558 return;
559 else
561 count[n]++;
562 dest += dstride[n];
568 #endif