1dnl Support macro file for intrinsic functions.
2dnl Contains the generic sections of the array functions.
3dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
4dnl Distributed under the GNU GPL with exception.  See COPYING for details.
5define(START_FOREACH_FUNCTION,
6`static inline int
7compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
8{
9  if (sizeof ('atype_name`) == 1)
10    return memcmp (a, b, n);
11  else
12    return memcmp_char4 (a, b, n);
13
14}
15
16extern void name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
17	'atype` * const restrict array'back_arg`, gfc_charlen_type len);
18export_proto('name`'rtype_qual`_'atype_code);
19
20void
21name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
22	'atype` * const restrict array'back_arg`, gfc_charlen_type len)
23{
24  index_type count[GFC_MAX_DIMENSIONS];
25  index_type extent[GFC_MAX_DIMENSIONS];
26  index_type sstride[GFC_MAX_DIMENSIONS];
27  index_type dstride;
28  const 'atype_name *base;
29  rtype_name * restrict dest;
30  index_type rank;
31  index_type n;
32
33  rank = GFC_DESCRIPTOR_RANK (array);
34  if (rank <= 0)
35    runtime_error ("Rank of array needs to be > 0");
36
37  if (retarray->base_addr == NULL)
38    {
39      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
40      retarray->dtype.rank = 1;
41      retarray->offset = 0;
42      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
43    }
44  else
45    {
46      if (unlikely (compile_options.bounds_check))
47	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
48				"u_name");
49    }
50
51  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
52  dest = retarray->base_addr;
53  for (n = 0; n < rank; n++)
54    {
55      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
56      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
57      count[n] = 0;
58      if (extent[n] <= 0)
59	{
60	  /* Set the return value.  */
61	  for (n = 0; n < rank; n++)
62	    dest[n * dstride] = 0;
63	  return;
64	}
65    }
66
67  base = array->base_addr;
68
69  /* Initialize the return value.  */
70  for (n = 0; n < rank; n++)
71    dest[n * dstride] = 1;
72  {
73')dnl
74define(START_FOREACH_BLOCK,
75`  while (base)
76    {
77      do
78	{
79	  /* Implementation start.  */
80')dnl
81define(FINISH_FOREACH_FUNCTION,
82`	  /* Implementation end.  */
83	  /* Advance to the next element.  */
84	  base += sstride[0];
85	}
86      while (++count[0] != extent[0]);
87      n = 0;
88      do
89	{
90	  /* When we get to the end of a dimension, reset it and increment
91	     the next dimension.  */
92	  count[n] = 0;
93	  /* We could precalculate these products, but this is a less
94	     frequently used path so probably not worth it.  */
95	  base -= sstride[n] * extent[n];
96	  n++;
97	  if (n >= rank)
98	    {
99	      /* Break out of the loop.  */
100	      base = NULL;
101	      break;
102	    }
103	  else
104	    {
105	      count[n]++;
106	      base += sstride[n];
107	    }
108	}
109      while (count[n] == extent[n]);
110    }
111  }
112}')dnl
113define(START_MASKED_FOREACH_FUNCTION,
114`
115extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
116	'atype` * const restrict, gfc_array_l1 * const restrict 'back_arg`,
117	gfc_charlen_type len);
118export_proto(m'name`'rtype_qual`_'atype_code`);
119
120void
121m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
122	'atype` * const restrict array,
123	gfc_array_l1 * const restrict mask'back_arg`,
124	gfc_charlen_type len)
125{
126  index_type count[GFC_MAX_DIMENSIONS];
127  index_type extent[GFC_MAX_DIMENSIONS];
128  index_type sstride[GFC_MAX_DIMENSIONS];
129  index_type mstride[GFC_MAX_DIMENSIONS];
130  index_type dstride;
131  'rtype_name *dest;
132  const atype_name *base;
133  GFC_LOGICAL_1 *mbase;
134  int rank;
135  index_type n;
136  int mask_kind;
137
138  if (mask == NULL)
139    {
140#ifdef HAVE_BACK_ARG
141      name`'rtype_qual`_'atype_code (retarray, array, back, len);
142#else
143      name`'rtype_qual`_'atype_code (retarray, array, len);
144#endif
145      return;
146    }
147
148  rank = GFC_DESCRIPTOR_RANK (array);
149  if (rank <= 0)
150    runtime_error ("Rank of array needs to be > 0");
151
152  if (retarray->base_addr == NULL)
153    {
154      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
155      retarray->dtype.rank = 1;
156      retarray->offset = 0;
157      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
158    }
159  else
160    {
161      if (unlikely (compile_options.bounds_check))
162	{
163
164	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
165				  "u_name");
166	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
167				  "MASK argument", "u_name");
168	}
169    }
170
171  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
172
173  mbase = mask->base_addr;
174
175  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
176#ifdef HAVE_GFC_LOGICAL_16
177      || mask_kind == 16
178#endif
179      )
180    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
181  else
182    runtime_error ("Funny sized logical array");
183
184  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
185  dest = retarray->base_addr;
186  for (n = 0; n < rank; n++)
187    {
188      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
189      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
190      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
191      count[n] = 0;
192      if (extent[n] <= 0)
193	{
194	  /* Set the return value.  */
195	  for (n = 0; n < rank; n++)
196	    dest[n * dstride] = 0;
197	  return;
198	}
199    }
200
201  base = array->base_addr;
202
203  /* Initialize the return value.  */
204  for (n = 0; n < rank; n++)
205    dest[n * dstride] = 0;
206  {
207')dnl
208define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
209define(FINISH_MASKED_FOREACH_FUNCTION,
210`	  /* Implementation end.  */
211	  /* Advance to the next element.  */
212	  base += sstride[0];
213	  mbase += mstride[0];
214	}
215      while (++count[0] != extent[0]);
216      n = 0;
217      do
218	{
219	  /* When we get to the end of a dimension, reset it and increment
220	     the next dimension.  */
221	  count[n] = 0;
222	  /* We could precalculate these products, but this is a less
223	     frequently used path so probably not worth it.  */
224	  base -= sstride[n] * extent[n];
225	  mbase -= mstride[n] * extent[n];
226	  n++;
227	  if (n >= rank)
228	    {
229	      /* Break out of the loop.  */
230	      base = NULL;
231	      break;
232	    }
233	  else
234	    {
235	      count[n]++;
236	      base += sstride[n];
237	      mbase += mstride[n];
238	    }
239	}
240      while (count[n] == extent[n]);
241    }
242  }
243}')dnl
244define(FOREACH_FUNCTION,
245`START_FOREACH_FUNCTION
246$1
247START_FOREACH_BLOCK
248$2
249FINISH_FOREACH_FUNCTION')dnl
250define(MASKED_FOREACH_FUNCTION,
251`START_MASKED_FOREACH_FUNCTION
252$1
253START_MASKED_FOREACH_BLOCK
254$2
255FINISH_MASKED_FOREACH_FUNCTION')dnl
256define(SCALAR_FOREACH_FUNCTION,
257`
258extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
259	'atype` * const restrict, GFC_LOGICAL_4 *'back_arg`,
260	gfc_charlen_type len);
261export_proto(s'name`'rtype_qual`_'atype_code);
262
263void
264`s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
265	'atype` * const restrict array,
266	GFC_LOGICAL_4 * mask'back_arg`,
267	gfc_charlen_type len)
268{
269  index_type rank;
270  index_type dstride;
271  index_type n;
272  'rtype_name *dest;
273
274  if (mask == NULL || *mask)
275    {
276#ifdef HAVE_BACK_ARG
277      name`'rtype_qual`_'atype_code (retarray, array, back, len);
278#else
279      name`'rtype_qual`_'atype_code (retarray, array, len);
280#endif
281      return;
282    }
283
284  rank = GFC_DESCRIPTOR_RANK (array);
285
286  if (rank <= 0)
287    runtime_error ("Rank of array needs to be > 0");
288
289  if (retarray->base_addr == NULL)
290    {
291      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
292      retarray->dtype.rank = 1;
293      retarray->offset = 0;
294      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
295    }
296  else if (unlikely (compile_options.bounds_check))
297    {
298       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
299			       "u_name");
300    }
301
302  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
303  dest = retarray->base_addr;
304  for (n = 0; n<rank; n++)
305    dest[n * dstride] = $1 ;
306}')dnl
307