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