libgfortran/generated/reshape_r16.c

   1 /* Implementation of the RESHAPE intrinsic
   2    Copyright 2002, 2006, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 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 #include <stdlib.h>
  28 #include <assert.h>
  29
  30
  31 #if defined (HAVE_GFC_REAL_16)
  32
  33 typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
  34
  35
  36 extern void reshape_r16 (gfc_array_r16 * const restrict,
  37         gfc_array_r16 * const restrict,
  38         shape_type * const restrict,
  39         gfc_array_r16 * const restrict,
  40         shape_type * const restrict);
  41 export_proto(reshape_r16);
  42
  43 void
  44 reshape_r16 (gfc_array_r16 * const restrict ret,
  45         gfc_array_r16 * const restrict source,
  46         shape_type * const restrict shape,
  47         gfc_array_r16 * const restrict pad,
  48         shape_type * const restrict order)
  49 {
  50   /* r.* indicates the return array.  */
  51   index_type rcount[GFC_MAX_DIMENSIONS];
  52   index_type rextent[GFC_MAX_DIMENSIONS];
  53   index_type rstride[GFC_MAX_DIMENSIONS];
  54   index_type rstride0;
  55   index_type rdim;
  56   index_type rsize;
  57   index_type rs;
  58   index_type rex;
  59   GFC_REAL_16 *rptr;
  60   /* s.* indicates the source array.  */
  61   index_type scount[GFC_MAX_DIMENSIONS];
  62   index_type sextent[GFC_MAX_DIMENSIONS];
  63   index_type sstride[GFC_MAX_DIMENSIONS];
  64   index_type sstride0;
  65   index_type sdim;
  66   index_type ssize;
  67   const GFC_REAL_16 *sptr;
  68   /* p.* indicates the pad array.  */
  69   index_type pcount[GFC_MAX_DIMENSIONS];
  70   index_type pextent[GFC_MAX_DIMENSIONS];
  71   index_type pstride[GFC_MAX_DIMENSIONS];
  72   index_type pdim;
  73   index_type psize;
  74   const GFC_REAL_16 *pptr;
  75
  76   const GFC_REAL_16 *src;
  77   int n;
  78   int dim;
  79   int sempty, pempty, shape_empty;
  80   index_type shape_data[GFC_MAX_DIMENSIONS];
  81
  82   rdim = GFC_DESCRIPTOR_EXTENT(shape,0);
  83   if (rdim != GFC_DESCRIPTOR_RANK(ret))
  84     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
  85
  86   shape_empty = 0;
  87
  88   for (n = 0; n < rdim; n++)
  89     {
  90       shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)];
  91       if (shape_data[n] <= 0)
  92       {
  93         shape_data[n] = 0;
  94         shape_empty = 1;
  95       }
  96     }
  97
  98   if (ret->data == NULL)
  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       ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_16));
 111       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
 112     }
 113
 114   if (shape_empty)
 115     return;
 116
 117   if (pad)
 118     {
 119       pdim = GFC_DESCRIPTOR_RANK (pad);
 120       psize = 1;
 121       pempty = 0;
 122       for (n = 0; n < pdim; n++)
 123         {
 124           pcount[n] = 0;
 125           pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n);
 126           pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
 127           if (pextent[n] <= 0)
 128             {
 129               pempty = 1;
 130               pextent[n] = 0;
 131             }
 132
 133           if (psize == pstride[n])
 134             psize *= pextent[n];
 135           else
 136             psize = 0;
 137         }
 138       pptr = pad->data;
 139     }
 140   else
 141     {
 142       pdim = 0;
 143       psize = 1;
 144       pempty = 1;
 145       pptr = NULL;
 146     }
 147
 148   if (unlikely (compile_options.bounds_check))
 149     {
 150       index_type ret_extent, source_extent;
 151
 152       rs = 1;
 153       for (n = 0; n < rdim; n++)
 154         {
 155           rs *= shape_data[n];
 156           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 157           if (ret_extent != shape_data[n])
 158             runtime_error("Incorrect extent in return value of RESHAPE"
 159                           " intrinsic in dimension %ld: is %ld,"
 160                           " should be %ld", (long int) n+1,
 161                           (long int) ret_extent, (long int) shape_data[n]);
 162         }
 163
 164       source_extent = 1;
 165       sdim = GFC_DESCRIPTOR_RANK (source);
 166       for (n = 0; n < sdim; n++)
 167         {
 168           index_type se;
 169           se = GFC_DESCRIPTOR_EXTENT(source,n);
 170           source_extent *= se > 0 ? se : 0;
 171         }
 172
 173       if (rs > source_extent && (!pad || pempty))
 174         runtime_error("Incorrect size in SOURCE argument to RESHAPE"
 175                       " intrinsic: is %ld, should be %ld",
 176                       (long int) source_extent, (long int) rs);
 177
 178       if (order)
 179         {
 180           int seen[GFC_MAX_DIMENSIONS];
 181           index_type v;
 182
 183           for (n = 0; n < rdim; n++)
 184             seen[n] = 0;
 185
 186           for (n = 0; n < rdim; n++)
 187             {
 188               v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
 189
 190               if (v < 0 || v >= rdim)
 191                 runtime_error("Value %ld out of range in ORDER argument"
 192                               " to RESHAPE intrinsic", (long int) v + 1);
 193
 194               if (seen[v] != 0)
 195                 runtime_error("Duplicate value %ld in ORDER argument to"
 196                               " RESHAPE intrinsic", (long int) v + 1);
 197
 198               seen[v] = 1;
 199             }
 200         }
 201     }
 202
 203   rsize = 1;
 204   for (n = 0; n < rdim; n++)
 205     {
 206       if (order)
 207         dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
 208       else
 209         dim = n;
 210
 211       rcount[n] = 0;
 212       rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
 213       rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
 214       if (rextent[n] < 0)
 215         rextent[n] = 0;
 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   ssize = 1;
 230   sempty = 0;
 231   for (n = 0; n < sdim; n++)
 232     {
 233       scount[n] = 0;
 234       sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
 235       sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
 236       if (sextent[n] <= 0)
 237         {
 238           sempty = 1;
 239           sextent[n] = 0;
 240         }
 241
 242       if (ssize == sstride[n])
 243         ssize *= sextent[n];
 244       else
 245         ssize = 0;
 246     }
 247
 248   if (rsize != 0 && ssize != 0 && psize != 0)
 249     {
 250       rsize *= sizeof (GFC_REAL_16);
 251       ssize *= sizeof (GFC_REAL_16);
 252       psize *= sizeof (GFC_REAL_16);
 253       reshape_packed ((char *)ret->data, rsize, (char *)source->data,
 254                       ssize, pad ? (char *)pad->data : NULL, psize);
 255       return;
 256     }
 257   rptr = ret->data;
 258   src = sptr = source->data;
 259   rstride0 = rstride[0];
 260   sstride0 = sstride[0];
 261
 262   if (sempty && pempty)
 263     abort ();
 264
 265   if (sempty)
 266     {
 267       /* Pretend we are using the pad array the first time around, too.  */
 268       src = pptr;
 269       sptr = pptr;
 270       sdim = pdim;
 271       for (dim = 0; dim < pdim; dim++)
 272         {
 273           scount[dim] = pcount[dim];
 274           sextent[dim] = pextent[dim];
 275           sstride[dim] = pstride[dim];
 276           sstride0 = pstride[0];
 277         }
 278     }
 279
 280   while (rptr)
 281     {
 282       /* Select between the source and pad arrays.  */
 283       *rptr = *src;
 284       /* Advance to the next element.  */
 285       rptr += rstride0;
 286       src += sstride0;
 287       rcount[0]++;
 288       scount[0]++;
 289
 290       /* Advance to the next destination element.  */
 291       n = 0;
 292       while (rcount[n] == rextent[n])
 293         {
 294           /* When we get to the end of a dimension, reset it and increment
 295              the next dimension.  */
 296           rcount[n] = 0;
 297           /* We could precalculate these products, but this is a less
 298              frequently used path so probably not worth it.  */
 299           rptr -= rstride[n] * rextent[n];
 300           n++;
 301           if (n == rdim)
 302             {
 303               /* Break out of the loop.  */
 304               rptr = NULL;
 305               break;
 306             }
 307           else
 308             {
 309               rcount[n]++;
 310               rptr += rstride[n];
 311             }
 312         }
 313       /* Advance to the next source element.  */
 314       n = 0;
 315       while (scount[n] == sextent[n])
 316         {
 317           /* When we get to the end of a dimension, reset it and increment
 318              the next dimension.  */
 319           scount[n] = 0;
 320           /* We could precalculate these products, but this is a less
 321              frequently used path so probably not worth it.  */
 322           src -= sstride[n] * sextent[n];
 323           n++;
 324           if (n == sdim)
 325             {
 326               if (sptr && pad)
 327                 {
 328                   /* Switch to the pad array.  */
 329                   sptr = NULL;
 330                   sdim = pdim;
 331                   for (dim = 0; dim < pdim; dim++)
 332                     {
 333                       scount[dim] = pcount[dim];
 334                       sextent[dim] = pextent[dim];
 335                       sstride[dim] = pstride[dim];
 336                       sstride0 = sstride[0];
 337                     }
 338                 }
 339               /* We now start again from the beginning of the pad array.  */
 340               src = pptr;
 341               break;
 342             }
 343           else
 344             {
 345               scount[n]++;
 346               src += sstride[n];
 347             }
 348         }
 349     }
 350 }
 351
 352 #endif