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