1 /* Generic implementation of the CSHIFT intrinsic
2 Copyright (C) 2003-2018 Free Software Foundation, Inc.
3 Contributed by Feng Wang <wf_cs@yahoo.com>
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 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"
30 cshift0 (gfc_array_char
* ret
, const gfc_array_char
* array
,
31 ptrdiff_t shift
, int which
, index_type size
)
33 /* r.* indicates the return array. */
34 index_type rstride
[GFC_MAX_DIMENSIONS
];
39 /* s.* indicates the source array. */
40 index_type sstride
[GFC_MAX_DIMENSIONS
];
45 index_type count
[GFC_MAX_DIMENSIONS
];
46 index_type extent
[GFC_MAX_DIMENSIONS
];
54 if (which
< 1 || which
> GFC_DESCRIPTOR_RANK (array
))
55 runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
57 arraysize
= size0 ((array_t
*) array
);
59 if (ret
->base_addr
== NULL
)
64 GFC_DTYPE_COPY(ret
,array
);
65 for (i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
69 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
74 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1) *
75 GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
77 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
80 /* xmallocarray allocates a single byte for zero size. */
81 ret
->base_addr
= xmallocarray (arraysize
, size
);
83 else if (unlikely (compile_options
.bounds_check
))
85 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
86 "return value", "CSHIFT");
92 type_size
= GFC_DTYPE_TYPE_SIZE (array
);
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
);
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
);
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
);
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
);
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
,
124 case GFC_DTYPE_REAL_4
:
125 cshift0_r4 ((gfc_array_r4
*)ret
, (gfc_array_r4
*) array
, shift
, which
);
128 case GFC_DTYPE_REAL_8
:
129 cshift0_r8 ((gfc_array_r8
*)ret
, (gfc_array_r8
*) array
, shift
, which
);
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(logn 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
,
146 # ifdef HAVE_GFC_REAL_16
147 case GFC_DTYPE_REAL_16
:
148 cshift0_r16 ((gfc_array_r16
*)ret
, (gfc_array_r16
*) array
, shift
,
154 case GFC_DTYPE_COMPLEX_4
:
155 cshift0_c4 ((gfc_array_c4
*)ret
, (gfc_array_c4
*) array
, shift
, which
);
158 case GFC_DTYPE_COMPLEX_8
:
159 cshift0_c8 ((gfc_array_c8
*)ret
, (gfc_array_c8
*) array
, shift
, which
);
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(logn 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
,
176 # ifdef HAVE_GFC_COMPLEX_16
177 case GFC_DTYPE_COMPLEX_16
:
178 cshift0_c16 ((gfc_array_c16
*)ret
, (gfc_array_c16
*) array
, shift
,
190 /* Let's check the actual alignment of the data pointers. If they
191 are suitably aligned, we can safely call the unpack functions. */
193 case sizeof (GFC_INTEGER_1
):
194 cshift0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
, shift
,
198 case sizeof (GFC_INTEGER_2
):
199 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(array
->base_addr
))
203 cshift0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
, shift
,
208 case sizeof (GFC_INTEGER_4
):
209 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(array
->base_addr
))
213 cshift0_i4 ((gfc_array_i4
*)ret
, (gfc_array_i4
*) array
, shift
,
218 case sizeof (GFC_INTEGER_8
):
219 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(array
->base_addr
))
221 /* Let's try to use the complex routines. First, a sanity
222 check that the sizes match; this should be optimized to
224 if (sizeof(GFC_INTEGER_8
) != sizeof(GFC_COMPLEX_4
))
227 if (GFC_UNALIGNED_C4(ret
->base_addr
)
228 || GFC_UNALIGNED_C4(array
->base_addr
))
231 cshift0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) array
, shift
,
237 cshift0_i8 ((gfc_array_i8
*)ret
, (gfc_array_i8
*) array
, shift
,
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
))
247 /* Let's try to use the complex routines. First, a sanity
248 check that the sizes match; this should be optimized to
250 if (sizeof(GFC_INTEGER_16
) != sizeof(GFC_COMPLEX_8
))
253 if (GFC_UNALIGNED_C8(ret
->base_addr
)
254 || GFC_UNALIGNED_C8(array
->base_addr
))
257 cshift0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
, shift
,
263 cshift0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
268 case sizeof (GFC_COMPLEX_8
):
270 if (GFC_UNALIGNED_C8(ret
->base_addr
)
271 || GFC_UNALIGNED_C8(array
->base_addr
))
275 cshift0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
, shift
,
293 /* Initialized for avoiding compiler warnings. */
298 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
302 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
305 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
308 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
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
);
324 dim
= GFC_DESCRIPTOR_RANK (array
);
325 rstride0
= rstride
[0];
326 sstride0
= sstride
[0];
327 rptr
= ret
->base_addr
;
328 sptr
= array
->base_addr
;
330 shift
= len
== 0 ? 0 : shift
% (ptrdiff_t)len
;
336 /* Do the shift for this dimension. */
338 /* If elements are contiguous, perform the operation
339 in two block moves. */
340 if (soffset
== size
&& roffset
== size
)
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
);
349 /* Otherwise, we'll have to perform the copy one element at
352 const char *src
= &sptr
[shift
* soffset
];
354 for (n
= 0; n
< len
- shift
; n
++)
356 memcpy (dest
, src
, size
);
360 for (src
= sptr
, n
= 0; n
< shift
; n
++)
362 memcpy (dest
, src
, size
);
368 /* Advance to the next section. */
373 while (count
[n
] == extent
[n
])
375 /* When we get to the end of a dimension, reset it and increment
376 the next dimension. */
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
];
385 /* Break out of the loop. */
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); \
405 cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
406 const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
408 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
409 GFC_DESCRIPTOR_SIZE (array)); \
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); \
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) \
426 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
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); \
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) \
443 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
444 array_length * sizeof (gfc_char4_t)); \
451 #ifdef HAVE_GFC_INTEGER_16