libgfortran/m4/reshape.m4

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