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 95 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;
43 /* Make dim zero based to avoid confusion. */
45 rank = GFC_DESCRIPTOR_RANK (array) - 1;
47 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
48 delta = array->dim[dim].stride;
50 for (n = 0; n < dim; n++)
52 sstride[n] = array->dim[n].stride;
53 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
58 for (n = dim; n < rank; n++)
60 sstride[n] = array->dim[n + 1].stride;
62 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
68 if (retarray->data == NULL)
72 for (n = 0; n < rank; n++)
74 retarray->dim[n].lbound = 0;
75 retarray->dim[n].ubound = extent[n]-1;
77 retarray->dim[n].stride = 1;
79 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
83 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
85 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
90 /* Make sure we have a zero-sized array. */
91 retarray->dim[0].lbound = 0;
92 retarray->dim[0].ubound = -1;
96 retarray->data = internal_malloc_size (alloc_size);
100 if (rank != GFC_DESCRIPTOR_RANK (retarray))
101 runtime_error ("rank of return array incorrect in"
102 " u_name intrinsic: is %ld, should be %ld",
103 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
106 if (compile_options.bounds_check)
108 for (n=0; n < rank; n++)
110 index_type ret_extent;
112 ret_extent = retarray->dim[n].ubound + 1
113 - retarray->dim[n].lbound;
114 if (extent[n] != ret_extent)
115 runtime_error ("Incorrect extent in return value of"
116 " u_name intrinsic in dimension %ld:"
117 " is %ld, should be %ld", (long int) n + 1,
118 (long int) ret_extent, (long int) extent[n]);
123 for (n = 0; n < rank; n++)
126 dstride[n] = retarray->dim[n].stride;
132 dest = retarray->data;
136 const atype_name * restrict src;
141 define(START_ARRAY_BLOCK,
146 for (n = 0; n < len; n++, src += delta)
149 define(FINISH_ARRAY_FUNCTION,
154 /* Advance to the next element. */
159 while (count[n] == extent[n])
161 /* When we get to the end of a dimension, reset it and increment
162 the next dimension. */
164 /* We could precalculate these products, but this is a less
165 frequently used path so probably not worth it. */
166 base -= sstride[n] * extent[n];
167 dest -= dstride[n] * extent[n];
171 /* Break out of the look. */
184 define(START_MASKED_ARRAY_FUNCTION,
186 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
187 atype * const restrict, const index_type * const restrict,
188 gfc_array_l1 * const restrict);
189 export_proto(`m'name`'rtype_qual`_'atype_code);
192 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
193 atype * const restrict array,
194 const index_type * const restrict pdim,
195 gfc_array_l1 * const restrict mask)
197 index_type count[GFC_MAX_DIMENSIONS];
198 index_type extent[GFC_MAX_DIMENSIONS];
199 index_type sstride[GFC_MAX_DIMENSIONS];
200 index_type dstride[GFC_MAX_DIMENSIONS];
201 index_type mstride[GFC_MAX_DIMENSIONS];
202 rtype_name * restrict dest;
203 const atype_name * restrict base;
204 const GFC_LOGICAL_1 * restrict mbase;
214 rank = GFC_DESCRIPTOR_RANK (array) - 1;
216 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
222 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
224 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
225 #ifdef HAVE_GFC_LOGICAL_16
229 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
231 runtime_error ("Funny sized logical array");
233 delta = array->dim[dim].stride;
234 mdelta = mask->dim[dim].stride * mask_kind;
236 for (n = 0; n < dim; n++)
238 sstride[n] = array->dim[n].stride;
239 mstride[n] = mask->dim[n].stride * mask_kind;
240 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
246 for (n = dim; n < rank; n++)
248 sstride[n] = array->dim[n + 1].stride;
249 mstride[n] = mask->dim[n + 1].stride * mask_kind;
251 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
257 if (retarray->data == NULL)
261 for (n = 0; n < rank; n++)
263 retarray->dim[n].lbound = 0;
264 retarray->dim[n].ubound = extent[n]-1;
266 retarray->dim[n].stride = 1;
268 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
271 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
274 retarray->offset = 0;
275 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
279 /* Make sure we have a zero-sized array. */
280 retarray->dim[0].lbound = 0;
281 retarray->dim[0].ubound = -1;
285 retarray->data = internal_malloc_size (alloc_size);
290 if (rank != GFC_DESCRIPTOR_RANK (retarray))
291 runtime_error ("rank of return array incorrect in u_name intrinsic");
293 if (compile_options.bounds_check)
295 for (n=0; n < rank; n++)
297 index_type ret_extent;
299 ret_extent = retarray->dim[n].ubound + 1
300 - retarray->dim[n].lbound;
301 if (extent[n] != ret_extent)
302 runtime_error ("Incorrect extent in return value of"
303 " u_name intrinsic in dimension %ld:"
304 " is %ld, should be %ld", (long int) n + 1,
305 (long int) ret_extent, (long int) extent[n]);
307 for (n=0; n<= rank; n++)
309 index_type mask_extent, array_extent;
311 array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
312 mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
313 if (array_extent != mask_extent)
314 runtime_error ("Incorrect extent in MASK argument of"
315 " u_name intrinsic in dimension %ld:"
316 " is %ld, should be %ld", (long int) n + 1,
317 (long int) mask_extent, (long int) array_extent);
322 for (n = 0; n < rank; n++)
325 dstride[n] = retarray->dim[n].stride;
330 dest = retarray->data;
335 const atype_name * restrict src;
336 const GFC_LOGICAL_1 * restrict msrc;
342 define(START_MASKED_ARRAY_BLOCK,
347 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
350 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 look. */
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,
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)
401 index_type count[GFC_MAX_DIMENSIONS];
402 index_type extent[GFC_MAX_DIMENSIONS];
403 index_type sstride[GFC_MAX_DIMENSIONS];
404 index_type dstride[GFC_MAX_DIMENSIONS];
405 rtype_name * restrict dest;
413 name`'rtype_qual`_'atype_code (retarray, array, pdim);
416 /* Make dim zero based to avoid confusion. */
418 rank = GFC_DESCRIPTOR_RANK (array) - 1;
420 for (n = 0; n < dim; n++)
422 sstride[n] = array->dim[n].stride;
423 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
429 for (n = dim; n < rank; n++)
431 sstride[n] = array->dim[n + 1].stride;
433 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
439 if (retarray->data == NULL)
443 for (n = 0; n < rank; n++)
445 retarray->dim[n].lbound = 0;
446 retarray->dim[n].ubound = extent[n]-1;
448 retarray->dim[n].stride = 1;
450 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
453 retarray->offset = 0;
454 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
456 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
461 /* Make sure we have a zero-sized array. */
462 retarray->dim[0].lbound = 0;
463 retarray->dim[0].ubound = -1;
467 retarray->data = internal_malloc_size (alloc_size);
471 if (rank != GFC_DESCRIPTOR_RANK (retarray))
472 runtime_error ("rank of return array incorrect in"
473 " u_name intrinsic: is %ld, should be %ld",
474 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
477 if (compile_options.bounds_check)
479 for (n=0; n < rank; n++)
481 index_type ret_extent;
483 ret_extent = retarray->dim[n].ubound + 1
484 - retarray->dim[n].lbound;
485 if (extent[n] != ret_extent)
486 runtime_error ("Incorrect extent in return value of"
487 " u_name intrinsic in dimension %ld:"
488 " is %ld, should be %ld", (long int) n + 1,
489 (long int) ret_extent, (long int) extent[n]);
494 for (n = 0; n < rank; n++)
497 dstride[n] = retarray->dim[n].stride;
500 dest = retarray->data;
508 while (count[n] == extent[n])
510 /* When we get to the end of a dimension, reset it and increment
511 the next dimension. */
513 /* We could precalculate these products, but this is a less
514 frequently used path so probably not worth it. */
515 dest -= dstride[n] * extent[n];
527 define(ARRAY_FUNCTION,
528 `START_ARRAY_FUNCTION
530 START_ARRAY_BLOCK($1)
532 FINISH_ARRAY_FUNCTION')dnl
533 define(MASKED_ARRAY_FUNCTION,
534 `START_MASKED_ARRAY_FUNCTION
536 START_MASKED_ARRAY_BLOCK($1)
538 FINISH_MASKED_ARRAY_FUNCTION')dnl