|
131
|
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,
|
|
|
6 `static inline int
|
|
|
7 compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
|
|
|
8 {
|
|
|
9 if (sizeof ('atype_name`) == 1)
|
|
|
10 return memcmp (a, b, n);
|
|
|
11 else
|
|
|
12 return memcmp_char4 (a, b, n);
|
|
|
13
|
|
|
14 }
|
|
|
15
|
|
|
16 extern void name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
|
|
|
17 'atype` * const restrict array'back_arg`, gfc_charlen_type len);
|
|
|
18 export_proto('name`'rtype_qual`_'atype_code);
|
|
|
19
|
|
|
20 void
|
|
|
21 name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
|
|
|
22 'atype` * const restrict array'back_arg`, gfc_charlen_type len)
|
|
|
23 {
|
|
|
24 index_type count[GFC_MAX_DIMENSIONS];
|
|
|
25 index_type extent[GFC_MAX_DIMENSIONS];
|
|
|
26 index_type sstride[GFC_MAX_DIMENSIONS];
|
|
|
27 index_type dstride;
|
|
|
28 const 'atype_name *base;
|
|
|
29 rtype_name * restrict dest;
|
|
|
30 index_type rank;
|
|
|
31 index_type n;
|
|
|
32
|
|
|
33 rank = GFC_DESCRIPTOR_RANK (array);
|
|
|
34 if (rank <= 0)
|
|
|
35 runtime_error ("Rank of array needs to be > 0");
|
|
|
36
|
|
|
37 if (retarray->base_addr == NULL)
|
|
|
38 {
|
|
|
39 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
|
|
|
40 retarray->dtype.rank = 1;
|
|
|
41 retarray->offset = 0;
|
|
|
42 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
|
|
|
43 }
|
|
|
44 else
|
|
|
45 {
|
|
|
46 if (unlikely (compile_options.bounds_check))
|
|
|
47 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
|
|
|
48 "u_name");
|
|
|
49 }
|
|
|
50
|
|
|
51 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
|
|
|
52 dest = retarray->base_addr;
|
|
|
53 for (n = 0; n < rank; n++)
|
|
|
54 {
|
|
|
55 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
|
|
|
56 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
|
|
57 count[n] = 0;
|
|
|
58 if (extent[n] <= 0)
|
|
|
59 {
|
|
|
60 /* Set the return value. */
|
|
|
61 for (n = 0; n < rank; n++)
|
|
|
62 dest[n * dstride] = 0;
|
|
|
63 return;
|
|
|
64 }
|
|
|
65 }
|
|
|
66
|
|
|
67 base = array->base_addr;
|
|
|
68
|
|
|
69 /* Initialize the return value. */
|
|
|
70 for (n = 0; n < rank; n++)
|
|
|
71 dest[n * dstride] = 1;
|
|
|
72 {
|
|
|
73 ')dnl
|
|
|
74 define(START_FOREACH_BLOCK,
|
|
|
75 ` while (base)
|
|
|
76 {
|
|
|
77 do
|
|
|
78 {
|
|
|
79 /* Implementation start. */
|
|
|
80 ')dnl
|
|
|
81 define(FINISH_FOREACH_FUNCTION,
|
|
|
82 ` /* Implementation end. */
|
|
|
83 /* Advance to the next element. */
|
|
|
84 base += sstride[0];
|
|
|
85 }
|
|
|
86 while (++count[0] != extent[0]);
|
|
|
87 n = 0;
|
|
|
88 do
|
|
|
89 {
|
|
|
90 /* When we get to the end of a dimension, reset it and increment
|
|
|
91 the next dimension. */
|
|
|
92 count[n] = 0;
|
|
|
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];
|
|
|
96 n++;
|
|
|
97 if (n >= rank)
|
|
|
98 {
|
|
|
99 /* Break out of the loop. */
|
|
|
100 base = NULL;
|
|
|
101 break;
|
|
|
102 }
|
|
|
103 else
|
|
|
104 {
|
|
|
105 count[n]++;
|
|
|
106 base += sstride[n];
|
|
|
107 }
|
|
|
108 }
|
|
|
109 while (count[n] == extent[n]);
|
|
|
110 }
|
|
|
111 }
|
|
|
112 }')dnl
|
|
|
113 define(START_MASKED_FOREACH_FUNCTION,
|
|
|
114 `
|
|
|
115 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
|
|
|
116 'atype` * const restrict, gfc_array_l1 * const restrict 'back_arg`,
|
|
|
117 gfc_charlen_type len);
|
|
|
118 export_proto(m'name`'rtype_qual`_'atype_code`);
|
|
|
119
|
|
|
120 void
|
|
|
121 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
|
|
|
122 'atype` * const restrict array,
|
|
|
123 gfc_array_l1 * const restrict mask'back_arg`,
|
|
|
124 gfc_charlen_type len)
|
|
|
125 {
|
|
|
126 index_type count[GFC_MAX_DIMENSIONS];
|
|
|
127 index_type extent[GFC_MAX_DIMENSIONS];
|
|
|
128 index_type sstride[GFC_MAX_DIMENSIONS];
|
|
|
129 index_type mstride[GFC_MAX_DIMENSIONS];
|
|
|
130 index_type dstride;
|
|
|
131 'rtype_name *dest;
|
|
|
132 const atype_name *base;
|
|
|
133 GFC_LOGICAL_1 *mbase;
|
|
|
134 int rank;
|
|
|
135 index_type n;
|
|
|
136 int mask_kind;
|
|
|
137
|
|
145
|
138 if (mask == NULL)
|
|
|
139 {
|
|
|
140 #ifdef HAVE_BACK_ARG
|
|
|
141 name`'rtype_qual`_'atype_code (retarray, array, back, len);
|
|
|
142 #else
|
|
|
143 name`'rtype_qual`_'atype_code (retarray, array, len);
|
|
|
144 #endif
|
|
|
145 return;
|
|
|
146 }
|
|
|
147
|
|
131
|
148 rank = GFC_DESCRIPTOR_RANK (array);
|
|
|
149 if (rank <= 0)
|
|
|
150 runtime_error ("Rank of array needs to be > 0");
|
|
|
151
|
|
|
152 if (retarray->base_addr == NULL)
|
|
|
153 {
|
|
|
154 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
|
|
|
155 retarray->dtype.rank = 1;
|
|
|
156 retarray->offset = 0;
|
|
|
157 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
|
|
|
158 }
|
|
|
159 else
|
|
|
160 {
|
|
|
161 if (unlikely (compile_options.bounds_check))
|
|
|
162 {
|
|
|
163
|
|
|
164 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
|
|
|
165 "u_name");
|
|
|
166 bounds_equal_extents ((array_t *) mask, (array_t *) array,
|
|
|
167 "MASK argument", "u_name");
|
|
|
168 }
|
|
|
169 }
|
|
|
170
|
|
|
171 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
|
|
172
|
|
|
173 mbase = mask->base_addr;
|
|
|
174
|
|
|
175 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
|
|
|
176 #ifdef HAVE_GFC_LOGICAL_16
|
|
|
177 || mask_kind == 16
|
|
|
178 #endif
|
|
|
179 )
|
|
|
180 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
|
|
|
181 else
|
|
|
182 runtime_error ("Funny sized logical array");
|
|
|
183
|
|
|
184 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
|
|
|
185 dest = retarray->base_addr;
|
|
|
186 for (n = 0; n < rank; n++)
|
|
|
187 {
|
|
|
188 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
|
|
|
189 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
|
|
190 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
|
|
191 count[n] = 0;
|
|
|
192 if (extent[n] <= 0)
|
|
|
193 {
|
|
|
194 /* Set the return value. */
|
|
|
195 for (n = 0; n < rank; n++)
|
|
|
196 dest[n * dstride] = 0;
|
|
|
197 return;
|
|
|
198 }
|
|
|
199 }
|
|
|
200
|
|
|
201 base = array->base_addr;
|
|
|
202
|
|
|
203 /* Initialize the return value. */
|
|
|
204 for (n = 0; n < rank; n++)
|
|
|
205 dest[n * dstride] = 0;
|
|
|
206 {
|
|
|
207 ')dnl
|
|
|
208 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
|
|
|
209 define(FINISH_MASKED_FOREACH_FUNCTION,
|
|
|
210 ` /* Implementation end. */
|
|
|
211 /* Advance to the next element. */
|
|
|
212 base += sstride[0];
|
|
|
213 mbase += mstride[0];
|
|
|
214 }
|
|
|
215 while (++count[0] != extent[0]);
|
|
|
216 n = 0;
|
|
|
217 do
|
|
|
218 {
|
|
|
219 /* When we get to the end of a dimension, reset it and increment
|
|
|
220 the next dimension. */
|
|
|
221 count[n] = 0;
|
|
|
222 /* We could precalculate these products, but this is a less
|
|
|
223 frequently used path so probably not worth it. */
|
|
|
224 base -= sstride[n] * extent[n];
|
|
|
225 mbase -= mstride[n] * extent[n];
|
|
|
226 n++;
|
|
|
227 if (n >= rank)
|
|
|
228 {
|
|
|
229 /* Break out of the loop. */
|
|
|
230 base = NULL;
|
|
|
231 break;
|
|
|
232 }
|
|
|
233 else
|
|
|
234 {
|
|
|
235 count[n]++;
|
|
|
236 base += sstride[n];
|
|
|
237 mbase += mstride[n];
|
|
|
238 }
|
|
|
239 }
|
|
|
240 while (count[n] == extent[n]);
|
|
|
241 }
|
|
|
242 }
|
|
|
243 }')dnl
|
|
|
244 define(FOREACH_FUNCTION,
|
|
|
245 `START_FOREACH_FUNCTION
|
|
|
246 $1
|
|
|
247 START_FOREACH_BLOCK
|
|
|
248 $2
|
|
|
249 FINISH_FOREACH_FUNCTION')dnl
|
|
|
250 define(MASKED_FOREACH_FUNCTION,
|
|
|
251 `START_MASKED_FOREACH_FUNCTION
|
|
|
252 $1
|
|
|
253 START_MASKED_FOREACH_BLOCK
|
|
|
254 $2
|
|
|
255 FINISH_MASKED_FOREACH_FUNCTION')dnl
|
|
|
256 define(SCALAR_FOREACH_FUNCTION,
|
|
|
257 `
|
|
|
258 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
|
|
|
259 'atype` * const restrict, GFC_LOGICAL_4 *'back_arg`,
|
|
|
260 gfc_charlen_type len);
|
|
|
261 export_proto(s'name`'rtype_qual`_'atype_code);
|
|
|
262
|
|
|
263 void
|
|
|
264 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
|
|
|
265 'atype` * const restrict array,
|
|
|
266 GFC_LOGICAL_4 * mask'back_arg`,
|
|
|
267 gfc_charlen_type len)
|
|
|
268 {
|
|
|
269 index_type rank;
|
|
|
270 index_type dstride;
|
|
|
271 index_type n;
|
|
|
272 'rtype_name *dest;
|
|
|
273
|
|
145
|
274 if (mask == NULL || *mask)
|
|
131
|
275 {
|
|
|
276 #ifdef HAVE_BACK_ARG
|
|
|
277 name`'rtype_qual`_'atype_code (retarray, array, back, len);
|
|
|
278 #else
|
|
|
279 name`'rtype_qual`_'atype_code (retarray, array, len);
|
|
|
280 #endif
|
|
|
281 return;
|
|
|
282 }
|
|
|
283
|
|
|
284 rank = GFC_DESCRIPTOR_RANK (array);
|
|
|
285
|
|
|
286 if (rank <= 0)
|
|
|
287 runtime_error ("Rank of array needs to be > 0");
|
|
|
288
|
|
|
289 if (retarray->base_addr == NULL)
|
|
|
290 {
|
|
|
291 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
|
|
|
292 retarray->dtype.rank = 1;
|
|
|
293 retarray->offset = 0;
|
|
|
294 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
|
|
|
295 }
|
|
|
296 else if (unlikely (compile_options.bounds_check))
|
|
|
297 {
|
|
|
298 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
|
|
|
299 "u_name");
|
|
|
300 }
|
|
|
301
|
|
|
302 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
|
|
|
303 dest = retarray->base_addr;
|
|
|
304 for (n = 0; n<rank; n++)
|
|
|
305 dest[n * dstride] = $1 ;
|
|
|
306 }')dnl
|
