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;
44 /* Make dim zero based to avoid confusion. */
46 rank = GFC_DESCRIPTOR_RANK (array) - 1;
48 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
51 delta = array->dim[dim].stride;
53 for (n = 0; n < dim; n++)
55 sstride[n] = array->dim[n].stride;
56 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
61 for (n = dim; n < rank; n++)
63 sstride[n] = array->dim[n + 1].stride;
65 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
71 if (retarray->data == NULL)
75 for (n = 0; n < rank; n++)
77 retarray->dim[n].lbound = 0;
78 retarray->dim[n].ubound = extent[n]-1;
80 retarray->dim[n].stride = 1;
82 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
86 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
88 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
93 /* Make sure we have a zero-sized array. */
94 retarray->dim[0].lbound = 0;
95 retarray->dim[0].ubound = -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))
111 for (n=0; n < rank; n++)
113 index_type ret_extent;
115 ret_extent = retarray->dim[n].ubound + 1
116 - retarray->dim[n].lbound;
117 if (extent[n] != ret_extent)
118 runtime_error ("Incorrect extent in return value of"
119 " u_name intrinsic in dimension %ld:"
120 " is %ld, should be %ld", (long int) n + 1,
121 (long int) ret_extent, (long int) extent[n]);
126 for (n = 0; n < rank; n++)
129 dstride[n] = retarray->dim[n].stride;
135 dest = retarray->data;
138 while (continue_loop)
140 const atype_name * restrict src;
145 define(START_ARRAY_BLOCK,
150 for (n = 0; n < len; n++, src += delta)
153 define(FINISH_ARRAY_FUNCTION,
158 /* Advance to the next element. */
163 while (count[n] == extent[n])
165 /* When we get to the end of a dimension, reset it and increment
166 the next dimension. */
168 /* We could precalculate these products, but this is a less
169 frequently used path so probably not worth it. */
170 base -= sstride[n] * extent[n];
171 dest -= dstride[n] * extent[n];
175 /* Break out of the look. */
188 define(START_MASKED_ARRAY_FUNCTION,
190 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
191 atype * const restrict, const index_type * const restrict,
192 gfc_array_l1 * const restrict);
193 export_proto(`m'name`'rtype_qual`_'atype_code);
196 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
197 atype * const restrict array,
198 const index_type * const restrict pdim,
199 gfc_array_l1 * const restrict mask)
201 index_type count[GFC_MAX_DIMENSIONS];
202 index_type extent[GFC_MAX_DIMENSIONS];
203 index_type sstride[GFC_MAX_DIMENSIONS];
204 index_type dstride[GFC_MAX_DIMENSIONS];
205 index_type mstride[GFC_MAX_DIMENSIONS];
206 rtype_name * restrict dest;
207 const atype_name * restrict base;
208 const GFC_LOGICAL_1 * restrict mbase;
218 rank = GFC_DESCRIPTOR_RANK (array) - 1;
220 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
226 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
228 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
229 #ifdef HAVE_GFC_LOGICAL_16
233 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
235 runtime_error ("Funny sized logical array");
237 delta = array->dim[dim].stride;
238 mdelta = mask->dim[dim].stride * mask_kind;
240 for (n = 0; n < dim; n++)
242 sstride[n] = array->dim[n].stride;
243 mstride[n] = mask->dim[n].stride * mask_kind;
244 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
250 for (n = dim; n < rank; n++)
252 sstride[n] = array->dim[n + 1].stride;
253 mstride[n] = mask->dim[n + 1].stride * mask_kind;
255 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
261 if (retarray->data == NULL)
265 for (n = 0; n < rank; n++)
267 retarray->dim[n].lbound = 0;
268 retarray->dim[n].ubound = extent[n]-1;
270 retarray->dim[n].stride = 1;
272 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
275 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
278 retarray->offset = 0;
279 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
283 /* Make sure we have a zero-sized array. */
284 retarray->dim[0].lbound = 0;
285 retarray->dim[0].ubound = -1;
289 retarray->data = internal_malloc_size (alloc_size);
294 if (rank != GFC_DESCRIPTOR_RANK (retarray))
295 runtime_error ("rank of return array incorrect in u_name intrinsic");
297 if (unlikely (compile_options.bounds_check))
299 for (n=0; n < rank; n++)
301 index_type ret_extent;
303 ret_extent = retarray->dim[n].ubound + 1
304 - retarray->dim[n].lbound;
305 if (extent[n] != ret_extent)
306 runtime_error ("Incorrect extent in return value of"
307 " u_name intrinsic in dimension %ld:"
308 " is %ld, should be %ld", (long int) n + 1,
309 (long int) ret_extent, (long int) extent[n]);
311 for (n=0; n<= rank; n++)
313 index_type mask_extent, array_extent;
315 array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
316 mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
317 if (array_extent != mask_extent)
318 runtime_error ("Incorrect extent in MASK argument of"
319 " u_name intrinsic in dimension %ld:"
320 " is %ld, should be %ld", (long int) n + 1,
321 (long int) mask_extent, (long int) array_extent);
326 for (n = 0; n < rank; n++)
329 dstride[n] = retarray->dim[n].stride;
334 dest = retarray->data;
339 const atype_name * restrict src;
340 const GFC_LOGICAL_1 * restrict msrc;
346 define(START_MASKED_ARRAY_BLOCK,
351 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
354 define(FINISH_MASKED_ARRAY_FUNCTION,
359 /* Advance to the next element. */
365 while (count[n] == extent[n])
367 /* When we get to the end of a dimension, reset it and increment
368 the next dimension. */
370 /* We could precalculate these products, but this is a less
371 frequently used path so probably not worth it. */
372 base -= sstride[n] * extent[n];
373 mbase -= mstride[n] * extent[n];
374 dest -= dstride[n] * extent[n];
378 /* Break out of the look. */
392 define(SCALAR_ARRAY_FUNCTION,
394 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
395 atype * const restrict, const index_type * const restrict,
397 export_proto(`s'name`'rtype_qual`_'atype_code);
400 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
401 atype * const restrict array,
402 const index_type * const restrict pdim,
403 GFC_LOGICAL_4 * mask)
405 index_type count[GFC_MAX_DIMENSIONS];
406 index_type extent[GFC_MAX_DIMENSIONS];
407 index_type sstride[GFC_MAX_DIMENSIONS];
408 index_type dstride[GFC_MAX_DIMENSIONS];
409 rtype_name * restrict dest;
417 name`'rtype_qual`_'atype_code (retarray, array, pdim);
420 /* Make dim zero based to avoid confusion. */
422 rank = GFC_DESCRIPTOR_RANK (array) - 1;
424 for (n = 0; n < dim; n++)
426 sstride[n] = array->dim[n].stride;
427 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
433 for (n = dim; n < rank; n++)
435 sstride[n] = array->dim[n + 1].stride;
437 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
443 if (retarray->data == NULL)
447 for (n = 0; n < rank; n++)
449 retarray->dim[n].lbound = 0;
450 retarray->dim[n].ubound = extent[n]-1;
452 retarray->dim[n].stride = 1;
454 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
457 retarray->offset = 0;
458 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
460 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
465 /* Make sure we have a zero-sized array. */
466 retarray->dim[0].lbound = 0;
467 retarray->dim[0].ubound = -1;
471 retarray->data = internal_malloc_size (alloc_size);
475 if (rank != GFC_DESCRIPTOR_RANK (retarray))
476 runtime_error ("rank of return array incorrect in"
477 " u_name intrinsic: is %ld, should be %ld",
478 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
481 if (unlikely (compile_options.bounds_check))
483 for (n=0; n < rank; n++)
485 index_type ret_extent;
487 ret_extent = retarray->dim[n].ubound + 1
488 - retarray->dim[n].lbound;
489 if (extent[n] != ret_extent)
490 runtime_error ("Incorrect extent in return value of"
491 " u_name intrinsic in dimension %ld:"
492 " is %ld, should be %ld", (long int) n + 1,
493 (long int) ret_extent, (long int) extent[n]);
498 for (n = 0; n < rank; n++)
501 dstride[n] = retarray->dim[n].stride;
504 dest = retarray->data;
512 while (count[n] == extent[n])
514 /* When we get to the end of a dimension, reset it and increment
515 the next dimension. */
517 /* We could precalculate these products, but this is a less
518 frequently used path so probably not worth it. */
519 dest -= dstride[n] * extent[n];
531 define(ARRAY_FUNCTION,
532 `START_ARRAY_FUNCTION
534 START_ARRAY_BLOCK($1)
536 FINISH_ARRAY_FUNCTION')dnl
537 define(MASKED_ARRAY_FUNCTION,
538 `START_MASKED_ARRAY_FUNCTION
540 START_MASKED_ARRAY_BLOCK($1)
542 FINISH_MASKED_ARRAY_FUNCTION')dnl