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);
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)
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. */
46 rank = GFC_DESCRIPTOR_RANK (array) - 1;
48 len = GFC_DESCRIPTOR_EXTENT(array,dim);
51 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
53 for (n = 0; n < dim; n++)
55 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
56 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
61 for (n = dim; n < rank; n++)
63 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
64 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
70 if (retarray->data == NULL)
72 size_t alloc_size, str;
74 for (n = 0; n < rank; n++)
79 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
81 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
86 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
88 alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
93 /* Make sure we have a zero-sized array. */
94 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
99 retarray->data = internal_malloc_size (alloc_size);
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);
123 dest = retarray->data;
126 while (continue_loop)
128 const atype_name * restrict src;
133 define(START_ARRAY_BLOCK,
138 for (n = 0; n < len; n++, src += delta)
141 define(FINISH_ARRAY_FUNCTION,
147 /* Advance to the next element. */
152 while (count[n] == extent[n])
154 /* When we get to the end of a dimension, reset it and increment
155 the next dimension. */
157 /* We could precalculate these products, but this is a less
158 frequently used path so probably not worth it. */
159 base -= sstride[n] * extent[n];
160 dest -= dstride[n] * extent[n];
164 /* Break out of the look. */
177 define(START_MASKED_ARRAY_FUNCTION,
179 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
180 atype * const restrict, const index_type * const restrict,
181 gfc_array_l1 * const restrict);
182 export_proto(`m'name`'rtype_qual`_'atype_code);
185 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
186 atype * const restrict array,
187 const index_type * const restrict pdim,
188 gfc_array_l1 * const restrict mask)
190 index_type count[GFC_MAX_DIMENSIONS];
191 index_type extent[GFC_MAX_DIMENSIONS];
192 index_type sstride[GFC_MAX_DIMENSIONS];
193 index_type dstride[GFC_MAX_DIMENSIONS];
194 index_type mstride[GFC_MAX_DIMENSIONS];
195 rtype_name * restrict dest;
196 const atype_name * restrict base;
197 const GFC_LOGICAL_1 * restrict mbase;
207 rank = GFC_DESCRIPTOR_RANK (array) - 1;
209 len = GFC_DESCRIPTOR_EXTENT(array,dim);
215 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
217 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
218 #ifdef HAVE_GFC_LOGICAL_16
222 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
224 runtime_error ("Funny sized logical array");
226 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
227 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
229 for (n = 0; n < dim; n++)
231 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
232 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
233 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
239 for (n = dim; n < rank; n++)
241 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
242 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
243 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
249 if (retarray->data == NULL)
251 size_t alloc_size, str;
253 for (n = 0; n < rank; n++)
258 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
260 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
264 alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
267 retarray->offset = 0;
268 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
272 /* Make sure we have a zero-sized array. */
273 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
277 retarray->data = internal_malloc_size (alloc_size);
282 if (rank != GFC_DESCRIPTOR_RANK (retarray))
283 runtime_error ("rank of return array incorrect in u_name intrinsic");
285 if (unlikely (compile_options.bounds_check))
287 bounds_ifunction_return ((array_t *) retarray, extent,
288 "return value", "u_name");
289 bounds_equal_extents ((array_t *) mask, (array_t *) array,
290 "MASK argument", "u_name");
294 for (n = 0; n < rank; n++)
297 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
302 dest = retarray->data;
307 const atype_name * restrict src;
308 const GFC_LOGICAL_1 * restrict msrc;
314 define(START_MASKED_ARRAY_BLOCK,
319 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
322 define(FINISH_MASKED_ARRAY_FUNCTION,
327 /* Advance to the next element. */
333 while (count[n] == extent[n])
335 /* When we get to the end of a dimension, reset it and increment
336 the next dimension. */
338 /* We could precalculate these products, but this is a less
339 frequently used path so probably not worth it. */
340 base -= sstride[n] * extent[n];
341 mbase -= mstride[n] * extent[n];
342 dest -= dstride[n] * extent[n];
346 /* Break out of the look. */
360 define(SCALAR_ARRAY_FUNCTION,
362 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
363 atype * const restrict, const index_type * const restrict,
365 export_proto(`s'name`'rtype_qual`_'atype_code);
368 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
369 atype * const restrict array,
370 const index_type * const restrict pdim,
371 GFC_LOGICAL_4 * mask)
373 index_type count[GFC_MAX_DIMENSIONS];
374 index_type extent[GFC_MAX_DIMENSIONS];
375 index_type dstride[GFC_MAX_DIMENSIONS];
376 rtype_name * restrict dest;
384 name`'rtype_qual`_'atype_code (retarray, array, pdim);
387 /* Make dim zero based to avoid confusion. */
389 rank = GFC_DESCRIPTOR_RANK (array) - 1;
391 for (n = 0; n < dim; n++)
393 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
399 for (n = dim; n < rank; n++)
402 GFC_DESCRIPTOR_EXTENT(array,n + 1);
408 if (retarray->data == NULL)
410 size_t alloc_size, str;
412 for (n = 0; n < rank; n++)
417 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
419 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
423 retarray->offset = 0;
424 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
426 alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
431 /* Make sure we have a zero-sized array. */
432 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
436 retarray->data = internal_malloc_size (alloc_size);
440 if (rank != GFC_DESCRIPTOR_RANK (retarray))
441 runtime_error ("rank of return array incorrect in"
442 " u_name intrinsic: is %ld, should be %ld",
443 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
446 if (unlikely (compile_options.bounds_check))
448 for (n=0; n < rank; n++)
450 index_type ret_extent;
452 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
453 if (extent[n] != ret_extent)
454 runtime_error ("Incorrect extent in return value of"
455 " u_name intrinsic in dimension %ld:"
456 " is %ld, should be %ld", (long int) n + 1,
457 (long int) ret_extent, (long int) extent[n]);
462 for (n = 0; n < rank; n++)
465 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
468 dest = retarray->data;
476 while (count[n] == extent[n])
478 /* When we get to the end of a dimension, reset it and increment
479 the next dimension. */
481 /* We could precalculate these products, but this is a less
482 frequently used path so probably not worth it. */
483 dest -= dstride[n] * extent[n];
495 define(ARRAY_FUNCTION,
496 `START_ARRAY_FUNCTION
498 START_ARRAY_BLOCK($1)
500 FINISH_ARRAY_FUNCTION($4)')dnl
501 define(MASKED_ARRAY_FUNCTION,
502 `START_MASKED_ARRAY_FUNCTION
504 START_MASKED_ARRAY_BLOCK($1)
506 FINISH_MASKED_ARRAY_FUNCTION')dnl