1 `/* Implementation of the EOSHIFT intrinsic
2 Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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"
33 `#if defined (HAVE_'atype_name`)
36 eoshift3 (gfc_array_char * const restrict ret,
37 const gfc_array_char * const restrict array,
38 const 'atype` * const restrict h,
39 const gfc_array_char * const restrict bound,
40 const 'atype_name` * const restrict pwhich,
41 const char * filler, index_type filler_len)
43 /* r.* indicates the return array. */
44 index_type rstride[GFC_MAX_DIMENSIONS];
49 /* s.* indicates the source array. */
50 index_type sstride[GFC_MAX_DIMENSIONS];
55 /* h.* indicates the shift array. */
56 index_type hstride[GFC_MAX_DIMENSIONS];
58 const 'atype_name` *hptr;
59 /* b.* indicates the bound array. */
60 index_type bstride[GFC_MAX_DIMENSIONS];
64 index_type count[GFC_MAX_DIMENSIONS];
65 index_type extent[GFC_MAX_DIMENSIONS];
75 /* The compiler cannot figure out that these are set, initialize
76 them to avoid warnings. */
81 arraysize = size0 ((array_t *) array);
82 size = GFC_DESCRIPTOR_SIZE(array);
89 if (ret->data == NULL)
93 ret->data = internal_malloc_size (size * arraysize);
95 ret->dtype = array->dtype;
96 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
100 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
105 str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
106 * GFC_DESCRIPTOR_STRIDE(ret,i-1);
108 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
112 ret->data = internal_malloc_size (size * arraysize);
114 ret->data = internal_malloc_size (1);
117 else if (unlikely (compile_options.bounds_check))
119 bounds_equal_extents ((array_t *) ret, (array_t *) array,
120 "return value", "EOSHIFT");
123 if (unlikely (compile_options.bounds_check))
125 bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
126 "SHIFT argument", "EOSHIFT");
135 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
139 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
142 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
145 len = GFC_DESCRIPTOR_EXTENT(array,dim);
150 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
151 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
152 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
154 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
156 bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
168 if (bound && bstride[0] == 0)
171 dim = GFC_DESCRIPTOR_RANK (array);
172 rstride0 = rstride[0];
173 sstride0 = sstride[0];
174 hstride0 = hstride[0];
175 bstride0 = bstride[0];
186 /* Do the shift for this dimension. */
188 if (( sh >= 0 ? sh : -sh ) > len)
194 delta = (sh >= 0) ? sh: -sh;
198 src = &sptr[delta * soffset];
204 dest = &rptr[delta * roffset];
206 for (n = 0; n < len - delta; n++)
208 memcpy (dest, src, size);
219 memcpy (dest, bptr, size);
228 memset (dest, filler[0], size);
230 for (i = 0; i < size; i += filler_len)
231 memcpy (&dest[i], filler, filler_len);
236 /* Advance to the next section. */
243 while (count[n] == extent[n])
245 /* When we get to the end of a dimension, reset it and increment
246 the next dimension. */
248 /* We could precalculate these products, but this is a less
249 frequently used path so probably not worth it. */
250 rptr -= rstride[n] * extent[n];
251 sptr -= sstride[n] * extent[n];
252 hptr -= hstride[n] * extent[n];
253 bptr -= bstride[n] * extent[n];
257 /* Break out of the loop. */
273 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
274 const gfc_array_char * const restrict,
275 const 'atype` * const restrict,
276 const gfc_array_char * const restrict,
277 const 'atype_name` *);
278 export_proto(eoshift3_'atype_kind`);
281 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
282 const gfc_array_char * const restrict array,
283 const 'atype` * const restrict h,
284 const gfc_array_char * const restrict bound,
285 const 'atype_name` * const restrict pwhich)
287 eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
291 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
293 const gfc_array_char * const restrict,
294 const 'atype` * const restrict,
295 const gfc_array_char * const restrict,
296 const 'atype_name` * const restrict,
297 GFC_INTEGER_4, GFC_INTEGER_4);
298 export_proto(eoshift3_'atype_kind`_char);
301 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
302 GFC_INTEGER_4 ret_length __attribute__((unused)),
303 const gfc_array_char * const restrict array,
304 const 'atype` * const restrict h,
305 const gfc_array_char * const restrict bound,
306 const 'atype_name` * const restrict pwhich,
307 GFC_INTEGER_4 array_length __attribute__((unused)),
308 GFC_INTEGER_4 bound_length __attribute__((unused)))
310 eoshift3 (ret, array, h, bound, pwhich, " ", 1);
314 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
316 const gfc_array_char * const restrict,
317 const 'atype` * const restrict,
318 const gfc_array_char * const restrict,
319 const 'atype_name` * const restrict,
320 GFC_INTEGER_4, GFC_INTEGER_4);
321 export_proto(eoshift3_'atype_kind`_char4);
324 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
325 GFC_INTEGER_4 ret_length __attribute__((unused)),
326 const gfc_array_char * const restrict array,
327 const 'atype` * const restrict h,
328 const gfc_array_char * const restrict bound,
329 const 'atype_name` * const restrict pwhich,
330 GFC_INTEGER_4 array_length __attribute__((unused)),
331 GFC_INTEGER_4 bound_length __attribute__((unused)))
333 static const gfc_char4_t space = (unsigned char) ''` ''`;
334 eoshift3 (ret, array, h, bound, pwhich,
335 (const char *) &space, sizeof (gfc_char4_t));