1/* Generic 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
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
29static void
30cshift0 (gfc_array_char * ret, const gfc_array_char * array,
31	 ptrdiff_t shift, int which, index_type size)
32{
33  /* r.* indicates the return array.  */
34  index_type rstride[GFC_MAX_DIMENSIONS];
35  index_type rstride0;
36  index_type roffset;
37  char *rptr;
38
39  /* s.* indicates the source array.  */
40  index_type sstride[GFC_MAX_DIMENSIONS];
41  index_type sstride0;
42  index_type soffset;
43  const char *sptr;
44
45  index_type count[GFC_MAX_DIMENSIONS];
46  index_type extent[GFC_MAX_DIMENSIONS];
47  index_type dim;
48  index_type len;
49  index_type n;
50  index_type arraysize;
51
52  index_type type_size;
53
54  if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
55    runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
56
57  arraysize = size0 ((array_t *) array);
58
59  if (ret->base_addr == NULL)
60    {
61      int i;
62
63      ret->offset = 0;
64      GFC_DTYPE_COPY(ret,array);
65      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
66        {
67	  index_type ub, str;
68
69          ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
70
71          if (i == 0)
72            str = 1;
73          else
74            str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
75	      GFC_DESCRIPTOR_STRIDE(ret,i-1);
76
77	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
78        }
79
80      /* xmallocarray allocates a single byte for zero size.  */
81      ret->base_addr = xmallocarray (arraysize, size);
82    }
83  else if (unlikely (compile_options.bounds_check))
84    {
85      bounds_equal_extents ((array_t *) ret, (array_t *) array,
86				 "return value", "CSHIFT");
87    }
88
89  if (arraysize == 0)
90    return;
91
92  type_size = GFC_DTYPE_TYPE_SIZE (array);
93
94  switch(type_size)
95    {
96    case GFC_DTYPE_LOGICAL_1:
97    case GFC_DTYPE_INTEGER_1:
98      cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
99      return;
100
101    case GFC_DTYPE_LOGICAL_2:
102    case GFC_DTYPE_INTEGER_2:
103      cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
104      return;
105
106    case GFC_DTYPE_LOGICAL_4:
107    case GFC_DTYPE_INTEGER_4:
108      cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
109      return;
110
111    case GFC_DTYPE_LOGICAL_8:
112    case GFC_DTYPE_INTEGER_8:
113      cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
114      return;
115
116#ifdef HAVE_GFC_INTEGER_16
117    case GFC_DTYPE_LOGICAL_16:
118    case GFC_DTYPE_INTEGER_16:
119      cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
120		   which);
121      return;
122#endif
123
124    case GFC_DTYPE_REAL_4:
125      cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
126      return;
127
128    case GFC_DTYPE_REAL_8:
129      cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
130      return;
131
132/* FIXME: This here is a hack, which will have to be removed when
133   the array descriptor is reworked.  Currently, we don't store the
134   kind value for the type, but only the size.  Because on targets with
135   __float128, we have sizeof(logn double) == sizeof(__float128),
136   we cannot discriminate here and have to fall back to the generic
137   handling (which is suboptimal).  */
138#if !defined(GFC_REAL_16_IS_FLOAT128)
139# ifdef HAVE_GFC_REAL_10
140    case GFC_DTYPE_REAL_10:
141      cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
142		   which);
143      return;
144# endif
145
146# ifdef HAVE_GFC_REAL_16
147    case GFC_DTYPE_REAL_16:
148      cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
149		   which);
150      return;
151# endif
152#endif
153
154    case GFC_DTYPE_COMPLEX_4:
155      cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
156      return;
157
158    case GFC_DTYPE_COMPLEX_8:
159      cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
160      return;
161
162/* FIXME: This here is a hack, which will have to be removed when
163   the array descriptor is reworked.  Currently, we don't store the
164   kind value for the type, but only the size.  Because on targets with
165   __float128, we have sizeof(logn double) == sizeof(__float128),
166   we cannot discriminate here and have to fall back to the generic
167   handling (which is suboptimal).  */
168#if !defined(GFC_REAL_16_IS_FLOAT128)
169# ifdef HAVE_GFC_COMPLEX_10
170    case GFC_DTYPE_COMPLEX_10:
171      cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
172		   which);
173      return;
174# endif
175
176# ifdef HAVE_GFC_COMPLEX_16
177    case GFC_DTYPE_COMPLEX_16:
178      cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
179		   which);
180      return;
181# endif
182#endif
183
184    default:
185      break;
186    }
187
188  switch (size)
189    {
190      /* Let's check the actual alignment of the data pointers.  If they
191	 are suitably aligned, we can safely call the unpack functions.  */
192
193    case sizeof (GFC_INTEGER_1):
194      cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
195		  which);
196      break;
197
198    case sizeof (GFC_INTEGER_2):
199      if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr))
200	break;
201      else
202	{
203	  cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
204		      which);
205	  return;
206	}
207
208    case sizeof (GFC_INTEGER_4):
209      if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr))
210	break;
211      else
212	{
213	  cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
214		      which);
215	  return;
216	}
217
218    case sizeof (GFC_INTEGER_8):
219      if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr))
220	{
221	  /* Let's try to use the complex routines.  First, a sanity
222	     check that the sizes match; this should be optimized to
223	     a no-op.  */
224	  if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
225	    break;
226
227	  if (GFC_UNALIGNED_C4(ret->base_addr)
228	      || GFC_UNALIGNED_C4(array->base_addr))
229	    break;
230
231	  cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
232		      which);
233	  return;
234	}
235      else
236	{
237	  cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
238		      which);
239	  return;
240	}
241
242#ifdef HAVE_GFC_INTEGER_16
243    case sizeof (GFC_INTEGER_16):
244      if (GFC_UNALIGNED_16(ret->base_addr)
245	  || GFC_UNALIGNED_16(array->base_addr))
246	{
247	  /* Let's try to use the complex routines.  First, a sanity
248	     check that the sizes match; this should be optimized to
249	     a no-op.  */
250	  if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
251	    break;
252
253	  if (GFC_UNALIGNED_C8(ret->base_addr)
254	      || GFC_UNALIGNED_C8(array->base_addr))
255	    break;
256
257	  cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
258		      which);
259	  return;
260	}
261      else
262	{
263	  cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
264		       shift, which);
265	  return;
266	}
267#else
268    case sizeof (GFC_COMPLEX_8):
269
270      if (GFC_UNALIGNED_C8(ret->base_addr)
271	  || GFC_UNALIGNED_C8(array->base_addr))
272	break;
273      else
274	{
275	  cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
276		      which);
277	  return;
278	}
279#endif
280
281    default:
282      break;
283    }
284
285
286  which = which - 1;
287  sstride[0] = 0;
288  rstride[0] = 0;
289
290  extent[0] = 1;
291  count[0] = 0;
292  n = 0;
293  /* Initialized for avoiding compiler warnings.  */
294  roffset = size;
295  soffset = size;
296  len = 0;
297
298  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
299    {
300      if (dim == which)
301        {
302          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
303          if (roffset == 0)
304            roffset = size;
305          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
306          if (soffset == 0)
307            soffset = size;
308          len = GFC_DESCRIPTOR_EXTENT(array,dim);
309        }
310      else
311        {
312          count[n] = 0;
313          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
314          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
315          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
316          n++;
317        }
318    }
319  if (sstride[0] == 0)
320    sstride[0] = size;
321  if (rstride[0] == 0)
322    rstride[0] = size;
323
324  dim = GFC_DESCRIPTOR_RANK (array);
325  rstride0 = rstride[0];
326  sstride0 = sstride[0];
327  rptr = ret->base_addr;
328  sptr = array->base_addr;
329
330  shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
331  if (shift < 0)
332    shift += len;
333
334  while (rptr)
335    {
336      /* Do the shift for this dimension.  */
337
338      /* If elements are contiguous, perform the operation
339	 in two block moves.  */
340      if (soffset == size && roffset == size)
341	{
342	  size_t len1 = shift * size;
343	  size_t len2 = (len - shift) * size;
344	  memcpy (rptr, sptr + len1, len2);
345	  memcpy (rptr + len2, sptr, len1);
346	}
347      else
348	{
349	  /* Otherwise, we'll have to perform the copy one element at
350	     a time.  */
351	  char *dest = rptr;
352	  const char *src = &sptr[shift * soffset];
353
354	  for (n = 0; n < len - shift; n++)
355	    {
356	      memcpy (dest, src, size);
357	      dest += roffset;
358	      src += soffset;
359	    }
360	  for (src = sptr, n = 0; n < shift; n++)
361	    {
362	      memcpy (dest, src, size);
363	      dest += roffset;
364	      src += soffset;
365	    }
366	}
367
368      /* Advance to the next section.  */
369      rptr += rstride0;
370      sptr += sstride0;
371      count[0]++;
372      n = 0;
373      while (count[n] == extent[n])
374        {
375          /* When we get to the end of a dimension, reset it and increment
376             the next dimension.  */
377          count[n] = 0;
378          /* We could precalculate these products, but this is a less
379             frequently used path so probably not worth it.  */
380          rptr -= rstride[n] * extent[n];
381          sptr -= sstride[n] * extent[n];
382          n++;
383          if (n >= dim - 1)
384            {
385              /* Break out of the loop.  */
386              rptr = NULL;
387              break;
388            }
389          else
390            {
391              count[n]++;
392              rptr += rstride[n];
393              sptr += sstride[n];
394            }
395        }
396    }
397}
398
399#define DEFINE_CSHIFT(N)						      \
400  extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,	      \
401			   const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
402  export_proto(cshift0_##N);						      \
403									      \
404  void									      \
405  cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,	      \
406	       const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
407  {									      \
408    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,			      \
409	     GFC_DESCRIPTOR_SIZE (array));				      \
410  }									      \
411									      \
412  extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,	      \
413				  const gfc_array_char *,		      \
414				  const GFC_INTEGER_##N *,		      \
415				  const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
416  export_proto(cshift0_##N##_char);					      \
417									      \
418  void									      \
419  cshift0_##N##_char (gfc_array_char *ret,				      \
420		      GFC_INTEGER_4 ret_length __attribute__((unused)),	      \
421		      const gfc_array_char *array,			      \
422		      const GFC_INTEGER_##N *pshift,			      \
423		      const GFC_INTEGER_##N *pdim,			      \
424		      GFC_INTEGER_4 array_length)			      \
425  {									      \
426    cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);	      \
427  }									      \
428									      \
429  extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,	      \
430				   const gfc_array_char *,		      \
431				   const GFC_INTEGER_##N *,		      \
432				   const GFC_INTEGER_##N *, GFC_INTEGER_4);   \
433  export_proto(cshift0_##N##_char4);					      \
434									      \
435  void									      \
436  cshift0_##N##_char4 (gfc_array_char *ret,				      \
437		       GFC_INTEGER_4 ret_length __attribute__((unused)),      \
438		       const gfc_array_char *array,			      \
439		       const GFC_INTEGER_##N *pshift,			      \
440		       const GFC_INTEGER_##N *pdim,			      \
441		       GFC_INTEGER_4 array_length)			      \
442  {									      \
443    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,			      \
444	     array_length * sizeof (gfc_char4_t));			      \
445  }
446
447DEFINE_CSHIFT (1);
448DEFINE_CSHIFT (2);
449DEFINE_CSHIFT (4);
450DEFINE_CSHIFT (8);
451#ifdef HAVE_GFC_INTEGER_16
452DEFINE_CSHIFT (16);
453#endif
454