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