1`/* Specific implementation of the PACK intrinsic
2   Copyright (C) 2002-2021 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.org>
4
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Ligbfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24<http://www.gnu.org/licenses/>.  */
25
26#include "libgfortran.h"
27#include <string.h>'
28
29include(iparm.m4)dnl
30
31`#if defined (HAVE_'rtype_name`)
32
33/* PACK is specified as follows:
34
35   13.14.80 PACK (ARRAY, MASK, [VECTOR])
36
37   Description: Pack an array into an array of rank one under the
38   control of a mask.
39
40   Class: Transformational function.
41
42   Arguments:
43      ARRAY   may be of any type. It shall not be scalar.
44      MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
45      VECTOR  (optional) shall be of the same type and type parameters
46              as ARRAY. VECTOR shall have at least as many elements as
47              there are true elements in MASK. If MASK is a scalar
48              with the value true, VECTOR shall have at least as many
49              elements as there are in ARRAY.
50
51   Result Characteristics: The result is an array of rank one with the
52   same type and type parameters as ARRAY. If VECTOR is present, the
53   result size is that of VECTOR; otherwise, the result size is the
54   number /t/ of true elements in MASK unless MASK is scalar with the
55   value true, in which case the result size is the size of ARRAY.
56
57   Result Value: Element /i/ of the result is the element of ARRAY
58   that corresponds to the /i/th true element of MASK, taking elements
59   in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
60   present and has size /n/ > /t/, element /i/ of the result has the
61   value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
62
63   Examples: The nonzero elements of an array M with the value
64   | 0 0 0 |
65   | 9 0 0 | may be "gathered" by the function PACK. The result of
66   | 0 0 7 |
67   PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
68   VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
69
70There are two variants of the PACK intrinsic: one, where MASK is
71array valued, and the other one where MASK is scalar.  */
72
73void
74pack_'rtype_code` ('rtype` *ret, const 'rtype` *array,
75	       const gfc_array_l1 *mask, const 'rtype` *vector)
76{
77  /* r.* indicates the return array.  */
78  index_type rstride0;
79  'rtype_name` * restrict rptr;
80  /* s.* indicates the source array.  */
81  index_type sstride[GFC_MAX_DIMENSIONS];
82  index_type sstride0;
83  const 'rtype_name` *sptr;
84  /* m.* indicates the mask array.  */
85  index_type mstride[GFC_MAX_DIMENSIONS];
86  index_type mstride0;
87  const GFC_LOGICAL_1 *mptr;
88
89  index_type count[GFC_MAX_DIMENSIONS];
90  index_type extent[GFC_MAX_DIMENSIONS];
91  int zero_sized;
92  index_type n;
93  index_type dim;
94  index_type nelem;
95  index_type total;
96  int mask_kind;
97
98  dim = GFC_DESCRIPTOR_RANK (array);
99
100  mptr = mask->base_addr;
101
102  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
103     and using shifting to address size and endian issues.  */
104
105  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
106
107  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
108#ifdef HAVE_GFC_LOGICAL_16
109      || mask_kind == 16
110#endif
111      )
112    {
113      /*  Do not convert a NULL pointer as we use test for NULL below.  */
114      if (mptr)
115	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
116    }
117  else
118    runtime_error ("Funny sized logical array");
119
120  zero_sized = 0;
121  for (n = 0; n < dim; n++)
122    {
123      count[n] = 0;
124      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
125      if (extent[n] <= 0)
126       zero_sized = 1;
127      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
128      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
129    }
130  if (sstride[0] == 0)
131    sstride[0] = 1;
132  if (mstride[0] == 0)
133    mstride[0] = mask_kind;
134
135  if (zero_sized)
136    sptr = NULL;
137  else
138    sptr = array->base_addr;
139
140  if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
141    {
142      /* Count the elements, either for allocating memory or
143	 for bounds checking.  */
144
145      if (vector != NULL)
146	{
147	  /* The return array will have as many
148	     elements as there are in VECTOR.  */
149	  total = GFC_DESCRIPTOR_EXTENT(vector,0);
150	  if (total < 0)
151	    {
152	      total = 0;
153	      vector = NULL;
154	    }
155	}
156      else
157        {
158      	  /* We have to count the true elements in MASK.  */
159	  total = count_0 (mask);
160        }
161
162      if (ret->base_addr == NULL)
163	{
164	  /* Setup the array descriptor.  */
165	  GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
166
167	  ret->offset = 0;
168
169	  /* xmallocarray allocates a single byte for zero size.  */
170	  ret->base_addr = xmallocarray (total, sizeof ('rtype_name`));
171
172	  if (total == 0)
173	    return;
174	}
175      else
176	{
177	  /* We come here because of range checking.  */
178	  index_type ret_extent;
179
180	  ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
181	  if (total != ret_extent)
182	    runtime_error ("Incorrect extent in return value of PACK intrinsic;"
183			   " is %ld, should be %ld", (long int) total,
184			   (long int) ret_extent);
185	}
186    }
187
188  rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
189  if (rstride0 == 0)
190    rstride0 = 1;
191  sstride0 = sstride[0];
192  mstride0 = mstride[0];
193  rptr = ret->base_addr;
194
195  while (sptr && mptr)
196    {
197      /* Test this element.  */
198      if (*mptr)
199        {
200          /* Add it.  */
201	  *rptr = *sptr;
202          rptr += rstride0;
203        }
204      /* Advance to the next element.  */
205      sptr += sstride0;
206      mptr += mstride0;
207      count[0]++;
208      n = 0;
209      while (count[n] == extent[n])
210        {
211          /* When we get to the end of a dimension, reset it and increment
212             the next dimension.  */
213          count[n] = 0;
214          /* We could precalculate these products, but this is a less
215             frequently used path so probably not worth it.  */
216          sptr -= sstride[n] * extent[n];
217          mptr -= mstride[n] * extent[n];
218          n++;
219          if (n >= dim)
220            {
221              /* Break out of the loop.  */
222              sptr = NULL;
223              break;
224            }
225          else
226            {
227              count[n]++;
228              sptr += sstride[n];
229              mptr += mstride[n];
230            }
231        }
232    }
233
234  /* Add any remaining elements from VECTOR.  */
235  if (vector)
236    {
237      n = GFC_DESCRIPTOR_EXTENT(vector,0);
238      nelem = ((rptr - ret->base_addr) / rstride0);
239      if (n > nelem)
240        {
241          sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
242          if (sstride0 == 0)
243            sstride0 = 1;
244
245          sptr = vector->base_addr + sstride0 * nelem;
246          n -= nelem;
247          while (n--)
248            {
249	      *rptr = *sptr;
250              rptr += rstride0;
251              sptr += sstride0;
252            }
253        }
254    }
255}
256
257#endif
258'
259