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