1/* Generic implementation of the CSHIFT intrinsic 2 Copyright (C) 2003-2022 Free Software Foundation, Inc. 3 Contributed by Feng Wang <wf_cs@yahoo.com> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 29static void 30cshift0 (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(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, 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(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, 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 447DEFINE_CSHIFT (1); 448DEFINE_CSHIFT (2); 449DEFINE_CSHIFT (4); 450DEFINE_CSHIFT (8); 451#ifdef HAVE_GFC_INTEGER_16 452DEFINE_CSHIFT (16); 453#endif 454