Daily bump.
[official-gcc.git] / libgfortran / generated / iall_i4.c
blob8083c5a0fab511427f10d7dc305a2200f2956750
1 /* Implementation of the IALL intrinsic
2 Copyright (C) 2010-2018 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
29 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
32 extern void iall_i4 (gfc_array_i4 * const restrict,
33 gfc_array_i4 * const restrict, const index_type * const restrict);
34 export_proto(iall_i4);
36 void
37 iall_i4 (gfc_array_i4 * const restrict retarray,
38 gfc_array_i4 * const restrict array,
39 const index_type * const restrict pdim)
41 index_type count[GFC_MAX_DIMENSIONS];
42 index_type extent[GFC_MAX_DIMENSIONS];
43 index_type sstride[GFC_MAX_DIMENSIONS];
44 index_type dstride[GFC_MAX_DIMENSIONS];
45 const GFC_INTEGER_4 * restrict base;
46 GFC_INTEGER_4 * restrict dest;
47 index_type rank;
48 index_type n;
49 index_type len;
50 index_type delta;
51 index_type dim;
52 int continue_loop;
54 /* Make dim zero based to avoid confusion. */
55 rank = GFC_DESCRIPTOR_RANK (array) - 1;
56 dim = (*pdim) - 1;
58 if (unlikely (dim < 0 || dim > rank))
60 runtime_error ("Dim argument incorrect in IALL intrinsic: "
61 "is %ld, should be between 1 and %ld",
62 (long int) dim + 1, (long int) rank + 1);
65 len = GFC_DESCRIPTOR_EXTENT(array,dim);
66 if (len < 0)
67 len = 0;
68 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
70 for (n = 0; n < dim; n++)
72 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
73 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
75 if (extent[n] < 0)
76 extent[n] = 0;
78 for (n = dim; n < rank; n++)
80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
81 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
83 if (extent[n] < 0)
84 extent[n] = 0;
87 if (retarray->base_addr == NULL)
89 size_t alloc_size, str;
91 for (n = 0; n < rank; n++)
93 if (n == 0)
94 str = 1;
95 else
96 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
98 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
102 retarray->offset = 0;
103 retarray->dtype.rank = rank;
105 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
107 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
108 if (alloc_size == 0)
110 /* Make sure we have a zero-sized array. */
111 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
112 return;
116 else
118 if (rank != GFC_DESCRIPTOR_RANK (retarray))
119 runtime_error ("rank of return array incorrect in"
120 " IALL intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
122 (long int) rank);
124 if (unlikely (compile_options.bounds_check))
125 bounds_ifunction_return ((array_t *) retarray, extent,
126 "return value", "IALL");
129 for (n = 0; n < rank; n++)
131 count[n] = 0;
132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
133 if (extent[n] <= 0)
134 return;
137 base = array->base_addr;
138 dest = retarray->base_addr;
140 continue_loop = 1;
141 while (continue_loop)
143 const GFC_INTEGER_4 * restrict src;
144 GFC_INTEGER_4 result;
145 src = base;
148 result = (GFC_INTEGER_4) -1;
149 if (len <= 0)
150 *dest = 0;
151 else
153 #if ! defined HAVE_BACK_ARG
154 for (n = 0; n < len; n++, src += delta)
156 #endif
158 result &= *src;
161 *dest = result;
164 /* Advance to the next element. */
165 count[0]++;
166 base += sstride[0];
167 dest += dstride[0];
168 n = 0;
169 while (count[n] == extent[n])
171 /* When we get to the end of a dimension, reset it and increment
172 the next dimension. */
173 count[n] = 0;
174 /* We could precalculate these products, but this is a less
175 frequently used path so probably not worth it. */
176 base -= sstride[n] * extent[n];
177 dest -= dstride[n] * extent[n];
178 n++;
179 if (n >= rank)
181 /* Break out of the loop. */
182 continue_loop = 0;
183 break;
185 else
187 count[n]++;
188 base += sstride[n];
189 dest += dstride[n];
196 extern void miall_i4 (gfc_array_i4 * const restrict,
197 gfc_array_i4 * const restrict, const index_type * const restrict,
198 gfc_array_l1 * const restrict);
199 export_proto(miall_i4);
201 void
202 miall_i4 (gfc_array_i4 * const restrict retarray,
203 gfc_array_i4 * const restrict array,
204 const index_type * const restrict pdim,
205 gfc_array_l1 * const restrict mask)
207 index_type count[GFC_MAX_DIMENSIONS];
208 index_type extent[GFC_MAX_DIMENSIONS];
209 index_type sstride[GFC_MAX_DIMENSIONS];
210 index_type dstride[GFC_MAX_DIMENSIONS];
211 index_type mstride[GFC_MAX_DIMENSIONS];
212 GFC_INTEGER_4 * restrict dest;
213 const GFC_INTEGER_4 * restrict base;
214 const GFC_LOGICAL_1 * restrict mbase;
215 index_type rank;
216 index_type dim;
217 index_type n;
218 index_type len;
219 index_type delta;
220 index_type mdelta;
221 int mask_kind;
223 dim = (*pdim) - 1;
224 rank = GFC_DESCRIPTOR_RANK (array) - 1;
227 if (unlikely (dim < 0 || dim > rank))
229 runtime_error ("Dim argument incorrect in IALL intrinsic: "
230 "is %ld, should be between 1 and %ld",
231 (long int) dim + 1, (long int) rank + 1);
234 len = GFC_DESCRIPTOR_EXTENT(array,dim);
235 if (len <= 0)
236 return;
238 mbase = mask->base_addr;
240 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
242 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
243 #ifdef HAVE_GFC_LOGICAL_16
244 || mask_kind == 16
245 #endif
247 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
248 else
249 runtime_error ("Funny sized logical array");
251 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
252 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
254 for (n = 0; n < dim; n++)
256 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
257 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
258 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
260 if (extent[n] < 0)
261 extent[n] = 0;
264 for (n = dim; n < rank; n++)
266 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
267 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
268 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
270 if (extent[n] < 0)
271 extent[n] = 0;
274 if (retarray->base_addr == NULL)
276 size_t alloc_size, str;
278 for (n = 0; n < rank; n++)
280 if (n == 0)
281 str = 1;
282 else
283 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
285 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
289 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
291 retarray->offset = 0;
292 retarray->dtype.rank = rank;
294 if (alloc_size == 0)
296 /* Make sure we have a zero-sized array. */
297 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
298 return;
300 else
301 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
304 else
306 if (rank != GFC_DESCRIPTOR_RANK (retarray))
307 runtime_error ("rank of return array incorrect in IALL intrinsic");
309 if (unlikely (compile_options.bounds_check))
311 bounds_ifunction_return ((array_t *) retarray, extent,
312 "return value", "IALL");
313 bounds_equal_extents ((array_t *) mask, (array_t *) array,
314 "MASK argument", "IALL");
318 for (n = 0; n < rank; n++)
320 count[n] = 0;
321 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
322 if (extent[n] <= 0)
323 return;
326 dest = retarray->base_addr;
327 base = array->base_addr;
329 while (base)
331 const GFC_INTEGER_4 * restrict src;
332 const GFC_LOGICAL_1 * restrict msrc;
333 GFC_INTEGER_4 result;
334 src = base;
335 msrc = mbase;
338 result = 0;
339 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
342 if (*msrc)
343 result &= *src;
345 *dest = result;
347 /* Advance to the next element. */
348 count[0]++;
349 base += sstride[0];
350 mbase += mstride[0];
351 dest += dstride[0];
352 n = 0;
353 while (count[n] == extent[n])
355 /* When we get to the end of a dimension, reset it and increment
356 the next dimension. */
357 count[n] = 0;
358 /* We could precalculate these products, but this is a less
359 frequently used path so probably not worth it. */
360 base -= sstride[n] * extent[n];
361 mbase -= mstride[n] * extent[n];
362 dest -= dstride[n] * extent[n];
363 n++;
364 if (n >= rank)
366 /* Break out of the loop. */
367 base = NULL;
368 break;
370 else
372 count[n]++;
373 base += sstride[n];
374 mbase += mstride[n];
375 dest += dstride[n];
382 extern void siall_i4 (gfc_array_i4 * const restrict,
383 gfc_array_i4 * const restrict, const index_type * const restrict,
384 GFC_LOGICAL_4 *);
385 export_proto(siall_i4);
387 void
388 siall_i4 (gfc_array_i4 * const restrict retarray,
389 gfc_array_i4 * const restrict array,
390 const index_type * const restrict pdim,
391 GFC_LOGICAL_4 * mask)
393 index_type count[GFC_MAX_DIMENSIONS];
394 index_type extent[GFC_MAX_DIMENSIONS];
395 index_type dstride[GFC_MAX_DIMENSIONS];
396 GFC_INTEGER_4 * restrict dest;
397 index_type rank;
398 index_type n;
399 index_type dim;
402 if (*mask)
404 #ifdef HAVE_BACK_ARG
405 iall_i4 (retarray, array, pdim, back);
406 #else
407 iall_i4 (retarray, array, pdim);
408 #endif
409 return;
411 /* Make dim zero based to avoid confusion. */
412 dim = (*pdim) - 1;
413 rank = GFC_DESCRIPTOR_RANK (array) - 1;
415 if (unlikely (dim < 0 || dim > rank))
417 runtime_error ("Dim argument incorrect in IALL intrinsic: "
418 "is %ld, should be between 1 and %ld",
419 (long int) dim + 1, (long int) rank + 1);
422 for (n = 0; n < dim; n++)
424 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
426 if (extent[n] <= 0)
427 extent[n] = 0;
430 for (n = dim; n < rank; n++)
432 extent[n] =
433 GFC_DESCRIPTOR_EXTENT(array,n + 1);
435 if (extent[n] <= 0)
436 extent[n] = 0;
439 if (retarray->base_addr == NULL)
441 size_t alloc_size, str;
443 for (n = 0; n < rank; n++)
445 if (n == 0)
446 str = 1;
447 else
448 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
450 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
454 retarray->offset = 0;
455 retarray->dtype.rank = rank;
457 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
459 if (alloc_size == 0)
461 /* Make sure we have a zero-sized array. */
462 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
463 return;
465 else
466 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
468 else
470 if (rank != GFC_DESCRIPTOR_RANK (retarray))
471 runtime_error ("rank of return array incorrect in"
472 " IALL intrinsic: is %ld, should be %ld",
473 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
474 (long int) rank);
476 if (unlikely (compile_options.bounds_check))
478 for (n=0; n < rank; n++)
480 index_type ret_extent;
482 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
483 if (extent[n] != ret_extent)
484 runtime_error ("Incorrect extent in return value of"
485 " IALL intrinsic in dimension %ld:"
486 " is %ld, should be %ld", (long int) n + 1,
487 (long int) ret_extent, (long int) extent[n]);
492 for (n = 0; n < rank; n++)
494 count[n] = 0;
495 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
498 dest = retarray->base_addr;
500 while(1)
502 *dest = 0;
503 count[0]++;
504 dest += dstride[0];
505 n = 0;
506 while (count[n] == extent[n])
508 /* When we get to the end of a dimension, reset it and increment
509 the next dimension. */
510 count[n] = 0;
511 /* We could precalculate these products, but this is a less
512 frequently used path so probably not worth it. */
513 dest -= dstride[n] * extent[n];
514 n++;
515 if (n >= rank)
516 return;
517 else
519 count[n]++;
520 dest += dstride[n];
526 #endif