1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002, 2004, 2005 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. */
35 #include "libgfortran.h"
37 /* PACK is specified as follows:
39 13.14.80 PACK (ARRAY, MASK, [VECTOR])
41 Description: Pack an array into an array of rank one under the
44 Class: Transformational fucntion.
47 ARRAY may be of any type. It shall not be scalar.
48 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
49 VECTOR (optional) shall be of the same type and type parameters
50 as ARRAY. VECTOR shall have at least as many elements as
51 there are true elements in MASK. If MASK is a scalar
52 with the value true, VECTOR shall have at least as many
53 elements as there are in ARRAY.
55 Result Characteristics: The result is an array of rank one with the
56 same type and type parameters as ARRAY. If VECTOR is present, the
57 result size is that of VECTOR; otherwise, the result size is the
58 number /t/ of true elements in MASK unless MASK is scalar with the
59 value true, in which case the result size is the size of ARRAY.
61 Result Value: Element /i/ of the result is the element of ARRAY
62 that corresponds to the /i/th true element of MASK, taking elements
63 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
64 present and has size /n/ > /t/, element /i/ of the result has the
65 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
67 Examples: The nonzero elements of an array M with the value
69 | 9 0 0 | may be "gathered" by the function PACK. The result of
71 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
72 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
74 There are two variants of the PACK intrinsic: one, where MASK is
75 array valued, and the other one where MASK is scalar. */
78 pack_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
79 const gfc_array_l4
*mask
, const gfc_array_char
*vector
,
82 /* r.* indicates the return array. */
85 /* s.* indicates the source array. */
86 index_type sstride
[GFC_MAX_DIMENSIONS
];
89 /* m.* indicates the mask array. */
90 index_type mstride
[GFC_MAX_DIMENSIONS
];
92 const GFC_LOGICAL_4
*mptr
;
94 index_type count
[GFC_MAX_DIMENSIONS
];
95 index_type extent
[GFC_MAX_DIMENSIONS
];
100 dim
= GFC_DESCRIPTOR_RANK (array
);
101 for (n
= 0; n
< dim
; n
++)
104 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
105 sstride
[n
] = array
->dim
[n
].stride
* size
;
106 mstride
[n
] = mask
->dim
[n
].stride
;
116 /* Use the same loop for both logical types. */
117 if (GFC_DESCRIPTOR_SIZE (mask
) != 4)
119 if (GFC_DESCRIPTOR_SIZE (mask
) != 8)
120 runtime_error ("Funny sized logical array");
121 for (n
= 0; n
< dim
; n
++)
123 mptr
= GFOR_POINTER_L8_TO_L4 (mptr
);
126 if (ret
->data
== NULL
)
128 /* Allocate the memory for the result. */
133 /* The return array will have as many
134 elements as there are in VECTOR. */
135 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
139 /* We have to count the true elements in MASK. */
141 /* TODO: We could speed up pack easily in the case of only
142 few .TRUE. entries in MASK, by keeping track of where we
143 would be in the source array during the initial traversal
144 of MASK, and caching the pointers to those elements. Then,
145 supposed the number of elements is small enough, we would
146 only have to traverse the list, and copy those elements
147 into the result array. In the case of datatypes which fit
148 in one of the integer types we could also cache the
149 value instead of a pointer to it.
150 This approach might be bad from the point of view of
151 cache behavior in the case where our cache is not big
152 enough to hold all elements that have to be copied. */
154 const GFC_LOGICAL_4
*m
= mptr
;
160 /* Test this element. */
164 /* Advance to the next element. */
168 while (count
[n
] == extent
[n
])
170 /* When we get to the end of a dimension, reset it
171 and increment the next dimension. */
173 /* We could precalculate this product, but this is a
174 less frequently used path so proabably not worth
176 m
-= mstride
[n
] * extent
[n
];
180 /* Break out of the loop. */
193 /* Setup the array descriptor. */
194 ret
->dim
[0].lbound
= 0;
195 ret
->dim
[0].ubound
= total
- 1;
196 ret
->dim
[0].stride
= 1;
198 ret
->data
= internal_malloc_size (size
* total
);
202 /* In this case, nothing remains to be done. */
206 rstride0
= ret
->dim
[0].stride
* size
;
209 sstride0
= sstride
[0];
210 mstride0
= mstride
[0];
215 /* Test this element. */
219 memcpy (rptr
, sptr
, size
);
222 /* Advance to the next element. */
227 while (count
[n
] == extent
[n
])
229 /* When we get to the end of a dimension, reset it and increment
230 the next dimension. */
232 /* We could precalculate these products, but this is a less
233 frequently used path so proabably not worth it. */
234 sptr
-= sstride
[n
] * extent
[n
];
235 mptr
-= mstride
[n
] * extent
[n
];
239 /* Break out of the loop. */
252 /* Add any remaining elements from VECTOR. */
255 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
256 nelem
= ((rptr
- ret
->data
) / rstride0
);
259 sstride0
= vector
->dim
[0].stride
* size
;
263 sptr
= vector
->data
+ sstride0
* nelem
;
267 memcpy (rptr
, sptr
, size
);
275 extern void pack (gfc_array_char
*, const gfc_array_char
*,
276 const gfc_array_l4
*, const gfc_array_char
*);
280 pack (gfc_array_char
*ret
, const gfc_array_char
*array
,
281 const gfc_array_l4
*mask
, const gfc_array_char
*vector
)
283 pack_internal (ret
, array
, mask
, vector
, GFC_DESCRIPTOR_SIZE (array
));
286 extern void pack_char (gfc_array_char
*, GFC_INTEGER_4
, const gfc_array_char
*,
287 const gfc_array_l4
*, const gfc_array_char
*,
288 GFC_INTEGER_4
, GFC_INTEGER_4
);
289 export_proto(pack_char
);
292 pack_char (gfc_array_char
*ret
,
293 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
294 const gfc_array_char
*array
, const gfc_array_l4
*mask
,
295 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
296 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
298 pack_internal (ret
, array
, mask
, vector
, array_length
);
302 pack_s_internal (gfc_array_char
*ret
, const gfc_array_char
*array
,
303 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
,
306 /* r.* indicates the return array. */
309 /* s.* indicates the source array. */
310 index_type sstride
[GFC_MAX_DIMENSIONS
];
314 index_type count
[GFC_MAX_DIMENSIONS
];
315 index_type extent
[GFC_MAX_DIMENSIONS
];
320 dim
= GFC_DESCRIPTOR_RANK (array
);
321 for (n
= 0; n
< dim
; n
++)
324 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
325 sstride
[n
] = array
->dim
[n
].stride
* size
;
330 sstride0
= sstride
[0];
333 if (ret
->data
== NULL
)
335 /* Allocate the memory for the result. */
340 /* The return array will have as many elements as there are
342 total
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
348 /* The result array will have as many elements as the input
351 for (n
= 1; n
< dim
; n
++)
356 /* The result array will be empty. */
357 ret
->dim
[0].lbound
= 0;
358 ret
->dim
[0].ubound
= -1;
359 ret
->dim
[0].stride
= 1;
360 ret
->data
= internal_malloc_size (0);
367 /* Setup the array descriptor. */
368 ret
->dim
[0].lbound
= 0;
369 ret
->dim
[0].ubound
= total
- 1;
370 ret
->dim
[0].stride
= 1;
372 ret
->data
= internal_malloc_size (size
* total
);
376 rstride0
= ret
->dim
[0].stride
* size
;
381 /* The remaining possibilities are now:
382 If MASK is .TRUE., we have to copy the source array into the
383 result array. We then have to fill it up with elements from VECTOR.
384 If MASK is .FALSE., we have to copy VECTOR into the result
385 array. If VECTOR were not present we would have already returned. */
391 /* Add this element. */
392 memcpy (rptr
, sptr
, size
);
395 /* Advance to the next element. */
399 while (count
[n
] == extent
[n
])
401 /* When we get to the end of a dimension, reset it and
402 increment the next dimension. */
404 /* We could precalculate these products, but this is a
405 less frequently used path so proabably not worth it. */
406 sptr
-= sstride
[n
] * extent
[n
];
410 /* Break out of the loop. */
423 /* Add any remaining elements from VECTOR. */
426 n
= vector
->dim
[0].ubound
+ 1 - vector
->dim
[0].lbound
;
427 nelem
= ((rptr
- ret
->data
) / rstride0
);
430 sstride0
= vector
->dim
[0].stride
* size
;
434 sptr
= vector
->data
+ sstride0
* nelem
;
438 memcpy (rptr
, sptr
, size
);
446 extern void pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
447 const GFC_LOGICAL_4
*, const gfc_array_char
*);
448 export_proto(pack_s
);
451 pack_s (gfc_array_char
*ret
, const gfc_array_char
*array
,
452 const GFC_LOGICAL_4
*mask
, const gfc_array_char
*vector
)
454 pack_s_internal (ret
, array
, mask
, vector
, GFC_DESCRIPTOR_SIZE (array
));
457 extern void pack_s_char (gfc_array_char
*ret
, GFC_INTEGER_4
,
458 const gfc_array_char
*array
, const GFC_LOGICAL_4
*,
459 const gfc_array_char
*, GFC_INTEGER_4
,
461 export_proto(pack_s_char
);
464 pack_s_char (gfc_array_char
*ret
,
465 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
466 const gfc_array_char
*array
, const GFC_LOGICAL_4
*mask
,
467 const gfc_array_char
*vector
, GFC_INTEGER_4 array_length
,
468 GFC_INTEGER_4 vector_length
__attribute__((unused
)))
470 pack_s_internal (ret
, array
, mask
, vector
, array_length
);