1`/* Implementation of the FINDLOC intrinsic
2   Copyright (C) 2018-2019 Free Software Foundation, Inc.
3   Contributed by Thomas König <tk@tkoenig.net>
4
5This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24<http://www.gnu.org/licenses/>.  */
25
26#include "libgfortran.h"
27#include <assert.h>
28
29#if defined (HAVE_'atype_name`)
30'header1`
31{
32  index_type count[GFC_MAX_DIMENSIONS];
33  index_type extent[GFC_MAX_DIMENSIONS];
34  index_type sstride[GFC_MAX_DIMENSIONS];
35  index_type dstride[GFC_MAX_DIMENSIONS];
36  const 'atype_name`'` * restrict base;
37  index_type * restrict dest;
38  index_type rank;
39  index_type n;
40  index_type len;
41  index_type delta;
42  index_type dim;
43  int continue_loop;
44
45  /* Make dim zero based to avoid confusion.  */
46  rank = GFC_DESCRIPTOR_RANK (array) - 1;
47  dim = (*pdim) - 1;
48
49  if (unlikely (dim < 0 || dim > rank))
50    {
51      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
52 		     "is %ld, should be between 1 and %ld",
53		     (long int) dim + 1, (long int) rank + 1);
54    }
55
56  len = GFC_DESCRIPTOR_EXTENT(array,dim);
57  if (len < 0)
58    len = 0;
59  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
60
61  for (n = 0; n < dim; n++)
62    {
63      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
64      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
65
66      if (extent[n] < 0)
67	extent[n] = 0;
68    }
69  for (n = dim; n < rank; n++)
70    {
71      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
72      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
73
74      if (extent[n] < 0)
75	extent[n] = 0;
76    }
77
78  if (retarray->base_addr == NULL)
79    {
80      size_t alloc_size, str;
81
82      for (n = 0; n < rank; n++)
83	{
84	  if (n == 0)
85	    str = 1;
86	  else
87	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
88
89	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
90
91	}
92
93      retarray->offset = 0;
94      retarray->dtype.rank = rank;
95
96      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
97
98      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
99      if (alloc_size == 0)
100	{
101	  /* Make sure we have a zero-sized array.  */
102	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
103	  return;
104	}
105    }
106  else
107    {
108      if (rank != GFC_DESCRIPTOR_RANK (retarray))
109	runtime_error ("rank of return array incorrect in"
110		       " FINDLOC intrinsic: is %ld, should be %ld",
111		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
112		       (long int) rank);
113
114      if (unlikely (compile_options.bounds_check))
115	bounds_ifunction_return ((array_t *) retarray, extent,
116				 "return value", "FINDLOC");
117    }
118
119  for (n = 0; n < rank; n++)
120    {
121      count[n] = 0;
122      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
123      if (extent[n] <= 0)
124	return;
125    }
126
127  dest = retarray->base_addr;
128  continue_loop = 1;
129
130  base = array->base_addr;
131  while (continue_loop)
132    {
133      const 'atype_name`'` * restrict src;
134      index_type result;
135
136      result = 0;
137      if (back)
138	{
139	  src = base + (len - 1) * delta * 'base_mult`;
140	  for (n = len; n > 0; n--, src -= delta * 'base_mult`)
141	    {
142	      if ('comparison`'`)
143		{
144		  result = n;
145		  break;
146		}
147	    }
148	}
149      else
150	{
151	  src = base;
152	  for (n = 1; n <= len; n++, src += delta * 'base_mult`)
153	    {
154	      if ('comparison`'`)
155		{
156		  result = n;
157		  break;
158		}
159	    }
160	}
161      *dest = result;
162
163      count[0]++;
164      base += sstride[0] * 'base_mult`;
165      dest += dstride[0];
166      n = 0;
167      while (count[n] == extent[n])
168	{
169	  count[n] = 0;
170	  base -= sstride[n] * extent[n] * 'base_mult`;
171	  dest -= dstride[n] * extent[n];
172	  n++;
173	  if (n >= rank)
174	    {
175	      continue_loop = 0;
176	      break;
177	    }
178	  else
179	    {
180	      count[n]++;
181	      base += sstride[n] * 'base_mult`;
182	      dest += dstride[n];
183	    }
184	}
185    }
186}
187'header2`'`
188{
189  index_type count[GFC_MAX_DIMENSIONS];
190  index_type extent[GFC_MAX_DIMENSIONS];
191  index_type sstride[GFC_MAX_DIMENSIONS];
192  index_type mstride[GFC_MAX_DIMENSIONS];
193  index_type dstride[GFC_MAX_DIMENSIONS];
194  const 'atype_name`'` * restrict base;
195  const GFC_LOGICAL_1 * restrict mbase;
196  index_type * restrict dest;
197  index_type rank;
198  index_type n;
199  index_type len;
200  index_type delta;
201  index_type mdelta;
202  index_type dim;
203  int mask_kind;
204  int continue_loop;
205
206  /* Make dim zero based to avoid confusion.  */
207  rank = GFC_DESCRIPTOR_RANK (array) - 1;
208  dim = (*pdim) - 1;
209
210  if (unlikely (dim < 0 || dim > rank))
211    {
212      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
213 		     "is %ld, should be between 1 and %ld",
214		     (long int) dim + 1, (long int) rank + 1);
215    }
216
217  len = GFC_DESCRIPTOR_EXTENT(array,dim);
218  if (len < 0)
219    len = 0;
220
221  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
222  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
223
224  mbase = mask->base_addr;
225
226  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
227
228  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
229#ifdef HAVE_GFC_LOGICAL_16
230      || mask_kind == 16
231#endif
232      )
233    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
234  else
235    internal_error (NULL, "Funny sized logical array");
236
237  for (n = 0; n < dim; n++)
238    {
239      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
240      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
241      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
242
243      if (extent[n] < 0)
244	extent[n] = 0;
245    }
246  for (n = dim; n < rank; n++)
247    {
248      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
249      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
250      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
251
252      if (extent[n] < 0)
253	extent[n] = 0;
254    }
255
256  if (retarray->base_addr == NULL)
257    {
258      size_t alloc_size, str;
259
260      for (n = 0; n < rank; n++)
261	{
262	  if (n == 0)
263	    str = 1;
264	  else
265	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
266
267	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
268
269	}
270
271      retarray->offset = 0;
272      retarray->dtype.rank = rank;
273
274      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
275
276      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
277      if (alloc_size == 0)
278	{
279	  /* Make sure we have a zero-sized array.  */
280	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
281	  return;
282	}
283    }
284  else
285    {
286      if (rank != GFC_DESCRIPTOR_RANK (retarray))
287	runtime_error ("rank of return array incorrect in"
288		       " FINDLOC intrinsic: is %ld, should be %ld",
289		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
290		       (long int) rank);
291
292      if (unlikely (compile_options.bounds_check))
293	bounds_ifunction_return ((array_t *) retarray, extent,
294				 "return value", "FINDLOC");
295    }
296
297  for (n = 0; n < rank; n++)
298    {
299      count[n] = 0;
300      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
301      if (extent[n] <= 0)
302	return;
303    }
304
305  dest = retarray->base_addr;
306  continue_loop = 1;
307
308  base = array->base_addr;
309  while (continue_loop)
310    {
311      const 'atype_name`'` * restrict src;
312      const GFC_LOGICAL_1 * restrict msrc;
313      index_type result;
314
315      result = 0;
316      if (back)
317	{
318	  src = base + (len - 1) * delta * 'base_mult`;
319	  msrc = mbase + (len - 1) * mdelta;
320	  for (n = len; n > 0; n--, src -= delta * 'base_mult`, msrc -= mdelta)
321	    {
322	      if (*msrc && 'comparison`'`)
323		{
324		  result = n;
325		  break;
326		}
327	    }
328	}
329      else
330	{
331	  src = base;
332	  msrc = mbase;
333	  for (n = 1; n <= len; n++, src += delta * 'base_mult`, msrc += mdelta)
334	    {
335	      if (*msrc && 'comparison`'`)
336		{
337		  result = n;
338		  break;
339		}
340	    }
341	}
342      *dest = result;
343
344      count[0]++;
345      base += sstride[0] * 'base_mult`;
346      mbase += mstride[0];
347      dest += dstride[0];
348      n = 0;
349      while (count[n] == extent[n])
350	{
351	  count[n] = 0;
352	  base -= sstride[n] * extent[n] * 'base_mult`;
353	  mbase -= mstride[n] * extent[n];
354	  dest -= dstride[n] * extent[n];
355	  n++;
356	  if (n >= rank)
357	    {
358	      continue_loop = 0;
359	      break;
360	    }
361	  else
362	    {
363	      count[n]++;
364	      base += sstride[n] * 'base_mult`;
365	      dest += dstride[n];
366	    }
367	}
368    }
369}
370'header3`'`
371{
372  index_type count[GFC_MAX_DIMENSIONS];
373  index_type extent[GFC_MAX_DIMENSIONS];
374  index_type dstride[GFC_MAX_DIMENSIONS];
375  index_type * restrict dest;
376  index_type rank;
377  index_type n;
378  index_type len;
379  index_type dim;
380  bool continue_loop;
381
382  if (mask == NULL || *mask)
383    {
384      findloc1_'atype_code`'` (retarray, array, value, pdim, back'len_arg`'`);
385      return;
386    }
387    /* Make dim zero based to avoid confusion.  */
388  rank = GFC_DESCRIPTOR_RANK (array) - 1;
389  dim = (*pdim) - 1;
390
391  if (unlikely (dim < 0 || dim > rank))
392    {
393      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
394 		     "is %ld, should be between 1 and %ld",
395		     (long int) dim + 1, (long int) rank + 1);
396    }
397
398  len = GFC_DESCRIPTOR_EXTENT(array,dim);
399  if (len < 0)
400    len = 0;
401
402  for (n = 0; n < dim; n++)
403    {
404      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
405
406      if (extent[n] <= 0)
407	extent[n] = 0;
408    }
409
410  for (n = dim; n < rank; n++)
411    {
412      extent[n] =
413	GFC_DESCRIPTOR_EXTENT(array,n + 1);
414
415      if (extent[n] <= 0)
416	extent[n] = 0;
417    }
418
419
420  if (retarray->base_addr == NULL)
421    {
422      size_t alloc_size, str;
423
424      for (n = 0; n < rank; n++)
425	{
426	  if (n == 0)
427	    str = 1;
428	  else
429	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
430
431	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
432	}
433
434      retarray->offset = 0;
435      retarray->dtype.rank = rank;
436
437      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
438
439      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
440      if (alloc_size == 0)
441	{
442	  /* Make sure we have a zero-sized array.  */
443	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
444	  return;
445	}
446    }
447  else
448    {
449      if (rank != GFC_DESCRIPTOR_RANK (retarray))
450	runtime_error ("rank of return array incorrect in"
451		       " FINDLOC intrinsic: is %ld, should be %ld",
452		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
453		       (long int) rank);
454
455      if (unlikely (compile_options.bounds_check))
456	bounds_ifunction_return ((array_t *) retarray, extent,
457				 "return value", "FINDLOC");
458    }
459
460  for (n = 0; n < rank; n++)
461    {
462      count[n] = 0;
463      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
464      if (extent[n] <= 0)
465	return;
466    }
467  dest = retarray->base_addr;
468  continue_loop = 1;
469
470  while (continue_loop)
471    {
472      *dest = 0;
473
474      count[0]++;
475      dest += dstride[0];
476      n = 0;
477      while (count[n] == extent[n])
478	{
479	  count[n] = 0;
480	  dest -= dstride[n] * extent[n];
481	  n++;
482	  if (n >= rank)
483	    {
484	      continue_loop = 0;
485	      break;
486	    }
487	  else
488	    {
489	      count[n]++;
490	      dest += dstride[n];
491	    }
492	}
493    }
494}
495#endif'
496