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