1 `/* Specific implementation of the PACK intrinsic
2 Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 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"
38 `#if defined (HAVE_'rtype_name`)
40 /* PACK is specified as follows:
42 13.14.80 PACK (ARRAY, MASK, [VECTOR])
44 Description: Pack an array into an array of rank one under the
47 Class: Transformational function.
50 ARRAY may be of any type. It shall not be scalar.
51 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
52 VECTOR (optional) shall be of the same type and type parameters
53 as ARRAY. VECTOR shall have at least as many elements as
54 there are true elements in MASK. If MASK is a scalar
55 with the value true, VECTOR shall have at least as many
56 elements as there are in ARRAY.
58 Result Characteristics: The result is an array of rank one with the
59 same type and type parameters as ARRAY. If VECTOR is present, the
60 result size is that of VECTOR; otherwise, the result size is the
61 number /t/ of true elements in MASK unless MASK is scalar with the
62 value true, in which case the result size is the size of ARRAY.
64 Result Value: Element /i/ of the result is the element of ARRAY
65 that corresponds to the /i/th true element of MASK, taking elements
66 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
67 present and has size /n/ > /t/, element /i/ of the result has the
68 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
70 Examples: The nonzero elements of an array M with the value
72 | 9 0 0 | may be "gathered" by the function PACK. The result of
74 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
75 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
77 There are two variants of the PACK intrinsic: one, where MASK is
78 array valued, and the other one where MASK is scalar. */
81 pack_'rtype_code` ('rtype` *ret, const 'rtype` *array,
82 const gfc_array_l1 *mask, const 'rtype` *vector)
84 /* r.* indicates the return array. */
86 'rtype_name` * restrict rptr;
87 /* s.* indicates the source array. */
88 index_type sstride[GFC_MAX_DIMENSIONS];
90 const 'rtype_name` *sptr;
91 /* m.* indicates the mask array. */
92 index_type mstride[GFC_MAX_DIMENSIONS];
94 const GFC_LOGICAL_1 *mptr;
96 index_type count[GFC_MAX_DIMENSIONS];
97 index_type extent[GFC_MAX_DIMENSIONS];
105 dim = GFC_DESCRIPTOR_RANK (array);
109 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
110 and using shifting to address size and endian issues. */
112 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
114 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
115 #ifdef HAVE_GFC_LOGICAL_16
120 /* Do not convert a NULL pointer as we use test for NULL below. */
122 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
125 runtime_error ("Funny sized logical array");
128 for (n = 0; n < dim; n++)
131 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
134 sstride[n] = array->dim[n].stride;
135 mstride[n] = mask->dim[n].stride * mask_kind;
140 mstride[0] = mask_kind;
147 if (ret->data == NULL || compile_options.bounds_check)
149 /* Count the elements, either for allocating memory or
150 for bounds checking. */
154 /* The return array will have as many
155 elements as there are in VECTOR. */
156 total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
165 /* We have to count the true elements in MASK. */
167 /* TODO: We could speed up pack easily in the case of only
168 few .TRUE. entries in MASK, by keeping track of where we
169 would be in the source array during the initial traversal
170 of MASK, and caching the pointers to those elements. Then,
171 supposed the number of elements is small enough, we would
172 only have to traverse the list, and copy those elements
173 into the result array. In the case of datatypes which fit
174 in one of the integer types we could also cache the
175 value instead of a pointer to it.
176 This approach might be bad from the point of view of
177 cache behavior in the case where our cache is not big
178 enough to hold all elements that have to be copied. */
180 const GFC_LOGICAL_1 *m = mptr;
188 /* Test this element. */
192 /* Advance to the next element. */
196 while (count[n] == extent[n])
198 /* When we get to the end of a dimension, reset it
199 and increment the next dimension. */
201 /* We could precalculate this product, but this is a
202 less frequently used path so probably not worth
204 m -= mstride[n] * extent[n];
208 /* Break out of the loop. */
221 if (ret->data == NULL)
223 /* Setup the array descriptor. */
224 ret->dim[0].lbound = 0;
225 ret->dim[0].ubound = total - 1;
226 ret->dim[0].stride = 1;
231 /* In this case, nothing remains to be done. */
232 ret->data = internal_malloc_size (1);
236 ret->data = internal_malloc_size (sizeof ('rtype_name`) * total);
240 /* We come here because of range checking. */
241 index_type ret_extent;
243 ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
244 if (total != ret_extent)
245 runtime_error ("Incorrect extent in return value of PACK intrinsic;"
246 " is %ld, should be %ld", (long int) total,
247 (long int) ret_extent);
251 rstride0 = ret->dim[0].stride;
254 sstride0 = sstride[0];
255 mstride0 = mstride[0];
260 /* Test this element. */
267 /* Advance to the next element. */
272 while (count[n] == extent[n])
274 /* When we get to the end of a dimension, reset it and increment
275 the next dimension. */
277 /* We could precalculate these products, but this is a less
278 frequently used path so probably not worth it. */
279 sptr -= sstride[n] * extent[n];
280 mptr -= mstride[n] * extent[n];
284 /* Break out of the loop. */
297 /* Add any remaining elements from VECTOR. */
300 n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
301 nelem = ((rptr - ret->data) / rstride0);
304 sstride0 = vector->dim[0].stride;
308 sptr = vector->data + sstride0 * nelem;