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