Daily bump.
[official-gcc.git] / libgfortran / generated / minval1_s4.c
blob74915fb82996828497e0f6ec9162ca4d29a46edf
1 /* Implementation of the MAXVAL intrinsic
2 Copyright (C) 2017-2018 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig
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)
31 #include <string.h>
32 #include <assert.h>
34 static inline int
35 compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
37 if (sizeof (GFC_INTEGER_4) == 1)
38 return memcmp (a, b, n);
39 else
40 return memcmp_char4 (a, b, n);
43 extern void minval1_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(minval1_s4);
48 void
49 minval1_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)
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_INTEGER_4 * restrict base;
58 GFC_INTEGER_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;
66 assert (xlen == string_len);
67 /* Make dim zero based to avoid confusion. */
68 rank = GFC_DESCRIPTOR_RANK (array) - 1;
69 dim = (*pdim) - 1;
71 if (unlikely (dim < 0 || dim > rank))
73 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
74 "is %ld, should be between 1 and %ld",
75 (long int) dim + 1, (long int) rank + 1);
78 len = GFC_DESCRIPTOR_EXTENT(array,dim);
79 if (len < 0)
80 len = 0;
82 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
84 for (n = 0; n < dim; n++)
86 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
87 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
89 if (extent[n] < 0)
90 extent[n] = 0;
92 for (n = dim; n < rank; n++)
94 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
95 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
97 if (extent[n] < 0)
98 extent[n] = 0;
101 if (retarray->base_addr == NULL)
103 size_t alloc_size, str;
105 for (n = 0; n < rank; n++)
107 if (n == 0)
108 str = 1;
109 else
110 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
112 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
116 retarray->offset = 0;
117 retarray->dtype.rank = rank;
119 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
120 * string_len;
122 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
123 if (alloc_size == 0)
125 /* Make sure we have a zero-sized array. */
126 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
127 return;
131 else
133 if (rank != GFC_DESCRIPTOR_RANK (retarray))
134 runtime_error ("rank of return array incorrect in"
135 " MINVAL intrinsic: is %ld, should be %ld",
136 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
137 (long int) rank);
139 if (unlikely (compile_options.bounds_check))
140 bounds_ifunction_return ((array_t *) retarray, extent,
141 "return value", "MINVAL");
144 for (n = 0; n < rank; n++)
146 count[n] = 0;
147 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
148 if (extent[n] <= 0)
149 return;
152 base = array->base_addr;
153 dest = retarray->base_addr;
155 continue_loop = 1;
156 while (continue_loop)
158 const GFC_INTEGER_4 * restrict src;
159 src = base;
162 const GFC_INTEGER_4 *retval;
163 retval = base;
164 if (len <= 0)
165 memset (dest, 255, sizeof (*dest) * string_len);
166 else
168 for (n = 0; n < len; n++, src += delta)
171 if (compare_fcn (src, retval, string_len) < 0)
173 retval = src;
177 memcpy (dest, retval, sizeof (*dest) * string_len);
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])
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)
197 /* Break out of the loop. */
198 continue_loop = 0;
199 break;
201 else
203 count[n]++;
204 base += sstride[n];
205 dest += dstride[n];
212 extern void mminval1_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(mminval1_s4);
218 void
219 mminval1_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)
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_INTEGER_4 * restrict dest;
232 const GFC_INTEGER_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;
242 assert (xlen == string_len);
244 dim = (*pdim) - 1;
245 rank = GFC_DESCRIPTOR_RANK (array) - 1;
247 if (unlikely (dim < 0 || dim > rank))
249 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
250 "is %ld, should be between 1 and %ld",
251 (long int) dim + 1, (long int) rank + 1);
254 len = GFC_DESCRIPTOR_EXTENT(array,dim);
255 if (len <= 0)
256 return;
258 mbase = mask->base_addr;
260 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
262 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
263 #ifdef HAVE_GFC_LOGICAL_16
264 || mask_kind == 16
265 #endif
267 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
268 else
269 runtime_error ("Funny sized logical array");
271 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
272 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
274 for (n = 0; n < dim; n++)
276 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
277 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
278 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
280 if (extent[n] < 0)
281 extent[n] = 0;
284 for (n = dim; n < rank; n++)
286 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
287 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
288 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
290 if (extent[n] < 0)
291 extent[n] = 0;
294 if (retarray->base_addr == NULL)
296 size_t alloc_size, str;
298 for (n = 0; n < rank; n++)
300 if (n == 0)
301 str = 1;
302 else
303 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
305 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
309 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
310 * string_len;
312 retarray->offset = 0;
313 retarray->dtype.rank = rank;
315 if (alloc_size == 0)
317 /* Make sure we have a zero-sized array. */
318 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
319 return;
321 else
322 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
325 else
327 if (rank != GFC_DESCRIPTOR_RANK (retarray))
328 runtime_error ("rank of return array incorrect in MINVAL intrinsic");
330 if (unlikely (compile_options.bounds_check))
332 bounds_ifunction_return ((array_t *) retarray, extent,
333 "return value", "MINVAL");
334 bounds_equal_extents ((array_t *) mask, (array_t *) array,
335 "MASK argument", "MINVAL");
339 for (n = 0; n < rank; n++)
341 count[n] = 0;
342 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
343 if (extent[n] <= 0)
344 return;
347 dest = retarray->base_addr;
348 base = array->base_addr;
350 while (base)
352 const GFC_INTEGER_4 * restrict src;
353 const GFC_LOGICAL_1 * restrict msrc;
355 src = base;
356 msrc = mbase;
359 const GFC_INTEGER_4 *retval;
360 memset (dest, 255, sizeof (*dest) * string_len);
361 retval = dest;
362 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
365 if (*msrc)
367 retval = src;
368 break;
371 for (; n < len; n++, src += delta, msrc += mdelta)
373 if (*msrc && compare_fcn (src, retval, string_len) < 0)
375 retval = src;
379 memcpy (dest, retval, sizeof (*dest) * string_len);
381 /* Advance to the next element. */
382 count[0]++;
383 base += sstride[0];
384 mbase += mstride[0];
385 dest += dstride[0];
386 n = 0;
387 while (count[n] == extent[n])
389 /* When we get to the end of a dimension, reset it and increment
390 the next dimension. */
391 count[n] = 0;
392 /* We could precalculate these products, but this is a less
393 frequently used path so probably not worth it. */
394 base -= sstride[n] * extent[n];
395 mbase -= mstride[n] * extent[n];
396 dest -= dstride[n] * extent[n];
397 n++;
398 if (n >= rank)
400 /* Break out of the loop. */
401 base = NULL;
402 break;
404 else
406 count[n]++;
407 base += sstride[n];
408 mbase += mstride[n];
409 dest += dstride[n];
416 void sminval1_s4 (gfc_array_s4 * const restrict,
417 gfc_charlen_type, gfc_array_s4 * const restrict,
418 const index_type * const restrict,
419 GFC_LOGICAL_4 *, gfc_charlen_type);
421 export_proto(sminval1_s4);
423 void
424 sminval1_s4 (gfc_array_s4 * const restrict retarray,
425 gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
426 const index_type * const restrict pdim,
427 GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
430 index_type count[GFC_MAX_DIMENSIONS];
431 index_type extent[GFC_MAX_DIMENSIONS];
432 index_type dstride[GFC_MAX_DIMENSIONS];
433 GFC_INTEGER_4 * restrict dest;
434 index_type rank;
435 index_type n;
436 index_type dim;
439 if (*mask)
441 minval1_s4 (retarray, xlen, array, pdim, string_len);
442 return;
444 /* Make dim zero based to avoid confusion. */
445 dim = (*pdim) - 1;
446 rank = GFC_DESCRIPTOR_RANK (array) - 1;
448 if (unlikely (dim < 0 || dim > rank))
450 runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
451 "is %ld, should be between 1 and %ld",
452 (long int) dim + 1, (long int) rank + 1);
455 for (n = 0; n < dim; n++)
457 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
459 if (extent[n] <= 0)
460 extent[n] = 0;
463 for (n = dim; n < rank; n++)
465 extent[n] =
466 GFC_DESCRIPTOR_EXTENT(array,n + 1);
468 if (extent[n] <= 0)
469 extent[n] = 0;
472 if (retarray->base_addr == NULL)
474 size_t alloc_size, str;
476 for (n = 0; n < rank; n++)
478 if (n == 0)
479 str = 1;
480 else
481 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
483 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
487 retarray->offset = 0;
488 retarray->dtype.rank = rank;
490 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
491 * string_len;
493 if (alloc_size == 0)
495 /* Make sure we have a zero-sized array. */
496 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
497 return;
499 else
500 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
502 else
504 if (rank != GFC_DESCRIPTOR_RANK (retarray))
505 runtime_error ("rank of return array incorrect in"
506 " MINVAL intrinsic: is %ld, should be %ld",
507 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
508 (long int) rank);
510 if (unlikely (compile_options.bounds_check))
512 for (n=0; n < rank; n++)
514 index_type ret_extent;
516 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
517 if (extent[n] != ret_extent)
518 runtime_error ("Incorrect extent in return value of"
519 " MINVAL intrinsic in dimension %ld:"
520 " is %ld, should be %ld", (long int) n + 1,
521 (long int) ret_extent, (long int) extent[n]);
526 for (n = 0; n < rank; n++)
528 count[n] = 0;
529 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
532 dest = retarray->base_addr;
534 while(1)
536 memset (dest, 255, sizeof (*dest) * string_len);
537 count[0]++;
538 dest += dstride[0];
539 n = 0;
540 while (count[n] == extent[n])
542 /* When we get to the end of a dimension, reset it and increment
543 the next dimension. */
544 count[n] = 0;
545 /* We could precalculate these products, but this is a less
546 frequently used path so probably not worth it. */
547 dest -= dstride[n] * extent[n];
548 n++;
549 if (n >= rank)
550 return;
551 else
553 count[n]++;
554 dest += dstride[n];
560 #endif