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 eoshift1 (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 index_type size, 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;
60 index_type count[GFC_MAX_DIMENSIONS];
61 index_type extent[GFC_MAX_DIMENSIONS];
69 /* The compiler cannot figure out that these are set, initialize
70 them to avoid warnings. */
83 if (ret->data == NULL)
87 ret->data = internal_malloc_size (size * size0 ((array_t *)array));
89 ret->dtype = array->dtype;
90 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
92 ret->dim[i].lbound = 0;
93 ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
96 ret->dim[i].stride = 1;
98 ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
103 if (size0 ((array_t *) ret) == 0)
108 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
112 roffset = ret->dim[dim].stride * size;
115 soffset = array->dim[dim].stride * size;
118 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
123 extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
124 rstride[n] = ret->dim[dim].stride * size;
125 sstride[n] = array->dim[dim].stride * size;
127 hstride[n] = h->dim[n].stride;
138 dim = GFC_DESCRIPTOR_RANK (array);
139 rstride0 = rstride[0];
140 sstride0 = sstride[0];
141 hstride0 = hstride[0];
148 /* Do the shift for this dimension. */
150 if (( sh >= 0 ? sh : -sh ) > len)
156 delta = (sh >= 0) ? sh: -sh;
160 src = &sptr[delta * soffset];
166 dest = &rptr[delta * roffset];
168 for (n = 0; n < len - delta; n++)
170 memcpy (dest, src, size);
181 memcpy (dest, pbound, size);
190 memset (dest, filler[0], size);
192 for (i = 0; i < size; i += filler_len)
193 memcpy (&dest[i], filler, filler_len);
198 /* Advance to the next section. */
204 while (count[n] == extent[n])
206 /* When we get to the end of a dimension, reset it and increment
207 the next dimension. */
209 /* We could precalculate these products, but this is a less
210 frequently used path so probably not worth it. */
211 rptr -= rstride[n] * extent[n];
212 sptr -= sstride[n] * extent[n];
213 hptr -= hstride[n] * extent[n];
217 /* Break out of the loop. */
232 void eoshift1_'atype_kind` (gfc_array_char * const restrict,
233 const gfc_array_char * const restrict,
234 const 'atype` * const restrict, const char * const restrict,
235 const 'atype_name` * const restrict);
236 export_proto(eoshift1_'atype_kind`);
239 eoshift1_'atype_kind` (gfc_array_char * const restrict ret,
240 const gfc_array_char * const restrict array,
241 const 'atype` * const restrict h,
242 const char * const restrict pbound,
243 const 'atype_name` * const restrict pwhich)
245 eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array),
250 void eoshift1_'atype_kind`_char (gfc_array_char * const restrict,
252 const gfc_array_char * const restrict,
253 const 'atype` * const restrict,
254 const char * const restrict,
255 const 'atype_name` * const restrict,
256 GFC_INTEGER_4, GFC_INTEGER_4);
257 export_proto(eoshift1_'atype_kind`_char);
260 eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
261 GFC_INTEGER_4 ret_length __attribute__((unused)),
262 const gfc_array_char * const restrict array,
263 const 'atype` * const restrict h,
264 const char * const restrict pbound,
265 const 'atype_name` * const restrict pwhich,
266 GFC_INTEGER_4 array_length,
267 GFC_INTEGER_4 bound_length __attribute__((unused)))
269 eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1);
273 void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict,
275 const gfc_array_char * const restrict,
276 const 'atype` * const restrict,
277 const char * const restrict,
278 const 'atype_name` * const restrict,
279 GFC_INTEGER_4, GFC_INTEGER_4);
280 export_proto(eoshift1_'atype_kind`_char4);
283 eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
284 GFC_INTEGER_4 ret_length __attribute__((unused)),
285 const gfc_array_char * const restrict array,
286 const 'atype` * const restrict h,
287 const char * const restrict pbound,
288 const 'atype_name` * const restrict pwhich,
289 GFC_INTEGER_4 array_length,
290 GFC_INTEGER_4 bound_length __attribute__((unused)))
292 static const gfc_char4_t space = (unsigned char) ''` ''`;
293 eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t),
294 (const char *) &space, sizeof (gfc_char4_t));