1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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"
31 /* PACK is specified as follows:
33 13.14.80 PACK (ARRAY, MASK, [VECTOR])
35 Description: Pack an array into an array of rank one under the
38 Class: Transformational function.
41 ARRAY may be of any type. It shall not be scalar.
42 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
43 VECTOR (optional) shall be of the same type and type parameters
44 as ARRAY. VECTOR shall have at least as many elements as
45 there are true elements in MASK. If MASK is a scalar
46 with the value true, VECTOR shall have at least as many
47 elements as there are in ARRAY.
49 Result Characteristics: The result is an array of rank one with the
50 same type and type parameters as ARRAY. If VECTOR is present, the
51 result size is that of VECTOR; otherwise, the result size is the
52 number /t/ of true elements in MASK unless MASK is scalar with the
53 value true, in which case the result size is the size of ARRAY.
55 Result Value: Element /i/ of the result is the element of ARRAY
56 that corresponds to the /i/th true element of MASK, taking elements
57 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
58 present and has size /n/ > /t/, element /i/ of the result has the
59 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
61 Examples: The nonzero elements of an array M with the value
63 | 9 0 0 | may be "gathered" by the function PACK. The result of
65 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
66 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
68 There are two variants of the PACK intrinsic: one, where MASK is
69 array valued, and the other one where MASK is scalar. */
72 pack_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
73 const gfc_array_l1
*mask
, const gfc_array_char
*vector
,
76 /* r.* indicates the return array. */
79 /* s.* indicates the source array. */
80 index_type sstride
[GFC_MAX_DIMENSIONS
];
83 /* m.* indicates the mask array. */
84 index_type mstride
[GFC_MAX_DIMENSIONS
];
86 const GFC_LOGICAL_1
*mptr
;
88 index_type count
[GFC_MAX_DIMENSIONS
];
89 index_type extent
[GFC_MAX_DIMENSIONS
];
97 dim
= GFC_DESCRIPTOR_RANK (array
);
102 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
103 and using shifting to address size and endian issues. */
105 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
107 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
108 #ifdef HAVE_GFC_LOGICAL_16
113 /* Don't convert a NULL pointer as we use test for NULL below. */
115 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
118 runtime_error ("Funny sized logical array");
121 for (n
= 0; n
< dim
; n
++)
124 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
127 sstride
[n
] = array
->dim
[n
].stride
* size
;
128 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
133 mstride
[0] = mask_kind
;
135 if (ret
->data
== NULL
|| compile_options
.bounds_check
)
137 /* Count the elements, either for allocating memory or
138 for bounds checking. */
142 /* The return array will have as many
143 elements as there are in VECTOR. */
144 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
148 /* We have to count the true elements in MASK. */
150 /* TODO: We could speed up pack easily in the case of only
151 few .TRUE. entries in MASK, by keeping track of where we
152 would be in the source array during the initial traversal
153 of MASK, and caching the pointers to those elements. Then,
154 supposed the number of elements is small enough, we would
155 only have to traverse the list, and copy those elements
156 into the result array. In the case of datatypes which fit
157 in one of the integer types we could also cache the
158 value instead of a pointer to it.
159 This approach might be bad from the point of view of
160 cache behavior in the case where our cache is not big
161 enough to hold all elements that have to be copied. */
163 const GFC_LOGICAL_1
*m
= mptr
;
171 /* Test this element. */
175 /* Advance to the next element. */
179 while (count
[n
] == extent
[n
])
181 /* When we get to the end of a dimension, reset it
182 and increment the next dimension. */
184 /* We could precalculate this product, but this is a
185 less frequently used path so probably not worth
187 m
-= mstride
[n
] * extent
[n
];
191 /* Break out of the loop. */
204 if (ret
->data
== NULL
)
206 /* Setup the array descriptor. */
207 ret
->dim
[0].lbound
= 0;
208 ret
->dim
[0].ubound
= total
- 1;
209 ret
->dim
[0].stride
= 1;
214 /* In this case, nothing remains to be done. */
215 ret
->data
= internal_malloc_size (1);
219 ret
->data
= internal_malloc_size (size
* total
);
223 /* We come here because of range checking. */
224 index_type ret_extent
;
226 ret_extent
= ret
->dim
[0].ubound
+ 1 - ret
->dim
[0].lbound
;
227 if (total
!= ret_extent
)
228 runtime_error ("Incorrect extent in return value of PACK intrinsic;"
229 " is %ld, should be %ld", (long int) total
,
230 (long int) ret_extent
);
234 rstride0
= ret
->dim
[0].stride
* size
;
237 sstride0
= sstride
[0];
238 mstride0
= mstride
[0];
243 /* Test this element. */
247 memcpy (rptr
, sptr
, size
);
250 /* Advance to the next element. */
255 while (count
[n
] == extent
[n
])
257 /* When we get to the end of a dimension, reset it and increment
258 the next dimension. */
260 /* We could precalculate these products, but this is a less
261 frequently used path so probably not worth it. */
262 sptr
-= sstride
[n
] * extent
[n
];
263 mptr
-= mstride
[n
] * extent
[n
];
267 /* Break out of the loop. */
280 /* Add any remaining elements from VECTOR. */
283 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
284 nelem
= ((rptr
- ret
->data
) / rstride0
);
287 sstride0
= vector
->dim
[0].stride
* size
;
291 sptr
= vector
->data
+ sstride0
* nelem
;
295 memcpy (rptr
, sptr
, size
);
303 extern void pack (gfc_array_char
*, const gfc_array_char
*,
304 const gfc_array_l1
*, const gfc_array_char
*);
308 pack (gfc_array_char
*ret
, const gfc_array_char
*array
,
309 const gfc_array_l1
*mask
, const gfc_array_char
*vector
)
311 index_type type_size
;
314 type_size
= GFC_DTYPE_TYPE_SIZE(array
);
318 case GFC_DTYPE_LOGICAL_1
:
319 case GFC_DTYPE_INTEGER_1
:
320 case GFC_DTYPE_DERIVED_1
:
321 pack_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
,
322 (gfc_array_l1
*) mask
, (gfc_array_i1
*) vector
);
325 case GFC_DTYPE_LOGICAL_2
:
326 case GFC_DTYPE_INTEGER_2
:
327 pack_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
,
328 (gfc_array_l1
*) mask
, (gfc_array_i2
*) vector
);
331 case GFC_DTYPE_LOGICAL_4
:
332 case GFC_DTYPE_INTEGER_4
:
334 pack_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) array
,
335 (gfc_array_l1
*) mask
, (gfc_array_i4
*) vector
);
338 case GFC_DTYPE_LOGICAL_8
:
339 case GFC_DTYPE_INTEGER_8
:
341 pack_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) array
,
342 (gfc_array_l1
*) mask
, (gfc_array_i8
*) vector
);
345 #ifdef HAVE_GFC_INTEGER_16
346 case GFC_DTYPE_LOGICAL_16
:
347 case GFC_DTYPE_INTEGER_16
:
349 pack_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
350 (gfc_array_l1
*) mask
, (gfc_array_i16
*) vector
);
353 case GFC_DTYPE_REAL_4
:
354 pack_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) array
,
355 (gfc_array_l1
*) mask
, (gfc_array_r4
*) vector
);
358 case GFC_DTYPE_REAL_8
:
359 pack_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) array
,
360 (gfc_array_l1
*) mask
, (gfc_array_r8
*) vector
);
363 #ifdef HAVE_GFC_REAL_10
364 case GFC_DTYPE_REAL_10
:
365 pack_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) array
,
366 (gfc_array_l1
*) mask
, (gfc_array_r10
*) vector
);
370 #ifdef HAVE_GFC_REAL_16
371 case GFC_DTYPE_REAL_16
:
372 pack_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) array
,
373 (gfc_array_l1
*) mask
, (gfc_array_r16
*) vector
);
376 case GFC_DTYPE_COMPLEX_4
:
377 pack_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) array
,
378 (gfc_array_l1
*) mask
, (gfc_array_c4
*) vector
);
381 case GFC_DTYPE_COMPLEX_8
:
382 pack_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
,
383 (gfc_array_l1
*) mask
, (gfc_array_c8
*) vector
);
386 #ifdef HAVE_GFC_COMPLEX_10
387 case GFC_DTYPE_COMPLEX_10
:
388 pack_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) array
,
389 (gfc_array_l1
*) mask
, (gfc_array_c10
*) vector
);
393 #ifdef HAVE_GFC_COMPLEX_16
394 case GFC_DTYPE_COMPLEX_16
:
395 pack_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) array
,
396 (gfc_array_l1
*) mask
, (gfc_array_c16
*) vector
);
400 /* For derived types, let's check the actual alignment of the
401 data pointers. If they are aligned, we can safely call
402 the unpack functions. */
404 case GFC_DTYPE_DERIVED_2
:
405 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(array
->data
)
406 || GFC_UNALIGNED_2(vector
->data
))
410 pack_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
,
411 (gfc_array_l1
*) mask
, (gfc_array_i2
*) vector
);
415 case GFC_DTYPE_DERIVED_4
:
416 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(array
->data
)
417 || GFC_UNALIGNED_4(vector
->data
))
421 pack_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) array
,
422 (gfc_array_l1
*) mask
, (gfc_array_i4
*) vector
);
426 case GFC_DTYPE_DERIVED_8
:
427 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(array
->data
)
428 || GFC_UNALIGNED_8(vector
->data
))
432 pack_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) array
,
433 (gfc_array_l1
*) mask
, (gfc_array_i8
*) vector
);
436 #ifdef HAVE_GFC_INTEGER_16
437 case GFC_DTYPE_DERIVED_16
:
438 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(array
->data
)
439 || GFC_UNALIGNED_16(vector
->data
))
443 pack_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
444 (gfc_array_l1
*) mask
, (gfc_array_i16
*) vector
);
451 size
= GFC_DESCRIPTOR_SIZE (array
);
452 pack_internal (ret
, array
, mask
, vector
, size
);
456 extern void pack_char (gfc_array_char
*, GFC_INTEGER_4
, const gfc_array_char
*,
457 const gfc_array_l1
*, const gfc_array_char
*,
458 GFC_INTEGER_4
, GFC_INTEGER_4
);
459 export_proto(pack_char
);
462 pack_char (gfc_array_char
*ret
,
463 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
464 const gfc_array_char
*array
, const gfc_array_l1
*mask
,
465 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
466 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
468 pack_internal (ret
, array
, mask
, vector
, array_length
);
472 extern void pack_char4 (gfc_array_char
*, GFC_INTEGER_4
, const gfc_array_char
*,
473 const gfc_array_l1
*, const gfc_array_char
*,
474 GFC_INTEGER_4
, GFC_INTEGER_4
);
475 export_proto(pack_char4
);
478 pack_char4 (gfc_array_char
*ret
,
479 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
480 const gfc_array_char
*array
, const gfc_array_l1
*mask
,
481 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
482 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
484 pack_internal (ret
, array
, mask
, vector
, array_length
* sizeof (gfc_char4_t
));
489 pack_s_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
490 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
,
493 /* r.* indicates the return array. */
496 /* s.* indicates the source array. */
497 index_type sstride
[GFC_MAX_DIMENSIONS
];
501 index_type count
[GFC_MAX_DIMENSIONS
];
502 index_type extent
[GFC_MAX_DIMENSIONS
];
509 dim
= GFC_DESCRIPTOR_RANK (array
);
511 for (n
= 0; n
< dim
; n
++)
514 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
518 sstride
[n
] = array
->dim
[n
].stride
* size
;
524 sstride0
= sstride
[0];
531 if (ret
->data
== NULL
)
533 /* Allocate the memory for the result. */
537 /* The return array will have as many elements as there are
539 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
550 /* The result array will have as many elements as the input
553 for (n
= 1; n
< dim
; n
++)
557 /* The result array will be empty. */
561 /* Setup the array descriptor. */
562 ret
->dim
[0].lbound
= 0;
563 ret
->dim
[0].ubound
= total
- 1;
564 ret
->dim
[0].stride
= 1;
569 ret
->data
= internal_malloc_size (1);
573 ret
->data
= internal_malloc_size (size
* total
);
576 rstride0
= ret
->dim
[0].stride
* size
;
581 /* The remaining possibilities are now:
582 If MASK is .TRUE., we have to copy the source array into the
583 result array. We then have to fill it up with elements from VECTOR.
584 If MASK is .FALSE., we have to copy VECTOR into the result
585 array. If VECTOR were not present we would have already returned. */
587 if (*mask
&& ssize
!= 0)
591 /* Add this element. */
592 memcpy (rptr
, sptr
, size
);
595 /* Advance to the next element. */
599 while (count
[n
] == extent
[n
])
601 /* When we get to the end of a dimension, reset it and
602 increment the next dimension. */
604 /* We could precalculate these products, but this is a
605 less frequently used path so probably not worth it. */
606 sptr
-= sstride
[n
] * extent
[n
];
610 /* Break out of the loop. */
623 /* Add any remaining elements from VECTOR. */
626 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
627 nelem
= ((rptr
- ret
->data
) / rstride0
);
630 sstride0
= vector
->dim
[0].stride
* size
;
634 sptr
= vector
->data
+ sstride0
* nelem
;
638 memcpy (rptr
, sptr
, size
);
646 extern void pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
647 const GFC_LOGICAL_4
*, const gfc_array_char
*);
648 export_proto(pack_s
);
651 pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
652 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
)
654 pack_s_internal (ret
, array
, mask
, vector
, GFC_DESCRIPTOR_SIZE (array
));
658 extern void pack_s_char (gfc_array_char
*ret
, GFC_INTEGER_4
,
659 const gfc_array_char
*array
, const GFC_LOGICAL_4
*,
660 const gfc_array_char
*, GFC_INTEGER_4
,
662 export_proto(pack_s_char
);
665 pack_s_char (gfc_array_char
*ret
,
666 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
667 const gfc_array_char
*array
, const GFC_LOGICAL_4
*mask
,
668 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
669 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
671 pack_s_internal (ret
, array
, mask
, vector
, array_length
);
675 extern void pack_s_char4 (gfc_array_char
*ret
, GFC_INTEGER_4
,
676 const gfc_array_char
*array
, const GFC_LOGICAL_4
*,
677 const gfc_array_char
*, GFC_INTEGER_4
,
679 export_proto(pack_s_char4
);
682 pack_s_char4 (gfc_array_char
*ret
,
683 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
684 const gfc_array_char
*array
, const GFC_LOGICAL_4
*mask
,
685 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
686 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
688 pack_s_internal (ret
, array
, mask
, vector
,
689 array_length
* sizeof (gfc_char4_t
));