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
  34 extern void reshape_`'rtype_kind (rtype *, rtype *, shape_type *,
  35                                     rtype *, shape_type *);
  36 export_proto(reshape_`'rtype_kind);
  37
  38 void
  39 reshape_`'rtype_kind (rtype * ret, rtype * source, shape_type * shape,
  40                       rtype * pad, shape_type * order)
  41 {
  42   /* r.* indicates the return array.  */
  43   index_type rcount[GFC_MAX_DIMENSIONS - 1];
  44   index_type rextent[GFC_MAX_DIMENSIONS - 1];
  45   index_type rstride[GFC_MAX_DIMENSIONS - 1];
  46   index_type rstride0;
  47   index_type rdim;
  48   index_type rsize;
  49   rtype_name *rptr;
  50   /* s.* indicates the source array.  */
  51   index_type scount[GFC_MAX_DIMENSIONS - 1];
  52   index_type sextent[GFC_MAX_DIMENSIONS - 1];
  53   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  54   index_type sstride0;
  55   index_type sdim;
  56   index_type ssize;
  57   const rtype_name *sptr;
  58   /* p.* indicates the pad array.  */
  59   index_type pcount[GFC_MAX_DIMENSIONS - 1];
  60   index_type pextent[GFC_MAX_DIMENSIONS - 1];
  61   index_type pstride[GFC_MAX_DIMENSIONS - 1];
  62   index_type pdim;
  63   index_type psize;
  64   const rtype_name *pptr;
  65
  66   const rtype_name *src;
  67   int n;
  68   int dim;
  69
  70   if (ret->dim[0].stride == 0)
  71     ret->dim[0].stride = 1;
  72   if (source->dim[0].stride == 0)
  73     source->dim[0].stride = 1;
  74   if (shape->dim[0].stride == 0)
  75     shape->dim[0].stride = 1;
  76   if (pad && pad->dim[0].stride == 0)
  77     pad->dim[0].stride = 1;
  78   if (order && order->dim[0].stride == 0)
  79     order->dim[0].stride = 1;
  80
  81   rdim = GFC_DESCRIPTOR_RANK (ret);
  82   rsize = 1;
  83   for (n = 0; n < rdim; n++)
  84     {
  85       if (order)
  86         dim = order->data[n * order->dim[0].stride] - 1;
  87       else
  88         dim = n;
  89
  90       rcount[n] = 0;
  91       rstride[n] = ret->dim[dim].stride;
  92       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
  93
  94       if (rextent[n] != shape->data[dim * shape->dim[0].stride])
  95         runtime_error ("shape and target do not conform");
  96
  97       if (rsize == rstride[n])
  98         rsize *= rextent[n];
  99       else
 100         rsize = 0;
 101       if (rextent[dim] <= 0)
 102         return;
 103     }
 104
 105   sdim = GFC_DESCRIPTOR_RANK (source);
 106   ssize = 1;
 107   for (n = 0; n < sdim; n++)
 108     {
 109       scount[n] = 0;
 110       sstride[n] = source->dim[n].stride;
 111       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 112       if (sextent[n] <= 0)
 113         abort ();
 114
 115       if (ssize == sstride[n])
 116         ssize *= sextent[n];
 117       else
 118         ssize = 0;
 119     }
 120
 121   if (pad)
 122     {
 123       if (pad->dim[0].stride == 0)
 124         pad->dim[0].stride = 1;
 125       pdim = GFC_DESCRIPTOR_RANK (pad);
 126       psize = 1;
 127       for (n = 0; n < pdim; n++)
 128         {
 129           pcount[n] = 0;
 130           pstride[n] = pad->dim[n].stride;
 131           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 132           if (pextent[n] <= 0)
 133             abort ();
 134           if (psize == pstride[n])
 135             psize *= pextent[n];
 136           else
 137             psize = 0;
 138         }
 139       pptr = pad->data;
 140     }
 141   else
 142     {
 143       pdim = 0;
 144       psize = 1;
 145       pptr = NULL;
 146     }
 147
 148   if (rsize != 0 && ssize != 0 && psize != 0)
 149     {
 150       rsize *= rtype_kind;
 151       ssize *= rtype_kind;
 152       psize *= rtype_kind;
 153       reshape_packed ((char *)ret->data, rsize, (char *)source->data,
 154                       ssize, pad ? (char *)pad->data : NULL, psize);
 155       return;
 156     }
 157   rptr = ret->data;
 158   src = sptr = source->data;
 159   rstride0 = rstride[0];
 160   sstride0 = sstride[0];
 161
 162   while (rptr)
 163     {
 164       /* Select between the source and pad arrays.  */
 165       *rptr = *src;
 166       /* Advance to the next element.  */
 167       rptr += rstride0;
 168       src += sstride0;
 169       rcount[0]++;
 170       scount[0]++;
 171       /* Advance to the next destination element.  */
 172       n = 0;
 173       while (rcount[n] == rextent[n])
 174         {
 175           /* When we get to the end of a dimension, reset it and increment
 176              the next dimension.  */
 177           rcount[n] = 0;
 178           /* We could precalculate these products, but this is a less
 179              frequently used path so proabably not worth it.  */
 180           rptr -= rstride[n] * rextent[n];
 181           n++;
 182           if (n == rdim)
 183             {
 184               /* Break out of the loop.  */
 185               rptr = NULL;
 186               break;
 187             }
 188           else
 189             {
 190               rcount[n]++;
 191               rptr += rstride[n];
 192             }
 193         }
 194       /* Advance to the next source element.  */
 195       n = 0;
 196       while (scount[n] == sextent[n])
 197         {
 198           /* When we get to the end of a dimension, reset it and increment
 199              the next dimension.  */
 200           scount[n] = 0;
 201           /* We could precalculate these products, but this is a less
 202              frequently used path so proabably not worth it.  */
 203           src -= sstride[n] * sextent[n];
 204           n++;
 205           if (n == sdim)
 206             {
 207               if (sptr && pad)
 208                 {
 209                   /* Switch to the pad array.  */
 210                   sptr = NULL;
 211                   sdim = pdim;
 212                   for (dim = 0; dim < pdim; dim++)
 213                     {
 214                       scount[dim] = pcount[dim];
 215                       sextent[dim] = pextent[dim];
 216                       sstride[dim] = pstride[dim];
 217                       sstride0 = sstride[0];
 218                     }
 219                 }
 220               /* We now start again from the beginning of the pad array.  */
 221               src = pptr;
 222               break;
 223             }
 224           else
 225             {
 226               scount[n]++;
 227               src += sstride[n];
 228             }
 229         }
 230     }
 231 }