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        gfc_charlen_type, atype * const restrict,
35	const index_type * const restrict, gfc_charlen_type);
36export_proto(name`'rtype_qual`_'atype_code);
37
38void
39name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
40	gfc_charlen_type xlen, atype * const restrict array,
41	const index_type * const restrict pdim, gfc_charlen_type string_len)
42{
43  index_type count[GFC_MAX_DIMENSIONS];
44  index_type extent[GFC_MAX_DIMENSIONS];
45  index_type sstride[GFC_MAX_DIMENSIONS];
46  index_type dstride[GFC_MAX_DIMENSIONS];
47  const atype_name * restrict base;
48  rtype_name * restrict dest;
49  index_type rank;
50  index_type n;
51  index_type len;
52  index_type delta;
53  index_type dim;
54  int continue_loop;
55
56  assert (xlen == string_len);
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
72  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
73
74  for (n = 0; n < dim; n++)
75    {
76      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
77      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
78
79      if (extent[n] < 0)
80	extent[n] = 0;
81    }
82  for (n = dim; n < rank; n++)
83    {
84      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
85      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
86
87      if (extent[n] < 0)
88	extent[n] = 0;
89    }
90
91  if (retarray->base_addr == NULL)
92    {
93      size_t alloc_size, str;
94
95      for (n = 0; n < rank; n++)
96	{
97	  if (n == 0)
98	    str = 1;
99	  else
100	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
101
102	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
103
104	}
105
106      retarray->offset = 0;
107      retarray->dtype.rank = rank;
108
109      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
110      		 * string_len;
111
112      retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
113      if (alloc_size == 0)
114	{
115	  /* Make sure we have a zero-sized array.  */
116	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
117	  return;
118
119	}
120    }
121  else
122    {
123      if (rank != GFC_DESCRIPTOR_RANK (retarray))
124	runtime_error ("rank of return array incorrect in"
125		       " u_name intrinsic: is %ld, should be %ld",
126		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
127		       (long int) rank);
128
129      if (unlikely (compile_options.bounds_check))
130	bounds_ifunction_return ((array_t *) retarray, extent,
131				 "return value", "u_name");
132    }
133
134  for (n = 0; n < rank; n++)
135    {
136      count[n] = 0;
137      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
138      if (extent[n] <= 0)
139	return;
140    }
141
142  base = array->base_addr;
143  dest = retarray->base_addr;
144
145  continue_loop = 1;
146  while (continue_loop)
147    {
148      const atype_name * restrict src;
149      src = base;
150      {
151')dnl
152define(START_ARRAY_BLOCK,
153`	if (len <= 0)
154	  memset (dest, '$1`, sizeof (*dest) * string_len);
155	else
156	  {
157	    for (n = 0; n < len; n++, src += delta)
158	      {
159')dnl
160define(FINISH_ARRAY_FUNCTION,
161`	      }
162	    '$1`
163	    memcpy (dest, retval, sizeof (*dest) * string_len);
164	  }
165      }
166      /* Advance to the next element.  */
167      count[0]++;
168      base += sstride[0];
169      dest += dstride[0];
170      n = 0;
171      while (count[n] == extent[n])
172	{
173	  /* When we get to the end of a dimension, reset it and increment
174	     the next dimension.  */
175	  count[n] = 0;
176	  /* We could precalculate these products, but this is a less
177	     frequently used path so probably not worth it.  */
178	  base -= sstride[n] * extent[n];
179	  dest -= dstride[n] * extent[n];
180	  n++;
181	  if (n >= rank)
182	    {
183	      /* Break out of the loop.  */
184	      continue_loop = 0;
185	      break;
186	    }
187	  else
188	    {
189	      count[n]++;
190	      base += sstride[n];
191	      dest += dstride[n];
192	    }
193	}
194    }
195}')dnl
196define(START_MASKED_ARRAY_FUNCTION,
197`
198extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
199        gfc_charlen_type, atype * const restrict,
200	const index_type * const restrict,
201	gfc_array_l1 * const restrict, gfc_charlen_type);
202export_proto(`m'name`'rtype_qual`_'atype_code);
203
204void
205`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
206	gfc_charlen_type xlen, atype * const restrict array,
207	const index_type * const restrict pdim,
208	gfc_array_l1 * const restrict mask,
209	gfc_charlen_type string_len)
210
211{
212  index_type count[GFC_MAX_DIMENSIONS];
213  index_type extent[GFC_MAX_DIMENSIONS];
214  index_type sstride[GFC_MAX_DIMENSIONS];
215  index_type dstride[GFC_MAX_DIMENSIONS];
216  index_type mstride[GFC_MAX_DIMENSIONS];
217  rtype_name * restrict dest;
218  const atype_name * restrict base;
219  const GFC_LOGICAL_1 * restrict mbase;
220  index_type rank;
221  index_type dim;
222  index_type n;
223  index_type len;
224  index_type delta;
225  index_type mdelta;
226  int mask_kind;
227
228  if (mask == NULL)
229    {
230      name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len);
231      return;
232    }
233
234  assert (xlen == string_len);
235
236  dim = (*pdim) - 1;
237  rank = GFC_DESCRIPTOR_RANK (array) - 1;
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      		 * string_len;
303
304      retarray->offset = 0;
305      retarray->dtype.rank = rank;
306
307      if (alloc_size == 0)
308	{
309	  /* Make sure we have a zero-sized array.  */
310	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
311	  return;
312	}
313      else
314	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
315
316    }
317  else
318    {
319      if (rank != GFC_DESCRIPTOR_RANK (retarray))
320	runtime_error ("rank of return array incorrect in u_name intrinsic");
321
322      if (unlikely (compile_options.bounds_check))
323	{
324	  bounds_ifunction_return ((array_t *) retarray, extent,
325				   "return value", "u_name");
326	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
327	  			"MASK argument", "u_name");
328	}
329    }
330
331  for (n = 0; n < rank; n++)
332    {
333      count[n] = 0;
334      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
335      if (extent[n] <= 0)
336	return;
337    }
338
339  dest = retarray->base_addr;
340  base = array->base_addr;
341
342  while (base)
343    {
344      const atype_name * restrict src;
345      const GFC_LOGICAL_1 * restrict msrc;
346
347      src = base;
348      msrc = mbase;
349      {
350')dnl
351define(START_MASKED_ARRAY_BLOCK,
352`	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
353	  {
354')dnl
355define(FINISH_MASKED_ARRAY_FUNCTION,
356`	  }
357	memcpy (dest, retval, sizeof (*dest) * string_len);
358      }
359      /* Advance to the next element.  */
360      count[0]++;
361      base += sstride[0];
362      mbase += mstride[0];
363      dest += dstride[0];
364      n = 0;
365      while (count[n] == extent[n])
366	{
367	  /* When we get to the end of a dimension, reset it and increment
368	     the next dimension.  */
369	  count[n] = 0;
370	  /* We could precalculate these products, but this is a less
371	     frequently used path so probably not worth it.  */
372	  base -= sstride[n] * extent[n];
373	  mbase -= mstride[n] * extent[n];
374	  dest -= dstride[n] * extent[n];
375	  n++;
376	  if (n >= rank)
377	    {
378	      /* Break out of the loop.  */
379	      base = NULL;
380	      break;
381	    }
382	  else
383	    {
384	      count[n]++;
385	      base += sstride[n];
386	      mbase += mstride[n];
387	      dest += dstride[n];
388	    }
389	}
390    }
391}')dnl
392define(SCALAR_ARRAY_FUNCTION,
393`
394void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
395        gfc_charlen_type, atype * const restrict,
396	const index_type * const restrict,
397	GFC_LOGICAL_4 *, gfc_charlen_type);
398
399export_proto(`s'name`'rtype_qual`_'atype_code);
400
401void
402`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
403	gfc_charlen_type xlen, atype * const restrict array,
404	const index_type * const restrict pdim,
405	GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
406
407{
408  index_type count[GFC_MAX_DIMENSIONS];
409  index_type extent[GFC_MAX_DIMENSIONS];
410  index_type dstride[GFC_MAX_DIMENSIONS];
411  rtype_name * restrict dest;
412  index_type rank;
413  index_type n;
414  index_type dim;
415
416
417  if (mask == NULL || *mask)
418    {
419      name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len);
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);
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);
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      		 * string_len;
470
471      if (alloc_size == 0)
472	{
473	  /* Make sure we have a zero-sized array.  */
474	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
475	  return;
476	}
477      else
478	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
479    }
480  else
481    {
482      if (rank != GFC_DESCRIPTOR_RANK (retarray))
483	runtime_error ("rank of return array incorrect in"
484		       " u_name intrinsic: is %ld, should be %ld",
485		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
486		       (long int) rank);
487
488      if (unlikely (compile_options.bounds_check))
489	{
490	  for (n=0; n < rank; n++)
491	    {
492	      index_type ret_extent;
493
494	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
495	      if (extent[n] != ret_extent)
496		runtime_error ("Incorrect extent in return value of"
497			       " u_name intrinsic in dimension %ld:"
498			       " is %ld, should be %ld", (long int) n + 1,
499			       (long int) ret_extent, (long int) extent[n]);
500	    }
501	}
502    }
503
504  for (n = 0; n < rank; n++)
505    {
506      count[n] = 0;
507      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
508    }
509
510  dest = retarray->base_addr;
511
512  while(1)
513    {
514      memset (dest, '$1`, sizeof (*dest) * string_len);
515      count[0]++;
516      dest += dstride[0];
517      n = 0;
518      while (count[n] == extent[n])
519	{
520	  /* When we get to the end of a dimension, reset it and increment
521	     the next dimension.  */
522	  count[n] = 0;
523	  /* We could precalculate these products, but this is a less
524	     frequently used path so probably not worth it.  */
525	  dest -= dstride[n] * extent[n];
526	  n++;
527	  if (n >= rank)
528	    return;
529	  else
530	    {
531	      count[n]++;
532	      dest += dstride[n];
533	    }
534      	}
535    }
536}')dnl
537define(ARRAY_FUNCTION,
538`START_ARRAY_FUNCTION($1)
539$2
540START_ARRAY_BLOCK($1)
541$3
542FINISH_ARRAY_FUNCTION($4)')dnl
543define(MASKED_ARRAY_FUNCTION,
544`START_MASKED_ARRAY_FUNCTION
545$2
546START_MASKED_ARRAY_BLOCK
547$3
548FINISH_MASKED_ARRAY_FUNCTION')dnl
549