1/* Special implementation of the SPREAD intrinsic 2 Copyright (C) 2008-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on 4 spread_generic.c written by Paul Brook <paul@nowt.org> 5 6This file is part of the GNU Fortran runtime library (libgfortran). 7 8Libgfortran is free software; you can redistribute it and/or 9modify it under the terms of the GNU General Public 10License as published by the Free Software Foundation; either 11version 3 of the License, or (at your option) any later version. 12 13Ligbfortran is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18Under Section 7 of GPL version 3, you are granted additional 19permissions described in the GCC Runtime Library Exception, version 203.1, as published by the Free Software Foundation. 21 22You should have received a copy of the GNU General Public License and 23a copy of the GCC Runtime Library Exception along with this program; 24see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 25<http://www.gnu.org/licenses/>. */ 26 27#include "libgfortran.h" 28#include <string.h> 29 30 31#if defined (HAVE_GFC_INTEGER_8) 32 33void 34spread_i8 (gfc_array_i8 *ret, const gfc_array_i8 *source, 35 const index_type along, const index_type pncopies) 36{ 37 /* r.* indicates the return array. */ 38 index_type rstride[GFC_MAX_DIMENSIONS]; 39 index_type rstride0; 40 index_type rdelta = 0; 41 index_type rrank; 42 index_type rs; 43 GFC_INTEGER_8 *rptr; 44 GFC_INTEGER_8 * restrict dest; 45 /* s.* indicates the source array. */ 46 index_type sstride[GFC_MAX_DIMENSIONS]; 47 index_type sstride0; 48 index_type srank; 49 const GFC_INTEGER_8 *sptr; 50 51 index_type count[GFC_MAX_DIMENSIONS]; 52 index_type extent[GFC_MAX_DIMENSIONS]; 53 index_type n; 54 index_type dim; 55 index_type ncopies; 56 57 srank = GFC_DESCRIPTOR_RANK(source); 58 59 rrank = srank + 1; 60 if (rrank > GFC_MAX_DIMENSIONS) 61 runtime_error ("return rank too large in spread()"); 62 63 if (along > rrank) 64 runtime_error ("dim outside of rank in spread()"); 65 66 ncopies = pncopies; 67 68 if (ret->base_addr == NULL) 69 { 70 71 size_t ub, stride; 72 73 /* The front end has signalled that we need to populate the 74 return array descriptor. */ 75 ret->dtype.rank = rrank; 76 77 dim = 0; 78 rs = 1; 79 for (n = 0; n < rrank; n++) 80 { 81 stride = rs; 82 if (n == along - 1) 83 { 84 ub = ncopies - 1; 85 rdelta = rs; 86 rs *= ncopies; 87 } 88 else 89 { 90 count[dim] = 0; 91 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 92 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); 93 rstride[dim] = rs; 94 95 ub = extent[dim] - 1; 96 rs *= extent[dim]; 97 dim++; 98 } 99 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); 100 } 101 ret->offset = 0; 102 103 /* xmallocarray allocates a single byte for zero size. */ 104 ret->base_addr = xmallocarray (rs, sizeof(GFC_INTEGER_8)); 105 if (rs <= 0) 106 return; 107 } 108 else 109 { 110 int zero_sized; 111 112 zero_sized = 0; 113 114 dim = 0; 115 if (GFC_DESCRIPTOR_RANK(ret) != rrank) 116 runtime_error ("rank mismatch in spread()"); 117 118 if (unlikely (compile_options.bounds_check)) 119 { 120 for (n = 0; n < rrank; n++) 121 { 122 index_type ret_extent; 123 124 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); 125 if (n == along - 1) 126 { 127 rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); 128 129 if (ret_extent != ncopies) 130 runtime_error("Incorrect extent in return value of SPREAD" 131 " intrinsic in dimension %ld: is %ld," 132 " should be %ld", (long int) n+1, 133 (long int) ret_extent, (long int) ncopies); 134 } 135 else 136 { 137 count[dim] = 0; 138 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 139 if (ret_extent != extent[dim]) 140 runtime_error("Incorrect extent in return value of SPREAD" 141 " intrinsic in dimension %ld: is %ld," 142 " should be %ld", (long int) n+1, 143 (long int) ret_extent, 144 (long int) extent[dim]); 145 146 if (extent[dim] <= 0) 147 zero_sized = 1; 148 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); 149 rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); 150 dim++; 151 } 152 } 153 } 154 else 155 { 156 for (n = 0; n < rrank; n++) 157 { 158 if (n == along - 1) 159 { 160 rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); 161 } 162 else 163 { 164 count[dim] = 0; 165 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 166 if (extent[dim] <= 0) 167 zero_sized = 1; 168 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); 169 rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); 170 dim++; 171 } 172 } 173 } 174 175 if (zero_sized) 176 return; 177 178 if (sstride[0] == 0) 179 sstride[0] = 1; 180 } 181 sstride0 = sstride[0]; 182 rstride0 = rstride[0]; 183 rptr = ret->base_addr; 184 sptr = source->base_addr; 185 186 while (sptr) 187 { 188 /* Spread this element. */ 189 dest = rptr; 190 for (n = 0; n < ncopies; n++) 191 { 192 *dest = *sptr; 193 dest += rdelta; 194 } 195 /* Advance to the next element. */ 196 sptr += sstride0; 197 rptr += rstride0; 198 count[0]++; 199 n = 0; 200 while (count[n] == extent[n]) 201 { 202 /* When we get to the end of a dimension, reset it and increment 203 the next dimension. */ 204 count[n] = 0; 205 /* We could precalculate these products, but this is a less 206 frequently used path so probably not worth it. */ 207 sptr -= sstride[n] * extent[n]; 208 rptr -= rstride[n] * extent[n]; 209 n++; 210 if (n >= srank) 211 { 212 /* Break out of the loop. */ 213 sptr = NULL; 214 break; 215 } 216 else 217 { 218 count[n]++; 219 sptr += sstride[n]; 220 rptr += rstride[n]; 221 } 222 } 223 } 224} 225 226/* This version of spread_internal treats the special case of a scalar 227 source. This is much simpler than the more general case above. */ 228 229void 230spread_scalar_i8 (gfc_array_i8 *ret, const GFC_INTEGER_8 *source, 231 const index_type along, const index_type ncopies) 232{ 233 GFC_INTEGER_8 * restrict dest; 234 index_type stride; 235 236 if (GFC_DESCRIPTOR_RANK (ret) != 1) 237 runtime_error ("incorrect destination rank in spread()"); 238 239 if (along > 1) 240 runtime_error ("dim outside of rank in spread()"); 241 242 if (ret->base_addr == NULL) 243 { 244 ret->base_addr = xmallocarray (ncopies, sizeof (GFC_INTEGER_8)); 245 ret->offset = 0; 246 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); 247 } 248 else 249 { 250 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) 251 / GFC_DESCRIPTOR_STRIDE(ret,0)) 252 runtime_error ("dim too large in spread()"); 253 } 254 255 dest = ret->base_addr; 256 stride = GFC_DESCRIPTOR_STRIDE(ret,0); 257 258 for (index_type n = 0; n < ncopies; n++) 259 { 260 *dest = *source; 261 dest += stride; 262 } 263} 264 265#endif 266 267