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 * restrict 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, shape_empty;
  73   index_type shape_data[GFC_MAX_DIMENSIONS];
  74
  75   rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  76   if (rdim != GFC_DESCRIPTOR_RANK(ret))
  77     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
  78
  79   shape_empty = 0;
  80
  81   for (n = 0; n < rdim; n++)
  82     {
  83       shape_data[n] = shape->data[n * shape->dim[0].stride];
  84       if (shape_data[n] <= 0)
  85         {
  86           shape_data[n] = 0;
  87           shape_empty = 1;
  88         }
  89     }
  90
  91   if (ret->data == NULL)
  92     {
  93       rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  94       rs = 1;
  95       for (n = 0; n < rdim; n++)
  96         {
  97           ret->dim[n].lbound = 0;
  98           rex = shape_data[n];
  99           ret->dim[n].ubound =  rex - 1;
 100           ret->dim[n].stride = rs;
 101           rs *= rex;
 102         }
 103       ret->offset = 0;
 104       ret->data = internal_malloc_size ( rs * size );
 105       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
 106     }
 107
 108   if (shape_empty)
 109     return;
 110
 111   if (unlikely (compile_options.bounds_check))
 112     {
 113       if (order)
 114         {
 115           int seen[GFC_MAX_DIMENSIONS];
 116           index_type v;
 117
 118           for (n = 0; n < rdim; n++)
 119             seen[n] = 0;
 120
 121           for (n = 0; n < rdim; n++)
 122             {
 123               v = order->data[n * order->dim[0].stride] - 1;
 124
 125               if (v < 0 || v >= rdim)
 126                 runtime_error("Value %ld out of range in ORDER argument"
 127                               " to RESHAPE intrinsic", (long int) v + 1);
 128
 129               if (seen[v] != 0)
 130                 runtime_error("Duplicate value %ld in ORDER argument to"
 131                               " RESHAPE intrinsic", (long int) v + 1);
 132
 133               seen[v] = 1;
 134             }
 135         }
 136     }
 137
 138   rsize = 1;
 139   for (n = 0; n < rdim; n++)
 140     {
 141       if (order)
 142         dim = order->data[n * order->dim[0].stride] - 1;
 143       else
 144         dim = n;
 145
 146       rcount[n] = 0;
 147       rstride[n] = ret->dim[dim].stride;
 148       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
 149
 150       if (rextent[n] != shape_data[dim])
 151         runtime_error ("shape and target do not conform");
 152
 153       if (rsize == rstride[n])
 154         rsize *= rextent[n];
 155       else
 156         rsize = 0;
 157       if (rextent[n] <= 0)
 158         return;
 159     }
 160
 161   sdim = GFC_DESCRIPTOR_RANK (source);
 162   ssize = 1;
 163   sempty = 0;
 164   for (n = 0; n < sdim; n++)
 165     {
 166       scount[n] = 0;
 167       sstride[n] = source->dim[n].stride;
 168       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 169       if (sextent[n] <= 0)
 170         {
 171           sempty = 1;
 172           sextent[n] = 0;
 173         }
 174
 175       if (ssize == sstride[n])
 176         ssize *= sextent[n];
 177       else
 178         ssize = 0;
 179     }
 180
 181   if (pad)
 182     {
 183       pdim = GFC_DESCRIPTOR_RANK (pad);
 184       psize = 1;
 185       pempty = 0;
 186       for (n = 0; n < pdim; n++)
 187         {
 188           pcount[n] = 0;
 189           pstride[n] = pad->dim[n].stride;
 190           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 191           if (pextent[n] <= 0)
 192             {
 193               pempty = 1;
 194               pextent[n] = 0;
 195             }
 196
 197           if (psize == pstride[n])
 198             psize *= pextent[n];
 199           else
 200             psize = 0;
 201         }
 202       pptr = pad->data;
 203     }
 204   else
 205     {
 206       pdim = 0;
 207       psize = 1;
 208       pempty = 1;
 209       pptr = NULL;
 210     }
 211
 212   if (rsize != 0 && ssize != 0 && psize != 0)
 213     {
 214       rsize *= size;
 215       ssize *= size;
 216       psize *= size;
 217       reshape_packed (ret->data, rsize, source->data, ssize,
 218                       pad ? pad->data : NULL, psize);
 219       return;
 220     }
 221   rptr = ret->data;
 222   src = sptr = source->data;
 223   rstride0 = rstride[0] * size;
 224   sstride0 = sstride[0] * size;
 225
 226   if (sempty && pempty)
 227     abort ();
 228
 229   if (sempty)
 230     {
 231       /* Switch immediately to the pad array.  */
 232       src = pptr;
 233       sptr = NULL;
 234       sdim = pdim;
 235       for (dim = 0; dim < pdim; dim++)
 236         {
 237           scount[dim] = pcount[dim];
 238           sextent[dim] = pextent[dim];
 239           sstride[dim] = pstride[dim];
 240           sstride0 = sstride[0] * size;
 241         }
 242     }
 243
 244   while (rptr)
 245     {
 246       /* Select between the source and pad arrays.  */
 247       memcpy(rptr, src, size);
 248       /* Advance to the next element.  */
 249       rptr += rstride0;
 250       src += sstride0;
 251       rcount[0]++;
 252       scount[0]++;
 253
 254       /* Advance to the next destination element.  */
 255       n = 0;
 256       while (rcount[n] == rextent[n])
 257         {
 258           /* When we get to the end of a dimension, reset it and increment
 259              the next dimension.  */
 260           rcount[n] = 0;
 261           /* We could precalculate these products, but this is a less
 262              frequently used path so probably not worth it.  */
 263           rptr -= rstride[n] * rextent[n] * size;
 264           n++;
 265           if (n == rdim)
 266             {
 267               /* Break out of the loop.  */
 268               rptr = NULL;
 269               break;
 270             }
 271           else
 272             {
 273               rcount[n]++;
 274               rptr += rstride[n] * size;
 275             }
 276         }
 277
 278       /* Advance to the next source element.  */
 279       n = 0;
 280       while (scount[n] == sextent[n])
 281         {
 282           /* When we get to the end of a dimension, reset it and increment
 283              the next dimension.  */
 284           scount[n] = 0;
 285           /* We could precalculate these products, but this is a less
 286              frequently used path so probably not worth it.  */
 287           src -= sstride[n] * sextent[n] * size;
 288           n++;
 289           if (n == sdim)
 290             {
 291               if (sptr && pad)
 292                 {
 293                   /* Switch to the pad array.  */
 294                   sptr = NULL;
 295                   sdim = pdim;
 296                   for (dim = 0; dim < pdim; dim++)
 297                     {
 298                       scount[dim] = pcount[dim];
 299                       sextent[dim] = pextent[dim];
 300                       sstride[dim] = pstride[dim];
 301                       sstride0 = sstride[0] * size;
 302                     }
 303                 }
 304               /* We now start again from the beginning of the pad array.  */
 305               src = pptr;
 306               break;
 307             }
 308           else
 309             {
 310               scount[n]++;
 311               src += sstride[n] * size;
 312             }
 313         }
 314     }
 315 }
 316
 317 extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
 318 export_proto(reshape);
 319
 320 void
 321 reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
 322          shape_type *order)
 323 {
 324   reshape_internal (ret, source, shape, pad, order,
 325                     GFC_DESCRIPTOR_SIZE (source));
 326 }
 327
 328
 329 extern void reshape_char (parray *, gfc_charlen_type, parray *, shape_type *,
 330                           parray *, shape_type *, gfc_charlen_type,
 331                           gfc_charlen_type);
 332 export_proto(reshape_char);
 333
 334 void
 335 reshape_char (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
 336               parray *source, shape_type *shape, parray *pad,
 337               shape_type *order, gfc_charlen_type source_length,
 338               gfc_charlen_type pad_length __attribute__((unused)))
 339 {
 340   reshape_internal (ret, source, shape, pad, order, source_length);
 341 }
 342
 343
 344 extern void reshape_char4 (parray *, gfc_charlen_type, parray *, shape_type *,
 345                            parray *, shape_type *, gfc_charlen_type,
 346                            gfc_charlen_type);
 347 export_proto(reshape_char4);
 348
 349 void
 350 reshape_char4 (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
 351                parray *source, shape_type *shape, parray *pad,
 352                shape_type *order, gfc_charlen_type source_length,
 353                gfc_charlen_type pad_length __attribute__((unused)))
 354 {
 355   reshape_internal (ret, source, shape, pad, order,
 356                     source_length * sizeof (gfc_char4_t));
 357 }