1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2017-2021 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 #include <stdlib.h>
28 #include <string.h>
29 #include <assert.h>
30 #include <limits.h>
31
32
33 #if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
34
35 #define HAVE_BACK_ARG 1
36
37 static inline int
compare_fcn(const GFC_UINTEGER_1 * a,const GFC_UINTEGER_1 * b,gfc_charlen_type n)38 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
39 {
40 if (sizeof (GFC_UINTEGER_1) == 1)
41 return memcmp (a, b, n);
42 else
43 return memcmp_char4 (a, b, n);
44
45 }
46
47 extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
48 gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
49 export_proto(maxloc0_8_s1);
50
51 void
maxloc0_8_s1(gfc_array_i8 * const restrict retarray,gfc_array_s1 * const restrict array,GFC_LOGICAL_4 back,gfc_charlen_type len)52 maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
53 gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
54 {
55 index_type count[GFC_MAX_DIMENSIONS];
56 index_type extent[GFC_MAX_DIMENSIONS];
57 index_type sstride[GFC_MAX_DIMENSIONS];
58 index_type dstride;
59 const GFC_UINTEGER_1 *base;
60 GFC_INTEGER_8 * restrict dest;
61 index_type rank;
62 index_type n;
63
64 rank = GFC_DESCRIPTOR_RANK (array);
65 if (rank <= 0)
66 runtime_error ("Rank of array needs to be > 0");
67
68 if (retarray->base_addr == NULL)
69 {
70 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
71 retarray->dtype.rank = 1;
72 retarray->offset = 0;
73 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
74 }
75 else
76 {
77 if (unlikely (compile_options.bounds_check))
78 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
79 "MAXLOC");
80 }
81
82 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
83 dest = retarray->base_addr;
84 for (n = 0; n < rank; n++)
85 {
86 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
87 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
88 count[n] = 0;
89 if (extent[n] <= 0)
90 {
91 /* Set the return value. */
92 for (n = 0; n < rank; n++)
93 dest[n * dstride] = 0;
94 return;
95 }
96 }
97
98 base = array->base_addr;
99
100 /* Initialize the return value. */
101 for (n = 0; n < rank; n++)
102 dest[n * dstride] = 1;
103 {
104
105 const GFC_UINTEGER_1 *maxval;
106 maxval = NULL;
107
108 while (base)
109 {
110 do
111 {
112 /* Implementation start. */
113
114 if (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0 :
115 compare_fcn (base, maxval, len) > 0))
116 {
117 maxval = base;
118 for (n = 0; n < rank; n++)
119 dest[n * dstride] = count[n] + 1;
120 }
121 /* Implementation end. */
122 /* Advance to the next element. */
123 base += sstride[0];
124 }
125 while (++count[0] != extent[0]);
126 n = 0;
127 do
128 {
129 /* When we get to the end of a dimension, reset it and increment
130 the next dimension. */
131 count[n] = 0;
132 /* We could precalculate these products, but this is a less
133 frequently used path so probably not worth it. */
134 base -= sstride[n] * extent[n];
135 n++;
136 if (n >= rank)
137 {
138 /* Break out of the loop. */
139 base = NULL;
140 break;
141 }
142 else
143 {
144 count[n]++;
145 base += sstride[n];
146 }
147 }
148 while (count[n] == extent[n]);
149 }
150 }
151 }
152
153
154 extern void mmaxloc0_8_s1 (gfc_array_i8 * const restrict,
155 gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
156 gfc_charlen_type len);
157 export_proto(mmaxloc0_8_s1);
158
159 void
mmaxloc0_8_s1(gfc_array_i8 * const restrict retarray,gfc_array_s1 * const restrict array,gfc_array_l1 * const restrict mask,GFC_LOGICAL_4 back,gfc_charlen_type len)160 mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
161 gfc_array_s1 * const restrict array,
162 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
163 gfc_charlen_type len)
164 {
165 index_type count[GFC_MAX_DIMENSIONS];
166 index_type extent[GFC_MAX_DIMENSIONS];
167 index_type sstride[GFC_MAX_DIMENSIONS];
168 index_type mstride[GFC_MAX_DIMENSIONS];
169 index_type dstride;
170 GFC_INTEGER_8 *dest;
171 const GFC_UINTEGER_1 *base;
172 GFC_LOGICAL_1 *mbase;
173 int rank;
174 index_type n;
175 int mask_kind;
176
177 if (mask == NULL)
178 {
179 #ifdef HAVE_BACK_ARG
180 maxloc0_8_s1 (retarray, array, back, len);
181 #else
182 maxloc0_8_s1 (retarray, array, len);
183 #endif
184 return;
185 }
186
187 rank = GFC_DESCRIPTOR_RANK (array);
188 if (rank <= 0)
189 runtime_error ("Rank of array needs to be > 0");
190
191 if (retarray->base_addr == NULL)
192 {
193 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
194 retarray->dtype.rank = 1;
195 retarray->offset = 0;
196 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
197 }
198 else
199 {
200 if (unlikely (compile_options.bounds_check))
201 {
202
203 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
204 "MAXLOC");
205 bounds_equal_extents ((array_t *) mask, (array_t *) array,
206 "MASK argument", "MAXLOC");
207 }
208 }
209
210 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
211
212 mbase = mask->base_addr;
213
214 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
215 #ifdef HAVE_GFC_LOGICAL_16
216 || mask_kind == 16
217 #endif
218 )
219 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
220 else
221 runtime_error ("Funny sized logical array");
222
223 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
224 dest = retarray->base_addr;
225 for (n = 0; n < rank; n++)
226 {
227 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
228 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
229 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
230 count[n] = 0;
231 if (extent[n] <= 0)
232 {
233 /* Set the return value. */
234 for (n = 0; n < rank; n++)
235 dest[n * dstride] = 0;
236 return;
237 }
238 }
239
240 base = array->base_addr;
241
242 /* Initialize the return value. */
243 for (n = 0; n < rank; n++)
244 dest[n * dstride] = 0;
245 {
246
247 const GFC_UINTEGER_1 *maxval;
248
249 maxval = NULL;
250
251 while (base)
252 {
253 do
254 {
255 /* Implementation start. */
256
257 if (*mbase &&
258 (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0:
259 compare_fcn (base, maxval, len) > 0)))
260 {
261 maxval = base;
262 for (n = 0; n < rank; n++)
263 dest[n * dstride] = count[n] + 1;
264 }
265 /* Implementation end. */
266 /* Advance to the next element. */
267 base += sstride[0];
268 mbase += mstride[0];
269 }
270 while (++count[0] != extent[0]);
271 n = 0;
272 do
273 {
274 /* When we get to the end of a dimension, reset it and increment
275 the next dimension. */
276 count[n] = 0;
277 /* We could precalculate these products, but this is a less
278 frequently used path so probably not worth it. */
279 base -= sstride[n] * extent[n];
280 mbase -= mstride[n] * extent[n];
281 n++;
282 if (n >= rank)
283 {
284 /* Break out of the loop. */
285 base = NULL;
286 break;
287 }
288 else
289 {
290 count[n]++;
291 base += sstride[n];
292 mbase += mstride[n];
293 }
294 }
295 while (count[n] == extent[n]);
296 }
297 }
298 }
299
300
301 extern void smaxloc0_8_s1 (gfc_array_i8 * const restrict,
302 gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
303 gfc_charlen_type len);
304 export_proto(smaxloc0_8_s1);
305
306 void
smaxloc0_8_s1(gfc_array_i8 * const restrict retarray,gfc_array_s1 * const restrict array,GFC_LOGICAL_4 * mask,GFC_LOGICAL_4 back,gfc_charlen_type len)307 smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
308 gfc_array_s1 * const restrict array,
309 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
310 gfc_charlen_type len)
311 {
312 index_type rank;
313 index_type dstride;
314 index_type n;
315 GFC_INTEGER_8 *dest;
316
317 if (mask == NULL || *mask)
318 {
319 #ifdef HAVE_BACK_ARG
320 maxloc0_8_s1 (retarray, array, back, len);
321 #else
322 maxloc0_8_s1 (retarray, array, len);
323 #endif
324 return;
325 }
326
327 rank = GFC_DESCRIPTOR_RANK (array);
328
329 if (rank <= 0)
330 runtime_error ("Rank of array needs to be > 0");
331
332 if (retarray->base_addr == NULL)
333 {
334 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
335 retarray->dtype.rank = 1;
336 retarray->offset = 0;
337 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
338 }
339 else if (unlikely (compile_options.bounds_check))
340 {
341 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
342 "MAXLOC");
343 }
344
345 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
346 dest = retarray->base_addr;
347 for (n = 0; n<rank; n++)
348 dest[n * dstride] = 0 ;
349 }
350 #endif
351