1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
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 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.
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 /* PACK is specified as follows:
31 13.14.80 PACK (ARRAY, MASK, [VECTOR])
33 Description: Pack an array into an array of rank one under the
36 Class: Transformational function.
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.
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.
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/.
59 Examples: The nonzero elements of an array M with the value
61 | 9 0 0 | may be "gathered" by the function PACK. The result of
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].
66 There are two variants of the PACK intrinsic: one, where MASK is
67 array valued, and the other one where MASK is scalar. */
70 pack_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
71 const gfc_array_l1
*mask
, const gfc_array_char
*vector
,
74 /* r.* indicates the return array. */
77 /* s.* indicates the source array. */
78 index_type sstride
[GFC_MAX_DIMENSIONS
];
81 /* m.* indicates the mask array. */
82 index_type mstride
[GFC_MAX_DIMENSIONS
];
84 const GFC_LOGICAL_1
*mptr
;
86 index_type count
[GFC_MAX_DIMENSIONS
];
87 index_type extent
[GFC_MAX_DIMENSIONS
];
95 dim
= GFC_DESCRIPTOR_RANK (array
);
97 sstride
[0] = 0; /* Avoid warnings if not initialized. */
100 sptr
= array
->base_addr
;
101 mptr
= mask
->base_addr
;
103 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
104 and using shifting to address size and endian issues. */
106 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
108 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
109 #ifdef HAVE_GFC_LOGICAL_16
114 /* Don't convert a NULL pointer as we use test for NULL below. */
116 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
119 runtime_error ("Funny sized logical array");
122 for (n
= 0; n
< dim
; n
++)
125 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
128 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,n
);
129 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
134 mstride
[0] = mask_kind
;
139 sptr
= array
->base_addr
;
141 if (ret
->base_addr
== NULL
|| unlikely (compile_options
.bounds_check
))
143 /* Count the elements, either for allocating memory or
144 for bounds checking. */
148 /* The return array will have as many
149 elements as there are in VECTOR. */
150 total
= GFC_DESCRIPTOR_EXTENT(vector
,0);
154 /* We have to count the true elements in MASK. */
156 total
= count_0 (mask
);
159 if (ret
->base_addr
== NULL
)
161 /* Setup the array descriptor. */
162 GFC_DIMENSION_SET(ret
->dim
[0], 0, total
-1, 1);
165 /* xmallocarray allocates a single byte for zero size. */
166 ret
->base_addr
= xmallocarray (total
, size
);
169 return; /* In this case, nothing remains to be done. */
173 /* We come here because of range checking. */
174 index_type ret_extent
;
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
);
184 rstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,0);
187 sstride0
= sstride
[0];
188 mstride0
= mstride
[0];
189 rptr
= ret
->base_addr
;
193 /* Test this element. */
197 memcpy (rptr
, sptr
, size
);
200 /* Advance to the next element. */
205 while (count
[n
] == extent
[n
])
207 /* When we get to the end of a dimension, reset it and increment
208 the next dimension. */
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
];
217 /* Break out of the loop. */
230 /* Add any remaining elements from VECTOR. */
233 n
= GFC_DESCRIPTOR_EXTENT(vector
,0);
234 nelem
= ((rptr
- ret
->base_addr
) / rstride0
);
237 sstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(vector
,0);
241 sptr
= vector
->base_addr
+ sstride0
* nelem
;
245 memcpy (rptr
, sptr
, size
);
253 extern void pack (gfc_array_char
*, const gfc_array_char
*,
254 const gfc_array_l1
*, const gfc_array_char
*);
258 pack (gfc_array_char
*ret
, const gfc_array_char
*array
,
259 const gfc_array_l1
*mask
, const gfc_array_char
*vector
)
261 index_type type_size
;
264 type_size
= GFC_DTYPE_TYPE_SIZE(array
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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
);
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. */
368 switch (GFC_DESCRIPTOR_SIZE (array
))
371 pack_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
,
372 (gfc_array_l1
*) mask
, (gfc_array_i1
*) vector
);
376 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(array
->base_addr
)
377 || (vector
&& GFC_UNALIGNED_2(vector
->base_addr
)))
381 pack_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
,
382 (gfc_array_l1
*) mask
, (gfc_array_i2
*) vector
);
387 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(array
->base_addr
)
388 || (vector
&& GFC_UNALIGNED_4(vector
->base_addr
)))
392 pack_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) array
,
393 (gfc_array_l1
*) mask
, (gfc_array_i4
*) vector
);
398 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(array
->base_addr
)
399 || (vector
&& GFC_UNALIGNED_8(vector
->base_addr
)))
403 pack_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) array
,
404 (gfc_array_l1
*) mask
, (gfc_array_i8
*) vector
);
408 #ifdef HAVE_GFC_INTEGER_16
410 if (GFC_UNALIGNED_16(ret
->base_addr
) || GFC_UNALIGNED_16(array
->base_addr
)
411 || (vector
&& GFC_UNALIGNED_16(vector
->base_addr
)))
415 pack_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
416 (gfc_array_l1
*) mask
, (gfc_array_i16
*) vector
);
424 size
= GFC_DESCRIPTOR_SIZE (array
);
425 pack_internal (ret
, array
, mask
, vector
, size
);
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
);
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
)))
441 pack_internal (ret
, array
, mask
, vector
, array_length
);
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
);
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
)))
457 pack_internal (ret
, array
, mask
, vector
, array_length
* sizeof (gfc_char4_t
));
462 pack_s_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
463 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
,
466 /* r.* indicates the return array. */
469 /* s.* indicates the source array. */
470 index_type sstride
[GFC_MAX_DIMENSIONS
];
474 index_type count
[GFC_MAX_DIMENSIONS
];
475 index_type extent
[GFC_MAX_DIMENSIONS
];
482 dim
= GFC_DESCRIPTOR_RANK (array
);
483 /* Initialize sstride[0] to avoid -Wmaybe-uninitialized
487 for (n
= 0; n
< dim
; n
++)
490 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
494 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,n
);
500 sstride0
= sstride
[0];
503 sptr
= array
->base_addr
;
507 if (ret
->base_addr
== NULL
)
509 /* Allocate the memory for the result. */
513 /* The return array will have as many elements as there are
515 total
= GFC_DESCRIPTOR_EXTENT(vector
,0);
526 /* The result array will have as many elements as the input
529 for (n
= 1; n
< dim
; n
++)
533 /* The result array will be empty. */
537 /* Setup the array descriptor. */
538 GFC_DIMENSION_SET(ret
->dim
[0],0,total
-1,1);
542 ret
->base_addr
= xmallocarray (total
, size
);
548 rstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,0);
551 rptr
= ret
->base_addr
;
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. */
559 if (*mask
&& ssize
!= 0)
563 /* Add this element. */
564 memcpy (rptr
, sptr
, size
);
567 /* Advance to the next element. */
571 while (count
[n
] == extent
[n
])
573 /* When we get to the end of a dimension, reset it and
574 increment the next dimension. */
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
];
582 /* Break out of the loop. */
595 /* Add any remaining elements from VECTOR. */
598 n
= GFC_DESCRIPTOR_EXTENT(vector
,0);
599 nelem
= ((rptr
- ret
->base_addr
) / rstride0
);
602 sstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(vector
,0);
606 sptr
= vector
->base_addr
+ sstride0
* nelem
;
610 memcpy (rptr
, sptr
, size
);
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
);
623 pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
624 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
)
626 pack_s_internal (ret
, array
, mask
, vector
, GFC_DESCRIPTOR_SIZE (array
));
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
,
634 export_proto(pack_s_char
);
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
)))
643 pack_s_internal (ret
, array
, mask
, vector
, array_length
);
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
,
651 export_proto(pack_s_char4
);
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
)))
660 pack_s_internal (ret
, array
, mask
, vector
,
661 array_length
* sizeof (gfc_char4_t
));