1`/* Implementation of the CSHIFT intrinsic
2   Copyright (C) 2003-2022 Free Software Foundation, Inc.
3   Contributed by Feng Wang <wf_cs@yahoo.com>
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_'atype_name`)
32
33static void
34cshift1 (gfc_array_char * const restrict ret,
35	const gfc_array_char * const restrict array,
36	const 'atype` * const restrict h,
37	const 'atype_name` * const restrict pwhich)
38{
39  /* r.* indicates the return array.  */
40  index_type rstride[GFC_MAX_DIMENSIONS];
41  index_type rstride0;
42  index_type roffset;
43  char *rptr;
44  char *dest;
45  /* s.* indicates the source array.  */
46  index_type sstride[GFC_MAX_DIMENSIONS];
47  index_type sstride0;
48  index_type soffset;
49  const char *sptr;
50  const char *src;
51  /* h.* indicates the shift array.  */
52  index_type hstride[GFC_MAX_DIMENSIONS];
53  index_type hstride0;
54  const 'atype_name` *hptr;
55
56  index_type count[GFC_MAX_DIMENSIONS];
57  index_type extent[GFC_MAX_DIMENSIONS];
58  index_type dim;
59  index_type len;
60  index_type n;
61  int which;
62  'atype_name` sh;
63  index_type arraysize;
64  index_type size;
65  index_type type_size;
66
67  if (pwhich)
68    which = *pwhich - 1;
69  else
70    which = 0;
71
72  if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
73    runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");
74
75  size = GFC_DESCRIPTOR_SIZE(array);
76
77  arraysize = size0 ((array_t *)array);
78
79  if (ret->base_addr == NULL)
80    {
81      ret->base_addr = xmallocarray (arraysize, size);
82      ret->offset = 0;
83      GFC_DTYPE_COPY(ret,array);
84      for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
85        {
86	  index_type ub, str;
87
88          ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
89
90          if (i == 0)
91            str = 1;
92          else
93	    str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
94	      GFC_DESCRIPTOR_STRIDE(ret,i-1);
95
96	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
97        }
98    }
99  else if (unlikely (compile_options.bounds_check))
100    {
101      bounds_equal_extents ((array_t *) ret, (array_t *) array,
102				 "return value", "CSHIFT");
103    }
104
105  if (unlikely (compile_options.bounds_check))
106    {
107      bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
108      			      "SHIFT argument", "CSHIFT");
109    }
110
111  if (arraysize == 0)
112    return;
113
114  /* See if we should dispatch to a helper function.  */
115
116  type_size = GFC_DTYPE_TYPE_SIZE (array);
117
118  switch (type_size)
119  {
120    case GFC_DTYPE_LOGICAL_1:
121    case GFC_DTYPE_INTEGER_1:
122      cshift1_'atype_kind`_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array,
123      			h, pwhich);
124      return;
125
126    case GFC_DTYPE_LOGICAL_2:
127    case GFC_DTYPE_INTEGER_2:
128      cshift1_'atype_kind`_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array,
129      			h, pwhich);
130      return;
131
132    case GFC_DTYPE_LOGICAL_4:
133    case GFC_DTYPE_INTEGER_4:
134      cshift1_'atype_kind`_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array,
135      			h, pwhich);
136      return;
137
138    case GFC_DTYPE_LOGICAL_8:
139    case GFC_DTYPE_INTEGER_8:
140      cshift1_'atype_kind`_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array,
141      			h, pwhich);
142      return;
143
144#if defined (HAVE_INTEGER_16)
145    case GFC_DTYPE_LOGICAL_16:
146    case GFC_DTYPE_INTEGER_16:
147      cshift1_'atype_kind`_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array,
148      			h, pwhich);
149      return;
150#endif
151
152    case GFC_DTYPE_REAL_4:
153      cshift1_'atype_kind`_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array,
154      			h, pwhich);
155      return;
156
157    case GFC_DTYPE_REAL_8:
158      cshift1_'atype_kind`_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array,
159      			h, pwhich);
160      return;
161
162#if defined (HAVE_REAL_10)
163    case GFC_DTYPE_REAL_10:
164      cshift1_'atype_kind`_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array,
165      			h, pwhich);
166      return;
167#endif
168
169#if defined (HAVE_REAL_16)
170    case GFC_DTYPE_REAL_16:
171      cshift1_'atype_kind`_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array,
172      			h, pwhich);
173      return;
174#endif
175
176    case GFC_DTYPE_COMPLEX_4:
177      cshift1_'atype_kind`_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array,
178      			h, pwhich);
179      return;
180
181    case GFC_DTYPE_COMPLEX_8:
182      cshift1_'atype_kind`_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array,
183      			h, pwhich);
184      return;
185
186#if defined (HAVE_COMPLEX_10)
187    case GFC_DTYPE_COMPLEX_10:
188      cshift1_'atype_kind`_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array,
189      			h, pwhich);
190      return;
191#endif
192
193#if defined (HAVE_COMPLEX_16)
194    case GFC_DTYPE_COMPLEX_16:
195      cshift1_'atype_kind`_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array,
196      			h, pwhich);
197      return;
198#endif
199
200    default:
201      break;
202
203  }
204
205  extent[0] = 1;
206  count[0] = 0;
207  n = 0;
208
209  /* Initialized for avoiding compiler warnings.  */
210  roffset = size;
211  soffset = size;
212  len = 0;
213
214  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
215    {
216      if (dim == which)
217        {
218          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
219          if (roffset == 0)
220            roffset = size;
221          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
222          if (soffset == 0)
223            soffset = size;
224          len = GFC_DESCRIPTOR_EXTENT(array,dim);
225        }
226      else
227        {
228          count[n] = 0;
229          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
230          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
231          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
232
233          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
234          n++;
235        }
236    }
237  if (sstride[0] == 0)
238    sstride[0] = size;
239  if (rstride[0] == 0)
240    rstride[0] = size;
241  if (hstride[0] == 0)
242    hstride[0] = 1;
243
244  dim = GFC_DESCRIPTOR_RANK (array);
245  rstride0 = rstride[0];
246  sstride0 = sstride[0];
247  hstride0 = hstride[0];
248  rptr = ret->base_addr;
249  sptr = array->base_addr;
250  hptr = h->base_addr;
251
252  while (rptr)
253    {
254      /* Do the shift for this dimension.  */
255      sh = *hptr;
256      /* Normal case should be -len < sh < len; try to
257         avoid the expensive remainder operation if possible.  */
258      if (sh < 0)
259        sh += len;
260      if (unlikely (sh >= len || sh < 0))
261        {
262	  sh = sh % len;
263	  if (sh < 0)
264	    sh += len;
265	}
266
267      src = &sptr[sh * soffset];
268      dest = rptr;
269      if (soffset == size && roffset == size)
270      {
271        size_t len1 = sh * size;
272	size_t len2 = (len - sh) * size;
273	memcpy (rptr, sptr + len1, len2);
274	memcpy (rptr + len2, sptr, len1);
275      }
276      else
277        {
278	  for (n = 0; n < len - sh; n++)
279            {
280	      memcpy (dest, src, size);
281	      dest += roffset;
282	      src += soffset;
283	    }
284	    for (src = sptr, n = 0; n < sh; n++)
285	      {
286		memcpy (dest, src, size);
287		dest += roffset;
288		src += soffset;
289	      }
290	  }
291
292      /* Advance to the next section.  */
293      rptr += rstride0;
294      sptr += sstride0;
295      hptr += hstride0;
296      count[0]++;
297      n = 0;
298      while (count[n] == extent[n])
299        {
300          /* When we get to the end of a dimension, reset it and increment
301             the next dimension.  */
302          count[n] = 0;
303          /* We could precalculate these products, but this is a less
304             frequently used path so probably not worth it.  */
305          rptr -= rstride[n] * extent[n];
306          sptr -= sstride[n] * extent[n];
307	  hptr -= hstride[n] * extent[n];
308          n++;
309          if (n >= dim - 1)
310            {
311              /* Break out of the loop.  */
312              rptr = NULL;
313              break;
314            }
315          else
316            {
317              count[n]++;
318              rptr += rstride[n];
319              sptr += sstride[n];
320	      hptr += hstride[n];
321            }
322        }
323    }
324}
325
326void cshift1_'atype_kind` (gfc_array_char * const restrict,
327	const gfc_array_char * const restrict,
328	const 'atype` * const restrict,
329	const 'atype_name` * const restrict);
330export_proto(cshift1_'atype_kind`);
331
332void
333cshift1_'atype_kind` (gfc_array_char * const restrict ret,
334	const gfc_array_char * const restrict array,
335	const 'atype` * const restrict h,
336	const 'atype_name` * const restrict pwhich)
337{
338  cshift1 (ret, array, h, pwhich);
339}
340
341
342void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
343	GFC_INTEGER_4,
344	const gfc_array_char * const restrict array,
345	const 'atype` * const restrict h,
346	const 'atype_name` * const restrict pwhich,
347	GFC_INTEGER_4);
348export_proto(cshift1_'atype_kind`_char);
349
350void
351cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
352	GFC_INTEGER_4 ret_length __attribute__((unused)),
353	const gfc_array_char * const restrict array,
354	const 'atype` * const restrict h,
355	const 'atype_name` * const restrict pwhich,
356	GFC_INTEGER_4 array_length __attribute__((unused)))
357{
358  cshift1 (ret, array, h, pwhich);
359}
360
361
362void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
363	GFC_INTEGER_4,
364	const gfc_array_char * const restrict array,
365	const 'atype` * const restrict h,
366	const 'atype_name` * const restrict pwhich,
367	GFC_INTEGER_4);
368export_proto(cshift1_'atype_kind`_char4);
369
370void
371cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
372	GFC_INTEGER_4 ret_length __attribute__((unused)),
373	const gfc_array_char * const restrict array,
374	const 'atype` * const restrict h,
375	const 'atype_name` * const restrict pwhich,
376	GFC_INTEGER_4 array_length __attribute__((unused)))
377{
378  cshift1 (ret, array, h, pwhich);
379}
380
381#endif'
382