libgfortran/m4/reshape.m4

   1 `/* 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 Libgfortran 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 <assert.h>'
  29
  30 include(iparm.m4)dnl
  31
  32 `#if defined (HAVE_'rtype_name`)
  33
  34 typedef GFC_ARRAY_DESCRIPTOR(1, 'index_type`) 'shape_type`;'
  35
  36 dnl For integer routines, only the kind (ie size) is used to name the
  37 dnl function.  The same function will be used for integer and logical
  38 dnl arrays of the same kind.
  39
  40 `extern void reshape_'rtype_ccode` ('rtype` * const restrict,
  41         'rtype` * const restrict,
  42         'shape_type` * const restrict,
  43         'rtype` * const restrict,
  44         'shape_type` * const restrict);
  45 export_proto(reshape_'rtype_ccode`);
  46
  47 void
  48 reshape_'rtype_ccode` ('rtype` * const restrict ret,
  49         'rtype` * const restrict source,
  50         'shape_type` * const restrict shape,
  51         'rtype` * const restrict pad,
  52         'shape_type` * const restrict order)
  53 {
  54   /* r.* indicates the return array.  */
  55   index_type rcount[GFC_MAX_DIMENSIONS];
  56   index_type rextent[GFC_MAX_DIMENSIONS];
  57   index_type rstride[GFC_MAX_DIMENSIONS];
  58   index_type rstride0;
  59   index_type rdim;
  60   index_type rsize;
  61   index_type rs;
  62   index_type rex;
  63   'rtype_name` *rptr;
  64   /* s.* indicates the source array.  */
  65   index_type scount[GFC_MAX_DIMENSIONS];
  66   index_type sextent[GFC_MAX_DIMENSIONS];
  67   index_type sstride[GFC_MAX_DIMENSIONS];
  68   index_type sstride0;
  69   index_type sdim;
  70   index_type ssize;
  71   const 'rtype_name` *sptr;
  72   /* p.* indicates the pad array.  */
  73   index_type pcount[GFC_MAX_DIMENSIONS];
  74   index_type pextent[GFC_MAX_DIMENSIONS];
  75   index_type pstride[GFC_MAX_DIMENSIONS];
  76   index_type pdim;
  77   index_type psize;
  78   const 'rtype_name` *pptr;
  79
  80   const 'rtype_name` *src;
  81   int n;
  82   int dim;
  83   int sempty, pempty, shape_empty;
  84   index_type shape_data[GFC_MAX_DIMENSIONS];
  85
  86   rdim = GFC_DESCRIPTOR_EXTENT(shape,0);
  87   if (rdim != GFC_DESCRIPTOR_RANK(ret))
  88     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
  89
  90   shape_empty = 0;
  91
  92   for (n = 0; n < rdim; n++)
  93     {
  94       shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)];
  95       if (shape_data[n] <= 0)
  96       {
  97         shape_data[n] = 0;
  98         shape_empty = 1;
  99       }
 100     }
 101
 102   if (ret->data == NULL)
 103     {
 104       rs = 1;
 105       for (n = 0; n < rdim; n++)
 106         {
 107           rex = shape_data[n];
 108
 109           GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs);
 110
 111           rs *= rex;
 112         }
 113       ret->offset = 0;
 114       ret->data = internal_malloc_size ( rs * sizeof ('rtype_name`));
 115       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
 116     }
 117
 118   if (shape_empty)
 119     return;
 120
 121   if (pad)
 122     {
 123       pdim = GFC_DESCRIPTOR_RANK (pad);
 124       psize = 1;
 125       pempty = 0;
 126       for (n = 0; n < pdim; n++)
 127         {
 128           pcount[n] = 0;
 129           pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n);
 130           pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
 131           if (pextent[n] <= 0)
 132             {
 133               pempty = 1;
 134               pextent[n] = 0;
 135             }
 136
 137           if (psize == pstride[n])
 138             psize *= pextent[n];
 139           else
 140             psize = 0;
 141         }
 142       pptr = pad->data;
 143     }
 144   else
 145     {
 146       pdim = 0;
 147       psize = 1;
 148       pempty = 1;
 149       pptr = NULL;
 150     }
 151
 152   if (unlikely (compile_options.bounds_check))
 153     {
 154       index_type ret_extent, source_extent;
 155
 156       rs = 1;
 157       for (n = 0; n < rdim; n++)
 158         {
 159           rs *= shape_data[n];
 160           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 161           if (ret_extent != shape_data[n])
 162             runtime_error("Incorrect extent in return value of RESHAPE"
 163                           " intrinsic in dimension %ld: is %ld,"
 164                           " should be %ld", (long int) n+1,
 165                           (long int) ret_extent, (long int) shape_data[n]);
 166         }
 167
 168       source_extent = 1;
 169       sdim = GFC_DESCRIPTOR_RANK (source);
 170       for (n = 0; n < sdim; n++)
 171         {
 172           index_type se;
 173           se = GFC_DESCRIPTOR_EXTENT(source,n);
 174           source_extent *= se > 0 ? se : 0;
 175         }
 176
 177       if (rs > source_extent && (!pad || pempty))
 178         runtime_error("Incorrect size in SOURCE argument to RESHAPE"
 179                       " intrinsic: is %ld, should be %ld",
 180                       (long int) source_extent, (long int) rs);
 181
 182       if (order)
 183         {
 184           int seen[GFC_MAX_DIMENSIONS];
 185           index_type v;
 186
 187           for (n = 0; n < rdim; n++)
 188             seen[n] = 0;
 189
 190           for (n = 0; n < rdim; n++)
 191             {
 192               v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
 193
 194               if (v < 0 || v >= rdim)
 195                 runtime_error("Value %ld out of range in ORDER argument"
 196                               " to RESHAPE intrinsic", (long int) v + 1);
 197
 198               if (seen[v] != 0)
 199                 runtime_error("Duplicate value %ld in ORDER argument to"
 200                               " RESHAPE intrinsic", (long int) v + 1);
 201
 202               seen[v] = 1;
 203             }
 204         }
 205     }
 206
 207   rsize = 1;
 208   for (n = 0; n < rdim; n++)
 209     {
 210       if (order)
 211         dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
 212       else
 213         dim = n;
 214
 215       rcount[n] = 0;
 216       rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
 217       rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
 218       if (rextent[n] < 0)
 219         rextent[n] = 0;
 220
 221       if (rextent[n] != shape_data[dim])
 222         runtime_error ("shape and target do not conform");
 223
 224       if (rsize == rstride[n])
 225         rsize *= rextent[n];
 226       else
 227         rsize = 0;
 228       if (rextent[n] <= 0)
 229         return;
 230     }
 231
 232   sdim = GFC_DESCRIPTOR_RANK (source);
 233   ssize = 1;
 234   sempty = 0;
 235   for (n = 0; n < sdim; n++)
 236     {
 237       scount[n] = 0;
 238       sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
 239       sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
 240       if (sextent[n] <= 0)
 241         {
 242           sempty = 1;
 243           sextent[n] = 0;
 244         }
 245
 246       if (ssize == sstride[n])
 247         ssize *= sextent[n];
 248       else
 249         ssize = 0;
 250     }
 251
 252   if (rsize != 0 && ssize != 0 && psize != 0)
 253     {
 254       rsize *= sizeof ('rtype_name`);
 255       ssize *= sizeof ('rtype_name`);
 256       psize *= sizeof ('rtype_name`);
 257       reshape_packed ((char *)ret->data, rsize, (char *)source->data,
 258                       ssize, pad ? (char *)pad->data : NULL, psize);
 259       return;
 260     }
 261   rptr = ret->data;
 262   src = sptr = source->data;
 263   rstride0 = rstride[0];
 264   sstride0 = sstride[0];
 265
 266   if (sempty && pempty)
 267     abort ();
 268
 269   if (sempty)
 270     {
 271       /* Pretend we are using the pad array the first time around, too.  */
 272       src = pptr;
 273       sptr = pptr;
 274       sdim = pdim;
 275       for (dim = 0; dim < pdim; dim++)
 276         {
 277           scount[dim] = pcount[dim];
 278           sextent[dim] = pextent[dim];
 279           sstride[dim] = pstride[dim];
 280           sstride0 = pstride[0];
 281         }
 282     }
 283
 284   while (rptr)
 285     {
 286       /* Select between the source and pad arrays.  */
 287       *rptr = *src;
 288       /* Advance to the next element.  */
 289       rptr += rstride0;
 290       src += sstride0;
 291       rcount[0]++;
 292       scount[0]++;
 293
 294       /* Advance to the next destination element.  */
 295       n = 0;
 296       while (rcount[n] == rextent[n])
 297         {
 298           /* When we get to the end of a dimension, reset it and increment
 299              the next dimension.  */
 300           rcount[n] = 0;
 301           /* We could precalculate these products, but this is a less
 302              frequently used path so probably not worth it.  */
 303           rptr -= rstride[n] * rextent[n];
 304           n++;
 305           if (n == rdim)
 306             {
 307               /* Break out of the loop.  */
 308               rptr = NULL;
 309               break;
 310             }
 311           else
 312             {
 313               rcount[n]++;
 314               rptr += rstride[n];
 315             }
 316         }
 317       /* Advance to the next source element.  */
 318       n = 0;
 319       while (scount[n] == sextent[n])
 320         {
 321           /* When we get to the end of a dimension, reset it and increment
 322              the next dimension.  */
 323           scount[n] = 0;
 324           /* We could precalculate these products, but this is a less
 325              frequently used path so probably not worth it.  */
 326           src -= sstride[n] * sextent[n];
 327           n++;
 328           if (n == sdim)
 329             {
 330               if (sptr && pad)
 331                 {
 332                   /* Switch to the pad array.  */
 333                   sptr = NULL;
 334                   sdim = pdim;
 335                   for (dim = 0; dim < pdim; dim++)
 336                     {
 337                       scount[dim] = pcount[dim];
 338                       sextent[dim] = pextent[dim];
 339                       sstride[dim] = pstride[dim];
 340                       sstride0 = sstride[0];
 341                     }
 342                 }
 343               /* We now start again from the beginning of the pad array.  */
 344               src = pptr;
 345               break;
 346             }
 347           else
 348             {
 349               scount[n]++;
 350               src += sstride[n];
 351             }
 352         }
 353     }
 354 }
 355
 356 #endif'