1
2 /* Implementation of the FINDLOC intrinsic
3 Copyright (C) 2018-2023 Free Software Foundation, Inc.
4 Contributed by Thomas König <tk@tkoenig.net>
5
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
26
27 #include "libgfortran.h"
28 #include <assert.h>
29
30 #if defined (HAVE_GFC_UINTEGER_1)
31 extern void findloc0_s1 (gfc_array_index_type * const restrict retarray,
32 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
33 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
34
35 export_proto(findloc0_s1);
36
37 void
38 findloc0_s1 (gfc_array_index_type * const restrict retarray,
39 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
40 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
41 {
42 index_type count[GFC_MAX_DIMENSIONS];
43 index_type extent[GFC_MAX_DIMENSIONS];
44 index_type sstride[GFC_MAX_DIMENSIONS];
45 index_type dstride;
46 const GFC_UINTEGER_1 *base;
47 index_type * restrict dest;
48 index_type rank;
49 index_type n;
50 index_type sz;
51
52 rank = GFC_DESCRIPTOR_RANK (array);
53 if (rank <= 0)
54 runtime_error ("Rank of array needs to be > 0");
55
56 if (retarray->base_addr == NULL)
57 {
58 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
59 retarray->dtype.rank = 1;
60 retarray->offset = 0;
61 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
62 }
63 else
64 {
65 if (unlikely (compile_options.bounds_check))
66 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
67 "FINDLOC");
68 }
69
70 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
71 dest = retarray->base_addr;
72
73 /* Set the return value. */
74 for (n = 0; n < rank; n++)
75 dest[n * dstride] = 0;
76
77 sz = 1;
78 for (n = 0; n < rank; n++)
79 {
80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
81 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
82 sz *= extent[n];
83 if (extent[n] <= 0)
84 return;
85 }
86
87 for (n = 0; n < rank; n++)
88 count[n] = 0;
89
90 if (back)
91 {
92 base = array->base_addr + (sz - 1) * len_array;
93
94 while (1)
95 {
96 do
97 {
98 if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
99 {
100 for (n = 0; n < rank; n++)
101 dest[n * dstride] = extent[n] - count[n];
102
103 return;
104 }
105 base -= sstride[0] * len_array;
106 } while(++count[0] != extent[0]);
107
108 n = 0;
109 do
110 {
111 /* When we get to the end of a dimension, reset it and increment
112 the next dimension. */
113 count[n] = 0;
114 /* We could precalculate these products, but this is a less
115 frequently used path so probably not worth it. */
116 base += sstride[n] * extent[n] * len_array;
117 n++;
118 if (n >= rank)
119 return;
120 else
121 {
122 count[n]++;
123 base -= sstride[n] * len_array;
124 }
125 } while (count[n] == extent[n]);
126 }
127 }
128 else
129 {
130 base = array->base_addr;
131 while (1)
132 {
133 do
134 {
135 if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
136 {
137 for (n = 0; n < rank; n++)
138 dest[n * dstride] = count[n] + 1;
139
140 return;
141 }
142 base += sstride[0] * len_array;
143 } while(++count[0] != extent[0]);
144
145 n = 0;
146 do
147 {
148 /* When we get to the end of a dimension, reset it and increment
149 the next dimension. */
150 count[n] = 0;
151 /* We could precalculate these products, but this is a less
152 frequently used path so probably not worth it. */
153 base -= sstride[n] * extent[n] * len_array;
154 n++;
155 if (n >= rank)
156 return;
157 else
158 {
159 count[n]++;
160 base += sstride[n] * len_array;
161 }
162 } while (count[n] == extent[n]);
163 }
164 }
165 return;
166 }
167
168 extern void mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
169 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
170 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
171 gfc_charlen_type len_value);
172 export_proto(mfindloc0_s1);
173
174 void
175 mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
176 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
177 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
178 gfc_charlen_type len_array, gfc_charlen_type len_value)
179 {
180 index_type count[GFC_MAX_DIMENSIONS];
181 index_type extent[GFC_MAX_DIMENSIONS];
182 index_type sstride[GFC_MAX_DIMENSIONS];
183 index_type mstride[GFC_MAX_DIMENSIONS];
184 index_type dstride;
185 const GFC_UINTEGER_1 *base;
186 index_type * restrict dest;
187 GFC_LOGICAL_1 *mbase;
188 index_type rank;
189 index_type n;
190 int mask_kind;
191 index_type sz;
192
193 rank = GFC_DESCRIPTOR_RANK (array);
194 if (rank <= 0)
195 runtime_error ("Rank of array needs to be > 0");
196
197 if (retarray->base_addr == NULL)
198 {
199 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
200 retarray->dtype.rank = 1;
201 retarray->offset = 0;
202 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
203 }
204 else
205 {
206 if (unlikely (compile_options.bounds_check))
207 {
208 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
209 "FINDLOC");
210 bounds_equal_extents ((array_t *) mask, (array_t *) array,
211 "MASK argument", "FINDLOC");
212 }
213 }
214
215 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
216
217 mbase = mask->base_addr;
218
219 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
220 #ifdef HAVE_GFC_LOGICAL_16
221 || mask_kind == 16
222 #endif
223 )
224 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
225 else
226 internal_error (NULL, "Funny sized logical array");
227
228 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
229 dest = retarray->base_addr;
230
231 /* Set the return value. */
232 for (n = 0; n < rank; n++)
233 dest[n * dstride] = 0;
234
235 sz = 1;
236 for (n = 0; n < rank; n++)
237 {
238 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
239 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
240 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
241 sz *= extent[n];
242 if (extent[n] <= 0)
243 return;
244 }
245
246 for (n = 0; n < rank; n++)
247 count[n] = 0;
248
249 if (back)
250 {
251 base = array->base_addr + (sz - 1) * len_array;
252 mbase = mbase + (sz - 1) * mask_kind;
253 while (1)
254 {
255 do
256 {
257 if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
258 {
259 for (n = 0; n < rank; n++)
260 dest[n * dstride] = extent[n] - count[n];
261
262 return;
263 }
264 base -= sstride[0] * len_array;
265 mbase -= mstride[0];
266 } while(++count[0] != extent[0]);
267
268 n = 0;
269 do
270 {
271 /* When we get to the end of a dimension, reset it and increment
272 the next dimension. */
273 count[n] = 0;
274 /* We could precalculate these products, but this is a less
275 frequently used path so probably not worth it. */
276 base += sstride[n] * extent[n] * len_array;
277 mbase -= mstride[n] * extent[n];
278 n++;
279 if (n >= rank)
280 return;
281 else
282 {
283 count[n]++;
284 base -= sstride[n] * len_array;
285 mbase += mstride[n];
286 }
287 } while (count[n] == extent[n]);
288 }
289 }
290 else
291 {
292 base = array->base_addr;
293 while (1)
294 {
295 do
296 {
297 if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
298 {
299 for (n = 0; n < rank; n++)
300 dest[n * dstride] = count[n] + 1;
301
302 return;
303 }
304 base += sstride[0] * len_array;
305 mbase += mstride[0];
306 } while(++count[0] != extent[0]);
307
308 n = 0;
309 do
310 {
311 /* When we get to the end of a dimension, reset it and increment
312 the next dimension. */
313 count[n] = 0;
314 /* We could precalculate these products, but this is a less
315 frequently used path so probably not worth it. */
316 base -= sstride[n] * extent[n] * len_array;
317 mbase -= mstride[n] * extent[n];
318 n++;
319 if (n >= rank)
320 return;
321 else
322 {
323 count[n]++;
324 base += sstride[n]* len_array;
325 mbase += mstride[n];
326 }
327 } while (count[n] == extent[n]);
328 }
329 }
330 return;
331 }
332
333 extern void sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
334 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
335 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
336 gfc_charlen_type len_value);
337 export_proto(sfindloc0_s1);
338
339 void
340 sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
341 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
342 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
343 gfc_charlen_type len_value)
344 {
345 index_type rank;
346 index_type dstride;
347 index_type * restrict dest;
348 index_type n;
349
350 if (mask == NULL || *mask)
351 {
352 findloc0_s1 (retarray, array, value, back, len_array, len_value);
353 return;
354 }
355
356 rank = GFC_DESCRIPTOR_RANK (array);
357
358 if (rank <= 0)
359 internal_error (NULL, "Rank of array needs to be > 0");
360
361 if (retarray->base_addr == NULL)
362 {
363 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
364 retarray->dtype.rank = 1;
365 retarray->offset = 0;
366 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
367 }
368 else if (unlikely (compile_options.bounds_check))
369 {
370 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
371 "FINDLOC");
372 }
373
374 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
375 dest = retarray->base_addr;
376 for (n = 0; n<rank; n++)
377 dest[n * dstride] = 0 ;
378 }
379
380 #endif
381
382
383