libgfortran/m4/reshape.m4

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