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;
48 /* Make dim zero based to avoid confusion. */
49 rank = GFC_DESCRIPTOR_RANK (array) - 1;
52 if (unlikely (dim < 0 || dim > rank))
54 runtime_error ("Dim argument incorrect in u_name intrinsic: "
55 "is %ld, should be between 1 and %ld",
56 (long int) dim + 1, (long int) rank + 1);
59 len = GFC_DESCRIPTOR_EXTENT(array,dim);
62 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
64 for (n = 0; n < dim; n++)
66 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
67 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
72 for (n = dim; n < rank; n++)
74 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
75 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
81 if (retarray->base_addr == NULL)
83 size_t alloc_size, str;
85 for (n = 0; n < rank; n++)
90 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
92 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
97 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
99 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
101 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
104 /* Make sure we have a zero-sized array. */
105 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
112 if (rank != GFC_DESCRIPTOR_RANK (retarray))
113 runtime_error ("rank of return array incorrect in"
114 " u_name intrinsic: is %ld, should be %ld",
115 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
118 if (unlikely (compile_options.bounds_check))
119 bounds_ifunction_return ((array_t *) retarray, extent,
120 "return value", "u_name");
123 for (n = 0; n < rank; n++)
126 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
131 base = array->base_addr;
132 dest = retarray->base_addr;
135 while (continue_loop)
137 const atype_name * restrict src;
142 define(START_ARRAY_BLOCK,
147 for (n = 0; n < len; n++, src += delta)
150 define(FINISH_ARRAY_FUNCTION,
156 /* Advance to the next element. */
161 while (count[n] == extent[n])
163 /* When we get to the end of a dimension, reset it and increment
164 the next dimension. */
166 /* We could precalculate these products, but this is a less
167 frequently used path so probably not worth it. */
168 base -= sstride[n] * extent[n];
169 dest -= dstride[n] * extent[n];
173 /* Break out of the loop. */
186 define(START_MASKED_ARRAY_FUNCTION,
188 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
189 'atype` * const restrict, const 'index_type` * const restrict,
190 gfc_array_l1 * const restrict'back_arg`);
191 export_proto(m'name`'rtype_qual`_'atype_code`);
194 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
195 'atype` * const restrict array,
196 const index_type * const restrict pdim,
197 gfc_array_l1 * const restrict mask'back_arg`)
199 index_type count[GFC_MAX_DIMENSIONS];
200 index_type extent[GFC_MAX_DIMENSIONS];
201 index_type sstride[GFC_MAX_DIMENSIONS];
202 index_type dstride[GFC_MAX_DIMENSIONS];
203 index_type mstride[GFC_MAX_DIMENSIONS];
204 'rtype_name * restrict dest;
205 const atype_name * restrict base;
206 const GFC_LOGICAL_1 * restrict mbase;
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 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
291 /* Make sure we have a zero-sized array. */
292 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
296 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
301 if (rank != GFC_DESCRIPTOR_RANK (retarray))
302 runtime_error ("rank of return array incorrect in u_name intrinsic");
304 if (unlikely (compile_options.bounds_check))
306 bounds_ifunction_return ((array_t *) retarray, extent,
307 "return value", "u_name");
308 bounds_equal_extents ((array_t *) mask, (array_t *) array,
309 "MASK argument", "u_name");
313 for (n = 0; n < rank; n++)
316 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
321 dest = retarray->base_addr;
322 base = array->base_addr;
326 const atype_name * restrict src;
327 const GFC_LOGICAL_1 * restrict msrc;
333 define(START_MASKED_ARRAY_BLOCK,
334 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
337 define(FINISH_MASKED_ARRAY_FUNCTION,
341 /* Advance to the next element. */
347 while (count[n] == extent[n])
349 /* When we get to the end of a dimension, reset it and increment
350 the next dimension. */
352 /* We could precalculate these products, but this is a less
353 frequently used path so probably not worth it. */
354 base -= sstride[n] * extent[n];
355 mbase -= mstride[n] * extent[n];
356 dest -= dstride[n] * extent[n];
360 /* Break out of the loop. */
374 define(SCALAR_ARRAY_FUNCTION,
376 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
377 'atype` * const restrict, const index_type * const restrict,
378 GFC_LOGICAL_4 *'back_arg`);
379 export_proto(s'name`'rtype_qual`_'atype_code);
382 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
383 'atype` * const restrict array,
384 const index_type * const restrict pdim,
385 GFC_LOGICAL_4 * mask'back_arg`)
387 index_type count[GFC_MAX_DIMENSIONS];
388 index_type extent[GFC_MAX_DIMENSIONS];
389 index_type dstride[GFC_MAX_DIMENSIONS];
390 'rtype_name * restrict dest;
399 name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
401 name`'rtype_qual`_'atype_code (retarray, array, pdim);
405 /* Make dim zero based to avoid confusion. */
407 rank = GFC_DESCRIPTOR_RANK (array) - 1;
409 if (unlikely (dim < 0 || dim > rank))
411 runtime_error ("Dim argument incorrect in u_name intrinsic: "
412 "is %ld, should be between 1 and %ld",
413 (long int) dim + 1, (long int) rank + 1);
416 for (n = 0; n < dim; n++)
418 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
424 for (n = dim; n < rank; n++)
427 GFC_DESCRIPTOR_EXTENT(array,n + 1);
433 if (retarray->base_addr == NULL)
435 size_t alloc_size, str;
437 for (n = 0; n < rank; n++)
442 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
444 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
448 retarray->offset = 0;
449 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
451 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
455 /* Make sure we have a zero-sized array. */
456 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
460 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
464 if (rank != GFC_DESCRIPTOR_RANK (retarray))
465 runtime_error ("rank of return array incorrect in"
466 " u_name intrinsic: is %ld, should be %ld",
467 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
470 if (unlikely (compile_options.bounds_check))
472 for (n=0; n < rank; n++)
474 index_type ret_extent;
476 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
477 if (extent[n] != ret_extent)
478 runtime_error ("Incorrect extent in return value of"
479 " u_name intrinsic in dimension %ld:"
480 " is %ld, should be %ld", (long int) n + 1,
481 (long int) ret_extent, (long int) extent[n]);
486 for (n = 0; n < rank; n++)
489 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
492 dest = retarray->base_addr;
500 while (count[n] == extent[n])
502 /* When we get to the end of a dimension, reset it and increment
503 the next dimension. */
505 /* We could precalculate these products, but this is a less
506 frequently used path so probably not worth it. */
507 dest -= dstride[n] * extent[n];
519 define(ARRAY_FUNCTION,
520 `START_ARRAY_FUNCTION
522 START_ARRAY_BLOCK($1)
524 FINISH_ARRAY_FUNCTION($4)')dnl
525 define(MASKED_ARRAY_FUNCTION,
526 `START_MASKED_ARRAY_FUNCTION
528 START_MASKED_ARRAY_BLOCK
530 FINISH_MASKED_ARRAY_FUNCTION')dnl