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 gfc_array_l1 * 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 gfc_array_l1 * 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 GFC_LOGICAL_1 * restrict base;
36 rtype_name * restrict dest;
44 /* Make dim zero based to avoid confusion. */
46 rank = GFC_DESCRIPTOR_RANK (array) - 1;
48 src_kind = GFC_DESCRIPTOR_SIZE (array);
50 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
51 delta = array->dim[dim].stride * src_kind;
53 for (n = 0; n < dim; n++)
55 sstride[n] = array->dim[n].stride * src_kind;
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 * src_kind;
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 %d, should be %d",
106 GFC_DESCRIPTOR_RANK (retarray), rank);
108 if (compile_options.bounds_check)
110 for (n=0; n < rank; n++)
112 index_type ret_extent;
114 ret_extent = retarray->dim[n].ubound + 1
115 - retarray->dim[n].lbound;
116 if (extent[n] != ret_extent)
117 runtime_error ("Incorrect extent in return value of"
118 " u_name intrinsic in dimension %d:"
119 " is %ld, should be %ld", n + 1,
120 (long int) ret_extent, (long int) extent[n]);
125 for (n = 0; n < rank; n++)
128 dstride[n] = retarray->dim[n].stride;
135 if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
136 #ifdef HAVE_GFC_LOGICAL_16
142 base = GFOR_POINTER_TO_L1 (base, src_kind);
145 internal_error (NULL, "Funny sized logical array in u_name intrinsic");
147 dest = retarray->data;
151 const GFC_LOGICAL_1 * restrict src;
156 define(START_ARRAY_BLOCK,
161 for (n = 0; n < len; n++, src += delta)
164 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 look. */
199 define(ARRAY_FUNCTION,
200 `START_ARRAY_FUNCTION
202 START_ARRAY_BLOCK($1)
204 FINISH_ARRAY_FUNCTION')dnl