172613Skris
272613Skris/* Implementation of the FINDLOC intrinsic
372613Skris   Copyright (C) 2018-2020 Free Software Foundation, Inc.
476866Skris   Contributed by Thomas K��nig <tk@tkoenig.net>
572613Skris
672613SkrisThis file is part of the GNU Fortran 95 runtime library (libgfortran).
772613Skris
872613SkrisLibgfortran is free software; you can redistribute it and/or
972613Skrismodify it under the terms of the GNU General Public
1072613SkrisLicense as published by the Free Software Foundation; either
11160814Ssimonversion 3 of the License, or (at your option) any later version.
1272613Skris
1372613SkrisLibgfortran is distributed in the hope that it will be useful,
1472613Skrisbut WITHOUT ANY WARRANTY; without even the implied warranty of
1572613SkrisMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1672613SkrisGNU General Public License for more details.
1772613Skris
1872613SkrisUnder Section 7 of GPL version 3, you are granted additional
1972613Skrispermissions described in the GCC Runtime Library Exception, version
2072613Skris3.1, as published by the Free Software Foundation.
2172613Skris
2272613SkrisYou should have received a copy of the GNU General Public License and
2372613Skrisa copy of the GCC Runtime Library Exception along with this program;
2472613Skrissee the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
2572613Skris<http://www.gnu.org/licenses/>.  */
2672613Skris
2772613Skris#include "libgfortran.h"
2872613Skris#include <assert.h>
2972613Skris
3072613Skris#if defined (HAVE_GFC_UINTEGER_4)
3172613Skrisextern void findloc0_s4 (gfc_array_index_type * const restrict retarray,
3272613Skris       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
3389837Skris			 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
3489837Skris
3589837Skrisexport_proto(findloc0_s4);
3689837Skris
3789837Skrisvoid
3872613Skrisfindloc0_s4 (gfc_array_index_type * const restrict retarray,
3989837Skris    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
4089837Skris	    GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
4189837Skris{
4289837Skris  index_type count[GFC_MAX_DIMENSIONS];
4389837Skris  index_type extent[GFC_MAX_DIMENSIONS];
4489837Skris  index_type sstride[GFC_MAX_DIMENSIONS];
4572613Skris  index_type dstride;
4672613Skris  const GFC_UINTEGER_4 *base;
4772613Skris  index_type * restrict dest;
4872613Skris  index_type rank;
4972613Skris  index_type n;
5072613Skris  index_type sz;
51269682Sjkim
52269682Sjkim  rank = GFC_DESCRIPTOR_RANK (array);
53269682Sjkim  if (rank <= 0)
54269682Sjkim    runtime_error ("Rank of array needs to be > 0");
55269682Sjkim
56269682Sjkim  if (retarray->base_addr == NULL)
57269682Sjkim    {
58269682Sjkim      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
59269682Sjkim      retarray->dtype.rank = 1;
60269682Sjkim      retarray->offset = 0;
6172613Skris      retarray->base_addr = xmallocarray (rank, sizeof (index_type));
6272613Skris    }
6372613Skris  else
6472613Skris    {
6572613Skris      if (unlikely (compile_options.bounds_check))
6672613Skris	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
6772613Skris				"FINDLOC");
6872613Skris    }
6972613Skris
7072613Skris  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
7172613Skris  dest = retarray->base_addr;
7272613Skris
7389837Skris  /* Set the return value.  */
7472613Skris  for (n = 0; n < rank; n++)
7572613Skris    dest[n * dstride] = 0;
7672613Skris
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_char4 (len_array, base, len_value, 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_char4 (len_array, base, len_value, 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
168extern void mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
169       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
170			 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
171			 gfc_charlen_type len_value);
172export_proto(mfindloc0_s4);
173
174void
175mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
176    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *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_4 *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_char4 (len_array, base, len_value, 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_char4 (len_array, base, len_value, 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
333extern void sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
334       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
335			 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
336			 gfc_charlen_type len_value);
337export_proto(sfindloc0_s4);
338
339void
340sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
341    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *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_s4 (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
384