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