libgfortran/intrinsics/reshape_generic.c

   1 /* Generic implementation of the RESHAPE intrinsic
   2    Copyright 2002 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Ligbfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 Boston, MA 02111-1307, USA.  */
  30
  31 #include "config.h"
  32 #include <stdlib.h>
  33 #include <string.h>
  34 #include <assert.h>
  35 #include "libgfortran.h"
  36
  37 typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
  38 typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
  39
  40 extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
  41 export_proto(reshape);
  42
  43 /* The shape parameter is ignored. We can currently deduce the shape from the
  44    return array.  */
  45
  46 void
  47 reshape (parray *ret, parray *source, shape_type *shape,
  48          parray *pad, shape_type *order)
  49 {
  50   /* r.* indicates the return array.  */
  51   index_type rcount[GFC_MAX_DIMENSIONS - 1];
  52   index_type rextent[GFC_MAX_DIMENSIONS - 1];
  53   index_type rstride[GFC_MAX_DIMENSIONS - 1];
  54   index_type rstride0;
  55   index_type rdim;
  56   index_type rsize;
  57   char *rptr;
  58   /* s.* indicates the source array.  */
  59   index_type scount[GFC_MAX_DIMENSIONS - 1];
  60   index_type sextent[GFC_MAX_DIMENSIONS - 1];
  61   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  62   index_type sstride0;
  63   index_type sdim;
  64   index_type ssize;
  65   const char *sptr;
  66   /* p.* indicates the pad array.  */
  67   index_type pcount[GFC_MAX_DIMENSIONS - 1];
  68   index_type pextent[GFC_MAX_DIMENSIONS - 1];
  69   index_type pstride[GFC_MAX_DIMENSIONS - 1];
  70   index_type pdim;
  71   index_type psize;
  72   const char *pptr;
  73
  74   const char *src;
  75   int n;
  76   int dim;
  77   int size;
  78
  79   size = GFC_DESCRIPTOR_SIZE (ret);
  80   if (ret->dim[0].stride == 0)
  81     ret->dim[0].stride = 1;
  82   if (source->dim[0].stride == 0)
  83     source->dim[0].stride = 1;
  84   if (shape->dim[0].stride == 0)
  85     shape->dim[0].stride = 1;
  86   if (pad && pad->dim[0].stride == 0)
  87     pad->dim[0].stride = 1;
  88   if (order && order->dim[0].stride == 0)
  89     order->dim[0].stride = 1;
  90
  91   rdim = GFC_DESCRIPTOR_RANK (ret);
  92   rsize = 1;
  93   for (n = 0; n < rdim; n++)
  94     {
  95       if (order)
  96         dim = order->data[n * order->dim[0].stride] - 1;
  97       else
  98         dim = n;
  99
 100       rcount[n] = 0;
 101       rstride[n] = ret->dim[dim].stride;
 102       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
 103
 104       if (rextent[n] != shape->data[dim * shape->dim[0].stride])
 105         runtime_error ("shape and target do not conform");
 106
 107       if (rsize == rstride[n])
 108         rsize *= rextent[n];
 109       else
 110         rsize = 0;
 111       if (rextent[dim] <= 0)
 112         return;
 113     }
 114
 115   sdim = GFC_DESCRIPTOR_RANK (source);
 116   ssize = 1;
 117   for (n = 0; n < sdim; n++)
 118     {
 119       scount[n] = 0;
 120       sstride[n] = source->dim[n].stride;
 121       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 122       if (sextent[n] <= 0)
 123         abort ();
 124
 125       if (rsize == sstride[n])
 126         ssize *= sextent[n];
 127       else
 128         ssize = 0;
 129     }
 130
 131   if (pad)
 132     {
 133       if (pad->dim[0].stride == 0)
 134         pad->dim[0].stride = 1;
 135       pdim = GFC_DESCRIPTOR_RANK (pad);
 136       psize = 1;
 137       for (n = 0; n < pdim; n++)
 138         {
 139           pcount[n] = 0;
 140           pstride[n] = pad->dim[n].stride;
 141           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 142           if (pextent[n] <= 0)
 143             abort ();
 144           if (psize == pstride[n])
 145             psize *= pextent[n];
 146           else
 147             rsize = 0;
 148         }
 149       pptr = pad->data;
 150     }
 151   else
 152     {
 153       pdim = 0;
 154       psize = 1;
 155       pptr = NULL;
 156     }
 157
 158   if (rsize != 0 && ssize != 0 && psize != 0)
 159     {
 160       rsize *= size;
 161       ssize *= size;
 162       psize *= size;
 163       reshape_packed (ret->data, rsize, source->data, ssize,
 164                       pad ? pad->data : NULL, psize);
 165       return;
 166     }
 167   rptr = ret->data;
 168   src = sptr = source->data;
 169   rstride0 = rstride[0] * size;
 170   sstride0 = sstride[0] * size;
 171
 172   while (rptr)
 173     {
 174       /* Select between the source and pad arrays.  */
 175       memcpy(rptr, src, size);
 176       /* Advance to the next element.  */
 177       rptr += rstride0;
 178       src += sstride0;
 179       rcount[0]++;
 180       scount[0]++;
 181       /* Advance to the next destination element.  */
 182       n = 0;
 183       while (rcount[n] == rextent[n])
 184         {
 185           /* When we get to the end of a dimension, reset it and increment
 186              the next dimension.  */
 187           rcount[n] = 0;
 188           /* We could precalculate these products, but this is a less
 189              frequently used path so proabably not worth it.  */
 190           rptr -= rstride[n] * rextent[n] * size;
 191           n++;
 192           if (n == rdim)
 193             {
 194               /* Break out of the loop.  */
 195               rptr = NULL;
 196               break;
 197             }
 198           else
 199             {
 200               rcount[n]++;
 201               rptr += rstride[n] * size;
 202             }
 203         }
 204       /* Advance to the next source element.  */
 205       n = 0;
 206       while (scount[n] == sextent[n])
 207         {
 208           /* When we get to the end of a dimension, reset it and increment
 209              the next dimension.  */
 210           scount[n] = 0;
 211           /* We could precalculate these products, but this is a less
 212              frequently used path so proabably not worth it.  */
 213           src -= sstride[n] * sextent[n] * size;
 214           n++;
 215           if (n == sdim)
 216             {
 217               if (sptr && pad)
 218                 {
 219                   /* Switch to the pad array.  */
 220                   sptr = NULL;
 221                   sdim = pdim;
 222                   for (dim = 0; dim < pdim; dim++)
 223                     {
 224                       scount[dim] = pcount[dim];
 225                       sextent[dim] = pextent[dim];
 226                       sstride[dim] = pstride[dim];
 227                       sstride0 = sstride[0] * size;
 228                     }
 229                 }
 230               /* We now start again from the beginning of the pad array.  */
 231               src = pptr;
 232               break;
 233             }
 234           else
 235             {
 236               scount[n]++;
 237               sptr += sstride[n] * size;
 238             }
 239         }
 240     }
 241 }