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.
5dnl
6dnl Pass the implementation for a single section as the parameter to
7dnl {MASK_}ARRAY_FUNCTION.
8dnl The variables base, delta, and len describe the input section.
9dnl For masked section the mask is described by mbase and mdelta.
10dnl These should not be modified. The result should be stored in *dest.
11dnl The names count, extent, sstride, dstride, base, dest, rank, dim
12dnl retarray, array, pdim and mstride should not be used.
13dnl The variable n is declared as index_type and may be used.
14dnl Other variable declarations may be placed at the start of the code,
15dnl The types of the array parameter and the return value are
16dnl atype_name and rtype_name respectively.
17dnl Execution should be allowed to continue to the end of the block.
18dnl You should not return or break from the inner loop of the implementation.
19dnl Care should also be taken to avoid using the names defined in iparm.m4
20define(START_ARRAY_FUNCTION,
21`#include <string.h>
22#include <assert.h>
23
24static inline int
25compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
26{
27  if (sizeof ('atype_name`) == 1)
28    return memcmp (a, b, n);
29  else
30    return memcmp_char4 (a, b, n);
31}
32
33extern void name`'rtype_qual`_'atype_code (rtype` * const restrict,
34	'atype` * const restrict, const index_type * const restrict 'back_arg`,
35	gfc_charlen_type);
36export_proto('name`'rtype_qual`_'atype_code`);
37
38void
39'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
40	'atype` * const restrict array,
41	const index_type * const restrict pdim'back_arg`,
42	gfc_charlen_type string_len)
43{
44  index_type count[GFC_MAX_DIMENSIONS];
45  index_type extent[GFC_MAX_DIMENSIONS];
46  index_type sstride[GFC_MAX_DIMENSIONS];
47  index_type dstride[GFC_MAX_DIMENSIONS];
48  const 'atype_name * restrict base;
49  rtype_name * restrict dest;
50  index_type rank;
51  index_type n;
52  index_type len;
53  index_type delta;
54  index_type dim;
55  int continue_loop;
56
57  /* Make dim zero based to avoid confusion.  */
58  rank = GFC_DESCRIPTOR_RANK (array) - 1;
59  dim = (*pdim) - 1;
60
61  if (unlikely (dim < 0 || dim > rank))
62    {
63      runtime_error ("Dim argument incorrect in u_name intrinsic: "
64 		     "is %ld, should be between 1 and %ld",
65		     (long int) dim + 1, (long int) rank + 1);
66    }
67
68  len = GFC_DESCRIPTOR_EXTENT(array,dim);
69  if (len < 0)
70    len = 0;
71  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
72
73  for (n = 0; n < dim; n++)
74    {
75      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
76      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
77
78      if (extent[n] < 0)
79	extent[n] = 0;
80    }
81  for (n = dim; n < rank; n++)
82    {
83      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
84      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
85
86      if (extent[n] < 0)
87	extent[n] = 0;
88    }
89
90  if (retarray->base_addr == NULL)
91    {
92      size_t alloc_size, str;
93
94      for (n = 0; n < rank; n++)
95	{
96	  if (n == 0)
97	    str = 1;
98	  else
99	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
100
101	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
102
103	}
104
105      retarray->offset = 0;
106      retarray->dtype.rank = rank;
107
108      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
109
110      retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
111      if (alloc_size == 0)
112	{
113	  /* Make sure we have a zero-sized array.  */
114	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
115	  return;
116
117	}
118    }
119  else
120    {
121      if (rank != GFC_DESCRIPTOR_RANK (retarray))
122	runtime_error ("rank of return array incorrect in"
123		       " u_name intrinsic: is %ld, should be %ld",
124		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
125		       (long int) rank);
126
127      if (unlikely (compile_options.bounds_check))
128	bounds_ifunction_return ((array_t *) retarray, extent,
129				 "return value", "u_name");
130    }
131
132  for (n = 0; n < rank; n++)
133    {
134      count[n] = 0;
135      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
136      if (extent[n] <= 0)
137	return;
138    }
139
140  base = array->base_addr;
141  dest = retarray->base_addr;
142
143  continue_loop = 1;
144  while (continue_loop)
145    {
146      const atype_name * restrict src;
147      rtype_name result;
148      src = base;
149      {
150')dnl
151define(START_ARRAY_BLOCK,
152`	if (len <= 0)
153	  *dest = '$1`;
154	else
155	  {
156	    for (n = 0; n < len; n++, src += delta)
157	      {
158')dnl
159define(FINISH_ARRAY_FUNCTION,
160`	      }
161	    '$1`
162	    *dest = result;
163	  }
164      }
165      /* Advance to the next element.  */
166      count[0]++;
167      base += sstride[0];
168      dest += dstride[0];
169      n = 0;
170      while (count[n] == extent[n])
171	{
172	  /* When we get to the end of a dimension, reset it and increment
173	     the next dimension.  */
174	  count[n] = 0;
175	  /* We could precalculate these products, but this is a less
176	     frequently used path so probably not worth it.  */
177	  base -= sstride[n] * extent[n];
178	  dest -= dstride[n] * extent[n];
179	  n++;
180	  if (n >= rank)
181	    {
182	      /* Break out of the loop.  */
183	      continue_loop = 0;
184	      break;
185	    }
186	  else
187	    {
188	      count[n]++;
189	      base += sstride[n];
190	      dest += dstride[n];
191	    }
192	}
193    }
194}')dnl
195define(START_MASKED_ARRAY_FUNCTION,
196`
197extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
198	'atype` * const restrict, const index_type * const restrict,
199	gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
200export_proto(m'name`'rtype_qual`_'atype_code`);
201
202void
203m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
204	'atype` * const restrict array,
205	const index_type * const restrict pdim,
206	gfc_array_l1 * const restrict mask'back_arg`,
207	gfc_charlen_type string_len)
208{
209  index_type count[GFC_MAX_DIMENSIONS];
210  index_type extent[GFC_MAX_DIMENSIONS];
211  index_type sstride[GFC_MAX_DIMENSIONS];
212  index_type dstride[GFC_MAX_DIMENSIONS];
213  index_type mstride[GFC_MAX_DIMENSIONS];
214  'rtype_name * restrict dest;
215  const atype_name * restrict base;
216  const GFC_LOGICAL_1 * restrict mbase;
217  index_type rank;
218  index_type dim;
219  index_type n;
220  index_type len;
221  index_type delta;
222  index_type mdelta;
223  int mask_kind;
224
225  if (mask == NULL)
226    {
227#ifdef HAVE_BACK_ARG
228      name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
229#else
230      name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
231#endif
232      return;
233    }
234
235  dim = (*pdim) - 1;
236  rank = GFC_DESCRIPTOR_RANK (array) - 1;
237
238
239  if (unlikely (dim < 0 || dim > rank))
240    {
241      runtime_error ("Dim argument incorrect in u_name intrinsic: "
242 		     "is %ld, should be between 1 and %ld",
243		     (long int) dim + 1, (long int) rank + 1);
244    }
245
246  len = GFC_DESCRIPTOR_EXTENT(array,dim);
247  if (len <= 0)
248    return;
249
250  mbase = mask->base_addr;
251
252  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
253
254  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
255#ifdef HAVE_GFC_LOGICAL_16
256      || mask_kind == 16
257#endif
258      )
259    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
260  else
261    runtime_error ("Funny sized logical array");
262
263  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
264  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
265
266  for (n = 0; n < dim; n++)
267    {
268      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
269      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
270      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
271
272      if (extent[n] < 0)
273	extent[n] = 0;
274
275    }
276  for (n = dim; n < rank; n++)
277    {
278      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
279      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
280      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
281
282      if (extent[n] < 0)
283	extent[n] = 0;
284    }
285
286  if (retarray->base_addr == NULL)
287    {
288      size_t alloc_size, str;
289
290      for (n = 0; n < rank; n++)
291	{
292	  if (n == 0)
293	    str = 1;
294	  else
295	    str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
296
297	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
298
299	}
300
301      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
302
303      retarray->offset = 0;
304      retarray->dtype.rank = rank;
305
306      if (alloc_size == 0)
307	{
308	  /* Make sure we have a zero-sized array.  */
309	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
310	  return;
311	}
312      else
313	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
314
315    }
316  else
317    {
318      if (rank != GFC_DESCRIPTOR_RANK (retarray))
319	runtime_error ("rank of return array incorrect in u_name intrinsic");
320
321      if (unlikely (compile_options.bounds_check))
322	{
323	  bounds_ifunction_return ((array_t *) retarray, extent,
324				   "return value", "u_name");
325	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
326	  			"MASK argument", "u_name");
327	}
328    }
329
330  for (n = 0; n < rank; n++)
331    {
332      count[n] = 0;
333      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
334      if (extent[n] <= 0)
335	return;
336    }
337
338  dest = retarray->base_addr;
339  base = array->base_addr;
340
341  while (base)
342    {
343      const atype_name * restrict src;
344      const GFC_LOGICAL_1 * restrict msrc;
345      rtype_name result;
346      src = base;
347      msrc = mbase;
348      {
349')dnl
350define(START_MASKED_ARRAY_BLOCK,
351`	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
352	  {
353')dnl
354define(FINISH_MASKED_ARRAY_FUNCTION,
355`	  }
356	*dest = result;
357      }
358      /* Advance to the next element.  */
359      count[0]++;
360      base += sstride[0];
361      mbase += mstride[0];
362      dest += dstride[0];
363      n = 0;
364      while (count[n] == extent[n])
365	{
366	  /* When we get to the end of a dimension, reset it and increment
367	     the next dimension.  */
368	  count[n] = 0;
369	  /* We could precalculate these products, but this is a less
370	     frequently used path so probably not worth it.  */
371	  base -= sstride[n] * extent[n];
372	  mbase -= mstride[n] * extent[n];
373	  dest -= dstride[n] * extent[n];
374	  n++;
375	  if (n >= rank)
376	    {
377	      /* Break out of the loop.  */
378	      base = NULL;
379	      break;
380	    }
381	  else
382	    {
383	      count[n]++;
384	      base += sstride[n];
385	      mbase += mstride[n];
386	      dest += dstride[n];
387	    }
388	}
389    }
390}')dnl
391define(SCALAR_ARRAY_FUNCTION,
392`
393extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
394	'atype` * const restrict, const index_type * const restrict,
395	GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
396export_proto(s'name`'rtype_qual`_'atype_code`);
397
398void
399s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
400	'atype` * const restrict array,
401	const index_type * const restrict pdim,
402	GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
403{
404  index_type count[GFC_MAX_DIMENSIONS];
405  index_type extent[GFC_MAX_DIMENSIONS];
406  index_type dstride[GFC_MAX_DIMENSIONS];
407  'rtype_name * restrict dest;
408  index_type rank;
409  index_type n;
410  index_type dim;
411
412
413  if (mask == NULL || *mask)
414    {
415#ifdef HAVE_BACK_ARG
416      name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
417#else
418      name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
419#endif
420      return;
421    }
422  /* Make dim zero based to avoid confusion.  */
423  dim = (*pdim) - 1;
424  rank = GFC_DESCRIPTOR_RANK (array) - 1;
425
426  if (unlikely (dim < 0 || dim > rank))
427    {
428      runtime_error ("Dim argument incorrect in u_name intrinsic: "
429 		     "is %ld, should be between 1 and %ld",
430		     (long int) dim + 1, (long int) rank + 1);
431    }
432
433  for (n = 0; n < dim; n++)
434    {
435      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
436
437      if (extent[n] <= 0)
438	extent[n] = 0;
439    }
440
441  for (n = dim; n < rank; n++)
442    {
443      extent[n] =
444	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
445
446      if (extent[n] <= 0)
447	extent[n] = 0;
448    }
449
450  if (retarray->base_addr == NULL)
451    {
452      size_t alloc_size, str;
453
454      for (n = 0; n < rank; n++)
455	{
456	  if (n == 0)
457	    str = 1;
458	  else
459	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
460
461	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
462
463	}
464
465      retarray->offset = 0;
466      retarray->dtype.rank = rank;
467
468      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
469
470      if (alloc_size == 0)
471	{
472	  /* Make sure we have a zero-sized array.  */
473	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
474	  return;
475	}
476      else
477	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
478    }
479  else
480    {
481      if (rank != GFC_DESCRIPTOR_RANK (retarray))
482	runtime_error ("rank of return array incorrect in"
483		       " u_name intrinsic: is %ld, should be %ld",
484		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
485		       (long int) rank);
486
487      if (unlikely (compile_options.bounds_check))
488	{
489	  for (n=0; n < rank; n++)
490	    {
491	      index_type ret_extent;
492
493	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
494	      if (extent[n] != ret_extent)
495		runtime_error ("Incorrect extent in return value of"
496			       " u_name intrinsic in dimension %ld:"
497			       " is %ld, should be %ld", (long int) n + 1,
498			       (long int) ret_extent, (long int) extent[n]);
499	    }
500	}
501    }
502
503  for (n = 0; n < rank; n++)
504    {
505      count[n] = 0;
506      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
507    }
508
509  dest = retarray->base_addr;
510
511  while(1)
512    {
513      *dest = '$1`;
514      count[0]++;
515      dest += dstride[0];
516      n = 0;
517      while (count[n] == extent[n])
518	{
519	  /* When we get to the end of a dimension, reset it and increment
520	     the next dimension.  */
521	  count[n] = 0;
522	  /* We could precalculate these products, but this is a less
523	     frequently used path so probably not worth it.  */
524	  dest -= dstride[n] * extent[n];
525	  n++;
526	  if (n >= rank)
527	    return;
528	  else
529	    {
530	      count[n]++;
531	      dest += dstride[n];
532	    }
533      	}
534    }
535}')dnl
536define(ARRAY_FUNCTION,
537`START_ARRAY_FUNCTION
538$2
539START_ARRAY_BLOCK($1)
540$3
541FINISH_ARRAY_FUNCTION($4)')dnl
542define(MASKED_ARRAY_FUNCTION,
543`START_MASKED_ARRAY_FUNCTION
544$2
545START_MASKED_ARRAY_BLOCK
546$3
547FINISH_MASKED_ARRAY_FUNCTION')dnl
548