* gnatvsn.ads: Bump copyright year.
[official-gcc.git] / libgfortran / generated / maxloc1_16_s4.c
bloba77da96e97b1fa9def0b9d1bc7e2112642087689
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_4) && defined (HAVE_GFC_INTEGER_16)
31 #include <string.h>
33 static inline int
34 compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
36 if (sizeof (GFC_INTEGER_4) == 1)
37 return memcmp (a, b, n);
38 else
39 return memcmp_char4 (a, b, n);
42 extern void maxloc1_16_s4 (gfc_array_i16 * const restrict,
43 gfc_array_s4 * const restrict, const index_type * const restrict,
44 gfc_charlen_type);
45 export_proto(maxloc1_16_s4);
47 void
48 maxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
49 gfc_array_s4 * const restrict array,
50 const index_type * const restrict pdim, gfc_charlen_type string_len)
52 index_type count[GFC_MAX_DIMENSIONS];
53 index_type extent[GFC_MAX_DIMENSIONS];
54 index_type sstride[GFC_MAX_DIMENSIONS];
55 index_type dstride[GFC_MAX_DIMENSIONS];
56 const GFC_INTEGER_4 * restrict base;
57 GFC_INTEGER_16 * restrict dest;
58 index_type rank;
59 index_type n;
60 index_type len;
61 index_type delta;
62 index_type dim;
63 int continue_loop;
65 /* Make dim zero based to avoid confusion. */
66 rank = GFC_DESCRIPTOR_RANK (array) - 1;
67 dim = (*pdim) - 1;
69 if (unlikely (dim < 0 || dim > rank))
71 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
72 "is %ld, should be between 1 and %ld",
73 (long int) dim + 1, (long int) rank + 1);
76 len = GFC_DESCRIPTOR_EXTENT(array,dim);
77 if (len < 0)
78 len = 0;
79 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
81 for (n = 0; n < dim; n++)
83 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
84 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
86 if (extent[n] < 0)
87 extent[n] = 0;
89 for (n = dim; n < rank; n++)
91 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
92 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
94 if (extent[n] < 0)
95 extent[n] = 0;
98 if (retarray->base_addr == NULL)
100 size_t alloc_size, str;
102 for (n = 0; n < rank; n++)
104 if (n == 0)
105 str = 1;
106 else
107 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
109 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
113 retarray->offset = 0;
114 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
116 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
118 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
119 if (alloc_size == 0)
121 /* Make sure we have a zero-sized array. */
122 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
123 return;
127 else
129 if (rank != GFC_DESCRIPTOR_RANK (retarray))
130 runtime_error ("rank of return array incorrect in"
131 " MAXLOC intrinsic: is %ld, should be %ld",
132 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
133 (long int) rank);
135 if (unlikely (compile_options.bounds_check))
136 bounds_ifunction_return ((array_t *) retarray, extent,
137 "return value", "MAXLOC");
140 for (n = 0; n < rank; n++)
142 count[n] = 0;
143 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
144 if (extent[n] <= 0)
145 return;
148 base = array->base_addr;
149 dest = retarray->base_addr;
151 continue_loop = 1;
152 while (continue_loop)
154 const GFC_INTEGER_4 * restrict src;
155 GFC_INTEGER_16 result;
156 src = base;
159 const GFC_INTEGER_4 *maxval;
160 maxval = base;
161 result = 1;
162 if (len <= 0)
163 *dest = 0;
164 else
166 for (n = 0; n < len; n++, src += delta)
169 if (compare_fcn (src, maxval, string_len) > 0)
171 maxval = src;
172 result = (GFC_INTEGER_16)n + 1;
176 *dest = result;
179 /* Advance to the next element. */
180 count[0]++;
181 base += sstride[0];
182 dest += dstride[0];
183 n = 0;
184 while (count[n] == extent[n])
186 /* When we get to the end of a dimension, reset it and increment
187 the next dimension. */
188 count[n] = 0;
189 /* We could precalculate these products, but this is a less
190 frequently used path so probably not worth it. */
191 base -= sstride[n] * extent[n];
192 dest -= dstride[n] * extent[n];
193 n++;
194 if (n >= rank)
196 /* Break out of the loop. */
197 continue_loop = 0;
198 break;
200 else
202 count[n]++;
203 base += sstride[n];
204 dest += dstride[n];
211 extern void mmaxloc1_16_s4 (gfc_array_i16 * const restrict,
212 gfc_array_s4 * const restrict, const index_type * const restrict,
213 gfc_array_l1 * const restrict, gfc_charlen_type);
214 export_proto(mmaxloc1_16_s4);
216 void
217 mmaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
218 gfc_array_s4 * const restrict array,
219 const index_type * const restrict pdim,
220 gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
222 index_type count[GFC_MAX_DIMENSIONS];
223 index_type extent[GFC_MAX_DIMENSIONS];
224 index_type sstride[GFC_MAX_DIMENSIONS];
225 index_type dstride[GFC_MAX_DIMENSIONS];
226 index_type mstride[GFC_MAX_DIMENSIONS];
227 GFC_INTEGER_16 * restrict dest;
228 const GFC_INTEGER_4 * restrict base;
229 const GFC_LOGICAL_1 * restrict mbase;
230 index_type rank;
231 index_type dim;
232 index_type n;
233 index_type len;
234 index_type delta;
235 index_type mdelta;
236 int mask_kind;
238 dim = (*pdim) - 1;
239 rank = GFC_DESCRIPTOR_RANK (array) - 1;
242 if (unlikely (dim < 0 || dim > rank))
244 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
245 "is %ld, should be between 1 and %ld",
246 (long int) dim + 1, (long int) rank + 1);
249 len = GFC_DESCRIPTOR_EXTENT(array,dim);
250 if (len <= 0)
251 return;
253 mbase = mask->base_addr;
255 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
257 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
258 #ifdef HAVE_GFC_LOGICAL_16
259 || mask_kind == 16
260 #endif
262 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
263 else
264 runtime_error ("Funny sized logical array");
266 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
267 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
269 for (n = 0; n < dim; n++)
271 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
272 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
273 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
275 if (extent[n] < 0)
276 extent[n] = 0;
279 for (n = dim; n < rank; n++)
281 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
282 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
283 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
285 if (extent[n] < 0)
286 extent[n] = 0;
289 if (retarray->base_addr == NULL)
291 size_t alloc_size, str;
293 for (n = 0; n < rank; n++)
295 if (n == 0)
296 str = 1;
297 else
298 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
300 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
304 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
306 retarray->offset = 0;
307 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
309 if (alloc_size == 0)
311 /* Make sure we have a zero-sized array. */
312 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
313 return;
315 else
316 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
319 else
321 if (rank != GFC_DESCRIPTOR_RANK (retarray))
322 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
324 if (unlikely (compile_options.bounds_check))
326 bounds_ifunction_return ((array_t *) retarray, extent,
327 "return value", "MAXLOC");
328 bounds_equal_extents ((array_t *) mask, (array_t *) array,
329 "MASK argument", "MAXLOC");
333 for (n = 0; n < rank; n++)
335 count[n] = 0;
336 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
337 if (extent[n] <= 0)
338 return;
341 dest = retarray->base_addr;
342 base = array->base_addr;
344 while (base)
346 const GFC_INTEGER_4 * restrict src;
347 const GFC_LOGICAL_1 * restrict msrc;
348 GFC_INTEGER_16 result;
349 src = base;
350 msrc = mbase;
353 const GFC_INTEGER_4 *maxval;
354 maxval = base;
355 result = 0;
356 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
359 if (*msrc)
361 maxval = src;
362 result = (GFC_INTEGER_16)n + 1;
363 break;
366 for (; n < len; n++, src += delta, msrc += mdelta)
368 if (*msrc && compare_fcn (src, maxval, string_len) > 0)
370 maxval = src;
371 result = (GFC_INTEGER_16)n + 1;
375 *dest = result;
377 /* Advance to the next element. */
378 count[0]++;
379 base += sstride[0];
380 mbase += mstride[0];
381 dest += dstride[0];
382 n = 0;
383 while (count[n] == extent[n])
385 /* When we get to the end of a dimension, reset it and increment
386 the next dimension. */
387 count[n] = 0;
388 /* We could precalculate these products, but this is a less
389 frequently used path so probably not worth it. */
390 base -= sstride[n] * extent[n];
391 mbase -= mstride[n] * extent[n];
392 dest -= dstride[n] * extent[n];
393 n++;
394 if (n >= rank)
396 /* Break out of the loop. */
397 base = NULL;
398 break;
400 else
402 count[n]++;
403 base += sstride[n];
404 mbase += mstride[n];
405 dest += dstride[n];
412 extern void smaxloc1_16_s4 (gfc_array_i16 * const restrict,
413 gfc_array_s4 * const restrict, const index_type * const restrict,
414 GFC_LOGICAL_4 *, gfc_charlen_type);
415 export_proto(smaxloc1_16_s4);
417 void
418 smaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
419 gfc_array_s4 * const restrict array,
420 const index_type * const restrict pdim,
421 GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
423 index_type count[GFC_MAX_DIMENSIONS];
424 index_type extent[GFC_MAX_DIMENSIONS];
425 index_type dstride[GFC_MAX_DIMENSIONS];
426 GFC_INTEGER_16 * restrict dest;
427 index_type rank;
428 index_type n;
429 index_type dim;
432 if (*mask)
434 maxloc1_16_s4 (retarray, array, pdim, string_len);
435 return;
437 /* Make dim zero based to avoid confusion. */
438 dim = (*pdim) - 1;
439 rank = GFC_DESCRIPTOR_RANK (array) - 1;
441 if (unlikely (dim < 0 || dim > rank))
443 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
444 "is %ld, should be between 1 and %ld",
445 (long int) dim + 1, (long int) rank + 1);
448 for (n = 0; n < dim; n++)
450 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
452 if (extent[n] <= 0)
453 extent[n] = 0;
456 for (n = dim; n < rank; n++)
458 extent[n] =
459 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
461 if (extent[n] <= 0)
462 extent[n] = 0;
465 if (retarray->base_addr == NULL)
467 size_t alloc_size, str;
469 for (n = 0; n < rank; n++)
471 if (n == 0)
472 str = 1;
473 else
474 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
476 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
480 retarray->offset = 0;
481 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
483 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
485 if (alloc_size == 0)
487 /* Make sure we have a zero-sized array. */
488 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
489 return;
491 else
492 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
494 else
496 if (rank != GFC_DESCRIPTOR_RANK (retarray))
497 runtime_error ("rank of return array incorrect in"
498 " MAXLOC intrinsic: is %ld, should be %ld",
499 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
500 (long int) rank);
502 if (unlikely (compile_options.bounds_check))
504 for (n=0; n < rank; n++)
506 index_type ret_extent;
508 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
509 if (extent[n] != ret_extent)
510 runtime_error ("Incorrect extent in return value of"
511 " MAXLOC intrinsic in dimension %ld:"
512 " is %ld, should be %ld", (long int) n + 1,
513 (long int) ret_extent, (long int) extent[n]);
518 for (n = 0; n < rank; n++)
520 count[n] = 0;
521 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
524 dest = retarray->base_addr;
526 while(1)
528 *dest = 0;
529 count[0]++;
530 dest += dstride[0];
531 n = 0;
532 while (count[n] == extent[n])
534 /* When we get to the end of a dimension, reset it and increment
535 the next dimension. */
536 count[n] = 0;
537 /* We could precalculate these products, but this is a less
538 frequently used path so probably not worth it. */
539 dest -= dstride[n] * extent[n];
540 n++;
541 if (n >= rank)
542 return;
543 else
545 count[n]++;
546 dest += dstride[n];
552 #endif