1 `/* Specific implementation of the UNPACK intrinsic
2 Copyright 2008, 2009 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 95 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];
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->data == 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 ret->dim[n].stride = rs;
95 ret->dim[n].lbound = 0;
96 ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
97 extent[n] = ret->dim[n].ubound + 1;
98 empty = empty || extent[n] <= 0;
99 rstride[n] = ret->dim[n].stride;
100 mstride[n] = mask->dim[n].stride * mask_kind;
104 ret->data = internal_malloc_size (rs * sizeof ('rtype_name`));
108 dim = GFC_DESCRIPTOR_RANK (ret);
109 for (n = 0; n < dim; n++)
112 extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
113 empty = empty || extent[n] <= 0;
114 rstride[n] = ret->dim[n].stride;
115 mstride[n] = mask->dim[n].stride * mask_kind;
127 vstride0 = vector->dim[0].stride;
130 rstride0 = rstride[0];
131 mstride0 = mstride[0];
148 /* Advance to the next element. */
153 while (count[n] == extent[n])
155 /* When we get to the end of a dimension, reset it and increment
156 the next dimension. */
158 /* We could precalculate these products, but this is a less
159 frequently used path so probably not worth it. */
160 rptr -= rstride[n] * extent[n];
161 mptr -= mstride[n] * extent[n];
165 /* Break out of the loop. */
180 unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
181 const gfc_array_l1 *mask, const 'rtype` *field)
183 /* r.* indicates the return array. */
184 index_type rstride[GFC_MAX_DIMENSIONS];
187 'rtype_name` * restrict rptr;
188 /* v.* indicates the vector array. */
191 /* f.* indicates the field array. */
192 index_type fstride[GFC_MAX_DIMENSIONS];
194 const 'rtype_name` *fptr;
195 /* m.* indicates the mask array. */
196 index_type mstride[GFC_MAX_DIMENSIONS];
198 const GFC_LOGICAL_1 *mptr;
200 index_type count[GFC_MAX_DIMENSIONS];
201 index_type extent[GFC_MAX_DIMENSIONS];
212 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
213 and using shifting to address size and endian issues. */
215 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
217 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
218 #ifdef HAVE_GFC_LOGICAL_16
223 /* Do not convert a NULL pointer as we use test for NULL below. */
225 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
228 runtime_error ("Funny sized logical array");
230 if (ret->data == NULL)
232 /* The front end has signalled that we need to populate the
233 return array descriptor. */
234 dim = GFC_DESCRIPTOR_RANK (mask);
236 for (n = 0; n < dim; n++)
239 ret->dim[n].stride = rs;
240 ret->dim[n].lbound = 0;
241 ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
242 extent[n] = ret->dim[n].ubound + 1;
243 empty = empty || extent[n] <= 0;
244 rstride[n] = ret->dim[n].stride;
245 fstride[n] = field->dim[n].stride;
246 mstride[n] = mask->dim[n].stride * mask_kind;
250 ret->data = internal_malloc_size (rs * sizeof ('rtype_name`));
254 dim = GFC_DESCRIPTOR_RANK (ret);
255 for (n = 0; n < dim; n++)
258 extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
259 empty = empty || extent[n] <= 0;
260 rstride[n] = ret->dim[n].stride;
261 fstride[n] = field->dim[n].stride;
262 mstride[n] = mask->dim[n].stride * mask_kind;
276 vstride0 = vector->dim[0].stride;
279 rstride0 = rstride[0];
280 fstride0 = fstride[0];
281 mstride0 = mstride[0];
299 /* Advance to the next element. */
305 while (count[n] == extent[n])
307 /* When we get to the end of a dimension, reset it and increment
308 the next dimension. */
310 /* We could precalculate these products, but this is a less
311 frequently used path so probably not worth it. */
312 rptr -= rstride[n] * extent[n];
313 fptr -= fstride[n] * extent[n];
314 mptr -= mstride[n] * extent[n];
318 /* Break out of the loop. */