1/* 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 12Ligbfortran 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 29 30#if defined (HAVE_GFC_INTEGER_16) 31 32static void 33cshift1 (gfc_array_char * const restrict ret, 34 const gfc_array_char * const restrict array, 35 const gfc_array_i16 * const restrict h, 36 const GFC_INTEGER_16 * const restrict pwhich) 37{ 38 /* r.* indicates the return array. */ 39 index_type rstride[GFC_MAX_DIMENSIONS]; 40 index_type rstride0; 41 index_type roffset; 42 char *rptr; 43 char *dest; 44 /* s.* indicates the source array. */ 45 index_type sstride[GFC_MAX_DIMENSIONS]; 46 index_type sstride0; 47 index_type soffset; 48 const char *sptr; 49 const char *src; 50 /* h.* indicates the shift array. */ 51 index_type hstride[GFC_MAX_DIMENSIONS]; 52 index_type hstride0; 53 const GFC_INTEGER_16 *hptr; 54 55 index_type count[GFC_MAX_DIMENSIONS]; 56 index_type extent[GFC_MAX_DIMENSIONS]; 57 index_type dim; 58 index_type len; 59 index_type n; 60 int which; 61 GFC_INTEGER_16 sh; 62 index_type arraysize; 63 index_type size; 64 index_type type_size; 65 66 if (pwhich) 67 which = *pwhich - 1; 68 else 69 which = 0; 70 71 if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array)) 72 runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'"); 73 74 size = GFC_DESCRIPTOR_SIZE(array); 75 76 arraysize = size0 ((array_t *)array); 77 78 if (ret->base_addr == NULL) 79 { 80 ret->base_addr = xmallocarray (arraysize, size); 81 ret->offset = 0; 82 GFC_DTYPE_COPY(ret,array); 83 for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) 84 { 85 index_type ub, str; 86 87 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; 88 89 if (i == 0) 90 str = 1; 91 else 92 str = GFC_DESCRIPTOR_EXTENT(ret,i-1) * 93 GFC_DESCRIPTOR_STRIDE(ret,i-1); 94 95 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); 96 } 97 } 98 else if (unlikely (compile_options.bounds_check)) 99 { 100 bounds_equal_extents ((array_t *) ret, (array_t *) array, 101 "return value", "CSHIFT"); 102 } 103 104 if (unlikely (compile_options.bounds_check)) 105 { 106 bounds_reduced_extents ((array_t *) h, (array_t *) array, which, 107 "SHIFT argument", "CSHIFT"); 108 } 109 110 if (arraysize == 0) 111 return; 112 113 /* See if we should dispatch to a helper function. */ 114 115 type_size = GFC_DTYPE_TYPE_SIZE (array); 116 117 switch (type_size) 118 { 119 case GFC_DTYPE_LOGICAL_1: 120 case GFC_DTYPE_INTEGER_1: 121 cshift1_16_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, 122 h, pwhich); 123 return; 124 125 case GFC_DTYPE_LOGICAL_2: 126 case GFC_DTYPE_INTEGER_2: 127 cshift1_16_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, 128 h, pwhich); 129 return; 130 131 case GFC_DTYPE_LOGICAL_4: 132 case GFC_DTYPE_INTEGER_4: 133 cshift1_16_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, 134 h, pwhich); 135 return; 136 137 case GFC_DTYPE_LOGICAL_8: 138 case GFC_DTYPE_INTEGER_8: 139 cshift1_16_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, 140 h, pwhich); 141 return; 142 143#if defined (HAVE_INTEGER_16) 144 case GFC_DTYPE_LOGICAL_16: 145 case GFC_DTYPE_INTEGER_16: 146 cshift1_16_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, 147 h, pwhich); 148 return; 149#endif 150 151 case GFC_DTYPE_REAL_4: 152 cshift1_16_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, 153 h, pwhich); 154 return; 155 156 case GFC_DTYPE_REAL_8: 157 cshift1_16_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, 158 h, pwhich); 159 return; 160 161#if defined (HAVE_REAL_10) 162 case GFC_DTYPE_REAL_10: 163 cshift1_16_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, 164 h, pwhich); 165 return; 166#endif 167 168#if defined (HAVE_REAL_16) 169 case GFC_DTYPE_REAL_16: 170 cshift1_16_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, 171 h, pwhich); 172 return; 173#endif 174 175 case GFC_DTYPE_COMPLEX_4: 176 cshift1_16_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, 177 h, pwhich); 178 return; 179 180 case GFC_DTYPE_COMPLEX_8: 181 cshift1_16_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, 182 h, pwhich); 183 return; 184 185#if defined (HAVE_COMPLEX_10) 186 case GFC_DTYPE_COMPLEX_10: 187 cshift1_16_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, 188 h, pwhich); 189 return; 190#endif 191 192#if defined (HAVE_COMPLEX_16) 193 case GFC_DTYPE_COMPLEX_16: 194 cshift1_16_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, 195 h, pwhich); 196 return; 197#endif 198 199 default: 200 break; 201 202 } 203 204 extent[0] = 1; 205 count[0] = 0; 206 n = 0; 207 208 /* Initialized for avoiding compiler warnings. */ 209 roffset = size; 210 soffset = size; 211 len = 0; 212 213 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 214 { 215 if (dim == which) 216 { 217 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); 218 if (roffset == 0) 219 roffset = size; 220 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 221 if (soffset == 0) 222 soffset = size; 223 len = GFC_DESCRIPTOR_EXTENT(array,dim); 224 } 225 else 226 { 227 count[n] = 0; 228 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 229 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); 230 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 231 232 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); 233 n++; 234 } 235 } 236 if (sstride[0] == 0) 237 sstride[0] = size; 238 if (rstride[0] == 0) 239 rstride[0] = size; 240 if (hstride[0] == 0) 241 hstride[0] = 1; 242 243 dim = GFC_DESCRIPTOR_RANK (array); 244 rstride0 = rstride[0]; 245 sstride0 = sstride[0]; 246 hstride0 = hstride[0]; 247 rptr = ret->base_addr; 248 sptr = array->base_addr; 249 hptr = h->base_addr; 250 251 while (rptr) 252 { 253 /* Do the shift for this dimension. */ 254 sh = *hptr; 255 /* Normal case should be -len < sh < len; try to 256 avoid the expensive remainder operation if possible. */ 257 if (sh < 0) 258 sh += len; 259 if (unlikely (sh >= len || sh < 0)) 260 { 261 sh = sh % len; 262 if (sh < 0) 263 sh += len; 264 } 265 266 src = &sptr[sh * soffset]; 267 dest = rptr; 268 if (soffset == size && roffset == size) 269 { 270 size_t len1 = sh * size; 271 size_t len2 = (len - sh) * size; 272 memcpy (rptr, sptr + len1, len2); 273 memcpy (rptr + len2, sptr, len1); 274 } 275 else 276 { 277 for (n = 0; n < len - sh; n++) 278 { 279 memcpy (dest, src, size); 280 dest += roffset; 281 src += soffset; 282 } 283 for (src = sptr, n = 0; n < sh; n++) 284 { 285 memcpy (dest, src, size); 286 dest += roffset; 287 src += soffset; 288 } 289 } 290 291 /* Advance to the next section. */ 292 rptr += rstride0; 293 sptr += sstride0; 294 hptr += hstride0; 295 count[0]++; 296 n = 0; 297 while (count[n] == extent[n]) 298 { 299 /* When we get to the end of a dimension, reset it and increment 300 the next dimension. */ 301 count[n] = 0; 302 /* We could precalculate these products, but this is a less 303 frequently used path so probably not worth it. */ 304 rptr -= rstride[n] * extent[n]; 305 sptr -= sstride[n] * extent[n]; 306 hptr -= hstride[n] * extent[n]; 307 n++; 308 if (n >= dim - 1) 309 { 310 /* Break out of the loop. */ 311 rptr = NULL; 312 break; 313 } 314 else 315 { 316 count[n]++; 317 rptr += rstride[n]; 318 sptr += sstride[n]; 319 hptr += hstride[n]; 320 } 321 } 322 } 323} 324 325void cshift1_16 (gfc_array_char * const restrict, 326 const gfc_array_char * const restrict, 327 const gfc_array_i16 * const restrict, 328 const GFC_INTEGER_16 * const restrict); 329export_proto(cshift1_16); 330 331void 332cshift1_16 (gfc_array_char * const restrict ret, 333 const gfc_array_char * const restrict array, 334 const gfc_array_i16 * const restrict h, 335 const GFC_INTEGER_16 * const restrict pwhich) 336{ 337 cshift1 (ret, array, h, pwhich); 338} 339 340 341void cshift1_16_char (gfc_array_char * const restrict ret, 342 GFC_INTEGER_4, 343 const gfc_array_char * const restrict array, 344 const gfc_array_i16 * const restrict h, 345 const GFC_INTEGER_16 * const restrict pwhich, 346 GFC_INTEGER_4); 347export_proto(cshift1_16_char); 348 349void 350cshift1_16_char (gfc_array_char * const restrict ret, 351 GFC_INTEGER_4 ret_length __attribute__((unused)), 352 const gfc_array_char * const restrict array, 353 const gfc_array_i16 * const restrict h, 354 const GFC_INTEGER_16 * const restrict pwhich, 355 GFC_INTEGER_4 array_length __attribute__((unused))) 356{ 357 cshift1 (ret, array, h, pwhich); 358} 359 360 361void cshift1_16_char4 (gfc_array_char * const restrict ret, 362 GFC_INTEGER_4, 363 const gfc_array_char * const restrict array, 364 const gfc_array_i16 * const restrict h, 365 const GFC_INTEGER_16 * const restrict pwhich, 366 GFC_INTEGER_4); 367export_proto(cshift1_16_char4); 368 369void 370cshift1_16_char4 (gfc_array_char * const restrict ret, 371 GFC_INTEGER_4 ret_length __attribute__((unused)), 372 const gfc_array_char * const restrict array, 373 const gfc_array_i16 * const restrict h, 374 const GFC_INTEGER_16 * const restrict pwhich, 375 GFC_INTEGER_4 array_length __attribute__((unused))) 376{ 377 cshift1 (ret, array, h, pwhich); 378} 379 380#endif 381