1 /* Generic implementation of the CSHIFT intrinsic
2 Copyright 2003, 2005, 2006, 2007 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 ssize_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
);
83 ret
->data
= internal_malloc_size (size
* arraysize
);
85 ret
->data
= internal_malloc_size (1);
87 else if (unlikely (compile_options
.bounds_check
))
89 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
90 "return value", "CSHIFT");
96 type_size
= GFC_DTYPE_TYPE_SIZE (array
);
100 case GFC_DTYPE_LOGICAL_1
:
101 case GFC_DTYPE_INTEGER_1
:
102 case GFC_DTYPE_DERIVED_1
:
103 cshift0_i1 ((gfc_array_i1
*)ret
, (gfc_array_i1
*) array
, shift
, which
);
106 case GFC_DTYPE_LOGICAL_2
:
107 case GFC_DTYPE_INTEGER_2
:
108 cshift0_i2 ((gfc_array_i2
*)ret
, (gfc_array_i2
*) array
, shift
, which
);
111 case GFC_DTYPE_LOGICAL_4
:
112 case GFC_DTYPE_INTEGER_4
:
113 cshift0_i4 ((gfc_array_i4
*)ret
, (gfc_array_i4
*) array
, shift
, which
);
116 case GFC_DTYPE_LOGICAL_8
:
117 case GFC_DTYPE_INTEGER_8
:
118 cshift0_i8 ((gfc_array_i8
*)ret
, (gfc_array_i8
*) array
, shift
, which
);
121 #ifdef HAVE_GFC_INTEGER_16
122 case GFC_DTYPE_LOGICAL_16
:
123 case GFC_DTYPE_INTEGER_16
:
124 cshift0_i16 ((gfc_array_i16
*)ret
, (gfc_array_i16
*) array
, shift
,
129 case GFC_DTYPE_REAL_4
:
130 cshift0_r4 ((gfc_array_r4
*)ret
, (gfc_array_r4
*) array
, shift
, which
);
133 case GFC_DTYPE_REAL_8
:
134 cshift0_r8 ((gfc_array_r8
*)ret
, (gfc_array_r8
*) array
, shift
, which
);
137 #ifdef HAVE_GFC_REAL_10
138 case GFC_DTYPE_REAL_10
:
139 cshift0_r10 ((gfc_array_r10
*)ret
, (gfc_array_r10
*) array
, shift
,
144 #ifdef HAVE_GFC_REAL_16
145 case GFC_DTYPE_REAL_16
:
146 cshift0_r16 ((gfc_array_r16
*)ret
, (gfc_array_r16
*) array
, shift
,
151 case GFC_DTYPE_COMPLEX_4
:
152 cshift0_c4 ((gfc_array_c4
*)ret
, (gfc_array_c4
*) array
, shift
, which
);
155 case GFC_DTYPE_COMPLEX_8
:
156 cshift0_c8 ((gfc_array_c8
*)ret
, (gfc_array_c8
*) array
, shift
, which
);
159 #ifdef HAVE_GFC_COMPLEX_10
160 case GFC_DTYPE_COMPLEX_10
:
161 cshift0_c10 ((gfc_array_c10
*)ret
, (gfc_array_c10
*) array
, shift
,
166 #ifdef HAVE_GFC_COMPLEX_16
167 case GFC_DTYPE_COMPLEX_16
:
168 cshift0_c16 ((gfc_array_c16
*)ret
, (gfc_array_c16
*) array
, shift
,
179 /* Let's check the actual alignment of the data pointers. If they
180 are suitably aligned, we can safely call the unpack functions. */
182 case sizeof (GFC_INTEGER_1
):
183 cshift0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) array
, shift
,
187 case sizeof (GFC_INTEGER_2
):
188 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(array
->data
))
192 cshift0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) array
, shift
,
197 case sizeof (GFC_INTEGER_4
):
198 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(array
->data
))
202 cshift0_i4 ((gfc_array_i4
*)ret
, (gfc_array_i4
*) array
, shift
,
207 case sizeof (GFC_INTEGER_8
):
208 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(array
->data
))
210 /* Let's try to use the complex routines. First, a sanity
211 check that the sizes match; this should be optimized to
213 if (sizeof(GFC_INTEGER_8
) != sizeof(GFC_COMPLEX_4
))
216 if (GFC_UNALIGNED_C4(ret
->data
) || GFC_UNALIGNED_C4(array
->data
))
219 cshift0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) array
, shift
,
225 cshift0_i8 ((gfc_array_i8
*)ret
, (gfc_array_i8
*) array
, shift
,
230 #ifdef HAVE_GFC_INTEGER_16
231 case sizeof (GFC_INTEGER_16
):
232 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(array
->data
))
234 /* Let's try to use the complex routines. First, a sanity
235 check that the sizes match; this should be optimized to
237 if (sizeof(GFC_INTEGER_16
) != sizeof(GFC_COMPLEX_8
))
240 if (GFC_UNALIGNED_C8(ret
->data
) || GFC_UNALIGNED_C8(array
->data
))
243 cshift0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
, shift
,
249 cshift0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) array
,
254 case sizeof (GFC_COMPLEX_8
):
256 if (GFC_UNALIGNED_C8(ret
->data
) || GFC_UNALIGNED_C8(array
->data
))
260 cshift0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) array
, shift
,
278 /* Initialized for avoiding compiler warnings. */
283 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
287 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
290 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
293 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
298 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,dim
);
299 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
300 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
309 dim
= GFC_DESCRIPTOR_RANK (array
);
310 rstride0
= rstride
[0];
311 sstride0
= sstride
[0];
315 shift
= len
== 0 ? 0 : shift
% (ssize_t
)len
;
321 /* Do the shift for this dimension. */
323 /* If elements are contiguous, perform the operation
324 in two block moves. */
325 if (soffset
== size
&& roffset
== size
)
327 size_t len1
= shift
* size
;
328 size_t len2
= (len
- shift
) * size
;
329 memcpy (rptr
, sptr
+ len1
, len2
);
330 memcpy (rptr
+ len2
, sptr
, len1
);
334 /* Otherwise, we'll have to perform the copy one element at
337 const char *src
= &sptr
[shift
* soffset
];
339 for (n
= 0; n
< len
- shift
; n
++)
341 memcpy (dest
, src
, size
);
345 for (src
= sptr
, n
= 0; n
< shift
; n
++)
347 memcpy (dest
, src
, size
);
353 /* Advance to the next section. */
358 while (count
[n
] == extent
[n
])
360 /* When we get to the end of a dimension, reset it and increment
361 the next dimension. */
363 /* We could precalculate these products, but this is a less
364 frequently used path so probably not worth it. */
365 rptr
-= rstride
[n
] * extent
[n
];
366 sptr
-= sstride
[n
] * extent
[n
];
370 /* Break out of the loop. */
384 #define DEFINE_CSHIFT(N) \
385 extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
386 const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
387 export_proto(cshift0_##N); \
390 cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
391 const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
393 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
394 GFC_DESCRIPTOR_SIZE (array)); \
397 extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
398 const gfc_array_char *, \
399 const GFC_INTEGER_##N *, \
400 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
401 export_proto(cshift0_##N##_char); \
404 cshift0_##N##_char (gfc_array_char *ret, \
405 GFC_INTEGER_4 ret_length __attribute__((unused)), \
406 const gfc_array_char *array, \
407 const GFC_INTEGER_##N *pshift, \
408 const GFC_INTEGER_##N *pdim, \
409 GFC_INTEGER_4 array_length) \
411 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
414 extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
415 const gfc_array_char *, \
416 const GFC_INTEGER_##N *, \
417 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
418 export_proto(cshift0_##N##_char4); \
421 cshift0_##N##_char4 (gfc_array_char *ret, \
422 GFC_INTEGER_4 ret_length __attribute__((unused)), \
423 const gfc_array_char *array, \
424 const GFC_INTEGER_##N *pshift, \
425 const GFC_INTEGER_##N *pdim, \
426 GFC_INTEGER_4 array_length) \
428 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
429 array_length * sizeof (gfc_char4_t)); \
436 #ifdef HAVE_GFC_INTEGER_16