libgfortran/generated/reshape_i16.c

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