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