1 /* Generic implementation of the CSHIFT intrinsic
2 Copyright (C) 2003-2023 Free Software Foundation, Inc.
3 Contributed by Feng Wang <wf_cs@yahoo.com>
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 static void
30 cshift0 (gfc_array_char * ret, const gfc_array_char * array,
31 ptrdiff_t shift, int which, index_type size)
32 {
33 /* r.* indicates the return array. */
34 index_type rstride[GFC_MAX_DIMENSIONS];
35 index_type rstride0;
36 index_type roffset;
37 char *rptr;
38
39 /* s.* indicates the source array. */
40 index_type sstride[GFC_MAX_DIMENSIONS];
41 index_type sstride0;
42 index_type soffset;
43 const char *sptr;
44
45 index_type count[GFC_MAX_DIMENSIONS];
46 index_type extent[GFC_MAX_DIMENSIONS];
47 index_type dim;
48 index_type len;
49 index_type n;
50 index_type arraysize;
51
52 index_type type_size;
53
54 if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
55 runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
56
57 arraysize = size0 ((array_t *) array);
58
59 if (ret->base_addr == NULL)
60 {
61 int i;
62
63 ret->offset = 0;
64 GFC_DTYPE_COPY(ret,array);
65 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
66 {
67 index_type ub, str;
68
69 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
70
71 if (i == 0)
72 str = 1;
73 else
74 str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
75 GFC_DESCRIPTOR_STRIDE(ret,i-1);
76
77 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
78 }
79
80 /* xmallocarray allocates a single byte for zero size. */
81 ret->base_addr = xmallocarray (arraysize, size);
82 }
83 else if (unlikely (compile_options.bounds_check))
84 {
85 bounds_equal_extents ((array_t *) ret, (array_t *) array,
86 "return value", "CSHIFT");
87 }
88
89 if (arraysize == 0)
90 return;
91
92 type_size = GFC_DTYPE_TYPE_SIZE (array);
93
94 switch(type_size)
95 {
96 case GFC_DTYPE_LOGICAL_1:
97 case GFC_DTYPE_INTEGER_1:
98 cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
99 return;
100
101 case GFC_DTYPE_LOGICAL_2:
102 case GFC_DTYPE_INTEGER_2:
103 cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
104 return;
105
106 case GFC_DTYPE_LOGICAL_4:
107 case GFC_DTYPE_INTEGER_4:
108 cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
109 return;
110
111 case GFC_DTYPE_LOGICAL_8:
112 case GFC_DTYPE_INTEGER_8:
113 cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
114 return;
115
116 #ifdef HAVE_GFC_INTEGER_16
117 case GFC_DTYPE_LOGICAL_16:
118 case GFC_DTYPE_INTEGER_16:
119 cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
120 which);
121 return;
122 #endif
123
124 case GFC_DTYPE_REAL_4:
125 cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
126 return;
127
128 case GFC_DTYPE_REAL_8:
129 cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
130 return;
131
132 /* FIXME: This here is a hack, which will have to be removed when
133 the array descriptor is reworked. Currently, we don't store the
134 kind value for the type, but only the size. Because on targets with
135 _Float128, we have sizeof(long double) == sizeof(_Float128),
136 we cannot discriminate here and have to fall back to the generic
137 handling (which is suboptimal). */
138 #if !defined(GFC_REAL_16_IS_FLOAT128)
139 # ifdef HAVE_GFC_REAL_10
140 case GFC_DTYPE_REAL_10:
141 cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
142 which);
143 return;
144 # endif
145
146 # ifdef HAVE_GFC_REAL_16
147 case GFC_DTYPE_REAL_16:
148 cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
149 which);
150 return;
151 # endif
152 #endif
153
154 case GFC_DTYPE_COMPLEX_4:
155 cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
156 return;
157
158 case GFC_DTYPE_COMPLEX_8:
159 cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
160 return;
161
162 /* FIXME: This here is a hack, which will have to be removed when
163 the array descriptor is reworked. Currently, we don't store the
164 kind value for the type, but only the size. Because on targets with
165 _Float128, we have sizeof(long double) == sizeof(_Float128),
166 we cannot discriminate here and have to fall back to the generic
167 handling (which is suboptimal). */
168 #if !defined(GFC_REAL_16_IS_FLOAT128)
169 # ifdef HAVE_GFC_COMPLEX_10
170 case GFC_DTYPE_COMPLEX_10:
171 cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
172 which);
173 return;
174 # endif
175
176 # ifdef HAVE_GFC_COMPLEX_16
177 case GFC_DTYPE_COMPLEX_16:
178 cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
179 which);
180 return;
181 # endif
182 #endif
183
184 default:
185 break;
186 }
187
188 switch (size)
189 {
190 /* Let's check the actual alignment of the data pointers. If they
191 are suitably aligned, we can safely call the unpack functions. */
192
193 case sizeof (GFC_INTEGER_1):
194 cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
195 which);
196 break;
197
198 case sizeof (GFC_INTEGER_2):
199 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr))
200 break;
201 else
202 {
203 cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
204 which);
205 return;
206 }
207
208 case sizeof (GFC_INTEGER_4):
209 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr))
210 break;
211 else
212 {
213 cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
214 which);
215 return;
216 }
217
218 case sizeof (GFC_INTEGER_8):
219 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr))
220 {
221 /* Let's try to use the complex routines. First, a sanity
222 check that the sizes match; this should be optimized to
223 a no-op. */
224 if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
225 break;
226
227 if (GFC_UNALIGNED_C4(ret->base_addr)
228 || GFC_UNALIGNED_C4(array->base_addr))
229 break;
230
231 cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
232 which);
233 return;
234 }
235 else
236 {
237 cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
238 which);
239 return;
240 }
241
242 #ifdef HAVE_GFC_INTEGER_16
243 case sizeof (GFC_INTEGER_16):
244 if (GFC_UNALIGNED_16(ret->base_addr)
245 || GFC_UNALIGNED_16(array->base_addr))
246 {
247 /* Let's try to use the complex routines. First, a sanity
248 check that the sizes match; this should be optimized to
249 a no-op. */
250 if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
251 break;
252
253 if (GFC_UNALIGNED_C8(ret->base_addr)
254 || GFC_UNALIGNED_C8(array->base_addr))
255 break;
256
257 cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
258 which);
259 return;
260 }
261 else
262 {
263 cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
264 shift, which);
265 return;
266 }
267 #else
268 case sizeof (GFC_COMPLEX_8):
269
270 if (GFC_UNALIGNED_C8(ret->base_addr)
271 || GFC_UNALIGNED_C8(array->base_addr))
272 break;
273 else
274 {
275 cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
276 which);
277 return;
278 }
279 #endif
280
281 default:
282 break;
283 }
284
285
286 which = which - 1;
287 sstride[0] = 0;
288 rstride[0] = 0;
289
290 extent[0] = 1;
291 count[0] = 0;
292 n = 0;
293 /* Initialized for avoiding compiler warnings. */
294 roffset = size;
295 soffset = size;
296 len = 0;
297
298 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
299 {
300 if (dim == which)
301 {
302 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
303 if (roffset == 0)
304 roffset = size;
305 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
306 if (soffset == 0)
307 soffset = size;
308 len = GFC_DESCRIPTOR_EXTENT(array,dim);
309 }
310 else
311 {
312 count[n] = 0;
313 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
314 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
315 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
316 n++;
317 }
318 }
319 if (sstride[0] == 0)
320 sstride[0] = size;
321 if (rstride[0] == 0)
322 rstride[0] = size;
323
324 dim = GFC_DESCRIPTOR_RANK (array);
325 rstride0 = rstride[0];
326 sstride0 = sstride[0];
327 rptr = ret->base_addr;
328 sptr = array->base_addr;
329
330 shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
331 if (shift < 0)
332 shift += len;
333
334 while (rptr)
335 {
336 /* Do the shift for this dimension. */
337
338 /* If elements are contiguous, perform the operation
339 in two block moves. */
340 if (soffset == size && roffset == size)
341 {
342 size_t len1 = shift * size;
343 size_t len2 = (len - shift) * size;
344 memcpy (rptr, sptr + len1, len2);
345 memcpy (rptr + len2, sptr, len1);
346 }
347 else
348 {
349 /* Otherwise, we'll have to perform the copy one element at
350 a time. */
351 char *dest = rptr;
352 const char *src = &sptr[shift * soffset];
353
354 for (n = 0; n < len - shift; n++)
355 {
356 memcpy (dest, src, size);
357 dest += roffset;
358 src += soffset;
359 }
360 for (src = sptr, n = 0; n < shift; n++)
361 {
362 memcpy (dest, src, size);
363 dest += roffset;
364 src += soffset;
365 }
366 }
367
368 /* Advance to the next section. */
369 rptr += rstride0;
370 sptr += sstride0;
371 count[0]++;
372 n = 0;
373 while (count[n] == extent[n])
374 {
375 /* When we get to the end of a dimension, reset it and increment
376 the next dimension. */
377 count[n] = 0;
378 /* We could precalculate these products, but this is a less
379 frequently used path so probably not worth it. */
380 rptr -= rstride[n] * extent[n];
381 sptr -= sstride[n] * extent[n];
382 n++;
383 if (n >= dim - 1)
384 {
385 /* Break out of the loop. */
386 rptr = NULL;
387 break;
388 }
389 else
390 {
391 count[n]++;
392 rptr += rstride[n];
393 sptr += sstride[n];
394 }
395 }
396 }
397 }
398
399 #define DEFINE_CSHIFT(N) \
400 extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
401 const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
402 export_proto(cshift0_##N); \
403 \
404 void \
405 cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
406 const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
407 { \
408 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
409 GFC_DESCRIPTOR_SIZE (array)); \
410 } \
411 \
412 extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
413 const gfc_array_char *, \
414 const GFC_INTEGER_##N *, \
415 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
416 export_proto(cshift0_##N##_char); \
417 \
418 void \
419 cshift0_##N##_char (gfc_array_char *ret, \
420 GFC_INTEGER_4 ret_length __attribute__((unused)), \
421 const gfc_array_char *array, \
422 const GFC_INTEGER_##N *pshift, \
423 const GFC_INTEGER_##N *pdim, \
424 GFC_INTEGER_4 array_length) \
425 { \
426 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
427 } \
428 \
429 extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
430 const gfc_array_char *, \
431 const GFC_INTEGER_##N *, \
432 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
433 export_proto(cshift0_##N##_char4); \
434 \
435 void \
436 cshift0_##N##_char4 (gfc_array_char *ret, \
437 GFC_INTEGER_4 ret_length __attribute__((unused)), \
438 const gfc_array_char *array, \
439 const GFC_INTEGER_##N *pshift, \
440 const GFC_INTEGER_##N *pdim, \
441 GFC_INTEGER_4 array_length) \
442 { \
443 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
444 array_length * sizeof (gfc_char4_t)); \
445 }
446
447 DEFINE_CSHIFT (1);
448 DEFINE_CSHIFT (2);
449 DEFINE_CSHIFT (4);
450 DEFINE_CSHIFT (8);
451 #ifdef HAVE_GFC_INTEGER_16
452 DEFINE_CSHIFT (16);
453 #endif