libgfortran/intrinsics/reshape_generic.c

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