libgfortran/generated/reshape_c8.c

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