1`/* Implementation of the RESHAPE 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 28include(iparm.m4)dnl 29 30`#if defined (HAVE_'rtype_name`) 31 32typedef GFC_FULL_ARRAY_DESCRIPTOR(1, 'index_type`) 'shape_type`;' 33 34dnl For integer routines, only the kind (ie size) is used to name the 35dnl function. The same function will be used for integer and logical 36dnl arrays of the same kind. 37 38`extern void reshape_'rtype_ccode` ('rtype` * const restrict, 39 'rtype` * const restrict, 40 'shape_type` * const restrict, 41 'rtype` * const restrict, 42 'shape_type` * const restrict); 43export_proto(reshape_'rtype_ccode`); 44 45void 46reshape_'rtype_ccode` ('rtype` * const restrict ret, 47 'rtype` * const restrict source, 48 'shape_type` * const restrict shape, 49 'rtype` * const restrict pad, 50 'shape_type` * const restrict order) 51{ 52 /* r.* indicates the return array. */ 53 index_type rcount[GFC_MAX_DIMENSIONS]; 54 index_type rextent[GFC_MAX_DIMENSIONS]; 55 index_type rstride[GFC_MAX_DIMENSIONS]; 56 index_type rstride0; 57 index_type rdim; 58 index_type rsize; 59 index_type rs; 60 index_type rex; 61 'rtype_name` *rptr; 62 /* s.* indicates the source array. */ 63 index_type scount[GFC_MAX_DIMENSIONS]; 64 index_type sextent[GFC_MAX_DIMENSIONS]; 65 index_type sstride[GFC_MAX_DIMENSIONS]; 66 index_type sstride0; 67 index_type sdim; 68 index_type ssize; 69 const 'rtype_name` *sptr; 70 /* p.* indicates the pad array. */ 71 index_type pcount[GFC_MAX_DIMENSIONS]; 72 index_type pextent[GFC_MAX_DIMENSIONS]; 73 index_type pstride[GFC_MAX_DIMENSIONS]; 74 index_type pdim; 75 index_type psize; 76 const 'rtype_name` *pptr; 77 78 const 'rtype_name` *src; 79 int sempty, pempty, shape_empty; 80 index_type shape_data[GFC_MAX_DIMENSIONS]; 81 82 rdim = GFC_DESCRIPTOR_EXTENT(shape,0); 83 /* rdim is always > 0; this lets the compiler optimize more and 84 avoids a potential warning. */ 85 GFC_ASSERT(rdim>0); 86 87 if (rdim != GFC_DESCRIPTOR_RANK(ret)) 88 runtime_error("rank of return array incorrect in RESHAPE intrinsic"); 89 90 shape_empty = 0; 91 92 for (index_type n = 0; n < rdim; n++) 93 { 94 shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; 95 if (shape_data[n] <= 0) 96 { 97 shape_data[n] = 0; 98 shape_empty = 1; 99 } 100 } 101 102 if (ret->base_addr == NULL) 103 { 104 index_type alloc_size; 105 106 rs = 1; 107 for (index_type n = 0; n < rdim; n++) 108 { 109 rex = shape_data[n]; 110 111 GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); 112 113 rs *= rex; 114 } 115 ret->offset = 0; 116 117 if (unlikely (rs < 1)) 118 alloc_size = 0; 119 else 120 alloc_size = rs; 121 122 ret->base_addr = xmallocarray (alloc_size, sizeof ('rtype_name`)); 123 ret->dtype.rank = rdim; 124 } 125 126 if (shape_empty) 127 return; 128 129 if (pad) 130 { 131 pdim = GFC_DESCRIPTOR_RANK (pad); 132 psize = 1; 133 pempty = 0; 134 for (index_type n = 0; n < pdim; n++) 135 { 136 pcount[n] = 0; 137 pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); 138 pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); 139 if (pextent[n] <= 0) 140 { 141 pempty = 1; 142 pextent[n] = 0; 143 } 144 145 if (psize == pstride[n]) 146 psize *= pextent[n]; 147 else 148 psize = 0; 149 } 150 pptr = pad->base_addr; 151 } 152 else 153 { 154 pdim = 0; 155 psize = 1; 156 pempty = 1; 157 pptr = NULL; 158 } 159 160 if (unlikely (compile_options.bounds_check)) 161 { 162 index_type ret_extent, source_extent; 163 164 rs = 1; 165 for (index_type n = 0; n < rdim; n++) 166 { 167 rs *= shape_data[n]; 168 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); 169 if (ret_extent != shape_data[n]) 170 runtime_error("Incorrect extent in return value of RESHAPE" 171 " intrinsic in dimension %ld: is %ld," 172 " should be %ld", (long int) n+1, 173 (long int) ret_extent, (long int) shape_data[n]); 174 } 175 176 source_extent = 1; 177 sdim = GFC_DESCRIPTOR_RANK (source); 178 for (index_type n = 0; n < sdim; n++) 179 { 180 index_type se; 181 se = GFC_DESCRIPTOR_EXTENT(source,n); 182 source_extent *= se > 0 ? se : 0; 183 } 184 185 if (rs > source_extent && (!pad || pempty)) 186 runtime_error("Incorrect size in SOURCE argument to RESHAPE" 187 " intrinsic: is %ld, should be %ld", 188 (long int) source_extent, (long int) rs); 189 190 if (order) 191 { 192 int seen[GFC_MAX_DIMENSIONS]; 193 index_type v; 194 195 for (index_type n = 0; n < rdim; n++) 196 seen[n] = 0; 197 198 for (index_type n = 0; n < rdim; n++) 199 { 200 v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; 201 202 if (v < 0 || v >= rdim) 203 runtime_error("Value %ld out of range in ORDER argument" 204 " to RESHAPE intrinsic", (long int) v + 1); 205 206 if (seen[v] != 0) 207 runtime_error("Duplicate value %ld in ORDER argument to" 208 " RESHAPE intrinsic", (long int) v + 1); 209 210 seen[v] = 1; 211 } 212 } 213 } 214 215 rsize = 1; 216 for (index_type n = 0; n < rdim; n++) 217 { 218 index_type dim; 219 if (order) 220 dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; 221 else 222 dim = n; 223 224 rcount[n] = 0; 225 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 226 rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); 227 if (rextent[n] < 0) 228 rextent[n] = 0; 229 230 if (rextent[n] != shape_data[dim]) 231 runtime_error ("shape and target do not conform"); 232 233 if (rsize == rstride[n]) 234 rsize *= rextent[n]; 235 else 236 rsize = 0; 237 if (rextent[n] <= 0) 238 return; 239 } 240 241 sdim = GFC_DESCRIPTOR_RANK (source); 242 243 /* sdim is always > 0; this lets the compiler optimize more and 244 avoids a warning. */ 245 GFC_ASSERT(sdim>0); 246 247 ssize = 1; 248 sempty = 0; 249 for (index_type n = 0; n < sdim; n++) 250 { 251 scount[n] = 0; 252 sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); 253 sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); 254 if (sextent[n] <= 0) 255 { 256 sempty = 1; 257 sextent[n] = 0; 258 } 259 260 if (ssize == sstride[n]) 261 ssize *= sextent[n]; 262 else 263 ssize = 0; 264 } 265 266 if (rsize != 0 && ssize != 0 && psize != 0) 267 { 268 rsize *= sizeof ('rtype_name`); 269 ssize *= sizeof ('rtype_name`); 270 psize *= sizeof ('rtype_name`); 271 reshape_packed ((char *)ret->base_addr, rsize, (char *)source->base_addr, 272 ssize, pad ? (char *)pad->base_addr : NULL, psize); 273 return; 274 } 275 rptr = ret->base_addr; 276 src = sptr = source->base_addr; 277 rstride0 = rstride[0]; 278 sstride0 = sstride[0]; 279 280 if (sempty && pempty) 281 abort (); 282 283 if (sempty) 284 { 285 /* Pretend we are using the pad array the first time around, too. */ 286 src = pptr; 287 sptr = pptr; 288 sdim = pdim; 289 for (index_type dim = 0; dim < pdim; dim++) 290 { 291 scount[dim] = pcount[dim]; 292 sextent[dim] = pextent[dim]; 293 sstride[dim] = pstride[dim]; 294 sstride0 = pstride[0]; 295 } 296 } 297 298 while (rptr) 299 { 300 /* Select between the source and pad arrays. */ 301 *rptr = *src; 302 /* Advance to the next element. */ 303 rptr += rstride0; 304 src += sstride0; 305 rcount[0]++; 306 scount[0]++; 307 308 /* Advance to the next destination element. */ 309 index_type n = 0; 310 while (rcount[n] == rextent[n]) 311 { 312 /* When we get to the end of a dimension, reset it and increment 313 the next dimension. */ 314 rcount[n] = 0; 315 /* We could precalculate these products, but this is a less 316 frequently used path so probably not worth it. */ 317 rptr -= rstride[n] * rextent[n]; 318 n++; 319 if (n == rdim) 320 { 321 /* Break out of the loop. */ 322 rptr = NULL; 323 break; 324 } 325 else 326 { 327 rcount[n]++; 328 rptr += rstride[n]; 329 } 330 } 331 /* Advance to the next source element. */ 332 n = 0; 333 while (scount[n] == sextent[n]) 334 { 335 /* When we get to the end of a dimension, reset it and increment 336 the next dimension. */ 337 scount[n] = 0; 338 /* We could precalculate these products, but this is a less 339 frequently used path so probably not worth it. */ 340 src -= sstride[n] * sextent[n]; 341 n++; 342 if (n == sdim) 343 { 344 if (sptr && pad) 345 { 346 /* Switch to the pad array. */ 347 sptr = NULL; 348 sdim = pdim; 349 for (index_type dim = 0; dim < pdim; dim++) 350 { 351 scount[dim] = pcount[dim]; 352 sextent[dim] = pextent[dim]; 353 sstride[dim] = pstride[dim]; 354 sstride0 = sstride[0]; 355 } 356 } 357 /* We now start again from the beginning of the pad array. */ 358 src = pptr; 359 break; 360 } 361 else 362 { 363 scount[n]++; 364 src += sstride[n]; 365 } 366 } 367 } 368} 369 370#endif' 371