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 #define INITVAL 'initval`
18 extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
20 atype * const restrict array, gfc_charlen_type);
21 export_proto(name`'rtype_qual`_'atype_code);
24 name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
25 gfc_charlen_type xlen,
26 'atype` * const restrict array, gfc_charlen_type len)
28 index_type count[GFC_MAX_DIMENSIONS];
29 index_type extent[GFC_MAX_DIMENSIONS];
30 index_type sstride[GFC_MAX_DIMENSIONS];
31 const 'atype_name` *base;
35 rank = GFC_DESCRIPTOR_RANK (array);
37 runtime_error ("Rank of array needs to be > 0");
41 /* Initialize return value. */
42 memset (ret, INITVAL, sizeof(*ret) * len);
44 for (n = 0; n < rank; n++)
46 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
47 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
53 base = array->base_addr;
57 define(START_FOREACH_BLOCK,
62 /* Implementation start. */
64 define(FINISH_FOREACH_FUNCTION,
65 ` /* Implementation end. */
66 /* Advance to the next element. */
69 while (++count[0] != extent[0]);
73 /* When we get to the end of a dimension, reset it and increment
74 the next dimension. */
76 /* We could precalculate these products, but this is a less
77 frequently used path so probably not worth it. */
78 base -= sstride[n] * extent[n];
82 /* Break out of the loop. */
92 while (count[n] == extent[n]);
94 memcpy (ret, retval, len * sizeof (*ret));
97 define(START_MASKED_FOREACH_FUNCTION,
99 extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
100 gfc_charlen_type, atype * const restrict array,
101 gfc_array_l1 * const restrict mask, gfc_charlen_type len);
102 export_proto(`m'name`'rtype_qual`_'atype_code);
105 `m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
106 gfc_charlen_type xlen, atype * const restrict array,
107 gfc_array_l1 * const restrict mask, gfc_charlen_type len)
109 index_type count[GFC_MAX_DIMENSIONS];
110 index_type extent[GFC_MAX_DIMENSIONS];
111 index_type sstride[GFC_MAX_DIMENSIONS];
112 index_type mstride[GFC_MAX_DIMENSIONS];
113 const atype_name *base;
114 GFC_LOGICAL_1 *mbase;
119 rank = GFC_DESCRIPTOR_RANK (array);
121 runtime_error ("Rank of array needs to be > 0");
123 assert (xlen == len);
125 /* Initialize return value. */
126 memset (ret, INITVAL, sizeof(*ret) * len);
128 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
130 mbase = mask->base_addr;
132 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
133 #ifdef HAVE_GFC_LOGICAL_16
137 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
139 runtime_error ("Funny sized logical array");
141 for (n = 0; n < rank; n++)
143 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
144 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
145 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
151 base = array->base_addr;
154 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
155 define(FINISH_MASKED_FOREACH_FUNCTION,
156 ` /* Implementation end. */
157 /* Advance to the next element. */
161 while (++count[0] != extent[0]);
165 /* When we get to the end of a dimension, reset it and increment
166 the next dimension. */
168 /* We could precalculate these products, but this is a less
169 frequently used path so probably not worth it. */
170 base -= sstride[n] * extent[n];
171 mbase -= mstride[n] * extent[n];
175 /* Break out of the loop. */
186 while (count[n] == extent[n]);
188 memcpy (ret, retval, len * sizeof (*ret));
191 define(FOREACH_FUNCTION,
192 `START_FOREACH_FUNCTION
196 FINISH_FOREACH_FUNCTION')dnl
197 define(MASKED_FOREACH_FUNCTION,
198 `START_MASKED_FOREACH_FUNCTION
200 START_MASKED_FOREACH_BLOCK
202 FINISH_MASKED_FOREACH_FUNCTION')dnl
203 define(SCALAR_FOREACH_FUNCTION,
205 extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
207 atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
208 export_proto(`s'name`'rtype_qual`_'atype_code);
211 `s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
212 gfc_charlen_type xlen, atype * const restrict array,
213 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
218 name`'rtype_qual`_'atype_code (ret, xlen, array, len);
221 memset (ret, INITVAL, sizeof (*ret) * len);