1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2017-2023 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_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
31 #define HAVE_BACK_ARG 1
37 compare_fcn (const GFC_UINTEGER_1
*a
, const GFC_UINTEGER_1
*b
, gfc_charlen_type n
)
39 if (sizeof (GFC_UINTEGER_1
) == 1)
40 return memcmp (a
, b
, n
);
42 return memcmp_char4 (a
, b
, n
);
45 extern void maxloc1_16_s1 (gfc_array_i16
* const restrict
,
46 gfc_array_s1
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
,
48 export_proto(maxloc1_16_s1
);
51 maxloc1_16_s1 (gfc_array_i16
* 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_UINTEGER_1
* restrict base
;
61 GFC_INTEGER_16
* restrict dest
;
69 /* Make dim zero based to avoid confusion. */
70 rank
= GFC_DESCRIPTOR_RANK (array
) - 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
);
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
);
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);
102 if (retarray
->base_addr
== NULL
)
104 size_t alloc_size
, str
;
106 for (n
= 0; n
< rank
; n
++)
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_16
));
125 /* Make sure we have a zero-sized array. */
126 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
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
)),
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
++)
147 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
152 base
= array
->base_addr
;
153 dest
= retarray
->base_addr
;
156 while (continue_loop
)
158 const GFC_UINTEGER_1
* restrict src
;
159 GFC_INTEGER_16 result
;
163 const GFC_UINTEGER_1
*maxval
;
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))
177 result
= (GFC_INTEGER_16
)n
+ 1;
184 /* Advance to the next element. */
189 while (count
[n
] == extent
[n
])
191 /* When we get to the end of a dimension, reset it and increment
192 the next dimension. */
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
];
201 /* Break out of the loop. */
216 extern void mmaxloc1_16_s1 (gfc_array_i16
* 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_16_s1
);
222 mmaxloc1_16_s1 (gfc_array_i16
* 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_16
* restrict dest
;
234 const GFC_UINTEGER_1
* restrict base
;
235 const GFC_LOGICAL_1
* restrict mbase
;
247 maxloc1_16_s1 (retarray
, array
, pdim
, back
, string_len
);
249 maxloc1_16_s1 (retarray
, array
, pdim
, string_len
);
255 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
258 if (unlikely (dim
< 0 || dim
> rank
))
260 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
261 "is %ld, should be between 1 and %ld",
262 (long int) dim
+ 1, (long int) rank
+ 1);
265 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
269 mbase
= mask
->base_addr
;
271 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
273 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
274 #ifdef HAVE_GFC_LOGICAL_16
278 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
280 runtime_error ("Funny sized logical array");
282 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
283 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
285 for (n
= 0; n
< dim
; n
++)
287 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
288 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
289 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
295 for (n
= dim
; n
< rank
; n
++)
297 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1) * string_len
;
298 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
299 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
305 if (retarray
->base_addr
== NULL
)
307 size_t alloc_size
, str
;
309 for (n
= 0; n
< rank
; n
++)
314 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
316 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
320 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
322 retarray
->offset
= 0;
323 retarray
->dtype
.rank
= rank
;
325 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
328 /* Make sure we have a zero-sized array. */
329 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
335 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
336 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
338 if (unlikely (compile_options
.bounds_check
))
340 bounds_ifunction_return ((array_t
*) retarray
, extent
,
341 "return value", "MAXLOC");
342 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
343 "MASK argument", "MAXLOC");
347 for (n
= 0; n
< rank
; n
++)
350 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
355 dest
= retarray
->base_addr
;
356 base
= array
->base_addr
;
360 const GFC_UINTEGER_1
* restrict src
;
361 const GFC_LOGICAL_1
* restrict msrc
;
362 GFC_INTEGER_16 result
;
367 const GFC_UINTEGER_1
*maxval
;
370 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
376 result
= (GFC_INTEGER_16
)n
+ 1;
380 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
382 if (*msrc
&& (back
? compare_fcn (src
, maxval
, string_len
) >= 0 :
383 compare_fcn (src
, maxval
, string_len
) > 0))
386 result
= (GFC_INTEGER_16
)n
+ 1;
392 /* Advance to the next element. */
398 while (count
[n
] == extent
[n
])
400 /* When we get to the end of a dimension, reset it and increment
401 the next dimension. */
403 /* We could precalculate these products, but this is a less
404 frequently used path so probably not worth it. */
405 base
-= sstride
[n
] * extent
[n
];
406 mbase
-= mstride
[n
] * extent
[n
];
407 dest
-= dstride
[n
] * extent
[n
];
411 /* Break out of the loop. */
427 extern void smaxloc1_16_s1 (gfc_array_i16
* const restrict
,
428 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
429 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
, gfc_charlen_type
);
430 export_proto(smaxloc1_16_s1
);
433 smaxloc1_16_s1 (gfc_array_i16
* const restrict retarray
,
434 gfc_array_s1
* const restrict array
,
435 const index_type
* const restrict pdim
,
436 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
, gfc_charlen_type string_len
)
438 index_type count
[GFC_MAX_DIMENSIONS
];
439 index_type extent
[GFC_MAX_DIMENSIONS
];
440 index_type dstride
[GFC_MAX_DIMENSIONS
];
441 GFC_INTEGER_16
* restrict dest
;
447 if (mask
== NULL
|| *mask
)
450 maxloc1_16_s1 (retarray
, array
, pdim
, back
, string_len
);
452 maxloc1_16_s1 (retarray
, array
, pdim
, string_len
);
456 /* Make dim zero based to avoid confusion. */
458 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
460 if (unlikely (dim
< 0 || dim
> rank
))
462 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
463 "is %ld, should be between 1 and %ld",
464 (long int) dim
+ 1, (long int) rank
+ 1);
467 for (n
= 0; n
< dim
; n
++)
469 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
) * string_len
;
475 for (n
= dim
; n
< rank
; n
++)
478 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1) * string_len
;
484 if (retarray
->base_addr
== NULL
)
486 size_t alloc_size
, str
;
488 for (n
= 0; n
< rank
; n
++)
493 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
495 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
499 retarray
->offset
= 0;
500 retarray
->dtype
.rank
= rank
;
502 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
504 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
507 /* Make sure we have a zero-sized array. */
508 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
514 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
515 runtime_error ("rank of return array incorrect in"
516 " MAXLOC intrinsic: is %ld, should be %ld",
517 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
520 if (unlikely (compile_options
.bounds_check
))
522 for (n
=0; n
< rank
; n
++)
524 index_type ret_extent
;
526 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
527 if (extent
[n
] != ret_extent
)
528 runtime_error ("Incorrect extent in return value of"
529 " MAXLOC intrinsic in dimension %ld:"
530 " is %ld, should be %ld", (long int) n
+ 1,
531 (long int) ret_extent
, (long int) extent
[n
]);
536 for (n
= 0; n
< rank
; n
++)
539 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
542 dest
= retarray
->base_addr
;
550 while (count
[n
] == extent
[n
])
552 /* When we get to the end of a dimension, reset it and increment
553 the next dimension. */
555 /* We could precalculate these products, but this is a less
556 frequently used path so probably not worth it. */
557 dest
-= dstride
[n
] * extent
[n
];