libgfortran/intrinsics/reshape_generic.c

   1 /* Generic implementation of the RESHAPE intrinsic
   2    Copyright 2002, 2006 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., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, 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 /* The shape parameter is ignored. We can currently deduce the shape from the
  41    return array.  */
  42
  43 static void
  44 reshape_internal (parray *ret, parray *source, shape_type *shape,
  45                   parray *pad, shape_type *order, index_type size)
  46 {
  47   /* r.* indicates the return array.  */
  48   index_type rcount[GFC_MAX_DIMENSIONS];
  49   index_type rextent[GFC_MAX_DIMENSIONS];
  50   index_type rstride[GFC_MAX_DIMENSIONS];
  51   index_type rstride0;
  52   index_type rdim;
  53   index_type rsize;
  54   index_type rs;
  55   index_type rex;
  56   char *rptr;
  57   /* s.* indicates the source array.  */
  58   index_type scount[GFC_MAX_DIMENSIONS];
  59   index_type sextent[GFC_MAX_DIMENSIONS];
  60   index_type sstride[GFC_MAX_DIMENSIONS];
  61   index_type sstride0;
  62   index_type sdim;
  63   index_type ssize;
  64   const char *sptr;
  65   /* p.* indicates the pad array.  */
  66   index_type pcount[GFC_MAX_DIMENSIONS];
  67   index_type pextent[GFC_MAX_DIMENSIONS];
  68   index_type pstride[GFC_MAX_DIMENSIONS];
  69   index_type pdim;
  70   index_type psize;
  71   const char *pptr;
  72
  73   const char *src;
  74   int n;
  75   int dim;
  76
  77   if (ret->data == NULL)
  78     {
  79       rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  80       rs = 1;
  81       for (n=0; n < rdim; n++)
  82         {
  83           ret->dim[n].lbound = 0;
  84           rex = shape->data[n * shape->dim[0].stride];
  85           ret->dim[n].ubound =  rex - 1;
  86           ret->dim[n].stride = rs;
  87           rs *= rex;
  88         }
  89       ret->offset = 0;
  90       ret->data = internal_malloc_size ( rs * size );
  91       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
  92     }
  93   else
  94     {
  95       rdim = GFC_DESCRIPTOR_RANK (ret);
  96     }
  97
  98   rsize = 1;
  99   for (n = 0; n < rdim; n++)
 100     {
 101       if (order)
 102         dim = order->data[n * order->dim[0].stride] - 1;
 103       else
 104         dim = n;
 105
 106       rcount[n] = 0;
 107       rstride[n] = ret->dim[dim].stride;
 108       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
 109
 110       if (rextent[n] != shape->data[dim * shape->dim[0].stride])
 111         runtime_error ("shape and target do not conform");
 112
 113       if (rsize == rstride[n])
 114         rsize *= rextent[n];
 115       else
 116         rsize = 0;
 117       if (rextent[n] <= 0)
 118         return;
 119     }
 120
 121   sdim = GFC_DESCRIPTOR_RANK (source);
 122   ssize = 1;
 123   for (n = 0; n < sdim; n++)
 124     {
 125       scount[n] = 0;
 126       sstride[n] = source->dim[n].stride;
 127       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 128       if (sextent[n] <= 0)
 129         abort ();
 130
 131       if (ssize == sstride[n])
 132         ssize *= sextent[n];
 133       else
 134         ssize = 0;
 135     }
 136
 137   if (pad)
 138     {
 139       pdim = GFC_DESCRIPTOR_RANK (pad);
 140       psize = 1;
 141       for (n = 0; n < pdim; n++)
 142         {
 143           pcount[n] = 0;
 144           pstride[n] = pad->dim[n].stride;
 145           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 146           if (pextent[n] <= 0)
 147             abort ();
 148           if (psize == pstride[n])
 149             psize *= pextent[n];
 150           else
 151             psize = 0;
 152         }
 153       pptr = pad->data;
 154     }
 155   else
 156     {
 157       pdim = 0;
 158       psize = 1;
 159       pptr = NULL;
 160     }
 161
 162   if (rsize != 0 && ssize != 0 && psize != 0)
 163     {
 164       rsize *= size;
 165       ssize *= size;
 166       psize *= size;
 167       reshape_packed (ret->data, rsize, source->data, ssize,
 168                       pad ? pad->data : NULL, psize);
 169       return;
 170     }
 171   rptr = ret->data;
 172   src = sptr = source->data;
 173   rstride0 = rstride[0] * size;
 174   sstride0 = sstride[0] * size;
 175
 176   while (rptr)
 177     {
 178       /* Select between the source and pad arrays.  */
 179       memcpy(rptr, src, size);
 180       /* Advance to the next element.  */
 181       rptr += rstride0;
 182       src += sstride0;
 183       rcount[0]++;
 184       scount[0]++;
 185       /* Advance to the next destination element.  */
 186       n = 0;
 187       while (rcount[n] == rextent[n])
 188         {
 189           /* When we get to the end of a dimension, reset it and increment
 190              the next dimension.  */
 191           rcount[n] = 0;
 192           /* We could precalculate these products, but this is a less
 193              frequently used path so probably not worth it.  */
 194           rptr -= rstride[n] * rextent[n] * size;
 195           n++;
 196           if (n == rdim)
 197             {
 198               /* Break out of the loop.  */
 199               rptr = NULL;
 200               break;
 201             }
 202           else
 203             {
 204               rcount[n]++;
 205               rptr += rstride[n] * size;
 206             }
 207         }
 208       /* Advance to the next source element.  */
 209       n = 0;
 210       while (scount[n] == sextent[n])
 211         {
 212           /* When we get to the end of a dimension, reset it and increment
 213              the next dimension.  */
 214           scount[n] = 0;
 215           /* We could precalculate these products, but this is a less
 216              frequently used path so probably not worth it.  */
 217           src -= sstride[n] * sextent[n] * size;
 218           n++;
 219           if (n == sdim)
 220             {
 221               if (sptr && pad)
 222                 {
 223                   /* Switch to the pad array.  */
 224                   sptr = NULL;
 225                   sdim = pdim;
 226                   for (dim = 0; dim < pdim; dim++)
 227                     {
 228                       scount[dim] = pcount[dim];
 229                       sextent[dim] = pextent[dim];
 230                       sstride[dim] = pstride[dim];
 231                       sstride0 = sstride[0] * size;
 232                     }
 233                 }
 234               /* We now start again from the beginning of the pad array.  */
 235               src = pptr;
 236               break;
 237             }
 238           else
 239             {
 240               scount[n]++;
 241               sptr += sstride[n] * size;
 242             }
 243         }
 244     }
 245 }
 246
 247 extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
 248 export_proto(reshape);
 249
 250 void
 251 reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
 252          shape_type *order)
 253 {
 254   reshape_internal (ret, source, shape, pad, order,
 255                     GFC_DESCRIPTOR_SIZE (source));
 256 }
 257
 258 extern void reshape_char (parray *, GFC_INTEGER_4, parray *, shape_type *,
 259                           parray *, shape_type *, GFC_INTEGER_4,
 260                           GFC_INTEGER_4);
 261 export_proto(reshape_char);
 262
 263 void
 264 reshape_char (parray *ret, GFC_INTEGER_4 ret_length __attribute__((unused)),
 265               parray *source, shape_type *shape, parray *pad,
 266               shape_type *order, GFC_INTEGER_4 source_length,
 267               GFC_INTEGER_4 pad_length __attribute__((unused)))
 268 {
 269   reshape_internal (ret, source, shape, pad, order, source_length);
 270 }