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