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