1/* Specific implementation of the UNPACK intrinsic
2   Copyright (C) 2008-2022 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
6This file is part of the GNU Fortran runtime library (libgfortran).
7
8Libgfortran is free software; you can redistribute it and/or
9modify it under the terms of the GNU General Public
10License as published by the Free Software Foundation; either
11version 3 of the License, or (at your option) any later version.
12
13Ligbfortran is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16GNU General Public License for more details.
17
18Under Section 7 of GPL version 3, you are granted additional
19permissions described in the GCC Runtime Library Exception, version
203.1, as published by the Free Software Foundation.
21
22You should have received a copy of the GNU General Public License and
23a copy of the GCC Runtime Library Exception along with this program;
24see 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_COMPLEX_8)
32
33void
34unpack0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector,
35		 const gfc_array_l1 *mask, const GFC_COMPLEX_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_COMPLEX_8 * restrict rptr;
42  /* v.* indicates the vector array.  */
43  index_type vstride0;
44  GFC_COMPLEX_8 *vptr;
45  /* Value for field, this is constant.  */
46  const GFC_COMPLEX_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_COMPLEX_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
177void
178unpack1_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector,
179		 const gfc_array_l1 *mask, const gfc_array_c8 *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_COMPLEX_8 * restrict rptr;
186  /* v.* indicates the vector array.  */
187  index_type vstride0;
188  GFC_COMPLEX_8 *vptr;
189  /* f.* indicates the field array.  */
190  index_type fstride[GFC_MAX_DIMENSIONS];
191  index_type fstride0;
192  const GFC_COMPLEX_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_COMPLEX_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