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.
5 define(START_FOREACH_FUNCTION,
7 extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
8 atype * const restrict array);
9 export_proto(name`'rtype_qual`_'atype_code);
12 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
13 atype * const restrict array)
15 index_type count[GFC_MAX_DIMENSIONS];
16 index_type extent[GFC_MAX_DIMENSIONS];
17 index_type sstride[GFC_MAX_DIMENSIONS];
19 const atype_name *base;
24 rank = GFC_DESCRIPTOR_RANK (array);
26 runtime_error ("Rank of array needs to be > 0");
28 if (retarray->data == NULL)
30 retarray->dim[0].lbound = 0;
31 retarray->dim[0].ubound = rank-1;
32 retarray->dim[0].stride = 1;
33 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
35 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
39 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
40 runtime_error ("rank of return array does not equal 1");
42 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
43 runtime_error ("dimension of return array incorrect");
46 dstride = retarray->dim[0].stride;
47 dest = retarray->data;
48 for (n = 0; n < rank; n++)
50 sstride[n] = array->dim[n].stride;
51 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
55 /* Set the return value. */
56 for (n = 0; n < rank; n++)
57 dest[n * dstride] = 0;
64 /* Initialize the return value. */
65 for (n = 0; n < rank; n++)
66 dest[n * dstride] = 0;
69 define(START_FOREACH_BLOCK,
73 /* Implementation start. */
75 define(FINISH_FOREACH_FUNCTION,
76 ` /* Implementation end. */
78 /* Advance to the next element. */
82 while (count[n] == extent[n])
84 /* When we get to the end of a dimension, reset it and increment
85 the next dimension. */
87 /* We could precalculate these products, but this is a less
88 frequently used path so probably not worth it. */
89 base -= sstride[n] * extent[n];
93 /* Break out of the loop. */
106 define(START_MASKED_FOREACH_FUNCTION,
108 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
109 atype * const restrict, gfc_array_l4 * const restrict);
110 export_proto(`m'name`'rtype_qual`_'atype_code);
113 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
114 atype * const restrict array,
115 gfc_array_l4 * const restrict mask)
117 index_type count[GFC_MAX_DIMENSIONS];
118 index_type extent[GFC_MAX_DIMENSIONS];
119 index_type sstride[GFC_MAX_DIMENSIONS];
120 index_type mstride[GFC_MAX_DIMENSIONS];
123 const atype_name *base;
124 GFC_LOGICAL_4 *mbase;
128 rank = GFC_DESCRIPTOR_RANK (array);
130 runtime_error ("Rank of array needs to be > 0");
132 if (retarray->data == NULL)
134 retarray->dim[0].lbound = 0;
135 retarray->dim[0].ubound = rank-1;
136 retarray->dim[0].stride = 1;
137 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
138 retarray->offset = 0;
139 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
143 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
144 runtime_error ("rank of return array does not equal 1");
146 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
147 runtime_error ("dimension of return array incorrect");
150 dstride = retarray->dim[0].stride;
151 dest = retarray->data;
152 for (n = 0; n < rank; n++)
154 sstride[n] = array->dim[n].stride;
155 mstride[n] = mask->dim[n].stride;
156 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
160 /* Set the return value. */
161 for (n = 0; n < rank; n++)
162 dest[n * dstride] = 0;
170 if (GFC_DESCRIPTOR_SIZE (mask) != 4)
172 /* This allows the same loop to be used for all logical types. */
173 assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
174 for (n = 0; n < rank; n++)
176 mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
180 /* Initialize the return value. */
181 for (n = 0; n < rank; n++)
182 dest[n * dstride] = 0;
185 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
186 define(FINISH_MASKED_FOREACH_FUNCTION,
187 ` /* Implementation end. */
189 /* Advance to the next element. */
194 while (count[n] == extent[n])
196 /* When we get to the end of a dimension, reset it and increment
197 the next dimension. */
199 /* We could precalculate these products, but this is a less
200 frequently used path so probably not worth it. */
201 base -= sstride[n] * extent[n];
202 mbase -= mstride[n] * extent[n];
206 /* Break out of the loop. */
220 define(FOREACH_FUNCTION,
221 `START_FOREACH_FUNCTION
225 FINISH_FOREACH_FUNCTION')dnl
226 define(MASKED_FOREACH_FUNCTION,
227 `START_MASKED_FOREACH_FUNCTION
229 START_MASKED_FOREACH_BLOCK
231 FINISH_MASKED_FOREACH_FUNCTION')dnl
232 define(SCALAR_FOREACH_FUNCTION,
234 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
235 atype * const restrict, GFC_LOGICAL_4 *);
236 export_proto(`s'name`'rtype_qual`_'atype_code);
239 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
240 atype * const restrict array,
241 GFC_LOGICAL_4 * mask)
250 name`'rtype_qual`_'atype_code (retarray, array);
254 rank = GFC_DESCRIPTOR_RANK (array);
257 runtime_error ("Rank of array needs to be > 0");
259 if (retarray->data == NULL)
261 retarray->dim[0].lbound = 0;
262 retarray->dim[0].ubound = rank-1;
263 retarray->dim[0].stride = 1;
264 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
265 retarray->offset = 0;
266 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
270 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
271 runtime_error ("rank of return array does not equal 1");
273 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
274 runtime_error ("dimension of return array incorrect");
277 dstride = retarray->dim[0].stride;
278 dest = retarray->data;
279 for (n = 0; n<rank; n++)
280 dest[n * dstride] = $1 ;