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