PR target/83926
[official-gcc.git] / libgfortran / m4 / unpack.m4
blob7100a2b6ad75d3715784c26fb1263221fcc2810c
1 `/* Specific implementation of the UNPACK intrinsic
2    Copyright (C) 2008-2018 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 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"
28 #include <string.h>'
30 include(iparm.m4)dnl
32 `#if defined (HAVE_'rtype_name`)
34 void
35 unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
36                  const gfc_array_l1 *mask, const 'rtype_name` *fptr)
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;
53   index_type count[GFC_MAX_DIMENSIONS];
54   index_type extent[GFC_MAX_DIMENSIONS];
55   index_type n;
56   index_type dim;
58   int empty;
59   int mask_kind;
61   empty = 0;
63   mptr = mask->base_addr;
65   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
66      and using shifting to address size and endian issues.  */
68   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
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");
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     }
120   if (empty)
121     return;
123   if (mstride[0] == 0)
124     mstride[0] = 1;
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;
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     }
178 void
179 unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
180                  const gfc_array_l1 *mask, const 'rtype` *field)
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;
199   index_type count[GFC_MAX_DIMENSIONS];
200   index_type extent[GFC_MAX_DIMENSIONS];
201   index_type n;
202   index_type dim;
204   int empty;
205   int mask_kind;
207   empty = 0;
209   mptr = mask->base_addr;
211   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
212      and using shifting to address size and endian issues.  */
214   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
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");
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     }
268   if (empty)
269     return;
271   if (fstride[0] == 0)
272     fstride[0] = 1;
273   if (mstride[0] == 0)
274     mstride[0] = 1;
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;
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     }
333 #endif