1/* Helper function for cshift functions.
2   Copyright (C) 2008-2022 Free Software Foundation, Inc.
3   Contributed by Thomas Koenig <tkoenig@gcc.gnu.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
29
30#if defined (HAVE_GFC_INTEGER_2)
31
32void
33cshift0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, ptrdiff_t shift,
34		     int which)
35{
36  /* r.* indicates the return array.  */
37  index_type rstride[GFC_MAX_DIMENSIONS];
38  index_type rstride0;
39  index_type roffset;
40  GFC_INTEGER_2 *rptr;
41
42  /* s.* indicates the source array.  */
43  index_type sstride[GFC_MAX_DIMENSIONS];
44  index_type sstride0;
45  index_type soffset;
46  const GFC_INTEGER_2 *sptr;
47
48  index_type count[GFC_MAX_DIMENSIONS];
49  index_type extent[GFC_MAX_DIMENSIONS];
50  index_type dim;
51  index_type len;
52  index_type n;
53
54  bool do_blocked;
55  index_type r_ex, a_ex;
56
57  which = which - 1;
58  sstride[0] = 0;
59  rstride[0] = 0;
60
61  extent[0] = 1;
62  count[0] = 0;
63  n = 0;
64  /* Initialized for avoiding compiler warnings.  */
65  roffset = 1;
66  soffset = 1;
67  len = 0;
68
69  r_ex = 1;
70  a_ex = 1;
71
72  if (which > 0)
73    {
74      /* Test if both ret and array are contiguous.  */
75      do_blocked = true;
76      dim = GFC_DESCRIPTOR_RANK (array);
77      for (n = 0; n < dim; n ++)
78	{
79	  index_type rs, as;
80	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
81	  if (rs != r_ex)
82	    {
83	      do_blocked = false;
84	      break;
85	    }
86	  as = GFC_DESCRIPTOR_STRIDE (array, n);
87	  if (as != a_ex)
88	    {
89	      do_blocked = false;
90	      break;
91	    }
92	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
93	  a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
94	}
95    }
96  else
97    do_blocked = false;
98
99  n = 0;
100
101  if (do_blocked)
102    {
103      /* For contiguous arrays, use the relationship that
104
105         dimension(n1,n2,n3) :: a, b
106	 b = cshift(a,sh,3)
107
108         can be dealt with as if
109
110	 dimension(n1*n2*n3) :: an, bn
111	 bn = cshift(a,sh*n1*n2,1)
112
113	 we can used a more blocked algorithm for dim>1.  */
114      sstride[0] = 1;
115      rstride[0] = 1;
116      roffset = 1;
117      soffset = 1;
118      len = GFC_DESCRIPTOR_STRIDE(array, which)
119	* GFC_DESCRIPTOR_EXTENT(array, which);
120      shift *= GFC_DESCRIPTOR_STRIDE(array, which);
121      for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
122	{
123	  count[n] = 0;
124	  extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
125	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
126	  sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
127	  n++;
128	}
129      dim = GFC_DESCRIPTOR_RANK (array) - which;
130    }
131  else
132    {
133      for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
134	{
135	  if (dim == which)
136	    {
137	      roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
138	      if (roffset == 0)
139		roffset = 1;
140	      soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
141	      if (soffset == 0)
142		soffset = 1;
143	      len = GFC_DESCRIPTOR_EXTENT(array,dim);
144	    }
145	  else
146	    {
147	      count[n] = 0;
148	      extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
149	      rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
150	      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
151	      n++;
152	    }
153	}
154      if (sstride[0] == 0)
155	sstride[0] = 1;
156      if (rstride[0] == 0)
157	rstride[0] = 1;
158
159      dim = GFC_DESCRIPTOR_RANK (array);
160    }
161
162  rstride0 = rstride[0];
163  sstride0 = sstride[0];
164  rptr = ret->base_addr;
165  sptr = array->base_addr;
166
167  /* Avoid the costly modulo for trivially in-bound shifts.  */
168  if (shift < 0 || shift >= len)
169    {
170      shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
171      if (shift < 0)
172	shift += len;
173    }
174
175  while (rptr)
176    {
177      /* Do the shift for this dimension.  */
178
179      /* If elements are contiguous, perform the operation
180	 in two block moves.  */
181      if (soffset == 1 && roffset == 1)
182	{
183	  size_t len1 = shift * sizeof (GFC_INTEGER_2);
184	  size_t len2 = (len - shift) * sizeof (GFC_INTEGER_2);
185	  memcpy (rptr, sptr + shift, len2);
186	  memcpy (rptr + (len - shift), sptr, len1);
187	}
188      else
189	{
190	  /* Otherwise, we will have to perform the copy one element at
191	     a time.  */
192	  GFC_INTEGER_2 *dest = rptr;
193	  const GFC_INTEGER_2 *src = &sptr[shift * soffset];
194
195	  for (n = 0; n < len - shift; n++)
196	    {
197	      *dest = *src;
198	      dest += roffset;
199	      src += soffset;
200	    }
201	  for (src = sptr, n = 0; n < shift; n++)
202	    {
203	      *dest = *src;
204	      dest += roffset;
205	      src += soffset;
206	    }
207	}
208
209      /* Advance to the next section.  */
210      rptr += rstride0;
211      sptr += sstride0;
212      count[0]++;
213      n = 0;
214      while (count[n] == extent[n])
215        {
216          /* When we get to the end of a dimension, reset it and increment
217             the next dimension.  */
218          count[n] = 0;
219          /* We could precalculate these products, but this is a less
220             frequently used path so probably not worth it.  */
221          rptr -= rstride[n] * extent[n];
222          sptr -= sstride[n] * extent[n];
223          n++;
224          if (n >= dim - 1)
225            {
226              /* Break out of the loop.  */
227              rptr = NULL;
228              break;
229            }
230          else
231            {
232              count[n]++;
233              rptr += rstride[n];
234              sptr += sstride[n];
235            }
236        }
237    }
238
239  return;
240}
241
242#endif
243