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;
61 /* Make dim zero based to avoid confusion. */
62 rank = GFC_DESCRIPTOR_RANK (array) - 1;
65 if (unlikely (dim < 0 || dim > rank))
67 runtime_error ("Dim argument incorrect in u_name intrinsic: "
68 "is %ld, should be between 1 and %ld",
69 (long int) dim + 1, (long int) rank + 1);
72 len = GFC_DESCRIPTOR_EXTENT(array,dim);
75 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
77 for (n = 0; n < dim; n++)
79 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
80 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
85 for (n = dim; n < rank; n++)
87 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
88 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
94 if (retarray->base_addr == NULL)
96 size_t alloc_size, str;
98 for (n = 0; n < rank; n++)
103 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
105 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
109 retarray->offset = 0;
110 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
112 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
114 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
117 /* Make sure we have a zero-sized array. */
118 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
125 if (rank != GFC_DESCRIPTOR_RANK (retarray))
126 runtime_error ("rank of return array incorrect in"
127 " u_name intrinsic: is %ld, should be %ld",
128 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
131 if (unlikely (compile_options.bounds_check))
132 bounds_ifunction_return ((array_t *) retarray, extent,
133 "return value", "u_name");
136 for (n = 0; n < rank; n++)
139 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
144 base = array->base_addr;
145 dest = retarray->base_addr;
148 while (continue_loop)
150 const atype_name * restrict src;
155 define(START_ARRAY_BLOCK,
160 for (n = 0; n < len; n++, src += delta)
163 define(FINISH_ARRAY_FUNCTION,
169 /* Advance to the next element. */
174 while (count[n] == extent[n])
176 /* When we get to the end of a dimension, reset it and increment
177 the next dimension. */
179 /* We could precalculate these products, but this is a less
180 frequently used path so probably not worth it. */
181 base -= sstride[n] * extent[n];
182 dest -= dstride[n] * extent[n];
186 /* Break out of the loop. */
199 define(START_MASKED_ARRAY_FUNCTION,
201 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
202 'atype` * const restrict, const index_type * const restrict,
203 gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
204 export_proto(m'name`'rtype_qual`_'atype_code`);
207 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
208 'atype` * const restrict array,
209 const index_type * const restrict pdim,
210 gfc_array_l1 * const restrict mask'back_arg`,
211 gfc_charlen_type string_len)
213 index_type count[GFC_MAX_DIMENSIONS];
214 index_type extent[GFC_MAX_DIMENSIONS];
215 index_type sstride[GFC_MAX_DIMENSIONS];
216 index_type dstride[GFC_MAX_DIMENSIONS];
217 index_type mstride[GFC_MAX_DIMENSIONS];
218 'rtype_name * restrict dest;
219 const atype_name * restrict base;
220 const GFC_LOGICAL_1 * restrict mbase;
233 rank = GFC_DESCRIPTOR_RANK (array) - 1;
236 if (unlikely (dim < 0 || dim > rank))
238 runtime_error ("Dim argument incorrect in u_name intrinsic: "
239 "is %ld, should be between 1 and %ld",
240 (long int) dim + 1, (long int) rank + 1);
243 len = GFC_DESCRIPTOR_EXTENT(array,dim);
247 mbase = mask->base_addr;
249 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
251 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
252 #ifdef HAVE_GFC_LOGICAL_16
256 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
258 runtime_error ("Funny sized logical array");
260 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
261 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
263 for (n = 0; n < dim; n++)
265 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
266 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
267 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
273 for (n = dim; n < rank; n++)
275 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
276 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
277 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
283 if (retarray->base_addr == NULL)
285 size_t alloc_size, str;
287 for (n = 0; n < rank; n++)
292 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
294 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
298 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
300 retarray->offset = 0;
301 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
305 /* Make sure we have a zero-sized array. */
306 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
310 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
315 if (rank != GFC_DESCRIPTOR_RANK (retarray))
316 runtime_error ("rank of return array incorrect in u_name intrinsic");
318 if (unlikely (compile_options.bounds_check))
320 bounds_ifunction_return ((array_t *) retarray, extent,
321 "return value", "u_name");
322 bounds_equal_extents ((array_t *) mask, (array_t *) array,
323 "MASK argument", "u_name");
327 for (n = 0; n < rank; n++)
330 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
335 dest = retarray->base_addr;
336 base = array->base_addr;
340 const atype_name * restrict src;
341 const GFC_LOGICAL_1 * restrict msrc;
347 define(START_MASKED_ARRAY_BLOCK,
348 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
351 define(FINISH_MASKED_ARRAY_FUNCTION,
355 /* Advance to the next element. */
361 while (count[n] == extent[n])
363 /* When we get to the end of a dimension, reset it and increment
364 the next dimension. */
366 /* We could precalculate these products, but this is a less
367 frequently used path so probably not worth it. */
368 base -= sstride[n] * extent[n];
369 mbase -= mstride[n] * extent[n];
370 dest -= dstride[n] * extent[n];
374 /* Break out of the loop. */
388 define(SCALAR_ARRAY_FUNCTION,
390 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
391 'atype` * const restrict, const index_type * const restrict,
392 GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
393 export_proto(s'name`'rtype_qual`_'atype_code`);
396 s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
397 'atype` * const restrict array,
398 const index_type * const restrict pdim,
399 GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
401 index_type count[GFC_MAX_DIMENSIONS];
402 index_type extent[GFC_MAX_DIMENSIONS];
403 index_type dstride[GFC_MAX_DIMENSIONS];
404 'rtype_name * restrict dest;
413 name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
415 name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
419 /* Make dim zero based to avoid confusion. */
421 rank = GFC_DESCRIPTOR_RANK (array) - 1;
423 if (unlikely (dim < 0 || dim > rank))
425 runtime_error ("Dim argument incorrect in u_name intrinsic: "
426 "is %ld, should be between 1 and %ld",
427 (long int) dim + 1, (long int) rank + 1);
430 for (n = 0; n < dim; n++)
432 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
438 for (n = dim; n < rank; n++)
441 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
447 if (retarray->base_addr == NULL)
449 size_t alloc_size, str;
451 for (n = 0; n < rank; n++)
456 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
458 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
462 retarray->offset = 0;
463 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
465 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
469 /* Make sure we have a zero-sized array. */
470 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
474 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
478 if (rank != GFC_DESCRIPTOR_RANK (retarray))
479 runtime_error ("rank of return array incorrect in"
480 " u_name intrinsic: is %ld, should be %ld",
481 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
484 if (unlikely (compile_options.bounds_check))
486 for (n=0; n < rank; n++)
488 index_type ret_extent;
490 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
491 if (extent[n] != ret_extent)
492 runtime_error ("Incorrect extent in return value of"
493 " u_name intrinsic in dimension %ld:"
494 " is %ld, should be %ld", (long int) n + 1,
495 (long int) ret_extent, (long int) extent[n]);
500 for (n = 0; n < rank; n++)
503 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
506 dest = retarray->base_addr;
514 while (count[n] == extent[n])
516 /* When we get to the end of a dimension, reset it and increment
517 the next dimension. */
519 /* We could precalculate these products, but this is a less
520 frequently used path so probably not worth it. */
521 dest -= dstride[n] * extent[n];
533 define(ARRAY_FUNCTION,
534 `START_ARRAY_FUNCTION
536 START_ARRAY_BLOCK($1)
538 FINISH_ARRAY_FUNCTION($4)')dnl
539 define(MASKED_ARRAY_FUNCTION,
540 `START_MASKED_ARRAY_FUNCTION
542 START_MASKED_ARRAY_BLOCK
544 FINISH_MASKED_ARRAY_FUNCTION')dnl