annotate libgfortran/m4/ifunction.m4 @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 dnl Support macro file for intrinsic functions.
kono
parents:
diff changeset
2 dnl Contains the generic sections of the array functions.
kono
parents:
diff changeset
3 dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
kono
parents:
diff changeset
4 dnl Distributed under the GNU GPL with exception. See COPYING for details.
kono
parents:
diff changeset
5 dnl
kono
parents:
diff changeset
6 dnl Pass the implementation for a single section as the parameter to
kono
parents:
diff changeset
7 dnl {MASK_}ARRAY_FUNCTION.
kono
parents:
diff changeset
8 dnl The variables base, delta, and len describe the input section.
kono
parents:
diff changeset
9 dnl For masked section the mask is described by mbase and mdelta.
kono
parents:
diff changeset
10 dnl These should not be modified. The result should be stored in *dest.
kono
parents:
diff changeset
11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim
kono
parents:
diff changeset
12 dnl retarray, array, pdim and mstride should not be used.
kono
parents:
diff changeset
13 dnl The variable n is declared as index_type and may be used.
kono
parents:
diff changeset
14 dnl Other variable declarations may be placed at the start of the code,
kono
parents:
diff changeset
15 dnl The types of the array parameter and the return value are
kono
parents:
diff changeset
16 dnl atype_name and rtype_name respectively.
kono
parents:
diff changeset
17 dnl Execution should be allowed to continue to the end of the block.
kono
parents:
diff changeset
18 dnl You should not return or break from the inner loop of the implementation.
kono
parents:
diff changeset
19 dnl Care should also be taken to avoid using the names defined in iparm.m4
kono
parents:
diff changeset
20 define(START_ARRAY_FUNCTION,
kono
parents:
diff changeset
21 `
kono
parents:
diff changeset
22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
kono
parents:
diff changeset
23 atype * const restrict, const index_type * const restrict);
kono
parents:
diff changeset
24 export_proto(name`'rtype_qual`_'atype_code);
kono
parents:
diff changeset
25
kono
parents:
diff changeset
26 void
kono
parents:
diff changeset
27 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
kono
parents:
diff changeset
28 atype * const restrict array,
kono
parents:
diff changeset
29 const index_type * const restrict pdim)
kono
parents:
diff changeset
30 {
kono
parents:
diff changeset
31 index_type count[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
32 index_type extent[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
33 index_type sstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
34 index_type dstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
35 const atype_name * restrict base;
kono
parents:
diff changeset
36 rtype_name * restrict dest;
kono
parents:
diff changeset
37 index_type rank;
kono
parents:
diff changeset
38 index_type n;
kono
parents:
diff changeset
39 index_type len;
kono
parents:
diff changeset
40 index_type delta;
kono
parents:
diff changeset
41 index_type dim;
kono
parents:
diff changeset
42 int continue_loop;
kono
parents:
diff changeset
43
kono
parents:
diff changeset
44 /* Make dim zero based to avoid confusion. */
kono
parents:
diff changeset
45 dim = (*pdim) - 1;
kono
parents:
diff changeset
46 rank = GFC_DESCRIPTOR_RANK (array) - 1;
kono
parents:
diff changeset
47
kono
parents:
diff changeset
48 if (unlikely (dim < 0 || dim > rank))
kono
parents:
diff changeset
49 {
kono
parents:
diff changeset
50 runtime_error ("Dim argument incorrect in u_name intrinsic: "
kono
parents:
diff changeset
51 "is %ld, should be between 1 and %ld",
kono
parents:
diff changeset
52 (long int) dim + 1, (long int) rank + 1);
kono
parents:
diff changeset
53 }
kono
parents:
diff changeset
54
kono
parents:
diff changeset
55 len = GFC_DESCRIPTOR_EXTENT(array,dim);
kono
parents:
diff changeset
56 if (len < 0)
kono
parents:
diff changeset
57 len = 0;
kono
parents:
diff changeset
58 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
kono
parents:
diff changeset
59
kono
parents:
diff changeset
60 for (n = 0; n < dim; n++)
kono
parents:
diff changeset
61 {
kono
parents:
diff changeset
62 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
kono
parents:
diff changeset
63 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
kono
parents:
diff changeset
64
kono
parents:
diff changeset
65 if (extent[n] < 0)
kono
parents:
diff changeset
66 extent[n] = 0;
kono
parents:
diff changeset
67 }
kono
parents:
diff changeset
68 for (n = dim; n < rank; n++)
kono
parents:
diff changeset
69 {
kono
parents:
diff changeset
70 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
kono
parents:
diff changeset
71 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
kono
parents:
diff changeset
72
kono
parents:
diff changeset
73 if (extent[n] < 0)
kono
parents:
diff changeset
74 extent[n] = 0;
kono
parents:
diff changeset
75 }
kono
parents:
diff changeset
76
kono
parents:
diff changeset
77 if (retarray->base_addr == NULL)
kono
parents:
diff changeset
78 {
kono
parents:
diff changeset
79 size_t alloc_size, str;
kono
parents:
diff changeset
80
kono
parents:
diff changeset
81 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
82 {
kono
parents:
diff changeset
83 if (n == 0)
kono
parents:
diff changeset
84 str = 1;
kono
parents:
diff changeset
85 else
kono
parents:
diff changeset
86 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
kono
parents:
diff changeset
87
kono
parents:
diff changeset
88 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
kono
parents:
diff changeset
89
kono
parents:
diff changeset
90 }
kono
parents:
diff changeset
91
kono
parents:
diff changeset
92 retarray->offset = 0;
kono
parents:
diff changeset
93 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
kono
parents:
diff changeset
94
kono
parents:
diff changeset
95 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
kono
parents:
diff changeset
96
kono
parents:
diff changeset
97 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
kono
parents:
diff changeset
98 if (alloc_size == 0)
kono
parents:
diff changeset
99 {
kono
parents:
diff changeset
100 /* Make sure we have a zero-sized array. */
kono
parents:
diff changeset
101 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
kono
parents:
diff changeset
102 return;
kono
parents:
diff changeset
103
kono
parents:
diff changeset
104 }
kono
parents:
diff changeset
105 }
kono
parents:
diff changeset
106 else
kono
parents:
diff changeset
107 {
kono
parents:
diff changeset
108 if (rank != GFC_DESCRIPTOR_RANK (retarray))
kono
parents:
diff changeset
109 runtime_error ("rank of return array incorrect in"
kono
parents:
diff changeset
110 " u_name intrinsic: is %ld, should be %ld",
kono
parents:
diff changeset
111 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
kono
parents:
diff changeset
112 (long int) rank);
kono
parents:
diff changeset
113
kono
parents:
diff changeset
114 if (unlikely (compile_options.bounds_check))
kono
parents:
diff changeset
115 bounds_ifunction_return ((array_t *) retarray, extent,
kono
parents:
diff changeset
116 "return value", "u_name");
kono
parents:
diff changeset
117 }
kono
parents:
diff changeset
118
kono
parents:
diff changeset
119 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
120 {
kono
parents:
diff changeset
121 count[n] = 0;
kono
parents:
diff changeset
122 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
kono
parents:
diff changeset
123 if (extent[n] <= 0)
kono
parents:
diff changeset
124 return;
kono
parents:
diff changeset
125 }
kono
parents:
diff changeset
126
kono
parents:
diff changeset
127 base = array->base_addr;
kono
parents:
diff changeset
128 dest = retarray->base_addr;
kono
parents:
diff changeset
129
kono
parents:
diff changeset
130 continue_loop = 1;
kono
parents:
diff changeset
131 while (continue_loop)
kono
parents:
diff changeset
132 {
kono
parents:
diff changeset
133 const atype_name * restrict src;
kono
parents:
diff changeset
134 rtype_name result;
kono
parents:
diff changeset
135 src = base;
kono
parents:
diff changeset
136 {
kono
parents:
diff changeset
137 ')dnl
kono
parents:
diff changeset
138 define(START_ARRAY_BLOCK,
kono
parents:
diff changeset
139 ` if (len <= 0)
kono
parents:
diff changeset
140 *dest = '$1`;
kono
parents:
diff changeset
141 else
kono
parents:
diff changeset
142 {
kono
parents:
diff changeset
143 for (n = 0; n < len; n++, src += delta)
kono
parents:
diff changeset
144 {
kono
parents:
diff changeset
145 ')dnl
kono
parents:
diff changeset
146 define(FINISH_ARRAY_FUNCTION,
kono
parents:
diff changeset
147 ` }
kono
parents:
diff changeset
148 '$1`
kono
parents:
diff changeset
149 *dest = result;
kono
parents:
diff changeset
150 }
kono
parents:
diff changeset
151 }
kono
parents:
diff changeset
152 /* Advance to the next element. */
kono
parents:
diff changeset
153 count[0]++;
kono
parents:
diff changeset
154 base += sstride[0];
kono
parents:
diff changeset
155 dest += dstride[0];
kono
parents:
diff changeset
156 n = 0;
kono
parents:
diff changeset
157 while (count[n] == extent[n])
kono
parents:
diff changeset
158 {
kono
parents:
diff changeset
159 /* When we get to the end of a dimension, reset it and increment
kono
parents:
diff changeset
160 the next dimension. */
kono
parents:
diff changeset
161 count[n] = 0;
kono
parents:
diff changeset
162 /* We could precalculate these products, but this is a less
kono
parents:
diff changeset
163 frequently used path so probably not worth it. */
kono
parents:
diff changeset
164 base -= sstride[n] * extent[n];
kono
parents:
diff changeset
165 dest -= dstride[n] * extent[n];
kono
parents:
diff changeset
166 n++;
kono
parents:
diff changeset
167 if (n >= rank)
kono
parents:
diff changeset
168 {
kono
parents:
diff changeset
169 /* Break out of the loop. */
kono
parents:
diff changeset
170 continue_loop = 0;
kono
parents:
diff changeset
171 break;
kono
parents:
diff changeset
172 }
kono
parents:
diff changeset
173 else
kono
parents:
diff changeset
174 {
kono
parents:
diff changeset
175 count[n]++;
kono
parents:
diff changeset
176 base += sstride[n];
kono
parents:
diff changeset
177 dest += dstride[n];
kono
parents:
diff changeset
178 }
kono
parents:
diff changeset
179 }
kono
parents:
diff changeset
180 }
kono
parents:
diff changeset
181 }')dnl
kono
parents:
diff changeset
182 define(START_MASKED_ARRAY_FUNCTION,
kono
parents:
diff changeset
183 `
kono
parents:
diff changeset
184 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
kono
parents:
diff changeset
185 atype * const restrict, const index_type * const restrict,
kono
parents:
diff changeset
186 gfc_array_l1 * const restrict);
kono
parents:
diff changeset
187 export_proto(`m'name`'rtype_qual`_'atype_code);
kono
parents:
diff changeset
188
kono
parents:
diff changeset
189 void
kono
parents:
diff changeset
190 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
kono
parents:
diff changeset
191 atype * const restrict array,
kono
parents:
diff changeset
192 const index_type * const restrict pdim,
kono
parents:
diff changeset
193 gfc_array_l1 * const restrict mask)
kono
parents:
diff changeset
194 {
kono
parents:
diff changeset
195 index_type count[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
196 index_type extent[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
197 index_type sstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
198 index_type dstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
199 index_type mstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
200 rtype_name * restrict dest;
kono
parents:
diff changeset
201 const atype_name * restrict base;
kono
parents:
diff changeset
202 const GFC_LOGICAL_1 * restrict mbase;
kono
parents:
diff changeset
203 index_type rank;
kono
parents:
diff changeset
204 index_type dim;
kono
parents:
diff changeset
205 index_type n;
kono
parents:
diff changeset
206 index_type len;
kono
parents:
diff changeset
207 index_type delta;
kono
parents:
diff changeset
208 index_type mdelta;
kono
parents:
diff changeset
209 int mask_kind;
kono
parents:
diff changeset
210
kono
parents:
diff changeset
211 dim = (*pdim) - 1;
kono
parents:
diff changeset
212 rank = GFC_DESCRIPTOR_RANK (array) - 1;
kono
parents:
diff changeset
213
kono
parents:
diff changeset
214
kono
parents:
diff changeset
215 if (unlikely (dim < 0 || dim > rank))
kono
parents:
diff changeset
216 {
kono
parents:
diff changeset
217 runtime_error ("Dim argument incorrect in u_name intrinsic: "
kono
parents:
diff changeset
218 "is %ld, should be between 1 and %ld",
kono
parents:
diff changeset
219 (long int) dim + 1, (long int) rank + 1);
kono
parents:
diff changeset
220 }
kono
parents:
diff changeset
221
kono
parents:
diff changeset
222 len = GFC_DESCRIPTOR_EXTENT(array,dim);
kono
parents:
diff changeset
223 if (len <= 0)
kono
parents:
diff changeset
224 return;
kono
parents:
diff changeset
225
kono
parents:
diff changeset
226 mbase = mask->base_addr;
kono
parents:
diff changeset
227
kono
parents:
diff changeset
228 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
kono
parents:
diff changeset
229
kono
parents:
diff changeset
230 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
kono
parents:
diff changeset
231 #ifdef HAVE_GFC_LOGICAL_16
kono
parents:
diff changeset
232 || mask_kind == 16
kono
parents:
diff changeset
233 #endif
kono
parents:
diff changeset
234 )
kono
parents:
diff changeset
235 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
kono
parents:
diff changeset
236 else
kono
parents:
diff changeset
237 runtime_error ("Funny sized logical array");
kono
parents:
diff changeset
238
kono
parents:
diff changeset
239 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
kono
parents:
diff changeset
240 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
kono
parents:
diff changeset
241
kono
parents:
diff changeset
242 for (n = 0; n < dim; n++)
kono
parents:
diff changeset
243 {
kono
parents:
diff changeset
244 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
kono
parents:
diff changeset
245 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
kono
parents:
diff changeset
246 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
kono
parents:
diff changeset
247
kono
parents:
diff changeset
248 if (extent[n] < 0)
kono
parents:
diff changeset
249 extent[n] = 0;
kono
parents:
diff changeset
250
kono
parents:
diff changeset
251 }
kono
parents:
diff changeset
252 for (n = dim; n < rank; n++)
kono
parents:
diff changeset
253 {
kono
parents:
diff changeset
254 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
kono
parents:
diff changeset
255 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
kono
parents:
diff changeset
256 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
kono
parents:
diff changeset
257
kono
parents:
diff changeset
258 if (extent[n] < 0)
kono
parents:
diff changeset
259 extent[n] = 0;
kono
parents:
diff changeset
260 }
kono
parents:
diff changeset
261
kono
parents:
diff changeset
262 if (retarray->base_addr == NULL)
kono
parents:
diff changeset
263 {
kono
parents:
diff changeset
264 size_t alloc_size, str;
kono
parents:
diff changeset
265
kono
parents:
diff changeset
266 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
267 {
kono
parents:
diff changeset
268 if (n == 0)
kono
parents:
diff changeset
269 str = 1;
kono
parents:
diff changeset
270 else
kono
parents:
diff changeset
271 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
kono
parents:
diff changeset
272
kono
parents:
diff changeset
273 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
kono
parents:
diff changeset
274
kono
parents:
diff changeset
275 }
kono
parents:
diff changeset
276
kono
parents:
diff changeset
277 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
kono
parents:
diff changeset
278
kono
parents:
diff changeset
279 retarray->offset = 0;
kono
parents:
diff changeset
280 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
kono
parents:
diff changeset
281
kono
parents:
diff changeset
282 if (alloc_size == 0)
kono
parents:
diff changeset
283 {
kono
parents:
diff changeset
284 /* Make sure we have a zero-sized array. */
kono
parents:
diff changeset
285 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
kono
parents:
diff changeset
286 return;
kono
parents:
diff changeset
287 }
kono
parents:
diff changeset
288 else
kono
parents:
diff changeset
289 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
kono
parents:
diff changeset
290
kono
parents:
diff changeset
291 }
kono
parents:
diff changeset
292 else
kono
parents:
diff changeset
293 {
kono
parents:
diff changeset
294 if (rank != GFC_DESCRIPTOR_RANK (retarray))
kono
parents:
diff changeset
295 runtime_error ("rank of return array incorrect in u_name intrinsic");
kono
parents:
diff changeset
296
kono
parents:
diff changeset
297 if (unlikely (compile_options.bounds_check))
kono
parents:
diff changeset
298 {
kono
parents:
diff changeset
299 bounds_ifunction_return ((array_t *) retarray, extent,
kono
parents:
diff changeset
300 "return value", "u_name");
kono
parents:
diff changeset
301 bounds_equal_extents ((array_t *) mask, (array_t *) array,
kono
parents:
diff changeset
302 "MASK argument", "u_name");
kono
parents:
diff changeset
303 }
kono
parents:
diff changeset
304 }
kono
parents:
diff changeset
305
kono
parents:
diff changeset
306 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
307 {
kono
parents:
diff changeset
308 count[n] = 0;
kono
parents:
diff changeset
309 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
kono
parents:
diff changeset
310 if (extent[n] <= 0)
kono
parents:
diff changeset
311 return;
kono
parents:
diff changeset
312 }
kono
parents:
diff changeset
313
kono
parents:
diff changeset
314 dest = retarray->base_addr;
kono
parents:
diff changeset
315 base = array->base_addr;
kono
parents:
diff changeset
316
kono
parents:
diff changeset
317 while (base)
kono
parents:
diff changeset
318 {
kono
parents:
diff changeset
319 const atype_name * restrict src;
kono
parents:
diff changeset
320 const GFC_LOGICAL_1 * restrict msrc;
kono
parents:
diff changeset
321 rtype_name result;
kono
parents:
diff changeset
322 src = base;
kono
parents:
diff changeset
323 msrc = mbase;
kono
parents:
diff changeset
324 {
kono
parents:
diff changeset
325 ')dnl
kono
parents:
diff changeset
326 define(START_MASKED_ARRAY_BLOCK,
kono
parents:
diff changeset
327 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
kono
parents:
diff changeset
328 {
kono
parents:
diff changeset
329 ')dnl
kono
parents:
diff changeset
330 define(FINISH_MASKED_ARRAY_FUNCTION,
kono
parents:
diff changeset
331 ` }
kono
parents:
diff changeset
332 *dest = result;
kono
parents:
diff changeset
333 }
kono
parents:
diff changeset
334 /* Advance to the next element. */
kono
parents:
diff changeset
335 count[0]++;
kono
parents:
diff changeset
336 base += sstride[0];
kono
parents:
diff changeset
337 mbase += mstride[0];
kono
parents:
diff changeset
338 dest += dstride[0];
kono
parents:
diff changeset
339 n = 0;
kono
parents:
diff changeset
340 while (count[n] == extent[n])
kono
parents:
diff changeset
341 {
kono
parents:
diff changeset
342 /* When we get to the end of a dimension, reset it and increment
kono
parents:
diff changeset
343 the next dimension. */
kono
parents:
diff changeset
344 count[n] = 0;
kono
parents:
diff changeset
345 /* We could precalculate these products, but this is a less
kono
parents:
diff changeset
346 frequently used path so probably not worth it. */
kono
parents:
diff changeset
347 base -= sstride[n] * extent[n];
kono
parents:
diff changeset
348 mbase -= mstride[n] * extent[n];
kono
parents:
diff changeset
349 dest -= dstride[n] * extent[n];
kono
parents:
diff changeset
350 n++;
kono
parents:
diff changeset
351 if (n >= rank)
kono
parents:
diff changeset
352 {
kono
parents:
diff changeset
353 /* Break out of the loop. */
kono
parents:
diff changeset
354 base = NULL;
kono
parents:
diff changeset
355 break;
kono
parents:
diff changeset
356 }
kono
parents:
diff changeset
357 else
kono
parents:
diff changeset
358 {
kono
parents:
diff changeset
359 count[n]++;
kono
parents:
diff changeset
360 base += sstride[n];
kono
parents:
diff changeset
361 mbase += mstride[n];
kono
parents:
diff changeset
362 dest += dstride[n];
kono
parents:
diff changeset
363 }
kono
parents:
diff changeset
364 }
kono
parents:
diff changeset
365 }
kono
parents:
diff changeset
366 }')dnl
kono
parents:
diff changeset
367 define(SCALAR_ARRAY_FUNCTION,
kono
parents:
diff changeset
368 `
kono
parents:
diff changeset
369 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
kono
parents:
diff changeset
370 atype * const restrict, const index_type * const restrict,
kono
parents:
diff changeset
371 GFC_LOGICAL_4 *);
kono
parents:
diff changeset
372 export_proto(`s'name`'rtype_qual`_'atype_code);
kono
parents:
diff changeset
373
kono
parents:
diff changeset
374 void
kono
parents:
diff changeset
375 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
kono
parents:
diff changeset
376 atype * const restrict array,
kono
parents:
diff changeset
377 const index_type * const restrict pdim,
kono
parents:
diff changeset
378 GFC_LOGICAL_4 * mask)
kono
parents:
diff changeset
379 {
kono
parents:
diff changeset
380 index_type count[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
381 index_type extent[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
382 index_type dstride[GFC_MAX_DIMENSIONS];
kono
parents:
diff changeset
383 rtype_name * restrict dest;
kono
parents:
diff changeset
384 index_type rank;
kono
parents:
diff changeset
385 index_type n;
kono
parents:
diff changeset
386 index_type dim;
kono
parents:
diff changeset
387
kono
parents:
diff changeset
388
kono
parents:
diff changeset
389 if (*mask)
kono
parents:
diff changeset
390 {
kono
parents:
diff changeset
391 name`'rtype_qual`_'atype_code (retarray, array, pdim);
kono
parents:
diff changeset
392 return;
kono
parents:
diff changeset
393 }
kono
parents:
diff changeset
394 /* Make dim zero based to avoid confusion. */
kono
parents:
diff changeset
395 dim = (*pdim) - 1;
kono
parents:
diff changeset
396 rank = GFC_DESCRIPTOR_RANK (array) - 1;
kono
parents:
diff changeset
397
kono
parents:
diff changeset
398 if (unlikely (dim < 0 || dim > rank))
kono
parents:
diff changeset
399 {
kono
parents:
diff changeset
400 runtime_error ("Dim argument incorrect in u_name intrinsic: "
kono
parents:
diff changeset
401 "is %ld, should be between 1 and %ld",
kono
parents:
diff changeset
402 (long int) dim + 1, (long int) rank + 1);
kono
parents:
diff changeset
403 }
kono
parents:
diff changeset
404
kono
parents:
diff changeset
405 for (n = 0; n < dim; n++)
kono
parents:
diff changeset
406 {
kono
parents:
diff changeset
407 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
kono
parents:
diff changeset
408
kono
parents:
diff changeset
409 if (extent[n] <= 0)
kono
parents:
diff changeset
410 extent[n] = 0;
kono
parents:
diff changeset
411 }
kono
parents:
diff changeset
412
kono
parents:
diff changeset
413 for (n = dim; n < rank; n++)
kono
parents:
diff changeset
414 {
kono
parents:
diff changeset
415 extent[n] =
kono
parents:
diff changeset
416 GFC_DESCRIPTOR_EXTENT(array,n + 1);
kono
parents:
diff changeset
417
kono
parents:
diff changeset
418 if (extent[n] <= 0)
kono
parents:
diff changeset
419 extent[n] = 0;
kono
parents:
diff changeset
420 }
kono
parents:
diff changeset
421
kono
parents:
diff changeset
422 if (retarray->base_addr == NULL)
kono
parents:
diff changeset
423 {
kono
parents:
diff changeset
424 size_t alloc_size, str;
kono
parents:
diff changeset
425
kono
parents:
diff changeset
426 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
427 {
kono
parents:
diff changeset
428 if (n == 0)
kono
parents:
diff changeset
429 str = 1;
kono
parents:
diff changeset
430 else
kono
parents:
diff changeset
431 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
kono
parents:
diff changeset
432
kono
parents:
diff changeset
433 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
kono
parents:
diff changeset
434
kono
parents:
diff changeset
435 }
kono
parents:
diff changeset
436
kono
parents:
diff changeset
437 retarray->offset = 0;
kono
parents:
diff changeset
438 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
kono
parents:
diff changeset
439
kono
parents:
diff changeset
440 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
kono
parents:
diff changeset
441
kono
parents:
diff changeset
442 if (alloc_size == 0)
kono
parents:
diff changeset
443 {
kono
parents:
diff changeset
444 /* Make sure we have a zero-sized array. */
kono
parents:
diff changeset
445 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
kono
parents:
diff changeset
446 return;
kono
parents:
diff changeset
447 }
kono
parents:
diff changeset
448 else
kono
parents:
diff changeset
449 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
kono
parents:
diff changeset
450 }
kono
parents:
diff changeset
451 else
kono
parents:
diff changeset
452 {
kono
parents:
diff changeset
453 if (rank != GFC_DESCRIPTOR_RANK (retarray))
kono
parents:
diff changeset
454 runtime_error ("rank of return array incorrect in"
kono
parents:
diff changeset
455 " u_name intrinsic: is %ld, should be %ld",
kono
parents:
diff changeset
456 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
kono
parents:
diff changeset
457 (long int) rank);
kono
parents:
diff changeset
458
kono
parents:
diff changeset
459 if (unlikely (compile_options.bounds_check))
kono
parents:
diff changeset
460 {
kono
parents:
diff changeset
461 for (n=0; n < rank; n++)
kono
parents:
diff changeset
462 {
kono
parents:
diff changeset
463 index_type ret_extent;
kono
parents:
diff changeset
464
kono
parents:
diff changeset
465 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
kono
parents:
diff changeset
466 if (extent[n] != ret_extent)
kono
parents:
diff changeset
467 runtime_error ("Incorrect extent in return value of"
kono
parents:
diff changeset
468 " u_name intrinsic in dimension %ld:"
kono
parents:
diff changeset
469 " is %ld, should be %ld", (long int) n + 1,
kono
parents:
diff changeset
470 (long int) ret_extent, (long int) extent[n]);
kono
parents:
diff changeset
471 }
kono
parents:
diff changeset
472 }
kono
parents:
diff changeset
473 }
kono
parents:
diff changeset
474
kono
parents:
diff changeset
475 for (n = 0; n < rank; n++)
kono
parents:
diff changeset
476 {
kono
parents:
diff changeset
477 count[n] = 0;
kono
parents:
diff changeset
478 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
kono
parents:
diff changeset
479 }
kono
parents:
diff changeset
480
kono
parents:
diff changeset
481 dest = retarray->base_addr;
kono
parents:
diff changeset
482
kono
parents:
diff changeset
483 while(1)
kono
parents:
diff changeset
484 {
kono
parents:
diff changeset
485 *dest = '$1`;
kono
parents:
diff changeset
486 count[0]++;
kono
parents:
diff changeset
487 dest += dstride[0];
kono
parents:
diff changeset
488 n = 0;
kono
parents:
diff changeset
489 while (count[n] == extent[n])
kono
parents:
diff changeset
490 {
kono
parents:
diff changeset
491 /* When we get to the end of a dimension, reset it and increment
kono
parents:
diff changeset
492 the next dimension. */
kono
parents:
diff changeset
493 count[n] = 0;
kono
parents:
diff changeset
494 /* We could precalculate these products, but this is a less
kono
parents:
diff changeset
495 frequently used path so probably not worth it. */
kono
parents:
diff changeset
496 dest -= dstride[n] * extent[n];
kono
parents:
diff changeset
497 n++;
kono
parents:
diff changeset
498 if (n >= rank)
kono
parents:
diff changeset
499 return;
kono
parents:
diff changeset
500 else
kono
parents:
diff changeset
501 {
kono
parents:
diff changeset
502 count[n]++;
kono
parents:
diff changeset
503 dest += dstride[n];
kono
parents:
diff changeset
504 }
kono
parents:
diff changeset
505 }
kono
parents:
diff changeset
506 }
kono
parents:
diff changeset
507 }')dnl
kono
parents:
diff changeset
508 define(ARRAY_FUNCTION,
kono
parents:
diff changeset
509 `START_ARRAY_FUNCTION
kono
parents:
diff changeset
510 $2
kono
parents:
diff changeset
511 START_ARRAY_BLOCK($1)
kono
parents:
diff changeset
512 $3
kono
parents:
diff changeset
513 FINISH_ARRAY_FUNCTION($4)')dnl
kono
parents:
diff changeset
514 define(MASKED_ARRAY_FUNCTION,
kono
parents:
diff changeset
515 `START_MASKED_ARRAY_FUNCTION
kono
parents:
diff changeset
516 $2
kono
parents:
diff changeset
517 START_MASKED_ARRAY_BLOCK
kono
parents:
diff changeset
518 $3
kono
parents:
diff changeset
519 FINISH_MASKED_ARRAY_FUNCTION')dnl