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;
20 rtype_name * restrict dest;
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 (unlikely (compile_options.bounds_check))
42 index_type ret_extent;
44 ret_rank = GFC_DESCRIPTOR_RANK (retarray);
46 runtime_error ("rank of return array in u_name intrinsic"
47 " should be 1, is %ld", (long int) ret_rank);
49 ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
50 if (ret_extent != rank)
51 runtime_error ("Incorrect extent in return value of"
52 " u_name intrnisic: is %ld, should be %ld",
53 (long int) ret_extent, (long int) rank);
57 dstride = retarray->dim[0].stride;
58 dest = retarray->data;
59 for (n = 0; n < rank; n++)
61 sstride[n] = array->dim[n].stride;
62 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
66 /* Set the return value. */
67 for (n = 0; n < rank; n++)
68 dest[n * dstride] = 0;
75 /* Initialize the return value. */
76 for (n = 0; n < rank; n++)
77 dest[n * dstride] = 0;
80 define(START_FOREACH_BLOCK,
84 /* Implementation start. */
86 define(FINISH_FOREACH_FUNCTION,
87 ` /* Implementation end. */
89 /* Advance to the next element. */
93 while (count[n] == extent[n])
95 /* When we get to the end of a dimension, reset it and increment
96 the next dimension. */
98 /* We could precalculate these products, but this is a less
99 frequently used path so probably not worth it. */
100 base -= sstride[n] * extent[n];
104 /* Break out of the loop. */
117 define(START_MASKED_FOREACH_FUNCTION,
119 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
120 atype * const restrict, gfc_array_l1 * const restrict);
121 export_proto(`m'name`'rtype_qual`_'atype_code);
124 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
125 atype * const restrict array,
126 gfc_array_l1 * const restrict mask)
128 index_type count[GFC_MAX_DIMENSIONS];
129 index_type extent[GFC_MAX_DIMENSIONS];
130 index_type sstride[GFC_MAX_DIMENSIONS];
131 index_type mstride[GFC_MAX_DIMENSIONS];
134 const atype_name *base;
135 GFC_LOGICAL_1 *mbase;
140 rank = GFC_DESCRIPTOR_RANK (array);
142 runtime_error ("Rank of array needs to be > 0");
144 if (retarray->data == NULL)
146 retarray->dim[0].lbound = 0;
147 retarray->dim[0].ubound = rank-1;
148 retarray->dim[0].stride = 1;
149 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
150 retarray->offset = 0;
151 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
155 if (unlikely (compile_options.bounds_check))
157 int ret_rank, mask_rank;
158 index_type ret_extent;
160 index_type array_extent, mask_extent;
162 ret_rank = GFC_DESCRIPTOR_RANK (retarray);
164 runtime_error ("rank of return array in u_name intrinsic"
165 " should be 1, is %ld", (long int) ret_rank);
167 ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
168 if (ret_extent != rank)
169 runtime_error ("Incorrect extent in return value of"
170 " u_name intrnisic: is %ld, should be %ld",
171 (long int) ret_extent, (long int) rank);
173 mask_rank = GFC_DESCRIPTOR_RANK (mask);
174 if (rank != mask_rank)
175 runtime_error ("rank of MASK argument in u_name intrnisic"
176 "should be %ld, is %ld", (long int) rank,
177 (long int) mask_rank);
179 for (n=0; n<rank; n++)
181 array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
182 mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
183 if (array_extent != mask_extent)
184 runtime_error ("Incorrect extent in MASK argument of"
185 " u_name intrinsic in dimension %ld:"
186 " is %ld, should be %ld", (long int) n + 1,
187 (long int) mask_extent, (long int) array_extent);
192 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
196 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
197 #ifdef HAVE_GFC_LOGICAL_16
201 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
203 runtime_error ("Funny sized logical array");
205 dstride = retarray->dim[0].stride;
206 dest = retarray->data;
207 for (n = 0; n < rank; n++)
209 sstride[n] = array->dim[n].stride;
210 mstride[n] = mask->dim[n].stride * mask_kind;
211 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
215 /* Set the return value. */
216 for (n = 0; n < rank; n++)
217 dest[n * dstride] = 0;
224 /* Initialize the return value. */
225 for (n = 0; n < rank; n++)
226 dest[n * dstride] = 0;
229 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
230 define(FINISH_MASKED_FOREACH_FUNCTION,
231 ` /* Implementation end. */
233 /* Advance to the next element. */
238 while (count[n] == extent[n])
240 /* When we get to the end of a dimension, reset it and increment
241 the next dimension. */
243 /* We could precalculate these products, but this is a less
244 frequently used path so probably not worth it. */
245 base -= sstride[n] * extent[n];
246 mbase -= mstride[n] * extent[n];
250 /* Break out of the loop. */
264 define(FOREACH_FUNCTION,
265 `START_FOREACH_FUNCTION
269 FINISH_FOREACH_FUNCTION')dnl
270 define(MASKED_FOREACH_FUNCTION,
271 `START_MASKED_FOREACH_FUNCTION
273 START_MASKED_FOREACH_BLOCK
275 FINISH_MASKED_FOREACH_FUNCTION')dnl
276 define(SCALAR_FOREACH_FUNCTION,
278 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
279 atype * const restrict, GFC_LOGICAL_4 *);
280 export_proto(`s'name`'rtype_qual`_'atype_code);
283 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
284 atype * const restrict array,
285 GFC_LOGICAL_4 * mask)
294 name`'rtype_qual`_'atype_code (retarray, array);
298 rank = GFC_DESCRIPTOR_RANK (array);
301 runtime_error ("Rank of array needs to be > 0");
303 if (retarray->data == NULL)
305 retarray->dim[0].lbound = 0;
306 retarray->dim[0].ubound = rank-1;
307 retarray->dim[0].stride = 1;
308 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
309 retarray->offset = 0;
310 retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
314 if (unlikely (compile_options.bounds_check))
317 index_type ret_extent;
319 ret_rank = GFC_DESCRIPTOR_RANK (retarray);
321 runtime_error ("rank of return array in u_name intrinsic"
322 " should be 1, is %ld", (long int) ret_rank);
324 ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
325 if (ret_extent != rank)
326 runtime_error ("dimension of return array incorrect");
330 dstride = retarray->dim[0].stride;
331 dest = retarray->data;
332 for (n = 0; n<rank; n++)
333 dest[n * dstride] = $1 ;