PR target/84365
[official-gcc.git] / libgfortran / generated / maxloc0_8_s1.c
blob2e95fa35d1c56e0f095ff143a0359b743a460020
1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2017-2018 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"
27 #include <stdlib.h>
28 #include <string.h>
29 #include <assert.h>
30 #include <limits.h>
33 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
35 #define HAVE_BACK_ARG 1
37 static inline int
38 compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
40 if (sizeof (GFC_INTEGER_1) == 1)
41 return memcmp (a, b, n);
42 else
43 return memcmp_char4 (a, b, n);
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);
51 void
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)
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;
64 #ifdef HAVE_BACK_ARG
65 assert (back == 0);
66 #endif
68 rank = GFC_DESCRIPTOR_RANK (array);
69 if (rank <= 0)
70 runtime_error ("Rank of array needs to be > 0");
72 if (retarray->base_addr == NULL)
74 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
75 GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
76 retarray->offset = 0;
77 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
79 else
81 if (unlikely (compile_options.bounds_check))
82 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
83 "MAXLOC");
86 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
87 dest = retarray->base_addr;
88 for (n = 0; n < rank; n++)
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)
95 /* Set the return value. */
96 for (n = 0; n < rank; n++)
97 dest[n * dstride] = 0;
98 return;
102 base = array->base_addr;
104 /* Initialize the return value. */
105 for (n = 0; n < rank; n++)
106 dest[n * dstride] = 1;
109 const GFC_INTEGER_1 *maxval;
110 maxval = base;
112 while (base)
116 /* Implementation start. */
118 if (compare_fcn (base, maxval, len) > 0)
120 maxval = base;
121 for (n = 0; n < rank; n++)
122 dest[n * dstride] = count[n] + 1;
124 /* Implementation end. */
125 /* Advance to the next element. */
126 base += sstride[0];
128 while (++count[0] != extent[0]);
129 n = 0;
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)
141 /* Break out of the loop. */
142 base = NULL;
143 break;
145 else
147 count[n]++;
148 base += sstride[n];
151 while (count[n] == extent[n]);
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);
162 void
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)
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;
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");
187 if (retarray->base_addr == NULL)
189 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
190 GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
191 retarray->offset = 0;
192 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
194 else
196 if (unlikely (compile_options.bounds_check))
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");
206 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
208 mbase = mask->base_addr;
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
215 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
216 else
217 runtime_error ("Funny sized logical array");
219 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
220 dest = retarray->base_addr;
221 for (n = 0; n < rank; n++)
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)
229 /* Set the return value. */
230 for (n = 0; n < rank; n++)
231 dest[n * dstride] = 0;
232 return;
236 base = array->base_addr;
238 /* Initialize the return value. */
239 for (n = 0; n < rank; n++)
240 dest[n * dstride] = 0;
243 const GFC_INTEGER_1 *maxval;
245 maxval = NULL;
247 while (base)
251 /* Implementation start. */
253 if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
255 maxval = base;
256 for (n = 0; n < rank; n++)
257 dest[n * dstride] = count[n] + 1;
259 /* Implementation end. */
260 /* Advance to the next element. */
261 base += sstride[0];
262 mbase += mstride[0];
264 while (++count[0] != extent[0]);
265 n = 0;
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)
278 /* Break out of the loop. */
279 base = NULL;
280 break;
282 else
284 count[n]++;
285 base += sstride[n];
286 mbase += mstride[n];
289 while (count[n] == extent[n]);
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);
300 void
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)
306 index_type rank;
307 index_type dstride;
308 index_type n;
309 GFC_INTEGER_8 *dest;
311 if (*mask)
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;
321 rank = GFC_DESCRIPTOR_RANK (array);
323 if (rank <= 0)
324 runtime_error ("Rank of array needs to be > 0");
326 if (retarray->base_addr == NULL)
328 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
329 GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
330 retarray->offset = 0;
331 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
333 else if (unlikely (compile_options.bounds_check))
335 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
336 "MAXLOC");
339 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
340 dest = retarray->base_addr;
341 for (n = 0; n<rank; n++)
342 dest[n * dstride] = 0 ;
344 #endif