1/* Implementation of the EOSHIFT intrinsic 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 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 29 30#if defined (HAVE_GFC_INTEGER_16) 31 32static void 33eoshift3 (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_array_char * const restrict bound, 37 const GFC_INTEGER_16 * const restrict pwhich, 38 const char * filler, index_type filler_len) 39{ 40 /* r.* indicates the return array. */ 41 index_type rstride[GFC_MAX_DIMENSIONS]; 42 index_type rstride0; 43 index_type roffset; 44 char *rptr; 45 char * restrict dest; 46 /* s.* indicates the source array. */ 47 index_type sstride[GFC_MAX_DIMENSIONS]; 48 index_type sstride0; 49 index_type soffset; 50 const char *sptr; 51 const char *src; 52 /* h.* indicates the shift array. */ 53 index_type hstride[GFC_MAX_DIMENSIONS]; 54 index_type hstride0; 55 const GFC_INTEGER_16 *hptr; 56 /* b.* indicates the bound array. */ 57 index_type bstride[GFC_MAX_DIMENSIONS]; 58 index_type bstride0; 59 const char *bptr; 60 61 index_type count[GFC_MAX_DIMENSIONS]; 62 index_type extent[GFC_MAX_DIMENSIONS]; 63 index_type dim; 64 index_type len; 65 index_type n; 66 index_type size; 67 index_type arraysize; 68 int which; 69 GFC_INTEGER_16 sh; 70 GFC_INTEGER_16 delta; 71 72 /* The compiler cannot figure out that these are set, initialize 73 them to avoid warnings. */ 74 len = 0; 75 soffset = 0; 76 roffset = 0; 77 78 arraysize = size0 ((array_t *) array); 79 size = GFC_DESCRIPTOR_SIZE(array); 80 81 if (pwhich) 82 which = *pwhich - 1; 83 else 84 which = 0; 85 86 if (ret->base_addr == NULL) 87 { 88 ret->base_addr = xmallocarray (arraysize, size); 89 ret->offset = 0; 90 GFC_DTYPE_COPY(ret,array); 91 for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) 92 { 93 index_type ub, str; 94 95 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; 96 97 if (i == 0) 98 str = 1; 99 else 100 str = GFC_DESCRIPTOR_EXTENT(ret,i-1) 101 * GFC_DESCRIPTOR_STRIDE(ret,i-1); 102 103 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); 104 105 } 106 /* xmallocarray allocates a single byte for zero size. */ 107 ret->base_addr = xmallocarray (arraysize, size); 108 109 } 110 else if (unlikely (compile_options.bounds_check)) 111 { 112 bounds_equal_extents ((array_t *) ret, (array_t *) array, 113 "return value", "EOSHIFT"); 114 } 115 116 if (unlikely (compile_options.bounds_check)) 117 { 118 bounds_reduced_extents ((array_t *) h, (array_t *) array, which, 119 "SHIFT argument", "EOSHIFT"); 120 } 121 122 if (arraysize == 0) 123 return; 124 125 extent[0] = 1; 126 count[0] = 0; 127 n = 0; 128 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 129 { 130 if (dim == which) 131 { 132 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); 133 if (roffset == 0) 134 roffset = size; 135 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 136 if (soffset == 0) 137 soffset = size; 138 len = GFC_DESCRIPTOR_EXTENT(array,dim); 139 } 140 else 141 { 142 count[n] = 0; 143 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 144 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); 145 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 146 147 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); 148 if (bound) 149 bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n); 150 else 151 bstride[n] = 0; 152 n++; 153 } 154 } 155 if (sstride[0] == 0) 156 sstride[0] = size; 157 if (rstride[0] == 0) 158 rstride[0] = size; 159 if (hstride[0] == 0) 160 hstride[0] = 1; 161 if (bound && bstride[0] == 0) 162 bstride[0] = size; 163 164 dim = GFC_DESCRIPTOR_RANK (array); 165 rstride0 = rstride[0]; 166 sstride0 = sstride[0]; 167 hstride0 = hstride[0]; 168 bstride0 = bstride[0]; 169 rptr = ret->base_addr; 170 sptr = array->base_addr; 171 hptr = h->base_addr; 172 if (bound) 173 bptr = bound->base_addr; 174 else 175 bptr = NULL; 176 177 while (rptr) 178 { 179 /* Do the shift for this dimension. */ 180 sh = *hptr; 181 if (( sh >= 0 ? sh : -sh ) > len) 182 { 183 delta = len; 184 sh = len; 185 } 186 else 187 delta = (sh >= 0) ? sh: -sh; 188 189 if (sh > 0) 190 { 191 src = &sptr[delta * soffset]; 192 dest = rptr; 193 } 194 else 195 { 196 src = sptr; 197 dest = &rptr[delta * roffset]; 198 } 199 200 /* If the elements are contiguous, perform a single block move. */ 201 if (soffset == size && roffset == size) 202 { 203 size_t chunk = size * (len - delta); 204 memcpy (dest, src, chunk); 205 dest += chunk; 206 } 207 else 208 { 209 for (n = 0; n < len - delta; n++) 210 { 211 memcpy (dest, src, size); 212 dest += roffset; 213 src += soffset; 214 } 215 } 216 217 if (sh < 0) 218 dest = rptr; 219 n = delta; 220 221 if (bptr) 222 while (n--) 223 { 224 memcpy (dest, bptr, size); 225 dest += roffset; 226 } 227 else 228 while (n--) 229 { 230 index_type i; 231 232 if (filler_len == 1) 233 memset (dest, filler[0], size); 234 else 235 for (i = 0; i < size; i += filler_len) 236 memcpy (&dest[i], filler, filler_len); 237 238 dest += roffset; 239 } 240 241 /* Advance to the next section. */ 242 rptr += rstride0; 243 sptr += sstride0; 244 hptr += hstride0; 245 bptr += bstride0; 246 count[0]++; 247 n = 0; 248 while (count[n] == extent[n]) 249 { 250 /* When we get to the end of a dimension, reset it and increment 251 the next dimension. */ 252 count[n] = 0; 253 /* We could precalculate these products, but this is a less 254 frequently used path so probably not worth it. */ 255 rptr -= rstride[n] * extent[n]; 256 sptr -= sstride[n] * extent[n]; 257 hptr -= hstride[n] * extent[n]; 258 bptr -= bstride[n] * extent[n]; 259 n++; 260 if (n >= dim - 1) 261 { 262 /* Break out of the loop. */ 263 rptr = NULL; 264 break; 265 } 266 else 267 { 268 count[n]++; 269 rptr += rstride[n]; 270 sptr += sstride[n]; 271 hptr += hstride[n]; 272 bptr += bstride[n]; 273 } 274 } 275 } 276} 277 278extern void eoshift3_16 (gfc_array_char * const restrict, 279 const gfc_array_char * const restrict, 280 const gfc_array_i16 * const restrict, 281 const gfc_array_char * const restrict, 282 const GFC_INTEGER_16 *); 283export_proto(eoshift3_16); 284 285void 286eoshift3_16 (gfc_array_char * const restrict ret, 287 const gfc_array_char * const restrict array, 288 const gfc_array_i16 * const restrict h, 289 const gfc_array_char * const restrict bound, 290 const GFC_INTEGER_16 * const restrict pwhich) 291{ 292 eoshift3 (ret, array, h, bound, pwhich, "\0", 1); 293} 294 295 296extern void eoshift3_16_char (gfc_array_char * const restrict, 297 GFC_INTEGER_4, 298 const gfc_array_char * const restrict, 299 const gfc_array_i16 * const restrict, 300 const gfc_array_char * const restrict, 301 const GFC_INTEGER_16 * const restrict, 302 GFC_INTEGER_4, GFC_INTEGER_4); 303export_proto(eoshift3_16_char); 304 305void 306eoshift3_16_char (gfc_array_char * const restrict ret, 307 GFC_INTEGER_4 ret_length __attribute__((unused)), 308 const gfc_array_char * const restrict array, 309 const gfc_array_i16 * const restrict h, 310 const gfc_array_char * const restrict bound, 311 const GFC_INTEGER_16 * const restrict pwhich, 312 GFC_INTEGER_4 array_length __attribute__((unused)), 313 GFC_INTEGER_4 bound_length __attribute__((unused))) 314{ 315 eoshift3 (ret, array, h, bound, pwhich, " ", 1); 316} 317 318 319extern void eoshift3_16_char4 (gfc_array_char * const restrict, 320 GFC_INTEGER_4, 321 const gfc_array_char * const restrict, 322 const gfc_array_i16 * const restrict, 323 const gfc_array_char * const restrict, 324 const GFC_INTEGER_16 * const restrict, 325 GFC_INTEGER_4, GFC_INTEGER_4); 326export_proto(eoshift3_16_char4); 327 328void 329eoshift3_16_char4 (gfc_array_char * const restrict ret, 330 GFC_INTEGER_4 ret_length __attribute__((unused)), 331 const gfc_array_char * const restrict array, 332 const gfc_array_i16 * const restrict h, 333 const gfc_array_char * const restrict bound, 334 const GFC_INTEGER_16 * const restrict pwhich, 335 GFC_INTEGER_4 array_length __attribute__((unused)), 336 GFC_INTEGER_4 bound_length __attribute__((unused))) 337{ 338 static const gfc_char4_t space = (unsigned char) ' '; 339 eoshift3 (ret, array, h, bound, pwhich, 340 (const char *) &space, sizeof (gfc_char4_t)); 341} 342 343#endif 344