libgfortran/intrinsics/reshape_generic.c

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