1 dnl Support macro file for intrinsic functions.
2 dnl Contains the generic sections of the array functions.
3 dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
4 dnl Distributed under the GNU GPL with exception. See COPYING for details.
6 dnl Pass the implementation for a single section as the parameter to
7 dnl {MASK_}ARRAY_FUNCTION.
8 dnl The variables base, delta, and len describe the input section.
9 dnl For masked section the mask is described by mbase and mdelta.
10 dnl These should not be modified. The result should be stored in *dest.
11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim
12 dnl retarray, array, pdim and mstride should not be used.
13 dnl The variable n is declared as index_type and may be used.
14 dnl Other variable declarations may be placed at the start of the code,
15 dnl The types of the array parameter and the return value are
16 dnl atype_name and rtype_name respectively.
17 dnl Execution should be allowed to continue to the end of the block.
18 dnl You should not return or break from the inner loop of the implementation.
19 dnl Care should also be taken to avoid using the names defined in iparm.m4
20 define(START_ARRAY_FUNCTION,
22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
23 atype` * const restrict, const 'index_type` * const restrict'back_arg`);
24 export_proto('name`'rtype_qual`_'atype_code);
27 name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
28 'atype` * const restrict array,
29 const index_type * const restrict pdim'back_arg`)
31 index_type count[GFC_MAX_DIMENSIONS];
32 index_type extent[GFC_MAX_DIMENSIONS];
33 index_type sstride[GFC_MAX_DIMENSIONS];
34 index_type dstride[GFC_MAX_DIMENSIONS];
35 const 'atype_name * restrict base;
36 rtype_name * restrict dest;
44 /* Make dim zero based to avoid confusion. */
45 rank = GFC_DESCRIPTOR_RANK (array) - 1;
48 if (unlikely (dim < 0 || dim > rank))
50 runtime_error ("Dim argument incorrect in u_name intrinsic: "
51 "is %ld, should be between 1 and %ld",
52 (long int) dim + 1, (long int) rank + 1);
55 len = GFC_DESCRIPTOR_EXTENT(array,dim);
58 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
60 for (n = 0; n < dim; n++)
62 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
63 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
68 for (n = dim; n < rank; n++)
70 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
71 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
77 if (retarray->base_addr == NULL)
79 size_t alloc_size, str;
81 for (n = 0; n < rank; n++)
86 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
88 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
93 retarray->dtype.rank = rank;
95 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
97 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
103 if (rank != GFC_DESCRIPTOR_RANK (retarray))
104 runtime_error ("rank of return array incorrect in"
105 " u_name intrinsic: is %ld, should be %ld",
106 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
109 if (unlikely (compile_options.bounds_check))
110 bounds_ifunction_return ((array_t *) retarray, extent,
111 "return value", "u_name");
114 for (n = 0; n < rank; n++)
117 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
122 base = array->base_addr;
123 dest = retarray->base_addr;
126 while (continue_loop)
128 const atype_name * restrict src;
133 define(START_ARRAY_BLOCK,
138 #if ! defined HAVE_BACK_ARG
139 for (n = 0; n < len; n++, src += delta)
143 define(FINISH_ARRAY_FUNCTION,
149 /* Advance to the next element. */
154 while (count[n] == extent[n])
156 /* When we get to the end of a dimension, reset it and increment
157 the next dimension. */
159 /* We could precalculate these products, but this is a less
160 frequently used path so probably not worth it. */
161 base -= sstride[n] * extent[n];
162 dest -= dstride[n] * extent[n];
166 /* Break out of the loop. */
179 define(START_MASKED_ARRAY_FUNCTION,
181 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
182 'atype` * const restrict, const 'index_type` * const restrict,
183 gfc_array_l1 * const restrict'back_arg`);
184 export_proto(m'name`'rtype_qual`_'atype_code`);
187 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
188 'atype` * const restrict array,
189 const index_type * const restrict pdim,
190 gfc_array_l1 * const restrict mask'back_arg`)
192 index_type count[GFC_MAX_DIMENSIONS];
193 index_type extent[GFC_MAX_DIMENSIONS];
194 index_type sstride[GFC_MAX_DIMENSIONS];
195 index_type dstride[GFC_MAX_DIMENSIONS];
196 index_type mstride[GFC_MAX_DIMENSIONS];
197 'rtype_name * restrict dest;
198 const atype_name * restrict base;
199 const GFC_LOGICAL_1 * restrict mbase;
211 name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
213 name`'rtype_qual`_'atype_code (retarray, array, pdim);
219 rank = GFC_DESCRIPTOR_RANK (array) - 1;
222 if (unlikely (dim < 0 || dim > rank))
224 runtime_error ("Dim argument incorrect in u_name intrinsic: "
225 "is %ld, should be between 1 and %ld",
226 (long int) dim + 1, (long int) rank + 1);
229 len = GFC_DESCRIPTOR_EXTENT(array,dim);
233 mbase = mask->base_addr;
235 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
237 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
238 #ifdef HAVE_GFC_LOGICAL_16
242 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
244 runtime_error ("Funny sized logical array");
246 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
247 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
249 for (n = 0; n < dim; n++)
251 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
252 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
253 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
259 for (n = dim; n < rank; n++)
261 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
262 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
263 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
269 if (retarray->base_addr == NULL)
271 size_t alloc_size, str;
273 for (n = 0; n < rank; n++)
278 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
280 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
284 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
286 retarray->offset = 0;
287 retarray->dtype.rank = rank;
289 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
295 if (rank != GFC_DESCRIPTOR_RANK (retarray))
296 runtime_error ("rank of return array incorrect in u_name intrinsic");
298 if (unlikely (compile_options.bounds_check))
300 bounds_ifunction_return ((array_t *) retarray, extent,
301 "return value", "u_name");
302 bounds_equal_extents ((array_t *) mask, (array_t *) array,
303 "MASK argument", "u_name");
307 for (n = 0; n < rank; n++)
310 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
315 dest = retarray->base_addr;
316 base = array->base_addr;
320 const atype_name * restrict src;
321 const GFC_LOGICAL_1 * restrict msrc;
327 define(START_MASKED_ARRAY_BLOCK,
328 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
331 define(FINISH_MASKED_ARRAY_FUNCTION,
335 /* Advance to the next element. */
341 while (count[n] == extent[n])
343 /* When we get to the end of a dimension, reset it and increment
344 the next dimension. */
346 /* We could precalculate these products, but this is a less
347 frequently used path so probably not worth it. */
348 base -= sstride[n] * extent[n];
349 mbase -= mstride[n] * extent[n];
350 dest -= dstride[n] * extent[n];
354 /* Break out of the loop. */
368 define(SCALAR_ARRAY_FUNCTION,
370 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
371 'atype` * const restrict, const index_type * const restrict,
372 GFC_LOGICAL_4 *'back_arg`);
373 export_proto(s'name`'rtype_qual`_'atype_code);
376 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
377 'atype` * const restrict array,
378 const index_type * const restrict pdim,
379 GFC_LOGICAL_4 * mask'back_arg`)
381 index_type count[GFC_MAX_DIMENSIONS];
382 index_type extent[GFC_MAX_DIMENSIONS];
383 index_type dstride[GFC_MAX_DIMENSIONS];
384 'rtype_name * restrict dest;
390 if (mask == NULL || *mask)
393 name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
395 name`'rtype_qual`_'atype_code (retarray, array, pdim);
399 /* Make dim zero based to avoid confusion. */
401 rank = GFC_DESCRIPTOR_RANK (array) - 1;
403 if (unlikely (dim < 0 || dim > rank))
405 runtime_error ("Dim argument incorrect in u_name intrinsic: "
406 "is %ld, should be between 1 and %ld",
407 (long int) dim + 1, (long int) rank + 1);
410 for (n = 0; n < dim; n++)
412 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
418 for (n = dim; n < rank; n++)
421 GFC_DESCRIPTOR_EXTENT(array,n + 1);
427 if (retarray->base_addr == NULL)
429 size_t alloc_size, str;
431 for (n = 0; n < rank; n++)
436 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
438 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
442 retarray->offset = 0;
443 retarray->dtype.rank = rank;
445 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
447 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
453 if (rank != GFC_DESCRIPTOR_RANK (retarray))
454 runtime_error ("rank of return array incorrect in"
455 " u_name intrinsic: is %ld, should be %ld",
456 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
459 if (unlikely (compile_options.bounds_check))
461 for (n=0; n < rank; n++)
463 index_type ret_extent;
465 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
466 if (extent[n] != ret_extent)
467 runtime_error ("Incorrect extent in return value of"
468 " u_name intrinsic in dimension %ld:"
469 " is %ld, should be %ld", (long int) n + 1,
470 (long int) ret_extent, (long int) extent[n]);
475 for (n = 0; n < rank; n++)
478 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
481 dest = retarray->base_addr;
489 while (count[n] == extent[n])
491 /* When we get to the end of a dimension, reset it and increment
492 the next dimension. */
494 /* We could precalculate these products, but this is a less
495 frequently used path so probably not worth it. */
496 dest -= dstride[n] * extent[n];
508 define(ARRAY_FUNCTION,
509 `START_ARRAY_FUNCTION
511 START_ARRAY_BLOCK($1)
513 FINISH_ARRAY_FUNCTION($4)')dnl
514 define(MASKED_ARRAY_FUNCTION,
515 `START_MASKED_ARRAY_FUNCTION
517 START_MASKED_ARRAY_BLOCK
519 FINISH_MASKED_ARRAY_FUNCTION')dnl