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