1 /* Implementation of the MAXVAL intrinsic
2 Copyright (C) 2017-2018 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
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.
11
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.
16
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.
20
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/>. */
25
26 #include "libgfortran.h"
27
28
29 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
30
31 #include <string.h>
32 #include <assert.h>
33
34 static inline int
compare_fcn(const GFC_INTEGER_4 * a,const GFC_INTEGER_4 * b,gfc_charlen_type n)35 compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
36 {
37 if (sizeof (GFC_INTEGER_4) == 1)
38 return memcmp (a, b, n);
39 else
40 return memcmp_char4 (a, b, n);
41 }
42
43 extern void maxval1_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(maxval1_s4);
47
48 void
maxval1_s4(gfc_array_s4 * const restrict retarray,gfc_charlen_type xlen,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,gfc_charlen_type string_len)49 maxval1_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)
52 {
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;
65
66 assert (xlen == string_len);
67 /* Make dim zero based to avoid confusion. */
68 rank = GFC_DESCRIPTOR_RANK (array) - 1;
69 dim = (*pdim) - 1;
70
71 if (unlikely (dim < 0 || dim > rank))
72 {
73 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
74 "is %ld, should be between 1 and %ld",
75 (long int) dim + 1, (long int) rank + 1);
76 }
77
78 len = GFC_DESCRIPTOR_EXTENT(array,dim);
79 if (len < 0)
80 len = 0;
81
82 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
83
84 for (n = 0; n < dim; n++)
85 {
86 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
87 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
88
89 if (extent[n] < 0)
90 extent[n] = 0;
91 }
92 for (n = dim; n < rank; n++)
93 {
94 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
95 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
96
97 if (extent[n] < 0)
98 extent[n] = 0;
99 }
100
101 if (retarray->base_addr == NULL)
102 {
103 size_t alloc_size, str;
104
105 for (n = 0; n < rank; n++)
106 {
107 if (n == 0)
108 str = 1;
109 else
110 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
111
112 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
113
114 }
115
116 retarray->offset = 0;
117 retarray->dtype.rank = rank;
118
119 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
120 * string_len;
121
122 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
123 if (alloc_size == 0)
124 {
125 /* Make sure we have a zero-sized array. */
126 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
127 return;
128
129 }
130 }
131 else
132 {
133 if (rank != GFC_DESCRIPTOR_RANK (retarray))
134 runtime_error ("rank of return array incorrect in"
135 " MAXVAL intrinsic: is %ld, should be %ld",
136 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
137 (long int) rank);
138
139 if (unlikely (compile_options.bounds_check))
140 bounds_ifunction_return ((array_t *) retarray, extent,
141 "return value", "MAXVAL");
142 }
143
144 for (n = 0; n < rank; n++)
145 {
146 count[n] = 0;
147 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
148 if (extent[n] <= 0)
149 return;
150 }
151
152 base = array->base_addr;
153 dest = retarray->base_addr;
154
155 continue_loop = 1;
156 while (continue_loop)
157 {
158 const GFC_INTEGER_4 * restrict src;
159 src = base;
160 {
161
162 const GFC_INTEGER_4 *retval;
163 retval = base;
164 if (len <= 0)
165 memset (dest, 0, sizeof (*dest) * string_len);
166 else
167 {
168 for (n = 0; n < len; n++, src += delta)
169 {
170
171 if (compare_fcn (src, retval, string_len) > 0)
172 {
173 retval = src;
174 }
175 }
176
177 memcpy (dest, retval, sizeof (*dest) * string_len);
178 }
179 }
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])
186 {
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)
196 {
197 /* Break out of the loop. */
198 continue_loop = 0;
199 break;
200 }
201 else
202 {
203 count[n]++;
204 base += sstride[n];
205 dest += dstride[n];
206 }
207 }
208 }
209 }
210
211
212 extern void mmaxval1_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(mmaxval1_s4);
217
218 void
mmaxval1_s4(gfc_array_s4 * const restrict retarray,gfc_charlen_type xlen,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,gfc_array_l1 * const restrict mask,gfc_charlen_type string_len)219 mmaxval1_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)
224
225 {
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;
241
242 assert (xlen == string_len);
243
244 dim = (*pdim) - 1;
245 rank = GFC_DESCRIPTOR_RANK (array) - 1;
246
247 if (unlikely (dim < 0 || dim > rank))
248 {
249 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
250 "is %ld, should be between 1 and %ld",
251 (long int) dim + 1, (long int) rank + 1);
252 }
253
254 len = GFC_DESCRIPTOR_EXTENT(array,dim);
255 if (len <= 0)
256 return;
257
258 mbase = mask->base_addr;
259
260 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
261
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
266 )
267 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
268 else
269 runtime_error ("Funny sized logical array");
270
271 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
272 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
273
274 for (n = 0; n < dim; n++)
275 {
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);
279
280 if (extent[n] < 0)
281 extent[n] = 0;
282
283 }
284 for (n = dim; n < rank; n++)
285 {
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);
289
290 if (extent[n] < 0)
291 extent[n] = 0;
292 }
293
294 if (retarray->base_addr == NULL)
295 {
296 size_t alloc_size, str;
297
298 for (n = 0; n < rank; n++)
299 {
300 if (n == 0)
301 str = 1;
302 else
303 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
304
305 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
306
307 }
308
309 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
310 * string_len;
311
312 retarray->offset = 0;
313 retarray->dtype.rank = rank;
314
315 if (alloc_size == 0)
316 {
317 /* Make sure we have a zero-sized array. */
318 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
319 return;
320 }
321 else
322 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
323
324 }
325 else
326 {
327 if (rank != GFC_DESCRIPTOR_RANK (retarray))
328 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
329
330 if (unlikely (compile_options.bounds_check))
331 {
332 bounds_ifunction_return ((array_t *) retarray, extent,
333 "return value", "MAXVAL");
334 bounds_equal_extents ((array_t *) mask, (array_t *) array,
335 "MASK argument", "MAXVAL");
336 }
337 }
338
339 for (n = 0; n < rank; n++)
340 {
341 count[n] = 0;
342 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
343 if (extent[n] <= 0)
344 return;
345 }
346
347 dest = retarray->base_addr;
348 base = array->base_addr;
349
350 while (base)
351 {
352 const GFC_INTEGER_4 * restrict src;
353 const GFC_LOGICAL_1 * restrict msrc;
354
355 src = base;
356 msrc = mbase;
357 {
358
359 const GFC_INTEGER_4 *retval;
360 memset (dest, 0, sizeof (*dest) * string_len);
361 retval = dest;
362 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
363 {
364
365 if (*msrc)
366 {
367 retval = src;
368 break;
369 }
370 }
371 for (; n < len; n++, src += delta, msrc += mdelta)
372 {
373 if (*msrc && compare_fcn (src, retval, string_len) > 0)
374 {
375 retval = src;
376 }
377
378 }
379 memcpy (dest, retval, sizeof (*dest) * string_len);
380 }
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])
388 {
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)
399 {
400 /* Break out of the loop. */
401 base = NULL;
402 break;
403 }
404 else
405 {
406 count[n]++;
407 base += sstride[n];
408 mbase += mstride[n];
409 dest += dstride[n];
410 }
411 }
412 }
413 }
414
415
416 void smaxval1_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);
420
421 export_proto(smaxval1_s4);
422
423 void
smaxval1_s4(gfc_array_s4 * const restrict retarray,gfc_charlen_type xlen,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,GFC_LOGICAL_4 * mask,gfc_charlen_type string_len)424 smaxval1_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)
428
429 {
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;
437
438
439 if (*mask)
440 {
441 maxval1_s4 (retarray, xlen, array, pdim, string_len);
442 return;
443 }
444 /* Make dim zero based to avoid confusion. */
445 dim = (*pdim) - 1;
446 rank = GFC_DESCRIPTOR_RANK (array) - 1;
447
448 if (unlikely (dim < 0 || dim > rank))
449 {
450 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
451 "is %ld, should be between 1 and %ld",
452 (long int) dim + 1, (long int) rank + 1);
453 }
454
455 for (n = 0; n < dim; n++)
456 {
457 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
458
459 if (extent[n] <= 0)
460 extent[n] = 0;
461 }
462
463 for (n = dim; n < rank; n++)
464 {
465 extent[n] =
466 GFC_DESCRIPTOR_EXTENT(array,n + 1);
467
468 if (extent[n] <= 0)
469 extent[n] = 0;
470 }
471
472 if (retarray->base_addr == NULL)
473 {
474 size_t alloc_size, str;
475
476 for (n = 0; n < rank; n++)
477 {
478 if (n == 0)
479 str = 1;
480 else
481 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
482
483 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
484
485 }
486
487 retarray->offset = 0;
488 retarray->dtype.rank = rank;
489
490 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
491 * string_len;
492
493 if (alloc_size == 0)
494 {
495 /* Make sure we have a zero-sized array. */
496 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
497 return;
498 }
499 else
500 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
501 }
502 else
503 {
504 if (rank != GFC_DESCRIPTOR_RANK (retarray))
505 runtime_error ("rank of return array incorrect in"
506 " MAXVAL intrinsic: is %ld, should be %ld",
507 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
508 (long int) rank);
509
510 if (unlikely (compile_options.bounds_check))
511 {
512 for (n=0; n < rank; n++)
513 {
514 index_type ret_extent;
515
516 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
517 if (extent[n] != ret_extent)
518 runtime_error ("Incorrect extent in return value of"
519 " MAXVAL intrinsic in dimension %ld:"
520 " is %ld, should be %ld", (long int) n + 1,
521 (long int) ret_extent, (long int) extent[n]);
522 }
523 }
524 }
525
526 for (n = 0; n < rank; n++)
527 {
528 count[n] = 0;
529 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
530 }
531
532 dest = retarray->base_addr;
533
534 while(1)
535 {
536 memset (dest, 0, sizeof (*dest) * string_len);
537 count[0]++;
538 dest += dstride[0];
539 n = 0;
540 while (count[n] == extent[n])
541 {
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
552 {
553 count[n]++;
554 dest += dstride[n];
555 }
556 }
557 }
558 }
559
560 #endif
561