1/* Implementation of the CSHIFT intrinsic.
2   Copyright (C) 2017-2022 Free Software Foundation, Inc.
3   Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
4
5This file is part of the GNU Fortran 95 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#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_INTEGER_16)
30
31void
32cshift1_16_c8 (gfc_array_c8 * const restrict ret,
33		const gfc_array_c8 * const restrict array,
34		const gfc_array_i16 * const restrict h,
35		const GFC_INTEGER_16 * const restrict pwhich)
36{
37  /* r.* indicates the return array.  */
38  index_type rstride[GFC_MAX_DIMENSIONS];
39  index_type rstride0;
40  index_type roffset;
41  GFC_COMPLEX_8 *rptr;
42  GFC_COMPLEX_8 *dest;
43  /* s.* indicates the source array.  */
44  index_type sstride[GFC_MAX_DIMENSIONS];
45  index_type sstride0;
46  index_type soffset;
47  const GFC_COMPLEX_8 *sptr;
48  const GFC_COMPLEX_8 *src;
49  /* h.* indicates the shift array.  */
50  index_type hstride[GFC_MAX_DIMENSIONS];
51  index_type hstride0;
52  const GFC_INTEGER_16 *hptr;
53
54  index_type count[GFC_MAX_DIMENSIONS];
55  index_type extent[GFC_MAX_DIMENSIONS];
56  index_type rs_ex[GFC_MAX_DIMENSIONS];
57  index_type ss_ex[GFC_MAX_DIMENSIONS];
58  index_type hs_ex[GFC_MAX_DIMENSIONS];
59
60  index_type dim;
61  index_type len;
62  index_type n;
63  int which;
64  GFC_INTEGER_16 sh;
65
66  /* Bounds checking etc is already done by the caller.  */
67
68  if (pwhich)
69    which = *pwhich - 1;
70  else
71    which = 0;
72
73  extent[0] = 1;
74  count[0] = 0;
75  n = 0;
76
77  /* Initialized for avoiding compiler warnings.  */
78  roffset = 1;
79  soffset = 1;
80  len = 0;
81
82  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
83    {
84      if (dim == which)
85        {
86          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
87          if (roffset == 0)
88            roffset = 1;
89          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
90          if (soffset == 0)
91            soffset = 1;
92          len = GFC_DESCRIPTOR_EXTENT(array,dim);
93        }
94      else
95        {
96          count[n] = 0;
97          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
98          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
99          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
100          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
101	  rs_ex[n] = rstride[n] * extent[n];
102	  ss_ex[n] = sstride[n] * extent[n];
103	  hs_ex[n] = hstride[n] * extent[n];
104          n++;
105        }
106    }
107  if (sstride[0] == 0)
108    sstride[0] = 1;
109  if (rstride[0] == 0)
110    rstride[0] = 1;
111  if (hstride[0] == 0)
112    hstride[0] = 1;
113
114  dim = GFC_DESCRIPTOR_RANK (array);
115  rstride0 = rstride[0];
116  sstride0 = sstride[0];
117  hstride0 = hstride[0];
118  rptr = ret->base_addr;
119  sptr = array->base_addr;
120  hptr = h->base_addr;
121
122  while (rptr)
123    {
124      /* Do the shift for this dimension.  */
125      sh = *hptr;
126      /* Normal case should be -len < sh < len; try to
127         avoid the expensive remainder operation if possible.  */
128      if (sh < 0)
129        sh += len;
130      if (unlikely(sh >= len || sh < 0))
131	{
132 	  sh = sh % len;
133	  if (sh < 0)
134            sh += len;
135	}
136      src = &sptr[sh * soffset];
137      dest = rptr;
138      if (soffset == 1 && roffset == 1)
139	{
140	  size_t len1 = sh * sizeof (GFC_COMPLEX_8);
141	  size_t len2 = (len - sh) * sizeof (GFC_COMPLEX_8);
142	  memcpy (rptr, sptr + sh, len2);
143	  memcpy (rptr + (len - sh), sptr, len1);
144	}
145      else
146        {
147	  for (n = 0; n < len - sh; n++)
148	    {
149	      *dest = *src;
150	      dest += roffset;
151	      src += soffset;
152	    }
153	  for (src = sptr, n = 0; n < sh; n++)
154	    {
155	      *dest = *src;
156	      dest += roffset;
157	      src += soffset;
158	    }
159	}
160
161      /* Advance to the next section.  */
162      rptr += rstride0;
163      sptr += sstride0;
164      hptr += hstride0;
165      count[0]++;
166      n = 0;
167      while (count[n] == extent[n])
168        {
169          /* When we get to the end of a dimension, reset it and increment
170             the next dimension.  */
171          count[n] = 0;
172          rptr -= rs_ex[n];
173          sptr -= ss_ex[n];
174	  hptr -= hs_ex[n];
175          n++;
176          if (n >= dim - 1)
177            {
178              /* Break out of the loop.  */
179              rptr = NULL;
180              break;
181            }
182          else
183            {
184              count[n]++;
185              rptr += rstride[n];
186              sptr += sstride[n];
187	      hptr += hstride[n];
188            }
189        }
190    }
191}
192
193#endif
194