Fix aarch64_evpc_tbl guard (PR 85910)
[official-gcc.git] / libgfortran / generated / maxloc1_4_s1.c
blob257ede21c05d0f3fb05cfef6ba4286178c2a2f8a
1 /* Implementation of the MAXLOC 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_1) && defined (HAVE_GFC_INTEGER_4)
31 #define HAVE_BACK_ARG 1
33 #include <string.h>
34 #include <assert.h>
36 static inline int
37 compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
39 if (sizeof (GFC_INTEGER_1) == 1)
40 return memcmp (a, b, n);
41 else
42 return memcmp_char4 (a, b, n);
45 extern void maxloc1_4_s1 (gfc_array_i4 * const restrict,
46 gfc_array_s1 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
47 gfc_charlen_type);
48 export_proto(maxloc1_4_s1);
50 void
51 maxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
52 gfc_array_s1 * const restrict array,
53 const index_type * const restrict pdim, GFC_LOGICAL_4 back,
54 gfc_charlen_type string_len)
56 index_type count[GFC_MAX_DIMENSIONS];
57 index_type extent[GFC_MAX_DIMENSIONS];
58 index_type sstride[GFC_MAX_DIMENSIONS];
59 index_type dstride[GFC_MAX_DIMENSIONS];
60 const GFC_INTEGER_1 * restrict base;
61 GFC_INTEGER_4 * restrict dest;
62 index_type rank;
63 index_type n;
64 index_type len;
65 index_type delta;
66 index_type dim;
67 int continue_loop;
69 /* Make dim zero based to avoid confusion. */
70 rank = GFC_DESCRIPTOR_RANK (array) - 1;
71 dim = (*pdim) - 1;
73 if (unlikely (dim < 0 || dim > rank))
75 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
76 "is %ld, should be between 1 and %ld",
77 (long int) dim + 1, (long int) rank + 1);
80 len = GFC_DESCRIPTOR_EXTENT(array,dim);
81 if (len < 0)
82 len = 0;
83 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
85 for (n = 0; n < dim; n++)
87 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
88 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
90 if (extent[n] < 0)
91 extent[n] = 0;
93 for (n = dim; n < rank; n++)
95 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
96 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
98 if (extent[n] < 0)
99 extent[n] = 0;
102 if (retarray->base_addr == NULL)
104 size_t alloc_size, str;
106 for (n = 0; n < rank; n++)
108 if (n == 0)
109 str = 1;
110 else
111 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
113 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
117 retarray->offset = 0;
118 retarray->dtype.rank = rank;
120 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
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 " MAXLOC 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", "MAXLOC");
144 for (n = 0; n < rank; n++)
146 count[n] = 0;
147 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
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_1 * restrict src;
159 GFC_INTEGER_4 result;
160 src = base;
163 const GFC_INTEGER_1 *maxval;
164 maxval = NULL;
165 result = 0;
166 if (len <= 0)
167 *dest = 0;
168 else
170 for (n = 0; n < len; n++, src += delta)
173 if (maxval == NULL || (back ? compare_fcn (src, maxval, string_len) >= 0 :
174 compare_fcn (src, maxval, string_len) > 0))
176 maxval = src;
177 result = (GFC_INTEGER_4)n + 1;
181 *dest = result;
184 /* Advance to the next element. */
185 count[0]++;
186 base += sstride[0];
187 dest += dstride[0];
188 n = 0;
189 while (count[n] == extent[n])
191 /* When we get to the end of a dimension, reset it and increment
192 the next dimension. */
193 count[n] = 0;
194 /* We could precalculate these products, but this is a less
195 frequently used path so probably not worth it. */
196 base -= sstride[n] * extent[n];
197 dest -= dstride[n] * extent[n];
198 n++;
199 if (n >= rank)
201 /* Break out of the loop. */
202 continue_loop = 0;
203 break;
205 else
207 count[n]++;
208 base += sstride[n];
209 dest += dstride[n];
216 extern void mmaxloc1_4_s1 (gfc_array_i4 * const restrict,
217 gfc_array_s1 * const restrict, const index_type * const restrict,
218 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
219 export_proto(mmaxloc1_4_s1);
221 void
222 mmaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
223 gfc_array_s1 * const restrict array,
224 const index_type * const restrict pdim,
225 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
226 gfc_charlen_type string_len)
228 index_type count[GFC_MAX_DIMENSIONS];
229 index_type extent[GFC_MAX_DIMENSIONS];
230 index_type sstride[GFC_MAX_DIMENSIONS];
231 index_type dstride[GFC_MAX_DIMENSIONS];
232 index_type mstride[GFC_MAX_DIMENSIONS];
233 GFC_INTEGER_4 * restrict dest;
234 const GFC_INTEGER_1 * restrict base;
235 const GFC_LOGICAL_1 * restrict mbase;
236 index_type rank;
237 index_type dim;
238 index_type n;
239 index_type len;
240 index_type delta;
241 index_type mdelta;
242 int mask_kind;
244 dim = (*pdim) - 1;
245 rank = GFC_DESCRIPTOR_RANK (array) - 1;
248 if (unlikely (dim < 0 || dim > rank))
250 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
251 "is %ld, should be between 1 and %ld",
252 (long int) dim + 1, (long int) rank + 1);
255 len = GFC_DESCRIPTOR_EXTENT(array,dim);
256 if (len <= 0)
257 return;
259 mbase = mask->base_addr;
261 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
263 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
264 #ifdef HAVE_GFC_LOGICAL_16
265 || mask_kind == 16
266 #endif
268 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
269 else
270 runtime_error ("Funny sized logical array");
272 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
273 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
275 for (n = 0; n < dim; n++)
277 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
278 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
279 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
281 if (extent[n] < 0)
282 extent[n] = 0;
285 for (n = dim; n < rank; n++)
287 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
288 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
289 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
291 if (extent[n] < 0)
292 extent[n] = 0;
295 if (retarray->base_addr == NULL)
297 size_t alloc_size, str;
299 for (n = 0; n < rank; n++)
301 if (n == 0)
302 str = 1;
303 else
304 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
306 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
310 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
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 MAXLOC intrinsic");
330 if (unlikely (compile_options.bounds_check))
332 bounds_ifunction_return ((array_t *) retarray, extent,
333 "return value", "MAXLOC");
334 bounds_equal_extents ((array_t *) mask, (array_t *) array,
335 "MASK argument", "MAXLOC");
339 for (n = 0; n < rank; n++)
341 count[n] = 0;
342 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
343 if (extent[n] <= 0)
344 return;
347 dest = retarray->base_addr;
348 base = array->base_addr;
350 while (base)
352 const GFC_INTEGER_1 * restrict src;
353 const GFC_LOGICAL_1 * restrict msrc;
354 GFC_INTEGER_4 result;
355 src = base;
356 msrc = mbase;
359 const GFC_INTEGER_1 *maxval;
360 maxval = base;
361 result = 0;
362 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
365 if (*msrc)
367 maxval = src;
368 result = (GFC_INTEGER_4)n + 1;
369 break;
372 for (; n < len; n++, src += delta, msrc += mdelta)
374 if (*msrc && (back ? compare_fcn (src, maxval, string_len) >= 0 :
375 compare_fcn (src, maxval, string_len) > 0))
377 maxval = src;
378 result = (GFC_INTEGER_4)n + 1;
382 *dest = result;
384 /* Advance to the next element. */
385 count[0]++;
386 base += sstride[0];
387 mbase += mstride[0];
388 dest += dstride[0];
389 n = 0;
390 while (count[n] == extent[n])
392 /* When we get to the end of a dimension, reset it and increment
393 the next dimension. */
394 count[n] = 0;
395 /* We could precalculate these products, but this is a less
396 frequently used path so probably not worth it. */
397 base -= sstride[n] * extent[n];
398 mbase -= mstride[n] * extent[n];
399 dest -= dstride[n] * extent[n];
400 n++;
401 if (n >= rank)
403 /* Break out of the loop. */
404 base = NULL;
405 break;
407 else
409 count[n]++;
410 base += sstride[n];
411 mbase += mstride[n];
412 dest += dstride[n];
419 extern void smaxloc1_4_s1 (gfc_array_i4 * const restrict,
420 gfc_array_s1 * const restrict, const index_type * const restrict,
421 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
422 export_proto(smaxloc1_4_s1);
424 void
425 smaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
426 gfc_array_s1 * const restrict array,
427 const index_type * const restrict pdim,
428 GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, 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 #ifdef HAVE_BACK_ARG
442 maxloc1_4_s1 (retarray, array, pdim, back, string_len);
443 #else
444 maxloc1_4_s1 (retarray, array, pdim, string_len);
445 #endif
446 return;
448 /* Make dim zero based to avoid confusion. */
449 dim = (*pdim) - 1;
450 rank = GFC_DESCRIPTOR_RANK (array) - 1;
452 if (unlikely (dim < 0 || dim > rank))
454 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
455 "is %ld, should be between 1 and %ld",
456 (long int) dim + 1, (long int) rank + 1);
459 for (n = 0; n < dim; n++)
461 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
463 if (extent[n] <= 0)
464 extent[n] = 0;
467 for (n = dim; n < rank; n++)
469 extent[n] =
470 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
472 if (extent[n] <= 0)
473 extent[n] = 0;
476 if (retarray->base_addr == NULL)
478 size_t alloc_size, str;
480 for (n = 0; n < rank; n++)
482 if (n == 0)
483 str = 1;
484 else
485 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
487 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
491 retarray->offset = 0;
492 retarray->dtype.rank = rank;
494 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
496 if (alloc_size == 0)
498 /* Make sure we have a zero-sized array. */
499 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
500 return;
502 else
503 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
505 else
507 if (rank != GFC_DESCRIPTOR_RANK (retarray))
508 runtime_error ("rank of return array incorrect in"
509 " MAXLOC intrinsic: is %ld, should be %ld",
510 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
511 (long int) rank);
513 if (unlikely (compile_options.bounds_check))
515 for (n=0; n < rank; n++)
517 index_type ret_extent;
519 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
520 if (extent[n] != ret_extent)
521 runtime_error ("Incorrect extent in return value of"
522 " MAXLOC intrinsic in dimension %ld:"
523 " is %ld, should be %ld", (long int) n + 1,
524 (long int) ret_extent, (long int) extent[n]);
529 for (n = 0; n < rank; n++)
531 count[n] = 0;
532 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
535 dest = retarray->base_addr;
537 while(1)
539 *dest = 0;
540 count[0]++;
541 dest += dstride[0];
542 n = 0;
543 while (count[n] == extent[n])
545 /* When we get to the end of a dimension, reset it and increment
546 the next dimension. */
547 count[n] = 0;
548 /* We could precalculate these products, but this is a less
549 frequently used path so probably not worth it. */
550 dest -= dstride[n] * extent[n];
551 n++;
552 if (n >= rank)
553 return;
554 else
556 count[n]++;
557 dest += dstride[n];
563 #endif