C++: Fix crash in warn_for_memset within templates (PR c++/83814)
[official-gcc.git] / libgfortran / generated / maxloc1_4_s1.c
blobb7b7d8cfe935e2b0a449ebad39d827d1010580fe
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 #ifdef HAVE_BACK_ARG
70 assert(back == 0);
71 #endif
73 /* Make dim zero based to avoid confusion. */
74 rank = GFC_DESCRIPTOR_RANK (array) - 1;
75 dim = (*pdim) - 1;
77 if (unlikely (dim < 0 || dim > rank))
79 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
80 "is %ld, should be between 1 and %ld",
81 (long int) dim + 1, (long int) rank + 1);
84 len = GFC_DESCRIPTOR_EXTENT(array,dim);
85 if (len < 0)
86 len = 0;
87 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
89 for (n = 0; n < dim; n++)
91 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
92 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
94 if (extent[n] < 0)
95 extent[n] = 0;
97 for (n = dim; n < rank; n++)
99 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
100 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
102 if (extent[n] < 0)
103 extent[n] = 0;
106 if (retarray->base_addr == NULL)
108 size_t alloc_size, str;
110 for (n = 0; n < rank; n++)
112 if (n == 0)
113 str = 1;
114 else
115 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
117 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
121 retarray->offset = 0;
122 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
124 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
126 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
127 if (alloc_size == 0)
129 /* Make sure we have a zero-sized array. */
130 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
131 return;
135 else
137 if (rank != GFC_DESCRIPTOR_RANK (retarray))
138 runtime_error ("rank of return array incorrect in"
139 " MAXLOC intrinsic: is %ld, should be %ld",
140 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
141 (long int) rank);
143 if (unlikely (compile_options.bounds_check))
144 bounds_ifunction_return ((array_t *) retarray, extent,
145 "return value", "MAXLOC");
148 for (n = 0; n < rank; n++)
150 count[n] = 0;
151 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
152 if (extent[n] <= 0)
153 return;
156 base = array->base_addr;
157 dest = retarray->base_addr;
159 continue_loop = 1;
160 while (continue_loop)
162 const GFC_INTEGER_1 * restrict src;
163 GFC_INTEGER_4 result;
164 src = base;
167 const GFC_INTEGER_1 *maxval;
168 maxval = base;
169 result = 1;
170 if (len <= 0)
171 *dest = 0;
172 else
174 for (n = 0; n < len; n++, src += delta)
177 if (compare_fcn (src, maxval, string_len) > 0)
179 maxval = src;
180 result = (GFC_INTEGER_4)n + 1;
184 *dest = result;
187 /* Advance to the next element. */
188 count[0]++;
189 base += sstride[0];
190 dest += dstride[0];
191 n = 0;
192 while (count[n] == extent[n])
194 /* When we get to the end of a dimension, reset it and increment
195 the next dimension. */
196 count[n] = 0;
197 /* We could precalculate these products, but this is a less
198 frequently used path so probably not worth it. */
199 base -= sstride[n] * extent[n];
200 dest -= dstride[n] * extent[n];
201 n++;
202 if (n >= rank)
204 /* Break out of the loop. */
205 continue_loop = 0;
206 break;
208 else
210 count[n]++;
211 base += sstride[n];
212 dest += dstride[n];
219 extern void mmaxloc1_4_s1 (gfc_array_i4 * const restrict,
220 gfc_array_s1 * const restrict, const index_type * const restrict,
221 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
222 export_proto(mmaxloc1_4_s1);
224 void
225 mmaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
226 gfc_array_s1 * const restrict array,
227 const index_type * const restrict pdim,
228 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
229 gfc_charlen_type string_len)
231 index_type count[GFC_MAX_DIMENSIONS];
232 index_type extent[GFC_MAX_DIMENSIONS];
233 index_type sstride[GFC_MAX_DIMENSIONS];
234 index_type dstride[GFC_MAX_DIMENSIONS];
235 index_type mstride[GFC_MAX_DIMENSIONS];
236 GFC_INTEGER_4 * restrict dest;
237 const GFC_INTEGER_1 * restrict base;
238 const GFC_LOGICAL_1 * restrict mbase;
239 index_type rank;
240 index_type dim;
241 index_type n;
242 index_type len;
243 index_type delta;
244 index_type mdelta;
245 int mask_kind;
247 #ifdef HAVE_BACK_ARG
248 assert (back == 0);
249 #endif
250 dim = (*pdim) - 1;
251 rank = GFC_DESCRIPTOR_RANK (array) - 1;
254 if (unlikely (dim < 0 || dim > rank))
256 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
257 "is %ld, should be between 1 and %ld",
258 (long int) dim + 1, (long int) rank + 1);
261 len = GFC_DESCRIPTOR_EXTENT(array,dim);
262 if (len <= 0)
263 return;
265 mbase = mask->base_addr;
267 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
269 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
270 #ifdef HAVE_GFC_LOGICAL_16
271 || mask_kind == 16
272 #endif
274 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
275 else
276 runtime_error ("Funny sized logical array");
278 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
279 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
281 for (n = 0; n < dim; n++)
283 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
284 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
285 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
287 if (extent[n] < 0)
288 extent[n] = 0;
291 for (n = dim; n < rank; n++)
293 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
294 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
295 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
297 if (extent[n] < 0)
298 extent[n] = 0;
301 if (retarray->base_addr == NULL)
303 size_t alloc_size, str;
305 for (n = 0; n < rank; n++)
307 if (n == 0)
308 str = 1;
309 else
310 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
312 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
316 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
318 retarray->offset = 0;
319 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
321 if (alloc_size == 0)
323 /* Make sure we have a zero-sized array. */
324 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
325 return;
327 else
328 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
331 else
333 if (rank != GFC_DESCRIPTOR_RANK (retarray))
334 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
336 if (unlikely (compile_options.bounds_check))
338 bounds_ifunction_return ((array_t *) retarray, extent,
339 "return value", "MAXLOC");
340 bounds_equal_extents ((array_t *) mask, (array_t *) array,
341 "MASK argument", "MAXLOC");
345 for (n = 0; n < rank; n++)
347 count[n] = 0;
348 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
349 if (extent[n] <= 0)
350 return;
353 dest = retarray->base_addr;
354 base = array->base_addr;
356 while (base)
358 const GFC_INTEGER_1 * restrict src;
359 const GFC_LOGICAL_1 * restrict msrc;
360 GFC_INTEGER_4 result;
361 src = base;
362 msrc = mbase;
365 const GFC_INTEGER_1 *maxval;
366 maxval = base;
367 result = 0;
368 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
371 if (*msrc)
373 maxval = src;
374 result = (GFC_INTEGER_4)n + 1;
375 break;
378 for (; n < len; n++, src += delta, msrc += mdelta)
380 if (*msrc && compare_fcn (src, maxval, string_len) > 0)
382 maxval = src;
383 result = (GFC_INTEGER_4)n + 1;
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 smaxloc1_4_s1 (gfc_array_i4 * const restrict,
425 gfc_array_s1 * const restrict, const index_type * const restrict,
426 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
427 export_proto(smaxloc1_4_s1);
429 void
430 smaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
431 gfc_array_s1 * const restrict array,
432 const index_type * const restrict pdim,
433 GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
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 maxloc1_4_s1 (retarray, array, pdim, back, string_len);
448 #else
449 maxloc1_4_s1 (retarray, array, pdim, string_len);
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 MAXLOC 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) * string_len;
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) * string_len;
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 GFC_DTYPE_COPY_SETRANK(retarray,array,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 " MAXLOC 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 " MAXLOC 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 = 0;
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