1 /* Generic implementation of the CSHIFT intrinsic
2 Copyright 2003, 2005, 2006, 2007, 2010 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"
32 cshift0 (gfc_array_char
* ret
, const gfc_array_char
* array
,
33 ptrdiff_t shift
, int which
, index_type size
)
35 /* r.* indicates the return array. */
36 index_type rstride
[GFC_MAX_DIMENSIONS
];
41 /* s.* indicates the source array. */
42 index_type sstride
[GFC_MAX_DIMENSIONS
];
47 index_type count
[GFC_MAX_DIMENSIONS
];
48 index_type extent
[GFC_MAX_DIMENSIONS
];
56 if (which
< 1 || which
> GFC_DESCRIPTOR_RANK (array
))
57 runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
59 arraysize
= size0 ((array_t
*) array
);
61 if (ret
->data
== NULL
)
66 ret
->dtype
= array
->dtype
;
67 for (i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
71 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
76 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1) *
77 GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
79 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
82 /* internal_malloc_size allocates a single byte for zero size. */
83 ret
->data
= internal_malloc_size (size
* arraysize
);
85 else if (unlikely (compile_options
.bounds_check
))
87 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
88 "return value", "CSHIFT");
94 type_size
= GFC_DTYPE_TYPE_SIZE (array
);
98 case GFC_DTYPE_LOGICAL_1
:
99 case GFC_DTYPE_INTEGER_1
:
100 case GFC_DTYPE_DERIVED_1
:
101 cshift0_i1 ((gfc_array_i1
*)ret
, (gfc_array_i1
*) array
, shift
, which
);
104 case GFC_DTYPE_LOGICAL_2
:
105 case GFC_DTYPE_INTEGER_2
:
106 cshift0_i2 ((gfc_array_i2
*)ret
, (gfc_array_i2
*) array
, shift
, which
);
109 case GFC_DTYPE_LOGICAL_4
:
110 case GFC_DTYPE_INTEGER_4
:
111 cshift0_i4 ((gfc_array_i4
*)ret
, (gfc_array_i4
*) array
, shift
, which
);
114 case GFC_DTYPE_LOGICAL_8
:
115 case GFC_DTYPE_INTEGER_8
:
116 cshift0_i8 ((gfc_array_i8
*)ret
, (gfc_array_i8
*) array
, shift
, which
);
119 #ifdef HAVE_GFC_INTEGER_16
120 case GFC_DTYPE_LOGICAL_16
:
121 case GFC_DTYPE_INTEGER_16
:
122 cshift0_i16 ((gfc_array_i16
*)ret
, (gfc_array_i16
*) array
, shift
,
127 case GFC_DTYPE_REAL_4
:
128 cshift0_r4 ((gfc_array_r4
*)ret
, (gfc_array_r4
*) array
, shift
, which
);
131 case GFC_DTYPE_REAL_8
:
132 cshift0_r8 ((gfc_array_r8
*)ret
, (gfc_array_r8
*) array
, shift
, which
);
135 /* FIXME: This here is a hack, which will have to be removed when
136 the array descriptor is reworked. Currently, we don't store the
137 kind value for the type, but only the size. Because on targets with
138 __float128, we have sizeof(logn double) == sizeof(__float128),
139 we cannot discriminate here and have to fall back to the generic
140 handling (which is suboptimal). */
141 #if !defined(GFC_REAL_16_IS_FLOAT128)
142 # ifdef HAVE_GFC_REAL_10
143 case GFC_DTYPE_REAL_10
:
144 cshift0_r10 ((gfc_array_r10
*)ret
, (gfc_array_r10
*) array
, shift
,
149 # ifdef HAVE_GFC_REAL_16
150 case GFC_DTYPE_REAL_16
:
151 cshift0_r16 ((gfc_array_r16
*)ret
, (gfc_array_r16
*) array
, shift
,
157 case GFC_DTYPE_COMPLEX_4
:
158 cshift0_c4 ((gfc_array_c4
*)ret
, (gfc_array_c4
*) array
, shift
, which
);
161 case GFC_DTYPE_COMPLEX_8
:
162 cshift0_c8 ((gfc_array_c8
*)ret
, (gfc_array_c8
*) array
, shift
, which
);
165 /* FIXME: This here is a hack, which will have to be removed when
166 the array descriptor is reworked. Currently, we don't store the
167 kind value for the type, but only the size. Because on targets with
168 __float128, we have sizeof(logn double) == sizeof(__float128),
169 we cannot discriminate here and have to fall back to the generic
170 handling (which is suboptimal). */
171 #if !defined(GFC_REAL_16_IS_FLOAT128)
172 # ifdef HAVE_GFC_COMPLEX_10
173 case GFC_DTYPE_COMPLEX_10
:
174 cshift0_c10 ((gfc_array_c10
*)ret
, (gfc_array_c10
*) array
, shift
,
179 # ifdef HAVE_GFC_COMPLEX_16
180 case GFC_DTYPE_COMPLEX_16
:
181 cshift0_c16 ((gfc_array_c16
*)ret
, (gfc_array_c16
*) array
, shift
,
193 /* Let's check the actual alignment of the data pointers. If they
194 are suitably aligned, we can safely call the unpack functions. */
196 case sizeof (GFC_INTEGER_1
):
197 cshift0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
, shift
,
201 case sizeof (GFC_INTEGER_2
):
202 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(array
->data
))
206 cshift0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
, shift
,
211 case sizeof (GFC_INTEGER_4
):
212 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(array
->data
))
216 cshift0_i4 ((gfc_array_i4
*)ret
, (gfc_array_i4
*) array
, shift
,
221 case sizeof (GFC_INTEGER_8
):
222 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(array
->data
))
224 /* Let's try to use the complex routines. First, a sanity
225 check that the sizes match; this should be optimized to
227 if (sizeof(GFC_INTEGER_8
) != sizeof(GFC_COMPLEX_4
))
230 if (GFC_UNALIGNED_C4(ret
->data
) || GFC_UNALIGNED_C4(array
->data
))
233 cshift0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) array
, shift
,
239 cshift0_i8 ((gfc_array_i8
*)ret
, (gfc_array_i8
*) array
, shift
,
244 #ifdef HAVE_GFC_INTEGER_16
245 case sizeof (GFC_INTEGER_16
):
246 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(array
->data
))
248 /* Let's try to use the complex routines. First, a sanity
249 check that the sizes match; this should be optimized to
251 if (sizeof(GFC_INTEGER_16
) != sizeof(GFC_COMPLEX_8
))
254 if (GFC_UNALIGNED_C8(ret
->data
) || GFC_UNALIGNED_C8(array
->data
))
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
->data
) || GFC_UNALIGNED_C8(array
->data
))
274 cshift0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
, shift
,
292 /* Initialized for avoiding compiler warnings. */
297 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
301 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
304 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
307 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
312 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,dim
);
313 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
314 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
323 dim
= GFC_DESCRIPTOR_RANK (array
);
324 rstride0
= rstride
[0];
325 sstride0
= sstride
[0];
329 shift
= len
== 0 ? 0 : shift
% (ptrdiff_t)len
;
335 /* Do the shift for this dimension. */
337 /* If elements are contiguous, perform the operation
338 in two block moves. */
339 if (soffset
== size
&& roffset
== size
)
341 size_t len1
= shift
* size
;
342 size_t len2
= (len
- shift
) * size
;
343 memcpy (rptr
, sptr
+ len1
, len2
);
344 memcpy (rptr
+ len2
, sptr
, len1
);
348 /* Otherwise, we'll have to perform the copy one element at
351 const char *src
= &sptr
[shift
* soffset
];
353 for (n
= 0; n
< len
- shift
; n
++)
355 memcpy (dest
, src
, size
);
359 for (src
= sptr
, n
= 0; n
< shift
; n
++)
361 memcpy (dest
, src
, size
);
367 /* Advance to the next section. */
372 while (count
[n
] == extent
[n
])
374 /* When we get to the end of a dimension, reset it and increment
375 the next dimension. */
377 /* We could precalculate these products, but this is a less
378 frequently used path so probably not worth it. */
379 rptr
-= rstride
[n
] * extent
[n
];
380 sptr
-= sstride
[n
] * extent
[n
];
384 /* Break out of the loop. */
398 #define DEFINE_CSHIFT(N) \
399 extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
400 const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
401 export_proto(cshift0_##N); \
404 cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
405 const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
407 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
408 GFC_DESCRIPTOR_SIZE (array)); \
411 extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
412 const gfc_array_char *, \
413 const GFC_INTEGER_##N *, \
414 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
415 export_proto(cshift0_##N##_char); \
418 cshift0_##N##_char (gfc_array_char *ret, \
419 GFC_INTEGER_4 ret_length __attribute__((unused)), \
420 const gfc_array_char *array, \
421 const GFC_INTEGER_##N *pshift, \
422 const GFC_INTEGER_##N *pdim, \
423 GFC_INTEGER_4 array_length) \
425 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
428 extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
429 const gfc_array_char *, \
430 const GFC_INTEGER_##N *, \
431 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
432 export_proto(cshift0_##N##_char4); \
435 cshift0_##N##_char4 (gfc_array_char *ret, \
436 GFC_INTEGER_4 ret_length __attribute__((unused)), \
437 const gfc_array_char *array, \
438 const GFC_INTEGER_##N *pshift, \
439 const GFC_INTEGER_##N *pdim, \
440 GFC_INTEGER_4 array_length) \
442 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
443 array_length * sizeof (gfc_char4_t)); \
450 #ifdef HAVE_GFC_INTEGER_16