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