1`/* Implementation of the CSHIFT intrinsic. 2 Copyright (C) 2017-2020 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> 4 5This file is part of the GNU Fortran 95 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>' 28include(iparm.m4)dnl 29 30`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`) 31 32void 33cshift1'rtype_qual`_'atype_code` ('atype` * const restrict ret, 34 const 'atype` * const restrict array, 35 const 'rtype` * const restrict h, 36 const 'rtype_name` * 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 'atype_name` *rptr; 43 'atype_name` *dest; 44 /* s.* indicates the source array. */ 45 index_type sstride[GFC_MAX_DIMENSIONS]; 46 index_type sstride0; 47 index_type soffset; 48 const 'atype_name` *sptr; 49 const 'atype_name` *src; 50 /* h.* indicates the shift array. */ 51 index_type hstride[GFC_MAX_DIMENSIONS]; 52 index_type hstride0; 53 const 'rtype_name` *hptr; 54 55 index_type count[GFC_MAX_DIMENSIONS]; 56 index_type extent[GFC_MAX_DIMENSIONS]; 57 index_type rs_ex[GFC_MAX_DIMENSIONS]; 58 index_type ss_ex[GFC_MAX_DIMENSIONS]; 59 index_type hs_ex[GFC_MAX_DIMENSIONS]; 60 61 index_type dim; 62 index_type len; 63 index_type n; 64 int which; 65 'rtype_name` sh; 66 67 /* Bounds checking etc is already done by the caller. */ 68 69 if (pwhich) 70 which = *pwhich - 1; 71 else 72 which = 0; 73 74 extent[0] = 1; 75 count[0] = 0; 76 n = 0; 77 78 /* Initialized for avoiding compiler warnings. */ 79 roffset = 1; 80 soffset = 1; 81 len = 0; 82 83 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 84 { 85 if (dim == which) 86 { 87 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); 88 if (roffset == 0) 89 roffset = 1; 90 soffset = GFC_DESCRIPTOR_STRIDE(array,dim); 91 if (soffset == 0) 92 soffset = 1; 93 len = GFC_DESCRIPTOR_EXTENT(array,dim); 94 } 95 else 96 { 97 count[n] = 0; 98 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 99 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 100 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 101 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); 102 rs_ex[n] = rstride[n] * extent[n]; 103 ss_ex[n] = sstride[n] * extent[n]; 104 hs_ex[n] = hstride[n] * extent[n]; 105 n++; 106 } 107 } 108 if (sstride[0] == 0) 109 sstride[0] = 1; 110 if (rstride[0] == 0) 111 rstride[0] = 1; 112 if (hstride[0] == 0) 113 hstride[0] = 1; 114 115 dim = GFC_DESCRIPTOR_RANK (array); 116 rstride0 = rstride[0]; 117 sstride0 = sstride[0]; 118 hstride0 = hstride[0]; 119 rptr = ret->base_addr; 120 sptr = array->base_addr; 121 hptr = h->base_addr; 122 123 while (rptr) 124 { 125 /* Do the shift for this dimension. */ 126 sh = *hptr; 127 /* Normal case should be -len < sh < len; try to 128 avoid the expensive remainder operation if possible. */ 129 if (sh < 0) 130 sh += len; 131 if (unlikely(sh >= len || sh < 0)) 132 { 133 sh = sh % len; 134 if (sh < 0) 135 sh += len; 136 } 137 src = &sptr[sh * soffset]; 138 dest = rptr; 139 if (soffset == 1 && roffset == 1) 140 { 141 size_t len1 = sh * sizeof ('atype_name`); 142 size_t len2 = (len - sh) * sizeof ('atype_name`); 143 memcpy (rptr, sptr + sh, len2); 144 memcpy (rptr + (len - sh), sptr, len1); 145 } 146 else 147 { 148 for (n = 0; n < len - sh; n++) 149 { 150 *dest = *src; 151 dest += roffset; 152 src += soffset; 153 } 154 for (src = sptr, n = 0; n < sh; n++) 155 { 156 *dest = *src; 157 dest += roffset; 158 src += soffset; 159 } 160 } 161 162 /* Advance to the next section. */ 163 rptr += rstride0; 164 sptr += sstride0; 165 hptr += hstride0; 166 count[0]++; 167 n = 0; 168 while (count[n] == extent[n]) 169 { 170 /* When we get to the end of a dimension, reset it and increment 171 the next dimension. */ 172 count[n] = 0; 173 rptr -= rs_ex[n]; 174 sptr -= ss_ex[n]; 175 hptr -= hs_ex[n]; 176 n++; 177 if (n >= dim - 1) 178 { 179 /* Break out of the loop. */ 180 rptr = NULL; 181 break; 182 } 183 else 184 { 185 count[n]++; 186 rptr += rstride[n]; 187 sptr += sstride[n]; 188 hptr += hstride[n]; 189 } 190 } 191 } 192} 193 194#endif' 195