1 /* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2013 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>.
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
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.
12
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.
17
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.
21
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/>. */
26
27 #include "libgfortran.h"
28 #include <stdlib.h>
29 #include <assert.h>
30 #include <string.h>
31
32
33 #if defined (HAVE_GFC_REAL_8)
34
35 void
unpack0_r8(gfc_array_r8 * ret,const gfc_array_r8 * vector,const gfc_array_l1 * mask,const GFC_REAL_8 * fptr)36 unpack0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector,
37 const gfc_array_l1 *mask, const GFC_REAL_8 *fptr)
38 {
39 /* r.* indicates the return array. */
40 index_type rstride[GFC_MAX_DIMENSIONS];
41 index_type rstride0;
42 index_type rs;
43 GFC_REAL_8 * restrict rptr;
44 /* v.* indicates the vector array. */
45 index_type vstride0;
46 GFC_REAL_8 *vptr;
47 /* Value for field, this is constant. */
48 const GFC_REAL_8 fval = *fptr;
49 /* m.* indicates the mask array. */
50 index_type mstride[GFC_MAX_DIMENSIONS];
51 index_type mstride0;
52 const GFC_LOGICAL_1 *mptr;
53
54 index_type count[GFC_MAX_DIMENSIONS];
55 index_type extent[GFC_MAX_DIMENSIONS];
56 index_type n;
57 index_type dim;
58
59 int empty;
60 int mask_kind;
61
62 empty = 0;
63
64 mptr = mask->base_addr;
65
66 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
67 and using shifting to address size and endian issues. */
68
69 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
70
71 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
72 #ifdef HAVE_GFC_LOGICAL_16
73 || mask_kind == 16
74 #endif
75 )
76 {
77 /* Do not convert a NULL pointer as we use test for NULL below. */
78 if (mptr)
79 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
80 }
81 else
82 runtime_error ("Funny sized logical array");
83
84 if (ret->base_addr == NULL)
85 {
86 /* The front end has signalled that we need to populate the
87 return array descriptor. */
88 dim = GFC_DESCRIPTOR_RANK (mask);
89 rs = 1;
90 for (n = 0; n < dim; n++)
91 {
92 count[n] = 0;
93 GFC_DIMENSION_SET(ret->dim[n], 0,
94 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
95 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
96 empty = empty || extent[n] <= 0;
97 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
98 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
99 rs *= extent[n];
100 }
101 ret->offset = 0;
102 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
103 }
104 else
105 {
106 dim = GFC_DESCRIPTOR_RANK (ret);
107 for (n = 0; n < dim; n++)
108 {
109 count[n] = 0;
110 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
111 empty = empty || extent[n] <= 0;
112 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
113 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
114 }
115 if (rstride[0] == 0)
116 rstride[0] = 1;
117 }
118
119 if (empty)
120 return;
121
122 if (mstride[0] == 0)
123 mstride[0] = 1;
124
125 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
126 if (vstride0 == 0)
127 vstride0 = 1;
128 rstride0 = rstride[0];
129 mstride0 = mstride[0];
130 rptr = ret->base_addr;
131 vptr = vector->base_addr;
132
133 while (rptr)
134 {
135 if (*mptr)
136 {
137 /* From vector. */
138 *rptr = *vptr;
139 vptr += vstride0;
140 }
141 else
142 {
143 /* From field. */
144 *rptr = fval;
145 }
146 /* Advance to the next element. */
147 rptr += rstride0;
148 mptr += mstride0;
149 count[0]++;
150 n = 0;
151 while (count[n] == extent[n])
152 {
153 /* When we get to the end of a dimension, reset it and increment
154 the next dimension. */
155 count[n] = 0;
156 /* We could precalculate these products, but this is a less
157 frequently used path so probably not worth it. */
158 rptr -= rstride[n] * extent[n];
159 mptr -= mstride[n] * extent[n];
160 n++;
161 if (n >= dim)
162 {
163 /* Break out of the loop. */
164 rptr = NULL;
165 break;
166 }
167 else
168 {
169 count[n]++;
170 rptr += rstride[n];
171 mptr += mstride[n];
172 }
173 }
174 }
175 }
176
177 void
unpack1_r8(gfc_array_r8 * ret,const gfc_array_r8 * vector,const gfc_array_l1 * mask,const gfc_array_r8 * field)178 unpack1_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector,
179 const gfc_array_l1 *mask, const gfc_array_r8 *field)
180 {
181 /* r.* indicates the return array. */
182 index_type rstride[GFC_MAX_DIMENSIONS];
183 index_type rstride0;
184 index_type rs;
185 GFC_REAL_8 * restrict rptr;
186 /* v.* indicates the vector array. */
187 index_type vstride0;
188 GFC_REAL_8 *vptr;
189 /* f.* indicates the field array. */
190 index_type fstride[GFC_MAX_DIMENSIONS];
191 index_type fstride0;
192 const GFC_REAL_8 *fptr;
193 /* m.* indicates the mask array. */
194 index_type mstride[GFC_MAX_DIMENSIONS];
195 index_type mstride0;
196 const GFC_LOGICAL_1 *mptr;
197
198 index_type count[GFC_MAX_DIMENSIONS];
199 index_type extent[GFC_MAX_DIMENSIONS];
200 index_type n;
201 index_type dim;
202
203 int empty;
204 int mask_kind;
205
206 empty = 0;
207
208 mptr = mask->base_addr;
209
210 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
211 and using shifting to address size and endian issues. */
212
213 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
214
215 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
216 #ifdef HAVE_GFC_LOGICAL_16
217 || mask_kind == 16
218 #endif
219 )
220 {
221 /* Do not convert a NULL pointer as we use test for NULL below. */
222 if (mptr)
223 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
224 }
225 else
226 runtime_error ("Funny sized logical array");
227
228 if (ret->base_addr == NULL)
229 {
230 /* The front end has signalled that we need to populate the
231 return array descriptor. */
232 dim = GFC_DESCRIPTOR_RANK (mask);
233 rs = 1;
234 for (n = 0; n < dim; n++)
235 {
236 count[n] = 0;
237 GFC_DIMENSION_SET(ret->dim[n], 0,
238 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
239 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
240 empty = empty || extent[n] <= 0;
241 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
242 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
243 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
244 rs *= extent[n];
245 }
246 ret->offset = 0;
247 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
248 }
249 else
250 {
251 dim = GFC_DESCRIPTOR_RANK (ret);
252 for (n = 0; n < dim; n++)
253 {
254 count[n] = 0;
255 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
256 empty = empty || extent[n] <= 0;
257 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
258 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
259 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
260 }
261 if (rstride[0] == 0)
262 rstride[0] = 1;
263 }
264
265 if (empty)
266 return;
267
268 if (fstride[0] == 0)
269 fstride[0] = 1;
270 if (mstride[0] == 0)
271 mstride[0] = 1;
272
273 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
274 if (vstride0 == 0)
275 vstride0 = 1;
276 rstride0 = rstride[0];
277 fstride0 = fstride[0];
278 mstride0 = mstride[0];
279 rptr = ret->base_addr;
280 fptr = field->base_addr;
281 vptr = vector->base_addr;
282
283 while (rptr)
284 {
285 if (*mptr)
286 {
287 /* From vector. */
288 *rptr = *vptr;
289 vptr += vstride0;
290 }
291 else
292 {
293 /* From field. */
294 *rptr = *fptr;
295 }
296 /* Advance to the next element. */
297 rptr += rstride0;
298 fptr += fstride0;
299 mptr += mstride0;
300 count[0]++;
301 n = 0;
302 while (count[n] == extent[n])
303 {
304 /* When we get to the end of a dimension, reset it and increment
305 the next dimension. */
306 count[n] = 0;
307 /* We could precalculate these products, but this is a less
308 frequently used path so probably not worth it. */
309 rptr -= rstride[n] * extent[n];
310 fptr -= fstride[n] * extent[n];
311 mptr -= mstride[n] * extent[n];
312 n++;
313 if (n >= dim)
314 {
315 /* Break out of the loop. */
316 rptr = NULL;
317 break;
318 }
319 else
320 {
321 count[n]++;
322 rptr += rstride[n];
323 fptr += fstride[n];
324 mptr += mstride[n];
325 }
326 }
327 }
328 }
329
330 #endif
331
332