1`/* Implementation of the EOSHIFT intrinsic
2   Copyright (C) 2002-2013 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.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 <stdlib.h>
28#include <assert.h>
29#include <string.h>'
30
31include(iparm.m4)dnl
32
33`#if defined (HAVE_'atype_name`)
34
35static void
36eoshift1 (gfc_array_char * const restrict ret,
37	const gfc_array_char * const restrict array,
38	const 'atype` * const restrict h,
39	const char * const restrict pbound,
40	const 'atype_name` * const restrict pwhich,
41	const char * filler, index_type filler_len)
42{
43  /* r.* indicates the return array.  */
44  index_type rstride[GFC_MAX_DIMENSIONS];
45  index_type rstride0;
46  index_type roffset;
47  char *rptr;
48  char * restrict dest;
49  /* s.* indicates the source array.  */
50  index_type sstride[GFC_MAX_DIMENSIONS];
51  index_type sstride0;
52  index_type soffset;
53  const char *sptr;
54  const char *src;
55  /* h.* indicates the shift array.  */
56  index_type hstride[GFC_MAX_DIMENSIONS];
57  index_type hstride0;
58  const 'atype_name` *hptr;
59
60  index_type count[GFC_MAX_DIMENSIONS];
61  index_type extent[GFC_MAX_DIMENSIONS];
62  index_type dim;
63  index_type len;
64  index_type n;
65  index_type size;
66  index_type arraysize;
67  int which;
68  'atype_name` sh;
69  'atype_name` delta;
70
71  /* The compiler cannot figure out that these are set, initialize
72     them to avoid warnings.  */
73  len = 0;
74  soffset = 0;
75  roffset = 0;
76
77  size = GFC_DESCRIPTOR_SIZE(array);
78
79  if (pwhich)
80    which = *pwhich - 1;
81  else
82    which = 0;
83
84  extent[0] = 1;
85  count[0] = 0;
86
87  arraysize = size0 ((array_t *) array);
88  if (ret->base_addr == NULL)
89    {
90      int i;
91
92      ret->offset = 0;
93      ret->dtype = array->dtype;
94      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
95        {
96	  index_type ub, str;
97
98	  ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
99
100          if (i == 0)
101            str = 1;
102          else
103            str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
104	      * GFC_DESCRIPTOR_STRIDE(ret,i-1);
105
106	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
107
108        }
109      /* xmalloc allocates a single byte for zero size.  */
110      ret->base_addr = xmalloc (size * arraysize);
111
112    }
113  else if (unlikely (compile_options.bounds_check))
114    {
115      bounds_equal_extents ((array_t *) ret, (array_t *) array,
116				 "return value", "EOSHIFT");
117    }
118
119  if (unlikely (compile_options.bounds_check))
120    {
121      bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
122      			      "SHIFT argument", "EOSHIFT");
123    }
124
125  if (arraysize == 0)
126    return;
127
128  n = 0;
129  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
130    {
131      if (dim == which)
132        {
133          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
134          if (roffset == 0)
135            roffset = size;
136          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
137          if (soffset == 0)
138            soffset = size;
139          len = GFC_DESCRIPTOR_EXTENT(array,dim);
140        }
141      else
142        {
143          count[n] = 0;
144          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
145          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
146          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
147
148          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
149          n++;
150        }
151    }
152  if (sstride[0] == 0)
153    sstride[0] = size;
154  if (rstride[0] == 0)
155    rstride[0] = size;
156  if (hstride[0] == 0)
157    hstride[0] = 1;
158
159  dim = GFC_DESCRIPTOR_RANK (array);
160  rstride0 = rstride[0];
161  sstride0 = sstride[0];
162  hstride0 = hstride[0];
163  rptr = ret->base_addr;
164  sptr = array->base_addr;
165  hptr = h->base_addr;
166
167  while (rptr)
168    {
169      /* Do the shift for this dimension.  */
170      sh = *hptr;
171      if (( sh >= 0 ? sh : -sh ) > len)
172	{
173	  delta = len;
174	  sh = len;
175	}
176      else
177	delta = (sh >= 0) ? sh: -sh;
178
179      if (sh > 0)
180        {
181          src = &sptr[delta * soffset];
182          dest = rptr;
183        }
184      else
185        {
186          src = sptr;
187          dest = &rptr[delta * roffset];
188        }
189      for (n = 0; n < len - delta; n++)
190        {
191          memcpy (dest, src, size);
192          dest += roffset;
193          src += soffset;
194        }
195      if (sh < 0)
196        dest = rptr;
197      n = delta;
198
199      if (pbound)
200	while (n--)
201	  {
202	    memcpy (dest, pbound, size);
203	    dest += roffset;
204	  }
205      else
206	while (n--)
207	  {
208	    index_type i;
209
210	    if (filler_len == 1)
211	      memset (dest, filler[0], size);
212	    else
213	      for (i = 0; i < size; i += filler_len)
214		memcpy (&dest[i], filler, filler_len);
215
216	    dest += roffset;
217	  }
218
219      /* Advance to the next section.  */
220      rptr += rstride0;
221      sptr += sstride0;
222      hptr += hstride0;
223      count[0]++;
224      n = 0;
225      while (count[n] == extent[n])
226        {
227          /* When we get to the end of a dimension, reset it and increment
228             the next dimension.  */
229          count[n] = 0;
230          /* We could precalculate these products, but this is a less
231             frequently used path so probably not worth it.  */
232          rptr -= rstride[n] * extent[n];
233          sptr -= sstride[n] * extent[n];
234	  hptr -= hstride[n] * extent[n];
235          n++;
236          if (n >= dim - 1)
237            {
238              /* Break out of the loop.  */
239              rptr = NULL;
240              break;
241            }
242          else
243            {
244              count[n]++;
245              rptr += rstride[n];
246              sptr += sstride[n];
247	      hptr += hstride[n];
248            }
249        }
250    }
251}
252
253void eoshift1_'atype_kind` (gfc_array_char * const restrict,
254	const gfc_array_char * const restrict,
255	const 'atype` * const restrict, const char * const restrict,
256	const 'atype_name` * const restrict);
257export_proto(eoshift1_'atype_kind`);
258
259void
260eoshift1_'atype_kind` (gfc_array_char * const restrict ret,
261	const gfc_array_char * const restrict array,
262	const 'atype` * const restrict h,
263	const char * const restrict pbound,
264	const 'atype_name` * const restrict pwhich)
265{
266  eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
267}
268
269
270void eoshift1_'atype_kind`_char (gfc_array_char * const restrict,
271	GFC_INTEGER_4,
272	const gfc_array_char * const restrict,
273	const 'atype` * const restrict,
274	const char * const restrict,
275	const 'atype_name` * const restrict,
276	GFC_INTEGER_4, GFC_INTEGER_4);
277export_proto(eoshift1_'atype_kind`_char);
278
279void
280eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
281	GFC_INTEGER_4 ret_length __attribute__((unused)),
282	const gfc_array_char * const restrict array,
283	const 'atype` * const restrict h,
284	const char *  const restrict pbound,
285	const 'atype_name` * const restrict pwhich,
286	GFC_INTEGER_4 array_length __attribute__((unused)),
287	GFC_INTEGER_4 bound_length __attribute__((unused)))
288{
289  eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
290}
291
292
293void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict,
294	GFC_INTEGER_4,
295	const gfc_array_char * const restrict,
296	const 'atype` * const restrict,
297	const char * const restrict,
298	const 'atype_name` * const restrict,
299	GFC_INTEGER_4, GFC_INTEGER_4);
300export_proto(eoshift1_'atype_kind`_char4);
301
302void
303eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
304	GFC_INTEGER_4 ret_length __attribute__((unused)),
305	const gfc_array_char * const restrict array,
306	const 'atype` * const restrict h,
307	const char *  const restrict pbound,
308	const 'atype_name` * const restrict pwhich,
309	GFC_INTEGER_4 array_length __attribute__((unused)),
310	GFC_INTEGER_4 bound_length __attribute__((unused)))
311{
312  static const gfc_char4_t space = (unsigned char) ''` ''`;
313  eoshift1 (ret, array, h, pbound, pwhich,
314	    (const char *) &space, sizeof (gfc_char4_t));
315}
316
317#endif'
318