1 /* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2021 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 <string.h>
29
30
31 #if defined (HAVE_GFC_REAL_8)
32
33 void
unpack0_r8(gfc_array_r8 * ret,const gfc_array_r8 * vector,const gfc_array_l1 * mask,const GFC_REAL_8 * fptr)34 unpack0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector,
35 const gfc_array_l1 *mask, const GFC_REAL_8 *fptr)
36 {
37 /* r.* indicates the return array. */
38 index_type rstride[GFC_MAX_DIMENSIONS];
39 index_type rstride0;
40 index_type rs;
41 GFC_REAL_8 * restrict rptr;
42 /* v.* indicates the vector array. */
43 index_type vstride0;
44 GFC_REAL_8 *vptr;
45 /* Value for field, this is constant. */
46 const GFC_REAL_8 fval = *fptr;
47 /* m.* indicates the mask array. */
48 index_type mstride[GFC_MAX_DIMENSIONS];
49 index_type mstride0;
50 const GFC_LOGICAL_1 *mptr;
51
52 index_type count[GFC_MAX_DIMENSIONS];
53 index_type extent[GFC_MAX_DIMENSIONS];
54 index_type n;
55 index_type dim;
56
57 int empty;
58 int mask_kind;
59
60 empty = 0;
61
62 mptr = mask->base_addr;
63
64 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
65 and using shifting to address size and endian issues. */
66
67 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
68
69 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
70 #ifdef HAVE_GFC_LOGICAL_16
71 || mask_kind == 16
72 #endif
73 )
74 {
75 /* Do not convert a NULL pointer as we use test for NULL below. */
76 if (mptr)
77 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
78 }
79 else
80 runtime_error ("Funny sized logical array");
81
82 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
83 rstride[0] = 1;
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 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
229 rstride[0] = 1;
230 if (ret->base_addr == NULL)
231 {
232 /* The front end has signalled that we need to populate the
233 return array descriptor. */
234 dim = GFC_DESCRIPTOR_RANK (mask);
235 rs = 1;
236 for (n = 0; n < dim; n++)
237 {
238 count[n] = 0;
239 GFC_DIMENSION_SET(ret->dim[n], 0,
240 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
241 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
242 empty = empty || extent[n] <= 0;
243 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
244 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
245 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
246 rs *= extent[n];
247 }
248 ret->offset = 0;
249 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
250 }
251 else
252 {
253 dim = GFC_DESCRIPTOR_RANK (ret);
254 for (n = 0; n < dim; n++)
255 {
256 count[n] = 0;
257 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
258 empty = empty || extent[n] <= 0;
259 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
260 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
261 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
262 }
263 if (rstride[0] == 0)
264 rstride[0] = 1;
265 }
266
267 if (empty)
268 return;
269
270 if (fstride[0] == 0)
271 fstride[0] = 1;
272 if (mstride[0] == 0)
273 mstride[0] = 1;
274
275 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
276 if (vstride0 == 0)
277 vstride0 = 1;
278 rstride0 = rstride[0];
279 fstride0 = fstride[0];
280 mstride0 = mstride[0];
281 rptr = ret->base_addr;
282 fptr = field->base_addr;
283 vptr = vector->base_addr;
284
285 while (rptr)
286 {
287 if (*mptr)
288 {
289 /* From vector. */
290 *rptr = *vptr;
291 vptr += vstride0;
292 }
293 else
294 {
295 /* From field. */
296 *rptr = *fptr;
297 }
298 /* Advance to the next element. */
299 rptr += rstride0;
300 fptr += fstride0;
301 mptr += mstride0;
302 count[0]++;
303 n = 0;
304 while (count[n] == extent[n])
305 {
306 /* When we get to the end of a dimension, reset it and increment
307 the next dimension. */
308 count[n] = 0;
309 /* We could precalculate these products, but this is a less
310 frequently used path so probably not worth it. */
311 rptr -= rstride[n] * extent[n];
312 fptr -= fstride[n] * extent[n];
313 mptr -= mstride[n] * extent[n];
314 n++;
315 if (n >= dim)
316 {
317 /* Break out of the loop. */
318 rptr = NULL;
319 break;
320 }
321 else
322 {
323 count[n]++;
324 rptr += rstride[n];
325 fptr += fstride[n];
326 mptr += mstride[n];
327 }
328 }
329 }
330 }
331
332 #endif
333
334