1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
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.
11
12 Ligbfortran 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.
16
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.
20
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/>. */
25
26 #include "libgfortran.h"
27 #include <string.h>
28
29 /* PACK is specified as follows:
30
31 13.14.80 PACK (ARRAY, MASK, [VECTOR])
32
33 Description: Pack an array into an array of rank one under the
34 control of a mask.
35
36 Class: Transformational function.
37
38 Arguments:
39 ARRAY may be of any type. It shall not be scalar.
40 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
41 VECTOR (optional) shall be of the same type and type parameters
42 as ARRAY. VECTOR shall have at least as many elements as
43 there are true elements in MASK. If MASK is a scalar
44 with the value true, VECTOR shall have at least as many
45 elements as there are in ARRAY.
46
47 Result Characteristics: The result is an array of rank one with the
48 same type and type parameters as ARRAY. If VECTOR is present, the
49 result size is that of VECTOR; otherwise, the result size is the
50 number /t/ of true elements in MASK unless MASK is scalar with the
51 value true, in which case the result size is the size of ARRAY.
52
53 Result Value: Element /i/ of the result is the element of ARRAY
54 that corresponds to the /i/th true element of MASK, taking elements
55 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
56 present and has size /n/ > /t/, element /i/ of the result has the
57 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
58
59 Examples: The nonzero elements of an array M with the value
60 | 0 0 0 |
61 | 9 0 0 | may be "gathered" by the function PACK. The result of
62 | 0 0 7 |
63 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
64 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
65
66 There are two variants of the PACK intrinsic: one, where MASK is
67 array valued, and the other one where MASK is scalar. */
68
69 static void
70 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
71 const gfc_array_l1 *mask, const gfc_array_char *vector,
72 index_type size)
73 {
74 /* r.* indicates the return array. */
75 index_type rstride0;
76 char * restrict rptr;
77 /* s.* indicates the source array. */
78 index_type sstride[GFC_MAX_DIMENSIONS];
79 index_type sstride0;
80 const char *sptr;
81 /* m.* indicates the mask array. */
82 index_type mstride[GFC_MAX_DIMENSIONS];
83 index_type mstride0;
84 const GFC_LOGICAL_1 *mptr;
85
86 index_type count[GFC_MAX_DIMENSIONS];
87 index_type extent[GFC_MAX_DIMENSIONS];
88 bool zero_sized;
89 index_type n;
90 index_type dim;
91 index_type nelem;
92 index_type total;
93 int mask_kind;
94
95 dim = GFC_DESCRIPTOR_RANK (array);
96
97 sstride[0] = 0; /* Avoid warnings if not initialized. */
98 mstride[0] = 0;
99
100 sptr = array->base_addr;
101 mptr = mask->base_addr;
102
103 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
104 and using shifting to address size and endian issues. */
105
106 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
107
108 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
109 #ifdef HAVE_GFC_LOGICAL_16
110 || mask_kind == 16
111 #endif
112 )
113 {
114 /* Don't convert a NULL pointer as we use test for NULL below. */
115 if (mptr)
116 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
117 }
118 else
119 runtime_error ("Funny sized logical array");
120
121 zero_sized = false;
122 for (n = 0; n < dim; n++)
123 {
124 count[n] = 0;
125 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
126 if (extent[n] <= 0)
127 zero_sized = true;
128 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
129 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
130 }
131 if (sstride[0] == 0)
132 sstride[0] = size;
133 if (mstride[0] == 0)
134 mstride[0] = mask_kind;
135
136 if (zero_sized)
137 sptr = NULL;
138 else
139 sptr = array->base_addr;
140
141 if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
142 {
143 /* Count the elements, either for allocating memory or
144 for bounds checking. */
145
146 if (vector != NULL)
147 {
148 /* The return array will have as many
149 elements as there are in VECTOR. */
150 total = GFC_DESCRIPTOR_EXTENT(vector,0);
151 }
152 else
153 {
154 /* We have to count the true elements in MASK. */
155
156 total = count_0 (mask);
157 }
158
159 if (ret->base_addr == NULL)
160 {
161 /* Setup the array descriptor. */
162 GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
163
164 ret->offset = 0;
165 /* xmallocarray allocates a single byte for zero size. */
166 ret->base_addr = xmallocarray (total, size);
167
168 if (total == 0)
169 return; /* In this case, nothing remains to be done. */
170 }
171 else
172 {
173 /* We come here because of range checking. */
174 index_type ret_extent;
175
176 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
177 if (total != ret_extent)
178 runtime_error ("Incorrect extent in return value of PACK intrinsic;"
179 " is %ld, should be %ld", (long int) total,
180 (long int) ret_extent);
181 }
182 }
183
184 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
185 if (rstride0 == 0)
186 rstride0 = size;
187 sstride0 = sstride[0];
188 mstride0 = mstride[0];
189 rptr = ret->base_addr;
190
191 while (sptr && mptr)
192 {
193 /* Test this element. */
194 if (*mptr)
195 {
196 /* Add it. */
197 memcpy (rptr, sptr, size);
198 rptr += rstride0;
199 }
200 /* Advance to the next element. */
201 sptr += sstride0;
202 mptr += mstride0;
203 count[0]++;
204 n = 0;
205 while (count[n] == extent[n])
206 {
207 /* When we get to the end of a dimension, reset it and increment
208 the next dimension. */
209 count[n] = 0;
210 /* We could precalculate these products, but this is a less
211 frequently used path so probably not worth it. */
212 sptr -= sstride[n] * extent[n];
213 mptr -= mstride[n] * extent[n];
214 n++;
215 if (n >= dim)
216 {
217 /* Break out of the loop. */
218 sptr = NULL;
219 break;
220 }
221 else
222 {
223 count[n]++;
224 sptr += sstride[n];
225 mptr += mstride[n];
226 }
227 }
228 }
229
230 /* Add any remaining elements from VECTOR. */
231 if (vector)
232 {
233 n = GFC_DESCRIPTOR_EXTENT(vector,0);
234 nelem = ((rptr - ret->base_addr) / rstride0);
235 if (n > nelem)
236 {
237 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
238 if (sstride0 == 0)
239 sstride0 = size;
240
241 sptr = vector->base_addr + sstride0 * nelem;
242 n -= nelem;
243 while (n--)
244 {
245 memcpy (rptr, sptr, size);
246 rptr += rstride0;
247 sptr += sstride0;
248 }
249 }
250 }
251 }
252
253 extern void pack (gfc_array_char *, const gfc_array_char *,
254 const gfc_array_l1 *, const gfc_array_char *);
255 export_proto(pack);
256
257 void
258 pack (gfc_array_char *ret, const gfc_array_char *array,
259 const gfc_array_l1 *mask, const gfc_array_char *vector)
260 {
261 index_type type_size;
262 index_type size;
263
264 type_size = GFC_DTYPE_TYPE_SIZE(array);
265
266 switch(type_size)
267 {
268 case GFC_DTYPE_LOGICAL_1:
269 case GFC_DTYPE_INTEGER_1:
270 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
271 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
272 return;
273
274 case GFC_DTYPE_LOGICAL_2:
275 case GFC_DTYPE_INTEGER_2:
276 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
277 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
278 return;
279
280 case GFC_DTYPE_LOGICAL_4:
281 case GFC_DTYPE_INTEGER_4:
282 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
283 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
284 return;
285
286 case GFC_DTYPE_LOGICAL_8:
287 case GFC_DTYPE_INTEGER_8:
288 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
289 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
290 return;
291
292 #ifdef HAVE_GFC_INTEGER_16
293 case GFC_DTYPE_LOGICAL_16:
294 case GFC_DTYPE_INTEGER_16:
295 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
296 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
297 return;
298 #endif
299
300 case GFC_DTYPE_REAL_4:
301 pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
302 (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
303 return;
304
305 case GFC_DTYPE_REAL_8:
306 pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
307 (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
308 return;
309
310 /* FIXME: This here is a hack, which will have to be removed when
311 the array descriptor is reworked. Currently, we don't store the
312 kind value for the type, but only the size. Because on targets with
313 _Float128, we have sizeof(long double) == sizeof(_Float128),
314 we cannot discriminate here and have to fall back to the generic
315 handling (which is suboptimal). */
316 #if !defined(GFC_REAL_16_IS_FLOAT128)
317 # ifdef HAVE_GFC_REAL_10
318 case GFC_DTYPE_REAL_10:
319 pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
320 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
321 return;
322 # endif
323
324 # ifdef HAVE_GFC_REAL_16
325 case GFC_DTYPE_REAL_16:
326 pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
327 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
328 return;
329 # endif
330 #endif
331
332 case GFC_DTYPE_COMPLEX_4:
333 pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
334 (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
335 return;
336
337 case GFC_DTYPE_COMPLEX_8:
338 pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
339 (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
340 return;
341
342 /* FIXME: This here is a hack, which will have to be removed when
343 the array descriptor is reworked. Currently, we don't store the
344 kind value for the type, but only the size. Because on targets with
345 _Float128, we have sizeof(long double) == sizeof(_Float128),
346 we cannot discriminate here and have to fall back to the generic
347 handling (which is suboptimal). */
348 #if !defined(GFC_REAL_16_IS_FLOAT128)
349 # ifdef HAVE_GFC_COMPLEX_10
350 case GFC_DTYPE_COMPLEX_10:
351 pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
352 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
353 return;
354 # endif
355
356 # ifdef HAVE_GFC_COMPLEX_16
357 case GFC_DTYPE_COMPLEX_16:
358 pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
359 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
360 return;
361 # endif
362 #endif
363 }
364
365 /* For other types, let's check the actual alignment of the data pointers.
366 If they are aligned, we can safely call the unpack functions. */
367
368 switch (GFC_DESCRIPTOR_SIZE (array))
369 {
370 case 1:
371 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
372 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
373 return;
374
375 case 2:
376 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
377 || (vector && GFC_UNALIGNED_2(vector->base_addr)))
378 break;
379 else
380 {
381 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
382 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
383 return;
384 }
385
386 case 4:
387 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
388 || (vector && GFC_UNALIGNED_4(vector->base_addr)))
389 break;
390 else
391 {
392 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
393 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
394 return;
395 }
396
397 case 8:
398 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
399 || (vector && GFC_UNALIGNED_8(vector->base_addr)))
400 break;
401 else
402 {
403 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
404 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
405 return;
406 }
407
408 #ifdef HAVE_GFC_INTEGER_16
409 case 16:
410 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
411 || (vector && GFC_UNALIGNED_16(vector->base_addr)))
412 break;
413 else
414 {
415 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
416 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
417 return;
418 }
419 #endif
420 default:
421 break;
422 }
423
424 size = GFC_DESCRIPTOR_SIZE (array);
425 pack_internal (ret, array, mask, vector, size);
426 }
427
428
429 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
430 const gfc_array_l1 *, const gfc_array_char *,
431 GFC_INTEGER_4, GFC_INTEGER_4);
432 export_proto(pack_char);
433
434 void
435 pack_char (gfc_array_char *ret,
436 GFC_INTEGER_4 ret_length __attribute__((unused)),
437 const gfc_array_char *array, const gfc_array_l1 *mask,
438 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
439 GFC_INTEGER_4 vector_length __attribute__((unused)))
440 {
441 pack_internal (ret, array, mask, vector, array_length);
442 }
443
444
445 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
446 const gfc_array_l1 *, const gfc_array_char *,
447 GFC_INTEGER_4, GFC_INTEGER_4);
448 export_proto(pack_char4);
449
450 void
451 pack_char4 (gfc_array_char *ret,
452 GFC_INTEGER_4 ret_length __attribute__((unused)),
453 const gfc_array_char *array, const gfc_array_l1 *mask,
454 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
455 GFC_INTEGER_4 vector_length __attribute__((unused)))
456 {
457 pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
458 }
459
460
461 static void
462 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
463 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
464 index_type size)
465 {
466 /* r.* indicates the return array. */
467 index_type rstride0;
468 char *rptr;
469 /* s.* indicates the source array. */
470 index_type sstride[GFC_MAX_DIMENSIONS];
471 index_type sstride0;
472 const char *sptr;
473
474 index_type count[GFC_MAX_DIMENSIONS];
475 index_type extent[GFC_MAX_DIMENSIONS];
476 index_type n;
477 index_type dim;
478 index_type ssize;
479 index_type nelem;
480 index_type total;
481
482 dim = GFC_DESCRIPTOR_RANK (array);
483 /* Initialize sstride[0] to avoid -Wmaybe-uninitialized
484 complaints. */
485 sstride[0] = size;
486 ssize = 1;
487 for (n = 0; n < dim; n++)
488 {
489 count[n] = 0;
490 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
491 if (extent[n] < 0)
492 extent[n] = 0;
493
494 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
495 ssize *= extent[n];
496 }
497 if (sstride[0] == 0)
498 sstride[0] = size;
499
500 sstride0 = sstride[0];
501
502 if (ssize != 0)
503 sptr = array->base_addr;
504 else
505 sptr = NULL;
506
507 if (ret->base_addr == NULL)
508 {
509 /* Allocate the memory for the result. */
510
511 if (vector != NULL)
512 {
513 /* The return array will have as many elements as there are
514 in vector. */
515 total = GFC_DESCRIPTOR_EXTENT(vector,0);
516 if (total <= 0)
517 {
518 total = 0;
519 vector = NULL;
520 }
521 }
522 else
523 {
524 if (*mask)
525 {
526 /* The result array will have as many elements as the input
527 array. */
528 total = extent[0];
529 for (n = 1; n < dim; n++)
530 total *= extent[n];
531 }
532 else
533 /* The result array will be empty. */
534 total = 0;
535 }
536
537 /* Setup the array descriptor. */
538 GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
539
540 ret->offset = 0;
541
542 ret->base_addr = xmallocarray (total, size);
543
544 if (total == 0)
545 return;
546 }
547
548 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
549 if (rstride0 == 0)
550 rstride0 = size;
551 rptr = ret->base_addr;
552
553 /* The remaining possibilities are now:
554 If MASK is .TRUE., we have to copy the source array into the
555 result array. We then have to fill it up with elements from VECTOR.
556 If MASK is .FALSE., we have to copy VECTOR into the result
557 array. If VECTOR were not present we would have already returned. */
558
559 if (*mask && ssize != 0)
560 {
561 while (sptr)
562 {
563 /* Add this element. */
564 memcpy (rptr, sptr, size);
565 rptr += rstride0;
566
567 /* Advance to the next element. */
568 sptr += sstride0;
569 count[0]++;
570 n = 0;
571 while (count[n] == extent[n])
572 {
573 /* When we get to the end of a dimension, reset it and
574 increment the next dimension. */
575 count[n] = 0;
576 /* We could precalculate these products, but this is a
577 less frequently used path so probably not worth it. */
578 sptr -= sstride[n] * extent[n];
579 n++;
580 if (n >= dim)
581 {
582 /* Break out of the loop. */
583 sptr = NULL;
584 break;
585 }
586 else
587 {
588 count[n]++;
589 sptr += sstride[n];
590 }
591 }
592 }
593 }
594
595 /* Add any remaining elements from VECTOR. */
596 if (vector)
597 {
598 n = GFC_DESCRIPTOR_EXTENT(vector,0);
599 nelem = ((rptr - ret->base_addr) / rstride0);
600 if (n > nelem)
601 {
602 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
603 if (sstride0 == 0)
604 sstride0 = size;
605
606 sptr = vector->base_addr + sstride0 * nelem;
607 n -= nelem;
608 while (n--)
609 {
610 memcpy (rptr, sptr, size);
611 rptr += rstride0;
612 sptr += sstride0;
613 }
614 }
615 }
616 }
617
618 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
619 const GFC_LOGICAL_4 *, const gfc_array_char *);
620 export_proto(pack_s);
621
622 void
623 pack_s (gfc_array_char *ret, const gfc_array_char *array,
624 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
625 {
626 pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
627 }
628
629
630 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
631 const gfc_array_char *array, const GFC_LOGICAL_4 *,
632 const gfc_array_char *, GFC_INTEGER_4,
633 GFC_INTEGER_4);
634 export_proto(pack_s_char);
635
636 void
637 pack_s_char (gfc_array_char *ret,
638 GFC_INTEGER_4 ret_length __attribute__((unused)),
639 const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
640 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
641 GFC_INTEGER_4 vector_length __attribute__((unused)))
642 {
643 pack_s_internal (ret, array, mask, vector, array_length);
644 }
645
646
647 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
648 const gfc_array_char *array, const GFC_LOGICAL_4 *,
649 const gfc_array_char *, GFC_INTEGER_4,
650 GFC_INTEGER_4);
651 export_proto(pack_s_char4);
652
653 void
654 pack_s_char4 (gfc_array_char *ret,
655 GFC_INTEGER_4 ret_length __attribute__((unused)),
656 const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
657 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
658 GFC_INTEGER_4 vector_length __attribute__((unused)))
659 {
660 pack_s_internal (ret, array, mask, vector,
661 array_length * sizeof (gfc_char4_t));
662 }