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");
104 for (n = 0; n < rank; n++)
107 dstride[n] = retarray->dim[n].stride;
113 dest = retarray->data;
117 const atype_name * restrict src;
122 define(START_ARRAY_BLOCK,
127 for (n = 0; n < len; n++, src += delta)
130 define(FINISH_ARRAY_FUNCTION,
135 /* Advance to the next element. */
140 while (count[n] == extent[n])
142 /* When we get to the end of a dimension, reset it and increment
143 the next dimension. */
145 /* We could precalculate these products, but this is a less
146 frequently used path so probably not worth it. */
147 base -= sstride[n] * extent[n];
148 dest -= dstride[n] * extent[n];
152 /* Break out of the look. */
165 define(START_MASKED_ARRAY_FUNCTION,
167 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
168 atype * const restrict, const index_type * const restrict,
169 gfc_array_l4 * const restrict);
170 export_proto(`m'name`'rtype_qual`_'atype_code);
173 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
174 atype * const restrict array,
175 const index_type * const restrict pdim,
176 gfc_array_l4 * const restrict mask)
178 index_type count[GFC_MAX_DIMENSIONS];
179 index_type extent[GFC_MAX_DIMENSIONS];
180 index_type sstride[GFC_MAX_DIMENSIONS];
181 index_type dstride[GFC_MAX_DIMENSIONS];
182 index_type mstride[GFC_MAX_DIMENSIONS];
183 rtype_name * restrict dest;
184 const atype_name * restrict base;
185 const GFC_LOGICAL_4 * restrict mbase;
194 rank = GFC_DESCRIPTOR_RANK (array) - 1;
196 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
199 delta = array->dim[dim].stride;
200 mdelta = mask->dim[dim].stride;
202 for (n = 0; n < dim; n++)
204 sstride[n] = array->dim[n].stride;
205 mstride[n] = mask->dim[n].stride;
206 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
212 for (n = dim; n < rank; n++)
214 sstride[n] = array->dim[n + 1].stride;
215 mstride[n] = mask->dim[n + 1].stride;
217 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
223 if (retarray->data == NULL)
227 for (n = 0; n < rank; n++)
229 retarray->dim[n].lbound = 0;
230 retarray->dim[n].ubound = extent[n]-1;
232 retarray->dim[n].stride = 1;
234 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
237 alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
240 retarray->offset = 0;
241 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
245 /* Make sure we have a zero-sized array. */
246 retarray->dim[0].lbound = 0;
247 retarray->dim[0].ubound = -1;
251 retarray->data = internal_malloc_size (alloc_size);
256 if (rank != GFC_DESCRIPTOR_RANK (retarray))
257 runtime_error ("rank of return array incorrect");
260 for (n = 0; n < rank; n++)
263 dstride[n] = retarray->dim[n].stride;
268 dest = retarray->data;
272 if (GFC_DESCRIPTOR_SIZE (mask) != 4)
274 /* This allows the same loop to be used for all logical types. */
275 assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
276 for (n = 0; n < rank; n++)
279 mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
284 const atype_name * restrict src;
285 const GFC_LOGICAL_4 * restrict msrc;
291 define(START_MASKED_ARRAY_BLOCK,
296 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
299 define(FINISH_MASKED_ARRAY_FUNCTION,
304 /* Advance to the next element. */
310 while (count[n] == extent[n])
312 /* When we get to the end of a dimension, reset it and increment
313 the next dimension. */
315 /* We could precalculate these products, but this is a less
316 frequently used path so probably not worth it. */
317 base -= sstride[n] * extent[n];
318 mbase -= mstride[n] * extent[n];
319 dest -= dstride[n] * extent[n];
323 /* Break out of the look. */
337 define(SCALAR_ARRAY_FUNCTION,
339 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
340 atype * const restrict, const index_type * const restrict,
342 export_proto(`s'name`'rtype_qual`_'atype_code);
345 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
346 atype * const restrict array,
347 const index_type * const restrict pdim,
348 GFC_LOGICAL_4 * mask)
357 name`'rtype_qual`_'atype_code (retarray, array, pdim);
360 rank = GFC_DESCRIPTOR_RANK (array);
362 runtime_error ("Rank of array needs to be > 0");
364 if (retarray->data == NULL)
366 retarray->dim[0].lbound = 0;
367 retarray->dim[0].ubound = rank-1;
368 retarray->dim[0].stride = 1;
369 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
370 retarray->offset = 0;
371 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
375 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
376 runtime_error ("rank of return array does not equal 1");
378 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
379 runtime_error ("dimension of return array incorrect");
382 dstride = retarray->dim[0].stride;
383 dest = retarray->data;
385 for (n = 0; n < rank; n++)
386 dest[n * dstride] = $1 ;
388 define(ARRAY_FUNCTION,
389 `START_ARRAY_FUNCTION
391 START_ARRAY_BLOCK($1)
393 FINISH_ARRAY_FUNCTION')dnl
394 define(MASKED_ARRAY_FUNCTION,
395 `START_MASKED_ARRAY_FUNCTION
397 START_MASKED_ARRAY_BLOCK($1)
399 FINISH_MASKED_ARRAY_FUNCTION')dnl