1 `/* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2014 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4 unpack_generic.c by Paul Brook <paul@nowt.org>.
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
13 Ligbfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 #include "libgfortran.h"
34 `#if defined (HAVE_'rtype_name`)
37 unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
38 const gfc_array_l1 *mask, const 'rtype_name` *fptr)
40 /* r.* indicates the return array. */
41 index_type rstride[GFC_MAX_DIMENSIONS];
44 'rtype_name` * restrict rptr;
45 /* v.* indicates the vector array. */
48 /* Value for field, this is constant. */
49 const 'rtype_name` fval = *fptr;
50 /* m.* indicates the mask array. */
51 index_type mstride[GFC_MAX_DIMENSIONS];
53 const GFC_LOGICAL_1 *mptr;
55 index_type count[GFC_MAX_DIMENSIONS];
56 index_type extent[GFC_MAX_DIMENSIONS];
65 mptr = mask->base_addr;
67 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
68 and using shifting to address size and endian issues. */
70 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
72 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
73 #ifdef HAVE_GFC_LOGICAL_16
78 /* Do not convert a NULL pointer as we use test for NULL below. */
80 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
83 runtime_error ("Funny sized logical array");
85 if (ret->base_addr == NULL)
87 /* The front end has signalled that we need to populate the
88 return array descriptor. */
89 dim = GFC_DESCRIPTOR_RANK (mask);
91 for (n = 0; n < dim; n++)
94 GFC_DIMENSION_SET(ret->dim[n], 0,
95 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
96 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
97 empty = empty || extent[n] <= 0;
98 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
99 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
103 ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
107 dim = GFC_DESCRIPTOR_RANK (ret);
108 for (n = 0; n < dim; n++)
111 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
112 empty = empty || extent[n] <= 0;
113 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
114 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
126 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
129 rstride0 = rstride[0];
130 mstride0 = mstride[0];
131 rptr = ret->base_addr;
132 vptr = vector->base_addr;
147 /* Advance to the next element. */
152 while (count[n] == extent[n])
154 /* When we get to the end of a dimension, reset it and increment
155 the next dimension. */
157 /* We could precalculate these products, but this is a less
158 frequently used path so probably not worth it. */
159 rptr -= rstride[n] * extent[n];
160 mptr -= mstride[n] * extent[n];
164 /* Break out of the loop. */
179 unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
180 const gfc_array_l1 *mask, const 'rtype` *field)
182 /* r.* indicates the return array. */
183 index_type rstride[GFC_MAX_DIMENSIONS];
186 'rtype_name` * restrict rptr;
187 /* v.* indicates the vector array. */
190 /* f.* indicates the field array. */
191 index_type fstride[GFC_MAX_DIMENSIONS];
193 const 'rtype_name` *fptr;
194 /* m.* indicates the mask array. */
195 index_type mstride[GFC_MAX_DIMENSIONS];
197 const GFC_LOGICAL_1 *mptr;
199 index_type count[GFC_MAX_DIMENSIONS];
200 index_type extent[GFC_MAX_DIMENSIONS];
209 mptr = mask->base_addr;
211 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
212 and using shifting to address size and endian issues. */
214 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
216 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217 #ifdef HAVE_GFC_LOGICAL_16
222 /* Do not convert a NULL pointer as we use test for NULL below. */
224 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
227 runtime_error ("Funny sized logical array");
229 if (ret->base_addr == NULL)
231 /* The front end has signalled that we need to populate the
232 return array descriptor. */
233 dim = GFC_DESCRIPTOR_RANK (mask);
235 for (n = 0; n < dim; n++)
238 GFC_DIMENSION_SET(ret->dim[n], 0,
239 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
240 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
241 empty = empty || extent[n] <= 0;
242 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
243 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
244 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
248 ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
252 dim = GFC_DESCRIPTOR_RANK (ret);
253 for (n = 0; n < dim; n++)
256 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
257 empty = empty || extent[n] <= 0;
258 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
259 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
260 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
274 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
277 rstride0 = rstride[0];
278 fstride0 = fstride[0];
279 mstride0 = mstride[0];
280 rptr = ret->base_addr;
281 fptr = field->base_addr;
282 vptr = vector->base_addr;
297 /* Advance to the next element. */
303 while (count[n] == extent[n])
305 /* When we get to the end of a dimension, reset it and increment
306 the next dimension. */
308 /* We could precalculate these products, but this is a less
309 frequently used path so probably not worth it. */
310 rptr -= rstride[n] * extent[n];
311 fptr -= fstride[n] * extent[n];
312 mptr -= mstride[n] * extent[n];
316 /* Break out of the loop. */