libgfortran/intrinsics/reshape_generic.c

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