1 /* Implementation of the MINLOC 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_8)
30
31 #define HAVE_BACK_ARG 1
32
33 #include <string.h>
34 #include <assert.h>
35
36 static inline int
compare_fcn(const GFC_INTEGER_4 * a,const GFC_INTEGER_4 * b,gfc_charlen_type n)37 compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
38 {
39 if (sizeof (GFC_INTEGER_4) == 1)
40 return memcmp (a, b, n);
41 else
42 return memcmp_char4 (a, b, n);
43 }
44
45 extern void minloc1_8_s4 (gfc_array_i8 * const restrict,
46 gfc_array_s4 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
47 gfc_charlen_type);
48 export_proto(minloc1_8_s4);
49
50 void
minloc1_8_s4(gfc_array_i8 * const restrict retarray,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,GFC_LOGICAL_4 back,gfc_charlen_type string_len)51 minloc1_8_s4 (gfc_array_i8 * const restrict retarray,
52 gfc_array_s4 * const restrict array,
53 const index_type * const restrict pdim, GFC_LOGICAL_4 back,
54 gfc_charlen_type string_len)
55 {
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_4 * restrict base;
61 GFC_INTEGER_8 * 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;
68
69 #ifdef HAVE_BACK_ARG
70 assert(back == 0);
71 #endif
72
73 /* Make dim zero based to avoid confusion. */
74 rank = GFC_DESCRIPTOR_RANK (array) - 1;
75 dim = (*pdim) - 1;
76
77 if (unlikely (dim < 0 || dim > rank))
78 {
79 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
80 "is %ld, should be between 1 and %ld",
81 (long int) dim + 1, (long int) rank + 1);
82 }
83
84 len = GFC_DESCRIPTOR_EXTENT(array,dim);
85 if (len < 0)
86 len = 0;
87 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
88
89 for (n = 0; n < dim; n++)
90 {
91 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
92 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
93
94 if (extent[n] < 0)
95 extent[n] = 0;
96 }
97 for (n = dim; n < rank; n++)
98 {
99 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
100 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
101
102 if (extent[n] < 0)
103 extent[n] = 0;
104 }
105
106 if (retarray->base_addr == NULL)
107 {
108 size_t alloc_size, str;
109
110 for (n = 0; n < rank; n++)
111 {
112 if (n == 0)
113 str = 1;
114 else
115 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
116
117 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
118
119 }
120
121 retarray->offset = 0;
122 retarray->dtype.rank = rank;
123
124 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
125
126 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
127 if (alloc_size == 0)
128 {
129 /* Make sure we have a zero-sized array. */
130 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
131 return;
132
133 }
134 }
135 else
136 {
137 if (rank != GFC_DESCRIPTOR_RANK (retarray))
138 runtime_error ("rank of return array incorrect in"
139 " MINLOC intrinsic: is %ld, should be %ld",
140 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
141 (long int) rank);
142
143 if (unlikely (compile_options.bounds_check))
144 bounds_ifunction_return ((array_t *) retarray, extent,
145 "return value", "MINLOC");
146 }
147
148 for (n = 0; n < rank; n++)
149 {
150 count[n] = 0;
151 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
152 if (extent[n] <= 0)
153 return;
154 }
155
156 base = array->base_addr;
157 dest = retarray->base_addr;
158
159 continue_loop = 1;
160 while (continue_loop)
161 {
162 const GFC_INTEGER_4 * restrict src;
163 GFC_INTEGER_8 result;
164 src = base;
165 {
166
167 const GFC_INTEGER_4 *minval;
168 minval = base;
169 result = 1;
170 if (len <= 0)
171 *dest = 0;
172 else
173 {
174 for (n = 0; n < len; n++, src += delta)
175 {
176
177 if (compare_fcn (src, minval, string_len) < 0)
178 {
179 minval = src;
180 result = (GFC_INTEGER_8)n + 1;
181 }
182 }
183
184 *dest = result;
185 }
186 }
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])
193 {
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)
203 {
204 /* Break out of the loop. */
205 continue_loop = 0;
206 break;
207 }
208 else
209 {
210 count[n]++;
211 base += sstride[n];
212 dest += dstride[n];
213 }
214 }
215 }
216 }
217
218
219 extern void mminloc1_8_s4 (gfc_array_i8 * const restrict,
220 gfc_array_s4 * const restrict, const index_type * const restrict,
221 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
222 export_proto(mminloc1_8_s4);
223
224 void
mminloc1_8_s4(gfc_array_i8 * const restrict retarray,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,gfc_array_l1 * const restrict mask,GFC_LOGICAL_4 back,gfc_charlen_type string_len)225 mminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
226 gfc_array_s4 * 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)
230 {
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_8 * restrict dest;
237 const GFC_INTEGER_4 * 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;
246
247 #ifdef HAVE_BACK_ARG
248 assert (back == 0);
249 #endif
250 dim = (*pdim) - 1;
251 rank = GFC_DESCRIPTOR_RANK (array) - 1;
252
253
254 if (unlikely (dim < 0 || dim > rank))
255 {
256 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
257 "is %ld, should be between 1 and %ld",
258 (long int) dim + 1, (long int) rank + 1);
259 }
260
261 len = GFC_DESCRIPTOR_EXTENT(array,dim);
262 if (len <= 0)
263 return;
264
265 mbase = mask->base_addr;
266
267 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
268
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
273 )
274 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
275 else
276 runtime_error ("Funny sized logical array");
277
278 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
279 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
280
281 for (n = 0; n < dim; n++)
282 {
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);
286
287 if (extent[n] < 0)
288 extent[n] = 0;
289
290 }
291 for (n = dim; n < rank; n++)
292 {
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);
296
297 if (extent[n] < 0)
298 extent[n] = 0;
299 }
300
301 if (retarray->base_addr == NULL)
302 {
303 size_t alloc_size, str;
304
305 for (n = 0; n < rank; n++)
306 {
307 if (n == 0)
308 str = 1;
309 else
310 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
311
312 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
313
314 }
315
316 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
317
318 retarray->offset = 0;
319 retarray->dtype.rank = rank;
320
321 if (alloc_size == 0)
322 {
323 /* Make sure we have a zero-sized array. */
324 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
325 return;
326 }
327 else
328 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
329
330 }
331 else
332 {
333 if (rank != GFC_DESCRIPTOR_RANK (retarray))
334 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
335
336 if (unlikely (compile_options.bounds_check))
337 {
338 bounds_ifunction_return ((array_t *) retarray, extent,
339 "return value", "MINLOC");
340 bounds_equal_extents ((array_t *) mask, (array_t *) array,
341 "MASK argument", "MINLOC");
342 }
343 }
344
345 for (n = 0; n < rank; n++)
346 {
347 count[n] = 0;
348 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
349 if (extent[n] <= 0)
350 return;
351 }
352
353 dest = retarray->base_addr;
354 base = array->base_addr;
355
356 while (base)
357 {
358 const GFC_INTEGER_4 * restrict src;
359 const GFC_LOGICAL_1 * restrict msrc;
360 GFC_INTEGER_8 result;
361 src = base;
362 msrc = mbase;
363 {
364
365 const GFC_INTEGER_4 *minval;
366 minval = base;
367 result = 0;
368 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
369 {
370
371 if (*msrc)
372 {
373 minval = src;
374 result = (GFC_INTEGER_8)n + 1;
375 break;
376 }
377 }
378 for (; n < len; n++, src += delta, msrc += mdelta)
379 {
380 if (*msrc && compare_fcn (src, minval, string_len) < 0)
381 {
382 minval = src;
383 result = (GFC_INTEGER_8)n + 1;
384 }
385
386 }
387 *dest = result;
388 }
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])
396 {
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)
407 {
408 /* Break out of the loop. */
409 base = NULL;
410 break;
411 }
412 else
413 {
414 count[n]++;
415 base += sstride[n];
416 mbase += mstride[n];
417 dest += dstride[n];
418 }
419 }
420 }
421 }
422
423
424 extern void sminloc1_8_s4 (gfc_array_i8 * const restrict,
425 gfc_array_s4 * const restrict, const index_type * const restrict,
426 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
427 export_proto(sminloc1_8_s4);
428
429 void
sminloc1_8_s4(gfc_array_i8 * const restrict retarray,gfc_array_s4 * const restrict array,const index_type * const restrict pdim,GFC_LOGICAL_4 * mask,GFC_LOGICAL_4 back,gfc_charlen_type string_len)430 sminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
431 gfc_array_s4 * const restrict array,
432 const index_type * const restrict pdim,
433 GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
434 {
435 index_type count[GFC_MAX_DIMENSIONS];
436 index_type extent[GFC_MAX_DIMENSIONS];
437 index_type dstride[GFC_MAX_DIMENSIONS];
438 GFC_INTEGER_8 * restrict dest;
439 index_type rank;
440 index_type n;
441 index_type dim;
442
443
444 if (*mask)
445 {
446 #ifdef HAVE_BACK_ARG
447 minloc1_8_s4 (retarray, array, pdim, back, string_len);
448 #else
449 minloc1_8_s4 (retarray, array, pdim, string_len);
450 #endif
451 return;
452 }
453 /* Make dim zero based to avoid confusion. */
454 dim = (*pdim) - 1;
455 rank = GFC_DESCRIPTOR_RANK (array) - 1;
456
457 if (unlikely (dim < 0 || dim > rank))
458 {
459 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
460 "is %ld, should be between 1 and %ld",
461 (long int) dim + 1, (long int) rank + 1);
462 }
463
464 for (n = 0; n < dim; n++)
465 {
466 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
467
468 if (extent[n] <= 0)
469 extent[n] = 0;
470 }
471
472 for (n = dim; n < rank; n++)
473 {
474 extent[n] =
475 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
476
477 if (extent[n] <= 0)
478 extent[n] = 0;
479 }
480
481 if (retarray->base_addr == NULL)
482 {
483 size_t alloc_size, str;
484
485 for (n = 0; n < rank; n++)
486 {
487 if (n == 0)
488 str = 1;
489 else
490 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
491
492 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
493
494 }
495
496 retarray->offset = 0;
497 retarray->dtype.rank = rank;
498
499 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
500
501 if (alloc_size == 0)
502 {
503 /* Make sure we have a zero-sized array. */
504 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
505 return;
506 }
507 else
508 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
509 }
510 else
511 {
512 if (rank != GFC_DESCRIPTOR_RANK (retarray))
513 runtime_error ("rank of return array incorrect in"
514 " MINLOC intrinsic: is %ld, should be %ld",
515 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
516 (long int) rank);
517
518 if (unlikely (compile_options.bounds_check))
519 {
520 for (n=0; n < rank; n++)
521 {
522 index_type ret_extent;
523
524 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
525 if (extent[n] != ret_extent)
526 runtime_error ("Incorrect extent in return value of"
527 " MINLOC intrinsic in dimension %ld:"
528 " is %ld, should be %ld", (long int) n + 1,
529 (long int) ret_extent, (long int) extent[n]);
530 }
531 }
532 }
533
534 for (n = 0; n < rank; n++)
535 {
536 count[n] = 0;
537 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
538 }
539
540 dest = retarray->base_addr;
541
542 while(1)
543 {
544 *dest = 0;
545 count[0]++;
546 dest += dstride[0];
547 n = 0;
548 while (count[n] == extent[n])
549 {
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
560 {
561 count[n]++;
562 dest += dstride[n];
563 }
564 }
565 }
566 }
567
568 #endif
569