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