1 `/* Implementation of the EOSHIFT intrinsic
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
31 `#if defined (HAVE_'atype_name`)
34 eoshift3 (gfc_array_char * const restrict ret,
35 const gfc_array_char * const restrict array,
36 const 'atype` * const restrict h,
37 const gfc_array_char * const restrict bound,
38 const 'atype_name` * const restrict pwhich,
39 const char * filler, index_type filler_len)
41 /* r.* indicates the return array. */
42 index_type rstride[GFC_MAX_DIMENSIONS];
47 /* s.* indicates the source array. */
48 index_type sstride[GFC_MAX_DIMENSIONS];
53 /* h.* indicates the shift array. */
54 index_type hstride[GFC_MAX_DIMENSIONS];
56 const 'atype_name` *hptr;
57 /* b.* indicates the bound array. */
58 index_type bstride[GFC_MAX_DIMENSIONS];
62 index_type count[GFC_MAX_DIMENSIONS];
63 index_type extent[GFC_MAX_DIMENSIONS];
73 /* The compiler cannot figure out that these are set, initialize
74 them to avoid warnings. */
79 arraysize = size0 ((array_t *) array);
80 size = GFC_DESCRIPTOR_SIZE(array);
87 if (ret->base_addr == NULL)
91 ret->base_addr = xmallocarray (arraysize, size);
93 ret->dtype = array->dtype;
94 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
98 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
103 str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
104 * GFC_DESCRIPTOR_STRIDE(ret,i-1);
106 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
109 /* xmallocarray allocates a single byte for zero size. */
110 ret->base_addr = xmallocarray (arraysize, size);
113 else if (unlikely (compile_options.bounds_check))
115 bounds_equal_extents ((array_t *) ret, (array_t *) array,
116 "return value", "EOSHIFT");
119 if (unlikely (compile_options.bounds_check))
121 bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
122 "SHIFT argument", "EOSHIFT");
131 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
135 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
138 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
141 len = GFC_DESCRIPTOR_EXTENT(array,dim);
146 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
147 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
148 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
150 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
152 bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
164 if (bound && bstride[0] == 0)
167 dim = GFC_DESCRIPTOR_RANK (array);
168 rstride0 = rstride[0];
169 sstride0 = sstride[0];
170 hstride0 = hstride[0];
171 bstride0 = bstride[0];
172 rptr = ret->base_addr;
173 sptr = array->base_addr;
176 bptr = bound->base_addr;
182 /* Do the shift for this dimension. */
184 if (( sh >= 0 ? sh : -sh ) > len)
190 delta = (sh >= 0) ? sh: -sh;
194 src = &sptr[delta * soffset];
200 dest = &rptr[delta * roffset];
203 /* If the elements are contiguous, perform a single block move. */
204 if (soffset == size && roffset == size)
206 size_t chunk = size * (len - delta);
207 memcpy (dest, src, chunk);
212 for (n = 0; n < len - delta; n++)
214 memcpy (dest, src, size);
227 memcpy (dest, bptr, size);
236 memset (dest, filler[0], size);
238 for (i = 0; i < size; i += filler_len)
239 memcpy (&dest[i], filler, filler_len);
244 /* Advance to the next section. */
251 while (count[n] == extent[n])
253 /* When we get to the end of a dimension, reset it and increment
254 the next dimension. */
256 /* We could precalculate these products, but this is a less
257 frequently used path so probably not worth it. */
258 rptr -= rstride[n] * extent[n];
259 sptr -= sstride[n] * extent[n];
260 hptr -= hstride[n] * extent[n];
261 bptr -= bstride[n] * extent[n];
265 /* Break out of the loop. */
281 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
282 const gfc_array_char * const restrict,
283 const 'atype` * const restrict,
284 const gfc_array_char * const restrict,
285 const 'atype_name` *);
286 export_proto(eoshift3_'atype_kind`);
289 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
290 const gfc_array_char * const restrict array,
291 const 'atype` * const restrict h,
292 const gfc_array_char * const restrict bound,
293 const 'atype_name` * const restrict pwhich)
295 eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
299 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
301 const gfc_array_char * const restrict,
302 const 'atype` * const restrict,
303 const gfc_array_char * const restrict,
304 const 'atype_name` * const restrict,
305 GFC_INTEGER_4, GFC_INTEGER_4);
306 export_proto(eoshift3_'atype_kind`_char);
309 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
310 GFC_INTEGER_4 ret_length __attribute__((unused)),
311 const gfc_array_char * const restrict array,
312 const 'atype` * const restrict h,
313 const gfc_array_char * const restrict bound,
314 const 'atype_name` * const restrict pwhich,
315 GFC_INTEGER_4 array_length __attribute__((unused)),
316 GFC_INTEGER_4 bound_length __attribute__((unused)))
318 eoshift3 (ret, array, h, bound, pwhich, " ", 1);
322 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
324 const gfc_array_char * const restrict,
325 const 'atype` * const restrict,
326 const gfc_array_char * const restrict,
327 const 'atype_name` * const restrict,
328 GFC_INTEGER_4, GFC_INTEGER_4);
329 export_proto(eoshift3_'atype_kind`_char4);
332 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
333 GFC_INTEGER_4 ret_length __attribute__((unused)),
334 const gfc_array_char * const restrict array,
335 const 'atype` * const restrict h,
336 const gfc_array_char * const restrict bound,
337 const 'atype_name` * const restrict pwhich,
338 GFC_INTEGER_4 array_length __attribute__((unused)),
339 GFC_INTEGER_4 bound_length __attribute__((unused)))
341 static const gfc_char4_t space = (unsigned char) ''` ''`;
342 eoshift3 (ret, array, h, bound, pwhich,
343 (const char *) &space, sizeof (gfc_char4_t));