1 `/* Helper function for cshift functions. 2 Copyright (C) 2008-2024 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig (a] gcc.gnu.org> 4 5 This file is part of the GNU Fortran runtime library (libgfortran). 6 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. 11 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. 16 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. 20 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/>. */ 25 26 #include "libgfortran.h" 27 #include <string.h>' 28 29 include(iparm.m4)dnl 30 31 `#if defined (HAVE_'rtype_name`) 32 33 void 34 cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift, 35 int which) 36 { 37 /* r.* indicates the return array. */ 38 index_type rstride[GFC_MAX_DIMENSIONS]; 39 index_type rstride0; 40 index_type roffset; 41 'rtype_name` *rptr; 42 43 /* s.* indicates the source array. */ 44 index_type sstride[GFC_MAX_DIMENSIONS]; 45 index_type sstride0; 46 index_type soffset; 47 const 'rtype_name` *sptr; 48 49 index_type count[GFC_MAX_DIMENSIONS]; 50 index_type extent[GFC_MAX_DIMENSIONS]; 51 index_type dim; 52 index_type len; 53 index_type n; 54 55 bool do_blocked; 56 index_type r_ex, a_ex; 57 58 which = which - 1; 59 sstride[0] = 0; 60 rstride[0] = 0; 61 62 extent[0] = 1; 63 count[0] = 0; 64 n = 0; 65 /* Initialized for avoiding compiler warnings. */ 66 roffset = 1; 67 soffset = 1; 68 len = 0; 69 70 r_ex = 1; 71 a_ex = 1; 72 73 if (which > 0) 74 { 75 /* Test if both ret and array are contiguous. */ 76 do_blocked = true; 77 dim = GFC_DESCRIPTOR_RANK (array); 78 for (n = 0; n < dim; n ++) 79 { 80 index_type rs, as; 81 rs = GFC_DESCRIPTOR_STRIDE (ret, n); 82 if (rs != r_ex) 83 { 84 do_blocked = false; 85 break; 86 } 87 as = GFC_DESCRIPTOR_STRIDE (array, n); 88 if (as != a_ex) 89 { 90 do_blocked = false; 91 break; 92 } 93 r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n); 94 a_ex *= GFC_DESCRIPTOR_EXTENT (array, n); 95 } 96 } 97 else 98 do_blocked = false; 99 100 n = 0; 101 102 if (do_blocked) 103 { 104 /* For contiguous arrays, use the relationship that 105 106 dimension(n1,n2,n3) :: a, b 107 b = cshift(a,sh,3) 108 109 can be dealt with as if 110 111 dimension(n1*n2*n3) :: an, bn 112 bn = cshift(a,sh*n1*n2,1) 113 114 we can used a more blocked algorithm for dim>1. */ 115 sstride[0] = 1; 116 rstride[0] = 1; 117 roffset = 1; 118 soffset = 1; 119 len = GFC_DESCRIPTOR_STRIDE(array, which) 120 * GFC_DESCRIPTOR_EXTENT(array, which); 121 shift *= GFC_DESCRIPTOR_STRIDE(array, which); 122 for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++) 123 { 124 count[n] = 0; 125 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 126 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 127 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 128 n++; 129 } 130 dim = GFC_DESCRIPTOR_RANK (array) - which; 131 } 132 else 133 { 134 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 135 { 136 if (dim == which) 137 { 138 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); 139 if (roffset == 0) 140 roffset = 1; 141 soffset = GFC_DESCRIPTOR_STRIDE(array,dim); 142 if (soffset == 0) 143 soffset = 1; 144 len = GFC_DESCRIPTOR_EXTENT(array,dim); 145 } 146 else 147 { 148 count[n] = 0; 149 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 150 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 151 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 152 n++; 153 } 154 } 155 if (sstride[0] == 0) 156 sstride[0] = 1; 157 if (rstride[0] == 0) 158 rstride[0] = 1; 159 160 dim = GFC_DESCRIPTOR_RANK (array); 161 } 162 163 rstride0 = rstride[0]; 164 sstride0 = sstride[0]; 165 rptr = ret->base_addr; 166 sptr = array->base_addr; 167 168 /* Avoid the costly modulo for trivially in-bound shifts. */ 169 if (shift < 0 || shift >= len) 170 { 171 shift = len == 0 ? 0 : shift % (ptrdiff_t)len; 172 if (shift < 0) 173 shift += len; 174 } 175 176 while (rptr) 177 { 178 /* Do the shift for this dimension. */ 179 180 /* If elements are contiguous, perform the operation 181 in two block moves. */ 182 if (soffset == 1 && roffset == 1) 183 { 184 size_t len1 = shift * sizeof ('rtype_name`); 185 size_t len2 = (len - shift) * sizeof ('rtype_name`); 186 memcpy (rptr, sptr + shift, len2); 187 memcpy (rptr + (len - shift), sptr, len1); 188 } 189 else 190 { 191 /* Otherwise, we will have to perform the copy one element at 192 a time. */ 193 'rtype_name` *dest = rptr; 194 const 'rtype_name` *src = &sptr[shift * soffset]; 195 196 for (n = 0; n < len - shift; n++) 197 { 198 *dest = *src; 199 dest += roffset; 200 src += soffset; 201 } 202 for (src = sptr, n = 0; n < shift; n++) 203 { 204 *dest = *src; 205 dest += roffset; 206 src += soffset; 207 } 208 } 209 210 /* Advance to the next section. */ 211 rptr += rstride0; 212 sptr += sstride0; 213 count[0]++; 214 n = 0; 215 while (count[n] == extent[n]) 216 { 217 /* When we get to the end of a dimension, reset it and increment 218 the next dimension. */ 219 count[n] = 0; 220 /* We could precalculate these products, but this is a less 221 frequently used path so probably not worth it. */ 222 rptr -= rstride[n] * extent[n]; 223 sptr -= sstride[n] * extent[n]; 224 n++; 225 if (n >= dim - 1) 226 { 227 /* Break out of the loop. */ 228 rptr = NULL; 229 break; 230 } 231 else 232 { 233 count[n]++; 234 rptr += rstride[n]; 235 sptr += sstride[n]; 236 } 237 } 238 } 239 240 return; 241 } 242 243 #endif' 244
Indexes created Sun Mar 22 00:23:16 UTC 2026