1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002, 2004, 2005, 2006, 2007 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 2 of the License, or (at your option) any later version.
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Ligbfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING. If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 #include "libgfortran.h"
36 /* PACK is specified as follows:
38 13.14.80 PACK (ARRAY, MASK, [VECTOR])
40 Description: Pack an array into an array of rank one under the
43 Class: Transformational function.
46 ARRAY may be of any type. It shall not be scalar.
47 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
48 VECTOR (optional) shall be of the same type and type parameters
49 as ARRAY. VECTOR shall have at least as many elements as
50 there are true elements in MASK. If MASK is a scalar
51 with the value true, VECTOR shall have at least as many
52 elements as there are in ARRAY.
54 Result Characteristics: The result is an array of rank one with the
55 same type and type parameters as ARRAY. If VECTOR is present, the
56 result size is that of VECTOR; otherwise, the result size is the
57 number /t/ of true elements in MASK unless MASK is scalar with the
58 value true, in which case the result size is the size of ARRAY.
60 Result Value: Element /i/ of the result is the element of ARRAY
61 that corresponds to the /i/th true element of MASK, taking elements
62 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
63 present and has size /n/ > /t/, element /i/ of the result has the
64 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
66 Examples: The nonzero elements of an array M with the value
68 | 9 0 0 | may be "gathered" by the function PACK. The result of
70 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
71 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
73 There are two variants of the PACK intrinsic: one, where MASK is
74 array valued, and the other one where MASK is scalar. */
77 pack_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
78 const gfc_array_l1
*mask
, const gfc_array_char
*vector
,
81 /* r.* indicates the return array. */
84 /* s.* indicates the source array. */
85 index_type sstride
[GFC_MAX_DIMENSIONS
];
88 /* m.* indicates the mask array. */
89 index_type mstride
[GFC_MAX_DIMENSIONS
];
91 const GFC_LOGICAL_1
*mptr
;
93 index_type count
[GFC_MAX_DIMENSIONS
];
94 index_type extent
[GFC_MAX_DIMENSIONS
];
102 dim
= GFC_DESCRIPTOR_RANK (array
);
107 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
108 and using shifting to address size and endian issues. */
110 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
112 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
113 #ifdef HAVE_GFC_LOGICAL_16
118 /* Don't convert a NULL pointer as we use test for NULL below. */
120 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
123 runtime_error ("Funny sized logical array");
126 for (n
= 0; n
< dim
; n
++)
129 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
132 sstride
[n
] = array
->dim
[n
].stride
* size
;
133 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
138 mstride
[0] = mask_kind
;
140 if (ret
->data
== NULL
|| compile_options
.bounds_check
)
142 /* Count the elements, either for allocating memory or
143 for bounds checking. */
147 /* The return array will have as many
148 elements as there are in VECTOR. */
149 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
153 /* We have to count the true elements in MASK. */
155 /* TODO: We could speed up pack easily in the case of only
156 few .TRUE. entries in MASK, by keeping track of where we
157 would be in the source array during the initial traversal
158 of MASK, and caching the pointers to those elements. Then,
159 supposed the number of elements is small enough, we would
160 only have to traverse the list, and copy those elements
161 into the result array. In the case of datatypes which fit
162 in one of the integer types we could also cache the
163 value instead of a pointer to it.
164 This approach might be bad from the point of view of
165 cache behavior in the case where our cache is not big
166 enough to hold all elements that have to be copied. */
168 const GFC_LOGICAL_1
*m
= mptr
;
176 /* Test this element. */
180 /* Advance to the next element. */
184 while (count
[n
] == extent
[n
])
186 /* When we get to the end of a dimension, reset it
187 and increment the next dimension. */
189 /* We could precalculate this product, but this is a
190 less frequently used path so probably not worth
192 m
-= mstride
[n
] * extent
[n
];
196 /* Break out of the loop. */
209 if (ret
->data
== NULL
)
211 /* Setup the array descriptor. */
212 ret
->dim
[0].lbound
= 0;
213 ret
->dim
[0].ubound
= total
- 1;
214 ret
->dim
[0].stride
= 1;
219 /* In this case, nothing remains to be done. */
220 ret
->data
= internal_malloc_size (1);
224 ret
->data
= internal_malloc_size (size
* total
);
228 /* We come here because of range checking. */
229 index_type ret_extent
;
231 ret_extent
= ret
->dim
[0].ubound
+ 1 - ret
->dim
[0].lbound
;
232 if (total
!= ret_extent
)
233 runtime_error ("Incorrect extent in return value of PACK intrinsic;"
234 " is %ld, should be %ld", (long int) total
,
235 (long int) ret_extent
);
239 rstride0
= ret
->dim
[0].stride
* size
;
242 sstride0
= sstride
[0];
243 mstride0
= mstride
[0];
248 /* Test this element. */
252 memcpy (rptr
, sptr
, size
);
255 /* Advance to the next element. */
260 while (count
[n
] == extent
[n
])
262 /* When we get to the end of a dimension, reset it and increment
263 the next dimension. */
265 /* We could precalculate these products, but this is a less
266 frequently used path so probably not worth it. */
267 sptr
-= sstride
[n
] * extent
[n
];
268 mptr
-= mstride
[n
] * extent
[n
];
272 /* Break out of the loop. */
285 /* Add any remaining elements from VECTOR. */
288 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
289 nelem
= ((rptr
- ret
->data
) / rstride0
);
292 sstride0
= vector
->dim
[0].stride
* size
;
296 sptr
= vector
->data
+ sstride0
* nelem
;
300 memcpy (rptr
, sptr
, size
);
308 extern void pack (gfc_array_char
*, const gfc_array_char
*,
309 const gfc_array_l1
*, const gfc_array_char
*);
313 pack (gfc_array_char
*ret
, const gfc_array_char
*array
,
314 const gfc_array_l1
*mask
, const gfc_array_char
*vector
)
316 index_type type_size
;
319 type_size
= GFC_DTYPE_TYPE_SIZE(array
);
323 case GFC_DTYPE_LOGICAL_1
:
324 case GFC_DTYPE_INTEGER_1
:
325 case GFC_DTYPE_DERIVED_1
:
326 pack_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
,
327 (gfc_array_l1
*) mask
, (gfc_array_i1
*) vector
);
330 case GFC_DTYPE_LOGICAL_2
:
331 case GFC_DTYPE_INTEGER_2
:
332 pack_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
,
333 (gfc_array_l1
*) mask
, (gfc_array_i2
*) vector
);
336 case GFC_DTYPE_LOGICAL_4
:
337 case GFC_DTYPE_INTEGER_4
:
339 pack_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) array
,
340 (gfc_array_l1
*) mask
, (gfc_array_i4
*) vector
);
343 case GFC_DTYPE_LOGICAL_8
:
344 case GFC_DTYPE_INTEGER_8
:
346 pack_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) array
,
347 (gfc_array_l1
*) mask
, (gfc_array_i8
*) vector
);
350 #ifdef HAVE_GFC_INTEGER_16
351 case GFC_DTYPE_LOGICAL_16
:
352 case GFC_DTYPE_INTEGER_16
:
354 pack_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
355 (gfc_array_l1
*) mask
, (gfc_array_i16
*) vector
);
358 case GFC_DTYPE_REAL_4
:
359 pack_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) array
,
360 (gfc_array_l1
*) mask
, (gfc_array_r4
*) vector
);
363 case GFC_DTYPE_REAL_8
:
364 pack_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) array
,
365 (gfc_array_l1
*) mask
, (gfc_array_r8
*) vector
);
368 #ifdef HAVE_GFC_REAL_10
369 case GFC_DTYPE_REAL_10
:
370 pack_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) array
,
371 (gfc_array_l1
*) mask
, (gfc_array_r10
*) vector
);
375 #ifdef HAVE_GFC_REAL_16
376 case GFC_DTYPE_REAL_16
:
377 pack_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) array
,
378 (gfc_array_l1
*) mask
, (gfc_array_r16
*) vector
);
381 case GFC_DTYPE_COMPLEX_4
:
382 pack_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) array
,
383 (gfc_array_l1
*) mask
, (gfc_array_c4
*) vector
);
386 case GFC_DTYPE_COMPLEX_8
:
387 pack_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
,
388 (gfc_array_l1
*) mask
, (gfc_array_c8
*) vector
);
391 #ifdef HAVE_GFC_COMPLEX_10
392 case GFC_DTYPE_COMPLEX_10
:
393 pack_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) array
,
394 (gfc_array_l1
*) mask
, (gfc_array_c10
*) vector
);
398 #ifdef HAVE_GFC_COMPLEX_16
399 case GFC_DTYPE_COMPLEX_16
:
400 pack_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) array
,
401 (gfc_array_l1
*) mask
, (gfc_array_c16
*) vector
);
405 /* For derived types, let's check the actual alignment of the
406 data pointers. If they are aligned, we can safely call
407 the unpack functions. */
409 case GFC_DTYPE_DERIVED_2
:
410 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(array
->data
)
411 || GFC_UNALIGNED_2(vector
->data
))
415 pack_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
,
416 (gfc_array_l1
*) mask
, (gfc_array_i2
*) vector
);
420 case GFC_DTYPE_DERIVED_4
:
421 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(array
->data
)
422 || GFC_UNALIGNED_4(vector
->data
))
426 pack_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) array
,
427 (gfc_array_l1
*) mask
, (gfc_array_i4
*) vector
);
431 case GFC_DTYPE_DERIVED_8
:
432 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(array
->data
)
433 || GFC_UNALIGNED_8(vector
->data
))
437 pack_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) array
,
438 (gfc_array_l1
*) mask
, (gfc_array_i8
*) vector
);
441 #ifdef HAVE_GFC_INTEGER_16
442 case GFC_DTYPE_DERIVED_16
:
443 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(array
->data
)
444 || GFC_UNALIGNED_16(vector
->data
))
448 pack_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
449 (gfc_array_l1
*) mask
, (gfc_array_i16
*) vector
);
456 size
= GFC_DESCRIPTOR_SIZE (array
);
457 pack_internal (ret
, array
, mask
, vector
, size
);
461 extern void pack_char (gfc_array_char
*, GFC_INTEGER_4
, const gfc_array_char
*,
462 const gfc_array_l1
*, const gfc_array_char
*,
463 GFC_INTEGER_4
, GFC_INTEGER_4
);
464 export_proto(pack_char
);
467 pack_char (gfc_array_char
*ret
,
468 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
469 const gfc_array_char
*array
, const gfc_array_l1
*mask
,
470 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
471 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
473 pack_internal (ret
, array
, mask
, vector
, array_length
);
477 extern void pack_char4 (gfc_array_char
*, GFC_INTEGER_4
, const gfc_array_char
*,
478 const gfc_array_l1
*, const gfc_array_char
*,
479 GFC_INTEGER_4
, GFC_INTEGER_4
);
480 export_proto(pack_char4
);
483 pack_char4 (gfc_array_char
*ret
,
484 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
485 const gfc_array_char
*array
, const gfc_array_l1
*mask
,
486 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
487 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
489 pack_internal (ret
, array
, mask
, vector
, array_length
* sizeof (gfc_char4_t
));
494 pack_s_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
495 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
,
498 /* r.* indicates the return array. */
501 /* s.* indicates the source array. */
502 index_type sstride
[GFC_MAX_DIMENSIONS
];
506 index_type count
[GFC_MAX_DIMENSIONS
];
507 index_type extent
[GFC_MAX_DIMENSIONS
];
514 dim
= GFC_DESCRIPTOR_RANK (array
);
516 for (n
= 0; n
< dim
; n
++)
519 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
523 sstride
[n
] = array
->dim
[n
].stride
* size
;
529 sstride0
= sstride
[0];
536 if (ret
->data
== NULL
)
538 /* Allocate the memory for the result. */
542 /* The return array will have as many elements as there are
544 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
555 /* The result array will have as many elements as the input
558 for (n
= 1; n
< dim
; n
++)
562 /* The result array will be empty. */
566 /* Setup the array descriptor. */
567 ret
->dim
[0].lbound
= 0;
568 ret
->dim
[0].ubound
= total
- 1;
569 ret
->dim
[0].stride
= 1;
574 ret
->data
= internal_malloc_size (1);
578 ret
->data
= internal_malloc_size (size
* total
);
581 rstride0
= ret
->dim
[0].stride
* size
;
586 /* The remaining possibilities are now:
587 If MASK is .TRUE., we have to copy the source array into the
588 result array. We then have to fill it up with elements from VECTOR.
589 If MASK is .FALSE., we have to copy VECTOR into the result
590 array. If VECTOR were not present we would have already returned. */
592 if (*mask
&& ssize
!= 0)
596 /* Add this element. */
597 memcpy (rptr
, sptr
, size
);
600 /* Advance to the next element. */
604 while (count
[n
] == extent
[n
])
606 /* When we get to the end of a dimension, reset it and
607 increment the next dimension. */
609 /* We could precalculate these products, but this is a
610 less frequently used path so probably not worth it. */
611 sptr
-= sstride
[n
] * extent
[n
];
615 /* Break out of the loop. */
628 /* Add any remaining elements from VECTOR. */
631 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
632 nelem
= ((rptr
- ret
->data
) / rstride0
);
635 sstride0
= vector
->dim
[0].stride
* size
;
639 sptr
= vector
->data
+ sstride0
* nelem
;
643 memcpy (rptr
, sptr
, size
);
651 extern void pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
652 const GFC_LOGICAL_4
*, const gfc_array_char
*);
653 export_proto(pack_s
);
656 pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
657 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
)
659 pack_s_internal (ret
, array
, mask
, vector
, GFC_DESCRIPTOR_SIZE (array
));
663 extern void pack_s_char (gfc_array_char
*ret
, GFC_INTEGER_4
,
664 const gfc_array_char
*array
, const GFC_LOGICAL_4
*,
665 const gfc_array_char
*, GFC_INTEGER_4
,
667 export_proto(pack_s_char
);
670 pack_s_char (gfc_array_char
*ret
,
671 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
672 const gfc_array_char
*array
, const GFC_LOGICAL_4
*mask
,
673 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
674 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
676 pack_s_internal (ret
, array
, mask
, vector
, array_length
);
680 extern void pack_s_char4 (gfc_array_char
*ret
, GFC_INTEGER_4
,
681 const gfc_array_char
*array
, const GFC_LOGICAL_4
*,
682 const gfc_array_char
*, GFC_INTEGER_4
,
684 export_proto(pack_s_char4
);
687 pack_s_char4 (gfc_array_char
*ret
,
688 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
689 const gfc_array_char
*array
, const GFC_LOGICAL_4
*mask
,
690 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
691 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
693 pack_s_internal (ret
, array
, mask
, vector
,
694 array_length
* sizeof (gfc_char4_t
));