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