1 /* Generic 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 Ligbfortran 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"
29 /* TODO: make this work for large shifts when
30 sizeof(int) < sizeof (index_type). */
33 eoshift2 (gfc_array_char
*ret
, const gfc_array_char
*array
,
34 int shift
, const gfc_array_char
*bound
, int which
,
35 const char *filler
, index_type filler_len
)
37 /* r.* indicates the return array. */
38 index_type rstride
[GFC_MAX_DIMENSIONS
];
43 /* s.* indicates the source array. */
44 index_type sstride
[GFC_MAX_DIMENSIONS
];
49 /* b.* indicates the bound array. */
50 index_type bstride
[GFC_MAX_DIMENSIONS
];
54 index_type count
[GFC_MAX_DIMENSIONS
];
55 index_type extent
[GFC_MAX_DIMENSIONS
];
62 /* The compiler cannot figure out that these are set, initialize
63 them to avoid warnings. */
68 size
= GFC_DESCRIPTOR_SIZE (array
);
70 arraysize
= size0 ((array_t
*) array
);
72 if (ret
->base_addr
== NULL
)
77 ret
->dtype
= array
->dtype
;
79 /* xmallocarray allocates a single byte for zero size. */
80 ret
->base_addr
= xmallocarray (arraysize
, size
);
82 for (i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
86 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
91 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1)
92 * GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
94 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
97 else if (unlikely (compile_options
.bounds_check
))
99 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
100 "return value", "EOSHIFT");
114 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
118 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
121 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
124 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
129 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,dim
);
130 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
131 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
133 bstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(bound
,n
);
143 if (bound
&& bstride
[0] == 0)
146 dim
= GFC_DESCRIPTOR_RANK (array
);
147 rstride0
= rstride
[0];
148 sstride0
= sstride
[0];
149 bstride0
= bstride
[0];
150 rptr
= ret
->base_addr
;
151 sptr
= array
->base_addr
;
153 if ((shift
>= 0 ? shift
: -shift
) > len
)
167 bptr
= bound
->base_addr
;
173 /* Do the shift for this dimension. */
176 src
= &sptr
[shift
* soffset
];
182 dest
= &rptr
[-shift
* roffset
];
185 /* If the elements are contiguous, perform a single block move. */
186 if (soffset
== size
&& roffset
== size
)
188 size_t chunk
= size
* len
;
189 memcpy (dest
, src
, chunk
);
194 for (n
= 0; n
< len
; n
++)
196 memcpy (dest
, src
, size
);
214 memcpy (dest
, bptr
, size
);
223 memset (dest
, filler
[0], size
);
225 for (i
= 0; i
< size
; i
+= filler_len
)
226 memcpy (&dest
[i
], filler
, filler_len
);
231 /* Advance to the next section. */
237 while (count
[n
] == extent
[n
])
239 /* When we get to the end of a dimension, reset it and increment
240 the next dimension. */
242 /* We could precalculate these products, but this is a less
243 frequently used path so probably not worth it. */
244 rptr
-= rstride
[n
] * extent
[n
];
245 sptr
-= sstride
[n
] * extent
[n
];
246 bptr
-= bstride
[n
] * extent
[n
];
250 /* Break out of the loop. */
266 #define DEFINE_EOSHIFT(N) \
267 extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *, \
268 const GFC_INTEGER_##N *, const gfc_array_char *, \
269 const GFC_INTEGER_##N *); \
270 export_proto(eoshift2_##N); \
273 eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array, \
274 const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound, \
275 const GFC_INTEGER_##N *pdim) \
277 eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
281 extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
282 const gfc_array_char *, \
283 const GFC_INTEGER_##N *, \
284 const gfc_array_char *, \
285 const GFC_INTEGER_##N *, \
286 GFC_INTEGER_4, GFC_INTEGER_4); \
287 export_proto(eoshift2_##N##_char); \
290 eoshift2_##N##_char (gfc_array_char *ret, \
291 GFC_INTEGER_4 ret_length __attribute__((unused)), \
292 const gfc_array_char *array, \
293 const GFC_INTEGER_##N *pshift, \
294 const gfc_array_char *pbound, \
295 const GFC_INTEGER_##N *pdim, \
296 GFC_INTEGER_4 array_length __attribute__((unused)), \
297 GFC_INTEGER_4 bound_length __attribute__((unused))) \
299 eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
303 extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
304 const gfc_array_char *, \
305 const GFC_INTEGER_##N *, \
306 const gfc_array_char *, \
307 const GFC_INTEGER_##N *, \
308 GFC_INTEGER_4, GFC_INTEGER_4); \
309 export_proto(eoshift2_##N##_char4); \
312 eoshift2_##N##_char4 (gfc_array_char *ret, \
313 GFC_INTEGER_4 ret_length __attribute__((unused)), \
314 const gfc_array_char *array, \
315 const GFC_INTEGER_##N *pshift, \
316 const gfc_array_char *pbound, \
317 const GFC_INTEGER_##N *pdim, \
318 GFC_INTEGER_4 array_length __attribute__((unused)), \
319 GFC_INTEGER_4 bound_length __attribute__((unused))) \
321 static const gfc_char4_t space = (unsigned char) ' '; \
322 eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
323 (const char *) &space, \
324 sizeof (gfc_char4_t)); \
331 #ifdef HAVE_GFC_INTEGER_16