1/* Specific implementation of the PACK intrinsic
2   Copyright (C) 2002-2022 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
29
30#if defined (HAVE_GFC_INTEGER_16)
31
32/* PACK is specified as follows:
33
34   13.14.80 PACK (ARRAY, MASK, [VECTOR])
35
36   Description: Pack an array into an array of rank one under the
37   control of a mask.
38
39   Class: Transformational function.
40
41   Arguments:
42      ARRAY   may be of any type. It shall not be scalar.
43      MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
44      VECTOR  (optional) shall be of the same type and type parameters
45              as ARRAY. VECTOR shall have at least as many elements as
46              there are true elements in MASK. If MASK is a scalar
47              with the value true, VECTOR shall have at least as many
48              elements as there are in ARRAY.
49
50   Result Characteristics: The result is an array of rank one with the
51   same type and type parameters as ARRAY. If VECTOR is present, the
52   result size is that of VECTOR; otherwise, the result size is the
53   number /t/ of true elements in MASK unless MASK is scalar with the
54   value true, in which case the result size is the size of ARRAY.
55
56   Result Value: Element /i/ of the result is the element of ARRAY
57   that corresponds to the /i/th true element of MASK, taking elements
58   in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
59   present and has size /n/ > /t/, element /i/ of the result has the
60   value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
61
62   Examples: The nonzero elements of an array M with the value
63   | 0 0 0 |
64   | 9 0 0 | may be "gathered" by the function PACK. The result of
65   | 0 0 7 |
66   PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
67   VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
68
69There are two variants of the PACK intrinsic: one, where MASK is
70array valued, and the other one where MASK is scalar.  */
71
72void
73pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array,
74	       const gfc_array_l1 *mask, const gfc_array_i16 *vector)
75{
76  /* r.* indicates the return array.  */
77  index_type rstride0;
78  GFC_INTEGER_16 * restrict rptr;
79  /* s.* indicates the source array.  */
80  index_type sstride[GFC_MAX_DIMENSIONS];
81  index_type sstride0;
82  const GFC_INTEGER_16 *sptr;
83  /* m.* indicates the mask array.  */
84  index_type mstride[GFC_MAX_DIMENSIONS];
85  index_type mstride0;
86  const GFC_LOGICAL_1 *mptr;
87
88  index_type count[GFC_MAX_DIMENSIONS];
89  index_type extent[GFC_MAX_DIMENSIONS];
90  int zero_sized;
91  index_type n;
92  index_type dim;
93  index_type nelem;
94  index_type total;
95  int mask_kind;
96
97  dim = GFC_DESCRIPTOR_RANK (array);
98
99  mptr = mask->base_addr;
100
101  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
102     and using shifting to address size and endian issues.  */
103
104  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
105
106  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
107#ifdef HAVE_GFC_LOGICAL_16
108      || mask_kind == 16
109#endif
110      )
111    {
112      /*  Do not convert a NULL pointer as we use test for NULL below.  */
113      if (mptr)
114	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
115    }
116  else
117    runtime_error ("Funny sized logical array");
118
119  zero_sized = 0;
120  for (n = 0; n < dim; n++)
121    {
122      count[n] = 0;
123      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
124      if (extent[n] <= 0)
125       zero_sized = 1;
126      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
127      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
128    }
129  if (sstride[0] == 0)
130    sstride[0] = 1;
131  if (mstride[0] == 0)
132    mstride[0] = mask_kind;
133
134  if (zero_sized)
135    sptr = NULL;
136  else
137    sptr = array->base_addr;
138
139  if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
140    {
141      /* Count the elements, either for allocating memory or
142	 for bounds checking.  */
143
144      if (vector != NULL)
145	{
146	  /* The return array will have as many
147	     elements as there are in VECTOR.  */
148	  total = GFC_DESCRIPTOR_EXTENT(vector,0);
149	  if (total < 0)
150	    {
151	      total = 0;
152	      vector = NULL;
153	    }
154	}
155      else
156        {
157      	  /* We have to count the true elements in MASK.  */
158	  total = count_0 (mask);
159        }
160
161      if (ret->base_addr == NULL)
162	{
163	  /* Setup the array descriptor.  */
164	  GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
165
166	  ret->offset = 0;
167
168	  /* xmallocarray allocates a single byte for zero size.  */
169	  ret->base_addr = xmallocarray (total, sizeof (GFC_INTEGER_16));
170
171	  if (total == 0)
172	    return;
173	}
174      else
175	{
176	  /* We come here because of range checking.  */
177	  index_type ret_extent;
178
179	  ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
180	  if (total != ret_extent)
181	    runtime_error ("Incorrect extent in return value of PACK intrinsic;"
182			   " is %ld, should be %ld", (long int) total,
183			   (long int) ret_extent);
184	}
185    }
186
187  rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
188  if (rstride0 == 0)
189    rstride0 = 1;
190  sstride0 = sstride[0];
191  mstride0 = mstride[0];
192  rptr = ret->base_addr;
193
194  while (sptr && mptr)
195    {
196      /* Test this element.  */
197      if (*mptr)
198        {
199          /* Add it.  */
200	  *rptr = *sptr;
201          rptr += rstride0;
202        }
203      /* Advance to the next element.  */
204      sptr += sstride0;
205      mptr += mstride0;
206      count[0]++;
207      n = 0;
208      while (count[n] == extent[n])
209        {
210          /* When we get to the end of a dimension, reset it and increment
211             the next dimension.  */
212          count[n] = 0;
213          /* We could precalculate these products, but this is a less
214             frequently used path so probably not worth it.  */
215          sptr -= sstride[n] * extent[n];
216          mptr -= mstride[n] * extent[n];
217          n++;
218          if (n >= dim)
219            {
220              /* Break out of the loop.  */
221              sptr = NULL;
222              break;
223            }
224          else
225            {
226              count[n]++;
227              sptr += sstride[n];
228              mptr += mstride[n];
229            }
230        }
231    }
232
233  /* Add any remaining elements from VECTOR.  */
234  if (vector)
235    {
236      n = GFC_DESCRIPTOR_EXTENT(vector,0);
237      nelem = ((rptr - ret->base_addr) / rstride0);
238      if (n > nelem)
239        {
240          sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
241          if (sstride0 == 0)
242            sstride0 = 1;
243
244          sptr = vector->base_addr + sstride0 * nelem;
245          n -= nelem;
246          while (n--)
247            {
248	      *rptr = *sptr;
249              rptr += rstride0;
250              sptr += sstride0;
251            }
252        }
253    }
254}
255
256#endif
257
258