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,
25 compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
27 if (sizeof ('atype_name`) == 1)
28 return memcmp (a, b, n);
30 return memcmp_char4 (a, b, n);
33 extern void name`'rtype_qual`_'atype_code (rtype` * const restrict,
34 'atype` * const restrict, const index_type * const restrict 'back_arg`,
36 export_proto('name`'rtype_qual`_'atype_code`);
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)
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;
57 /* Make dim zero based to avoid confusion. */
58 rank = GFC_DESCRIPTOR_RANK (array) - 1;
61 if (unlikely (dim < 0 || dim > rank))
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);
68 len = GFC_DESCRIPTOR_EXTENT(array,dim);
71 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
73 for (n = 0; n < dim; n++)
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81 for (n = dim; n < rank; n++)
83 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
84 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
90 if (retarray->base_addr == NULL)
92 size_t alloc_size, str;
94 for (n = 0; n < rank; n++)
99 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
101 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
105 retarray->offset = 0;
106 retarray->dtype.rank = rank;
108 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
110 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
116 if (rank != GFC_DESCRIPTOR_RANK (retarray))
117 runtime_error ("rank of return array incorrect in"
118 " u_name intrinsic: is %ld, should be %ld",
119 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
122 if (unlikely (compile_options.bounds_check))
123 bounds_ifunction_return ((array_t *) retarray, extent,
124 "return value", "u_name");
127 for (n = 0; n < rank; n++)
130 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
135 base = array->base_addr;
136 dest = retarray->base_addr;
139 while (continue_loop)
141 const atype_name * restrict src;
146 define(START_ARRAY_BLOCK,
151 for (n = 0; n < len; n++, src += delta)
154 define(FINISH_ARRAY_FUNCTION,
160 /* Advance to the next element. */
165 while (count[n] == extent[n])
167 /* When we get to the end of a dimension, reset it and increment
168 the next dimension. */
170 /* We could precalculate these products, but this is a less
171 frequently used path so probably not worth it. */
172 base -= sstride[n] * extent[n];
173 dest -= dstride[n] * extent[n];
177 /* Break out of the loop. */
190 define(START_MASKED_ARRAY_FUNCTION,
192 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
193 'atype` * const restrict, const index_type * const restrict,
194 gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
195 export_proto(m'name`'rtype_qual`_'atype_code`);
198 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
199 'atype` * const restrict array,
200 const index_type * const restrict pdim,
201 gfc_array_l1 * const restrict mask'back_arg`,
202 gfc_charlen_type string_len)
204 index_type count[GFC_MAX_DIMENSIONS];
205 index_type extent[GFC_MAX_DIMENSIONS];
206 index_type sstride[GFC_MAX_DIMENSIONS];
207 index_type dstride[GFC_MAX_DIMENSIONS];
208 index_type mstride[GFC_MAX_DIMENSIONS];
209 'rtype_name * restrict dest;
210 const atype_name * restrict base;
211 const GFC_LOGICAL_1 * restrict mbase;
223 name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
225 name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
231 rank = GFC_DESCRIPTOR_RANK (array) - 1;
234 if (unlikely (dim < 0 || dim > rank))
236 runtime_error ("Dim argument incorrect in u_name intrinsic: "
237 "is %ld, should be between 1 and %ld",
238 (long int) dim + 1, (long int) rank + 1);
241 len = GFC_DESCRIPTOR_EXTENT(array,dim);
245 mbase = mask->base_addr;
247 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
249 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
250 #ifdef HAVE_GFC_LOGICAL_16
254 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
256 runtime_error ("Funny sized logical array");
258 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
259 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
261 for (n = 0; n < dim; n++)
263 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
264 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
265 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
271 for (n = dim; n < rank; n++)
273 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
274 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
275 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
281 if (retarray->base_addr == NULL)
283 size_t alloc_size, str;
285 for (n = 0; n < rank; n++)
290 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
292 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
296 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
298 retarray->offset = 0;
299 retarray->dtype.rank = rank;
301 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
307 if (rank != GFC_DESCRIPTOR_RANK (retarray))
308 runtime_error ("rank of return array incorrect in u_name intrinsic");
310 if (unlikely (compile_options.bounds_check))
312 bounds_ifunction_return ((array_t *) retarray, extent,
313 "return value", "u_name");
314 bounds_equal_extents ((array_t *) mask, (array_t *) array,
315 "MASK argument", "u_name");
319 for (n = 0; n < rank; n++)
322 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
327 dest = retarray->base_addr;
328 base = array->base_addr;
332 const atype_name * restrict src;
333 const GFC_LOGICAL_1 * restrict msrc;
339 define(START_MASKED_ARRAY_BLOCK,
340 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
343 define(FINISH_MASKED_ARRAY_FUNCTION,
347 /* Advance to the next element. */
353 while (count[n] == extent[n])
355 /* When we get to the end of a dimension, reset it and increment
356 the next dimension. */
358 /* We could precalculate these products, but this is a less
359 frequently used path so probably not worth it. */
360 base -= sstride[n] * extent[n];
361 mbase -= mstride[n] * extent[n];
362 dest -= dstride[n] * extent[n];
366 /* Break out of the loop. */
380 define(SCALAR_ARRAY_FUNCTION,
382 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
383 'atype` * const restrict, const index_type * const restrict,
384 GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
385 export_proto(s'name`'rtype_qual`_'atype_code`);
388 s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
389 'atype` * const restrict array,
390 const index_type * const restrict pdim,
391 GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
393 index_type count[GFC_MAX_DIMENSIONS];
394 index_type extent[GFC_MAX_DIMENSIONS];
395 index_type dstride[GFC_MAX_DIMENSIONS];
396 'rtype_name * restrict dest;
402 if (mask == NULL || *mask)
405 name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
407 name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
411 /* Make dim zero based to avoid confusion. */
413 rank = GFC_DESCRIPTOR_RANK (array) - 1;
415 if (unlikely (dim < 0 || dim > rank))
417 runtime_error ("Dim argument incorrect in u_name intrinsic: "
418 "is %ld, should be between 1 and %ld",
419 (long int) dim + 1, (long int) rank + 1);
422 for (n = 0; n < dim; n++)
424 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
430 for (n = dim; n < rank; n++)
433 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
439 if (retarray->base_addr == NULL)
441 size_t alloc_size, str;
443 for (n = 0; n < rank; n++)
448 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
450 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
454 retarray->offset = 0;
455 retarray->dtype.rank = rank;
457 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
459 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
465 if (rank != GFC_DESCRIPTOR_RANK (retarray))
466 runtime_error ("rank of return array incorrect in"
467 " u_name intrinsic: is %ld, should be %ld",
468 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
471 if (unlikely (compile_options.bounds_check))
473 for (n=0; n < rank; n++)
475 index_type ret_extent;
477 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
478 if (extent[n] != ret_extent)
479 runtime_error ("Incorrect extent in return value of"
480 " u_name intrinsic in dimension %ld:"
481 " is %ld, should be %ld", (long int) n + 1,
482 (long int) ret_extent, (long int) extent[n]);
487 for (n = 0; n < rank; n++)
490 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
493 dest = retarray->base_addr;
501 while (count[n] == extent[n])
503 /* When we get to the end of a dimension, reset it and increment
504 the next dimension. */
506 /* We could precalculate these products, but this is a less
507 frequently used path so probably not worth it. */
508 dest -= dstride[n] * extent[n];
520 define(ARRAY_FUNCTION,
521 `START_ARRAY_FUNCTION
523 START_ARRAY_BLOCK($1)
525 FINISH_ARRAY_FUNCTION($4)')dnl
526 define(MASKED_ARRAY_FUNCTION,
527 `START_MASKED_ARRAY_FUNCTION
529 START_MASKED_ARRAY_BLOCK
531 FINISH_MASKED_ARRAY_FUNCTION')dnl