libgfortran/m4/reshape.m4

   1 `/* Implementation of the RESHAPE
   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 (libgfor).
   6
   7 Libgfor is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU Lesser General Public
   9 License as published by the Free Software Foundation; either
  10 version 2.1 of the License, or (at your option) any later version.
  11
  12 Ligbfor 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 Lesser General Public License for more details.
  16
  17 You should have received a copy of the GNU Lesser General Public
  18 License along with libgfor; see the file COPYING.LIB.  If not,
  19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 #include "config.h"
  23 #include <stdlib.h>
  24 #include <assert.h>
  25 #include "libgfortran.h"'
  26 include(iparm.m4)dnl
  27
  28 typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
  29
  30 /* The shape parameter is ignored. We can currently deduce the shape from the
  31    return array.  */
  32 dnl Only the kind (ie size) is used to name the function.
  33 void
  34 `__reshape_'rtype_kind (rtype * ret, rtype * source, shape_type * shape,
  35                       rtype * pad, shape_type * order)
  36 {
  37   /* r.* indicates the return array.  */
  38   index_type rcount[GFC_MAX_DIMENSIONS - 1];
  39   index_type rextent[GFC_MAX_DIMENSIONS - 1];
  40   index_type rstride[GFC_MAX_DIMENSIONS - 1];
  41   index_type rstride0;
  42   index_type rdim;
  43   index_type rsize;
  44   rtype_name *rptr;
  45   /* s.* indicates the source array.  */
  46   index_type scount[GFC_MAX_DIMENSIONS - 1];
  47   index_type sextent[GFC_MAX_DIMENSIONS - 1];
  48   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  49   index_type sstride0;
  50   index_type sdim;
  51   index_type ssize;
  52   const rtype_name *sptr;
  53   /* p.* indicates the pad array.  */
  54   index_type pcount[GFC_MAX_DIMENSIONS - 1];
  55   index_type pextent[GFC_MAX_DIMENSIONS - 1];
  56   index_type pstride[GFC_MAX_DIMENSIONS - 1];
  57   index_type pdim;
  58   index_type psize;
  59   const rtype_name *pptr;
  60
  61   const rtype_name *src;
  62   int n;
  63   int dim;
  64
  65   if (ret->dim[0].stride == 0)
  66     ret->dim[0].stride = 1;
  67   if (source->dim[0].stride == 0)
  68     source->dim[0].stride = 1;
  69   if (shape->dim[0].stride == 0)
  70     shape->dim[0].stride = 1;
  71   if (pad && pad->dim[0].stride == 0)
  72     pad->dim[0].stride = 1;
  73   if (order && order->dim[0].stride == 0)
  74     order->dim[0].stride = 1;
  75
  76   rdim = GFC_DESCRIPTOR_RANK (ret);
  77   rsize = 1;
  78   for (n = 0; n < rdim; n++)
  79     {
  80       if (order)
  81         dim = order->data[n * order->dim[0].stride] - 1;
  82       else
  83         dim = n;
  84
  85       rcount[n] = 0;
  86       rstride[n] = ret->dim[dim].stride;
  87       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
  88
  89       if (rextent[n] != shape->data[dim * shape->dim[0].stride])
  90         runtime_error ("shape and target do not conform");
  91
  92       if (rsize == rstride[n])
  93         rsize *= rextent[n];
  94       else
  95         rsize = 0;
  96       if (rextent[dim] <= 0)
  97         return;
  98     }
  99
 100   sdim = GFC_DESCRIPTOR_RANK (source);
 101   ssize = 1;
 102   for (n = 0; n < sdim; n++)
 103     {
 104       scount[n] = 0;
 105       sstride[n] = source->dim[n].stride;
 106       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 107       if (sextent[n] <= 0)
 108         abort ();
 109
 110       if (ssize == sstride[n])
 111         ssize *= sextent[n];
 112       else
 113         ssize = 0;
 114     }
 115
 116   if (pad)
 117     {
 118       if (pad->dim[0].stride == 0)
 119         pad->dim[0].stride = 1;
 120       pdim = GFC_DESCRIPTOR_RANK (pad);
 121       psize = 1;
 122       for (n = 0; n < pdim; n++)
 123         {
 124           pcount[n] = 0;
 125           pstride[n] = pad->dim[n].stride;
 126           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 127           if (pextent[n] <= 0)
 128             abort ();
 129           if (psize == pstride[n])
 130             psize *= pextent[n];
 131           else
 132             psize = 0;
 133         }
 134       pptr = pad->data;
 135     }
 136   else
 137     {
 138       pdim = 0;
 139       psize = 1;
 140       pptr = NULL;
 141     }
 142
 143   if (rsize != 0 && ssize != 0 && psize != 0)
 144     {
 145       rsize *= rtype_kind;
 146       ssize *= rtype_kind;
 147       psize *= rtype_kind;
 148       reshape_packed ((char *)ret->data, rsize, (char *)source->data,
 149                       ssize, pad ? (char *)pad->data : NULL, psize);
 150       return;
 151     }
 152   rptr = ret->data;
 153   src = sptr = source->data;
 154   rstride0 = rstride[0];
 155   sstride0 = sstride[0];
 156
 157   while (rptr)
 158     {
 159       /* Select between the source and pad arrays.  */
 160       *rptr = *src;
 161       /* Advance to the next element.  */
 162       rptr += rstride0;
 163       src += sstride0;
 164       rcount[0]++;
 165       scount[0]++;
 166       /* Advance to the next destination element.  */
 167       n = 0;
 168       while (rcount[n] == rextent[n])
 169         {
 170           /* When we get to the end of a dimension, reset it and increment
 171              the next dimension.  */
 172           rcount[n] = 0;
 173           /* We could precalculate these products, but this is a less
 174              frequently used path so proabably not worth it.  */
 175           rptr -= rstride[n] * rextent[n];
 176           n++;
 177           if (n == rdim)
 178             {
 179               /* Break out of the loop.  */
 180               rptr = NULL;
 181               break;
 182             }
 183           else
 184             {
 185               rcount[n]++;
 186               rptr += rstride[n];
 187             }
 188         }
 189       /* Advance to the next source element.  */
 190       n = 0;
 191       while (scount[n] == sextent[n])
 192         {
 193           /* When we get to the end of a dimension, reset it and increment
 194              the next dimension.  */
 195           scount[n] = 0;
 196           /* We could precalculate these products, but this is a less
 197              frequently used path so proabably not worth it.  */
 198           src -= sstride[n] * sextent[n];
 199           n++;
 200           if (n == sdim)
 201             {
 202               if (sptr && pad)
 203                 {
 204                   /* Switch to the pad array.  */
 205                   sptr = NULL;
 206                   sdim = pdim;
 207                   for (dim = 0; dim < pdim; dim++)
 208                     {
 209                       scount[dim] = pcount[dim];
 210                       sextent[dim] = pextent[dim];
 211                       sstride[dim] = pstride[dim];
 212                       sstride0 = sstride[0];
 213                     }
 214                 }
 215               /* We now start again from the beginning of the pad array.  */
 216               src = pptr;
 217               break;
 218             }
 219           else
 220             {
 221               scount[n]++;
 222               src += sstride[n];
 223             }
 224         }
 225     }
 226 }
 227