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