libgfortran/intrinsics/reshape_generic.c

   1 /* Generic implementation of the RESHAPE intrinsic
   2    Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version.
  11
  12 Ligbfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <string.h>
  29 #include <assert.h>
  30
  31 typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
  32 typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
  33
  34 static void
  35 reshape_internal (parray *ret, parray *source, shape_type *shape,
  36                   parray *pad, shape_type *order, index_type size)
  37 {
  38   /* r.* indicates the return array.  */
  39   index_type rcount[GFC_MAX_DIMENSIONS];
  40   index_type rextent[GFC_MAX_DIMENSIONS];
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type rdim;
  44   index_type rsize;
  45   index_type rs;
  46   index_type rex;
  47   char * restrict rptr;
  48   /* s.* indicates the source array.  */
  49   index_type scount[GFC_MAX_DIMENSIONS];
  50   index_type sextent[GFC_MAX_DIMENSIONS];
  51   index_type sstride[GFC_MAX_DIMENSIONS];
  52   index_type sstride0;
  53   index_type sdim;
  54   index_type ssize;
  55   const char *sptr;
  56   /* p.* indicates the pad array.  */
  57   index_type pcount[GFC_MAX_DIMENSIONS];
  58   index_type pextent[GFC_MAX_DIMENSIONS];
  59   index_type pstride[GFC_MAX_DIMENSIONS];
  60   index_type pdim;
  61   index_type psize;
  62   const char *pptr;
  63
  64   const char *src;
  65   int n;
  66   int dim;
  67   int sempty, pempty, shape_empty;
  68   index_type shape_data[GFC_MAX_DIMENSIONS];
  69
  70   rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  71   if (rdim != GFC_DESCRIPTOR_RANK(ret))
  72     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
  73
  74   shape_empty = 0;
  75
  76   for (n = 0; n < rdim; n++)
  77     {
  78       shape_data[n] = shape->data[n * shape->dim[0].stride];
  79       if (shape_data[n] <= 0)
  80         {
  81           shape_data[n] = 0;
  82           shape_empty = 1;
  83         }
  84     }
  85
  86   if (ret->data == NULL)
  87     {
  88       rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  89       rs = 1;
  90       for (n = 0; n < rdim; n++)
  91         {
  92           ret->dim[n].lbound = 0;
  93           rex = shape_data[n];
  94           ret->dim[n].ubound =  rex - 1;
  95           ret->dim[n].stride = rs;
  96           rs *= rex;
  97         }
  98       ret->offset = 0;
  99       ret->data = internal_malloc_size ( rs * size );
 100       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
 101     }
 102
 103   if (shape_empty)
 104     return;
 105
 106   if (pad)
 107     {
 108       pdim = GFC_DESCRIPTOR_RANK (pad);
 109       psize = 1;
 110       pempty = 0;
 111       for (n = 0; n < pdim; n++)
 112         {
 113           pcount[n] = 0;
 114           pstride[n] = pad->dim[n].stride;
 115           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 116           if (pextent[n] <= 0)
 117             {
 118               pempty = 1;
 119               pextent[n] = 0;
 120             }
 121
 122           if (psize == pstride[n])
 123             psize *= pextent[n];
 124           else
 125             psize = 0;
 126         }
 127       pptr = pad->data;
 128     }
 129   else
 130     {
 131       pdim = 0;
 132       psize = 1;
 133       pempty = 1;
 134       pptr = NULL;
 135     }
 136
 137   if (unlikely (compile_options.bounds_check))
 138     {
 139       index_type ret_extent, source_extent;
 140
 141       rs = 1;
 142       for (n = 0; n < rdim; n++)
 143         {
 144           rs *= shape_data[n];
 145           ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 146           if (ret_extent != shape_data[n])
 147             runtime_error("Incorrect extent in return value of RESHAPE"
 148                           " intrinsic in dimension %ld: is %ld,"
 149                           " should be %ld", (long int) n+1,
 150                           (long int) ret_extent, (long int) shape_data[n]);
 151         }
 152
 153       source_extent = 1;
 154       sdim = GFC_DESCRIPTOR_RANK (source);
 155       for (n = 0; n < sdim; n++)
 156         {
 157           index_type se;
 158           se = source->dim[n].ubound + 1 - source->dim[0].lbound;
 159           source_extent *= se > 0 ? se : 0;
 160         }
 161
 162       if (rs > source_extent && (!pad || pempty))
 163         runtime_error("Incorrect size in SOURCE argument to RESHAPE"
 164                       " intrinsic: is %ld, should be %ld",
 165                       (long int) source_extent, (long int) rs);
 166
 167       if (order)
 168         {
 169           int seen[GFC_MAX_DIMENSIONS];
 170           index_type v;
 171
 172           for (n = 0; n < rdim; n++)
 173             seen[n] = 0;
 174
 175           for (n = 0; n < rdim; n++)
 176             {
 177               v = order->data[n * order->dim[0].stride] - 1;
 178
 179               if (v < 0 || v >= rdim)
 180                 runtime_error("Value %ld out of range in ORDER argument"
 181                               " to RESHAPE intrinsic", (long int) v + 1);
 182
 183               if (seen[v] != 0)
 184                 runtime_error("Duplicate value %ld in ORDER argument to"
 185                               " RESHAPE intrinsic", (long int) v + 1);
 186
 187               seen[v] = 1;
 188             }
 189         }
 190     }
 191
 192   rsize = 1;
 193   for (n = 0; n < rdim; n++)
 194     {
 195       if (order)
 196         dim = order->data[n * order->dim[0].stride] - 1;
 197       else
 198         dim = n;
 199
 200       rcount[n] = 0;
 201       rstride[n] = ret->dim[dim].stride;
 202       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
 203
 204       if (rextent[n] != shape_data[dim])
 205         runtime_error ("shape and target do not conform");
 206
 207       if (rsize == rstride[n])
 208         rsize *= rextent[n];
 209       else
 210         rsize = 0;
 211       if (rextent[n] <= 0)
 212         return;
 213     }
 214
 215   sdim = GFC_DESCRIPTOR_RANK (source);
 216   ssize = 1;
 217   sempty = 0;
 218   for (n = 0; n < sdim; n++)
 219     {
 220       scount[n] = 0;
 221       sstride[n] = source->dim[n].stride;
 222       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 223       if (sextent[n] <= 0)
 224         {
 225           sempty = 1;
 226           sextent[n] = 0;
 227         }
 228
 229       if (ssize == sstride[n])
 230         ssize *= sextent[n];
 231       else
 232         ssize = 0;
 233     }
 234
 235   if (rsize != 0 && ssize != 0 && psize != 0)
 236     {
 237       rsize *= size;
 238       ssize *= size;
 239       psize *= size;
 240       reshape_packed (ret->data, rsize, source->data, ssize,
 241                       pad ? pad->data : NULL, psize);
 242       return;
 243     }
 244   rptr = ret->data;
 245   src = sptr = source->data;
 246   rstride0 = rstride[0] * size;
 247   sstride0 = sstride[0] * size;
 248
 249   if (sempty && pempty)
 250     abort ();
 251
 252   if (sempty)
 253     {
 254       /* Pretend we are using the pad array the first time around, too.  */
 255       src = pptr;
 256       sptr = pptr;
 257       sdim = pdim;
 258       for (dim = 0; dim < pdim; dim++)
 259         {
 260           scount[dim] = pcount[dim];
 261           sextent[dim] = pextent[dim];
 262           sstride[dim] = pstride[dim];
 263           sstride0 = pstride[0] * size;
 264         }
 265     }
 266
 267   while (rptr)
 268     {
 269       /* Select between the source and pad arrays.  */
 270       memcpy(rptr, src, size);
 271       /* Advance to the next element.  */
 272       rptr += rstride0;
 273       src += sstride0;
 274       rcount[0]++;
 275       scount[0]++;
 276
 277       /* Advance to the next destination element.  */
 278       n = 0;
 279       while (rcount[n] == rextent[n])
 280         {
 281           /* When we get to the end of a dimension, reset it and increment
 282              the next dimension.  */
 283           rcount[n] = 0;
 284           /* We could precalculate these products, but this is a less
 285              frequently used path so probably not worth it.  */
 286           rptr -= rstride[n] * rextent[n] * size;
 287           n++;
 288           if (n == rdim)
 289             {
 290               /* Break out of the loop.  */
 291               rptr = NULL;
 292               break;
 293             }
 294           else
 295             {
 296               rcount[n]++;
 297               rptr += rstride[n] * size;
 298             }
 299         }
 300
 301       /* Advance to the next source element.  */
 302       n = 0;
 303       while (scount[n] == sextent[n])
 304         {
 305           /* When we get to the end of a dimension, reset it and increment
 306              the next dimension.  */
 307           scount[n] = 0;
 308           /* We could precalculate these products, but this is a less
 309              frequently used path so probably not worth it.  */
 310           src -= sstride[n] * sextent[n] * size;
 311           n++;
 312           if (n == sdim)
 313             {
 314               if (sptr && pad)
 315                 {
 316                   /* Switch to the pad array.  */
 317                   sptr = NULL;
 318                   sdim = pdim;
 319                   for (dim = 0; dim < pdim; dim++)
 320                     {
 321                       scount[dim] = pcount[dim];
 322                       sextent[dim] = pextent[dim];
 323                       sstride[dim] = pstride[dim];
 324                       sstride0 = sstride[0] * size;
 325                     }
 326                 }
 327               /* We now start again from the beginning of the pad array.  */
 328               src = pptr;
 329               break;
 330             }
 331           else
 332             {
 333               scount[n]++;
 334               src += sstride[n] * size;
 335             }
 336         }
 337     }
 338 }
 339
 340 extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
 341 export_proto(reshape);
 342
 343 void
 344 reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
 345          shape_type *order)
 346 {
 347   reshape_internal (ret, source, shape, pad, order,
 348                     GFC_DESCRIPTOR_SIZE (source));
 349 }
 350
 351
 352 extern void reshape_char (parray *, gfc_charlen_type, parray *, shape_type *,
 353                           parray *, shape_type *, gfc_charlen_type,
 354                           gfc_charlen_type);
 355 export_proto(reshape_char);
 356
 357 void
 358 reshape_char (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
 359               parray *source, shape_type *shape, parray *pad,
 360               shape_type *order, gfc_charlen_type source_length,
 361               gfc_charlen_type pad_length __attribute__((unused)))
 362 {
 363   reshape_internal (ret, source, shape, pad, order, source_length);
 364 }
 365
 366
 367 extern void reshape_char4 (parray *, gfc_charlen_type, parray *, shape_type *,
 368                            parray *, shape_type *, gfc_charlen_type,
 369                            gfc_charlen_type);
 370 export_proto(reshape_char4);
 371
 372 void
 373 reshape_char4 (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
 374                parray *source, shape_type *shape, parray *pad,
 375                shape_type *order, gfc_charlen_type source_length,
 376                gfc_charlen_type pad_length __attribute__((unused)))
 377 {
 378   reshape_internal (ret, source, shape, pad, order,
 379                     source_length * sizeof (gfc_char4_t));
 380 }