1
2/* Implementation of the FINDLOC intrinsic
3   Copyright (C) 2018-2020 Free Software Foundation, Inc.
4   Contributed by Thomas K��nig <tk@tkoenig.net>
5
6This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8Libgfortran is free software; you can redistribute it and/or
9modify it under the terms of the GNU General Public
10License as published by the Free Software Foundation; either
11version 3 of the License, or (at your option) any later version.
12
13Libgfortran is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16GNU General Public License for more details.
17
18Under Section 7 of GPL version 3, you are granted additional
19permissions described in the GCC Runtime Library Exception, version
203.1, as published by the Free Software Foundation.
21
22You should have received a copy of the GNU General Public License and
23a copy of the GCC Runtime Library Exception along with this program;
24see 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_COMPLEX_16)
31extern void findloc0_c16 (gfc_array_index_type * const restrict retarray,
32       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
33			 GFC_LOGICAL_4);
34export_proto(findloc0_c16);
35
36void
37findloc0_c16 (gfc_array_index_type * const restrict retarray,
38    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 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_COMPLEX_16 *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
167extern void mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
168       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
169			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170export_proto(mfindloc0_c16);
171
172void
173mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
174    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 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_COMPLEX_16 *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
330extern void sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
331       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
332			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333export_proto(sfindloc0_c16);
334
335void
336sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
337    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 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_c16 (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