1/* Implementation of the EOSHIFT intrinsic
2   Copyright (C) 2002-2020 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
12Libgfortran 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
32static void
33eoshift3 (gfc_array_char * const restrict ret,
34	const gfc_array_char * const restrict array,
35	const gfc_array_i16 * const restrict h,
36	const gfc_array_char * const restrict bound,
37	const GFC_INTEGER_16 * const restrict pwhich,
38	const char * filler, index_type filler_len)
39{
40  /* r.* indicates the return array.  */
41  index_type rstride[GFC_MAX_DIMENSIONS];
42  index_type rstride0;
43  index_type roffset;
44  char *rptr;
45  char * restrict dest;
46  /* s.* indicates the source array.  */
47  index_type sstride[GFC_MAX_DIMENSIONS];
48  index_type sstride0;
49  index_type soffset;
50  const char *sptr;
51  const char *src;
52  /* h.* indicates the shift array.  */
53  index_type hstride[GFC_MAX_DIMENSIONS];
54  index_type hstride0;
55  const GFC_INTEGER_16 *hptr;
56  /* b.* indicates the bound array.  */
57  index_type bstride[GFC_MAX_DIMENSIONS];
58  index_type bstride0;
59  const char *bptr;
60
61  index_type count[GFC_MAX_DIMENSIONS];
62  index_type extent[GFC_MAX_DIMENSIONS];
63  index_type dim;
64  index_type len;
65  index_type n;
66  index_type size;
67  index_type arraysize;
68  int which;
69  GFC_INTEGER_16 sh;
70  GFC_INTEGER_16 delta;
71
72  /* The compiler cannot figure out that these are set, initialize
73     them to avoid warnings.  */
74  len = 0;
75  soffset = 0;
76  roffset = 0;
77
78  arraysize = size0 ((array_t *) array);
79  size = GFC_DESCRIPTOR_SIZE(array);
80
81  if (pwhich)
82    which = *pwhich - 1;
83  else
84    which = 0;
85
86  if (ret->base_addr == NULL)
87    {
88      ret->base_addr = xmallocarray (arraysize, size);
89      ret->offset = 0;
90      GFC_DTYPE_COPY(ret,array);
91      for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
92        {
93	  index_type ub, str;
94
95	  ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
96
97          if (i == 0)
98            str = 1;
99          else
100            str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
101	      * GFC_DESCRIPTOR_STRIDE(ret,i-1);
102
103	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
104
105        }
106      /* xmallocarray allocates a single byte for zero size.  */
107      ret->base_addr = xmallocarray (arraysize, size);
108
109    }
110  else if (unlikely (compile_options.bounds_check))
111    {
112      bounds_equal_extents ((array_t *) ret, (array_t *) array,
113				 "return value", "EOSHIFT");
114    }
115
116  if (unlikely (compile_options.bounds_check))
117    {
118      bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
119      			      "SHIFT argument", "EOSHIFT");
120    }
121
122  if (arraysize == 0)
123    return;
124
125  extent[0] = 1;
126  count[0] = 0;
127  n = 0;
128  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
129    {
130      if (dim == which)
131        {
132          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
133          if (roffset == 0)
134            roffset = size;
135          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
136          if (soffset == 0)
137            soffset = size;
138          len = GFC_DESCRIPTOR_EXTENT(array,dim);
139        }
140      else
141        {
142          count[n] = 0;
143          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
144          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
145          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
146
147          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
148          if (bound)
149            bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
150          else
151            bstride[n] = 0;
152          n++;
153        }
154    }
155  if (sstride[0] == 0)
156    sstride[0] = size;
157  if (rstride[0] == 0)
158    rstride[0] = size;
159  if (hstride[0] == 0)
160    hstride[0] = 1;
161  if (bound && bstride[0] == 0)
162    bstride[0] = size;
163
164  dim = GFC_DESCRIPTOR_RANK (array);
165  rstride0 = rstride[0];
166  sstride0 = sstride[0];
167  hstride0 = hstride[0];
168  bstride0 = bstride[0];
169  rptr = ret->base_addr;
170  sptr = array->base_addr;
171  hptr = h->base_addr;
172  if (bound)
173    bptr = bound->base_addr;
174  else
175    bptr = NULL;
176
177  while (rptr)
178    {
179      /* Do the shift for this dimension.  */
180      sh = *hptr;
181      if (( sh >= 0 ? sh : -sh ) > len)
182	{
183	  delta = len;
184	  sh = len;
185	}
186      else
187	delta = (sh >= 0) ? sh: -sh;
188
189      if (sh > 0)
190        {
191          src = &sptr[delta * soffset];
192          dest = rptr;
193        }
194      else
195        {
196          src = sptr;
197          dest = &rptr[delta * roffset];
198        }
199
200      /* If the elements are contiguous, perform a single block move.  */
201      if (soffset == size && roffset == size)
202	{
203	  size_t chunk = size * (len - delta);
204	  memcpy (dest, src, chunk);
205	  dest += chunk;
206	}
207      else
208	{
209	  for (n = 0; n < len - delta; n++)
210	    {
211	      memcpy (dest, src, size);
212	      dest += roffset;
213	      src += soffset;
214	    }
215	}
216
217      if (sh < 0)
218        dest = rptr;
219      n = delta;
220
221      if (bptr)
222	while (n--)
223	  {
224	    memcpy (dest, bptr, size);
225	    dest += roffset;
226	  }
227      else
228	while (n--)
229	  {
230	    index_type i;
231
232	    if (filler_len == 1)
233	      memset (dest, filler[0], size);
234	    else
235	      for (i = 0; i < size; i += filler_len)
236		memcpy (&dest[i], filler, filler_len);
237
238	    dest += roffset;
239	  }
240
241      /* Advance to the next section.  */
242      rptr += rstride0;
243      sptr += sstride0;
244      hptr += hstride0;
245      bptr += bstride0;
246      count[0]++;
247      n = 0;
248      while (count[n] == extent[n])
249        {
250          /* When we get to the end of a dimension, reset it and increment
251             the next dimension.  */
252          count[n] = 0;
253          /* We could precalculate these products, but this is a less
254             frequently used path so probably not worth it.  */
255          rptr -= rstride[n] * extent[n];
256          sptr -= sstride[n] * extent[n];
257	  hptr -= hstride[n] * extent[n];
258          bptr -= bstride[n] * extent[n];
259          n++;
260          if (n >= dim - 1)
261            {
262              /* Break out of the loop.  */
263              rptr = NULL;
264              break;
265            }
266          else
267            {
268              count[n]++;
269              rptr += rstride[n];
270              sptr += sstride[n];
271	      hptr += hstride[n];
272              bptr += bstride[n];
273            }
274        }
275    }
276}
277
278extern void eoshift3_16 (gfc_array_char * const restrict,
279	const gfc_array_char * const restrict,
280	const gfc_array_i16 * const restrict,
281	const gfc_array_char * const restrict,
282	const GFC_INTEGER_16 *);
283export_proto(eoshift3_16);
284
285void
286eoshift3_16 (gfc_array_char * const restrict ret,
287	const gfc_array_char * const restrict array,
288	const gfc_array_i16 * const restrict h,
289	const gfc_array_char * const restrict bound,
290	const GFC_INTEGER_16 * const restrict pwhich)
291{
292  eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
293}
294
295
296extern void eoshift3_16_char (gfc_array_char * const restrict,
297	GFC_INTEGER_4,
298	const gfc_array_char * const restrict,
299	const gfc_array_i16 * const restrict,
300	const gfc_array_char * const restrict,
301	const GFC_INTEGER_16 * const restrict,
302	GFC_INTEGER_4, GFC_INTEGER_4);
303export_proto(eoshift3_16_char);
304
305void
306eoshift3_16_char (gfc_array_char * const restrict ret,
307	GFC_INTEGER_4 ret_length __attribute__((unused)),
308	const gfc_array_char * const restrict array,
309	const gfc_array_i16 *  const restrict h,
310	const gfc_array_char * const restrict bound,
311	const GFC_INTEGER_16 * const restrict pwhich,
312	GFC_INTEGER_4 array_length __attribute__((unused)),
313	GFC_INTEGER_4 bound_length __attribute__((unused)))
314{
315  eoshift3 (ret, array, h, bound, pwhich, " ", 1);
316}
317
318
319extern void eoshift3_16_char4 (gfc_array_char * const restrict,
320	GFC_INTEGER_4,
321	const gfc_array_char * const restrict,
322	const gfc_array_i16 * const restrict,
323	const gfc_array_char * const restrict,
324	const GFC_INTEGER_16 * const restrict,
325	GFC_INTEGER_4, GFC_INTEGER_4);
326export_proto(eoshift3_16_char4);
327
328void
329eoshift3_16_char4 (gfc_array_char * const restrict ret,
330	GFC_INTEGER_4 ret_length __attribute__((unused)),
331	const gfc_array_char * const restrict array,
332	const gfc_array_i16 *  const restrict h,
333	const gfc_array_char * const restrict bound,
334	const GFC_INTEGER_16 * const restrict pwhich,
335	GFC_INTEGER_4 array_length __attribute__((unused)),
336	GFC_INTEGER_4 bound_length __attribute__((unused)))
337{
338  static const gfc_char4_t space = (unsigned char) ' ';
339  eoshift3 (ret, array, h, bound, pwhich,
340	    (const char *) &space, sizeof (gfc_char4_t));
341}
342
343#endif
344