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 Runtime Library (libgfortran)
4 dnl Distributed under the GNU GPL with exception. See COPYING for details.
5 define(START_FOREACH_FUNCTION,
7 compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
9 if (sizeof ('atype_name`) == 1)
10 return memcmp (a, b, n);
12 return memcmp_char4 (a, b, n);
16 extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
17 atype * const restrict array, gfc_charlen_type len);
18 export_proto(name`'rtype_qual`_'atype_code);
21 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
22 atype * const restrict array, gfc_charlen_type len)
24 index_type count[GFC_MAX_DIMENSIONS];
25 index_type extent[GFC_MAX_DIMENSIONS];
26 index_type sstride[GFC_MAX_DIMENSIONS];
28 const atype_name *base;
29 rtype_name * restrict dest;
33 rank = GFC_DESCRIPTOR_RANK (array);
35 runtime_error ("Rank of array needs to be > 0");
37 if (retarray->base_addr == NULL)
39 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
40 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
42 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
46 if (unlikely (compile_options.bounds_check))
47 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
51 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
52 dest = retarray->base_addr;
53 for (n = 0; n < rank; n++)
55 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
56 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
60 /* Set the return value. */
61 for (n = 0; n < rank; n++)
62 dest[n * dstride] = 0;
67 base = array->base_addr;
69 /* Initialize the return value. */
70 for (n = 0; n < rank; n++)
71 dest[n * dstride] = 1;
74 define(START_FOREACH_BLOCK,
79 /* Implementation start. */
81 define(FINISH_FOREACH_FUNCTION,
82 ` /* Implementation end. */
83 /* Advance to the next element. */
86 while (++count[0] != extent[0]);
90 /* When we get to the end of a dimension, reset it and increment
91 the next dimension. */
93 /* We could precalculate these products, but this is a less
94 frequently used path so probably not worth it. */
95 base -= sstride[n] * extent[n];
99 /* Break out of the loop. */
109 while (count[n] == extent[n]);
113 define(START_MASKED_FOREACH_FUNCTION,
115 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
116 atype * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
117 export_proto(`m'name`'rtype_qual`_'atype_code);
120 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
121 atype * const restrict array,
122 gfc_array_l1 * const restrict mask, gfc_charlen_type len)
124 index_type count[GFC_MAX_DIMENSIONS];
125 index_type extent[GFC_MAX_DIMENSIONS];
126 index_type sstride[GFC_MAX_DIMENSIONS];
127 index_type mstride[GFC_MAX_DIMENSIONS];
130 const atype_name *base;
131 GFC_LOGICAL_1 *mbase;
136 rank = GFC_DESCRIPTOR_RANK (array);
138 runtime_error ("Rank of array needs to be > 0");
140 if (retarray->base_addr == NULL)
142 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
143 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
144 retarray->offset = 0;
145 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
149 if (unlikely (compile_options.bounds_check))
152 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
154 bounds_equal_extents ((array_t *) mask, (array_t *) array,
155 "MASK argument", "u_name");
159 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
161 mbase = mask->base_addr;
163 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
164 #ifdef HAVE_GFC_LOGICAL_16
168 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
170 runtime_error ("Funny sized logical array");
172 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
173 dest = retarray->base_addr;
174 for (n = 0; n < rank; n++)
176 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
177 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
178 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
182 /* Set the return value. */
183 for (n = 0; n < rank; n++)
184 dest[n * dstride] = 0;
189 base = array->base_addr;
191 /* Initialize the return value. */
192 for (n = 0; n < rank; n++)
193 dest[n * dstride] = 0;
196 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
197 define(FINISH_MASKED_FOREACH_FUNCTION,
198 ` /* Implementation end. */
199 /* Advance to the next element. */
203 while (++count[0] != extent[0]);
207 /* When we get to the end of a dimension, reset it and increment
208 the next dimension. */
210 /* We could precalculate these products, but this is a less
211 frequently used path so probably not worth it. */
212 base -= sstride[n] * extent[n];
213 mbase -= mstride[n] * extent[n];
217 /* Break out of the loop. */
228 while (count[n] == extent[n]);
232 define(FOREACH_FUNCTION,
233 `START_FOREACH_FUNCTION
237 FINISH_FOREACH_FUNCTION')dnl
238 define(MASKED_FOREACH_FUNCTION,
239 `START_MASKED_FOREACH_FUNCTION
241 START_MASKED_FOREACH_BLOCK
243 FINISH_MASKED_FOREACH_FUNCTION')dnl
244 define(SCALAR_FOREACH_FUNCTION,
246 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
247 atype * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
248 export_proto(`s'name`'rtype_qual`_'atype_code);
251 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
252 atype * const restrict array,
253 GFC_LOGICAL_4 * mask, gfc_charlen_type len)
262 name`'rtype_qual`_'atype_code (retarray, array, len);
266 rank = GFC_DESCRIPTOR_RANK (array);
269 runtime_error ("Rank of array needs to be > 0");
271 if (retarray->base_addr == NULL)
273 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
274 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
275 retarray->offset = 0;
276 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
278 else if (unlikely (compile_options.bounds_check))
280 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
284 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
285 dest = retarray->base_addr;
286 for (n = 0; n<rank; n++)
287 dest[n * dstride] = $1 ;