libgfortran/m4/spread.m4

   1 `/* Special implementation of the SPREAD intrinsic
   2    Copyright (C) 2008-2017 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
   4    spread_generic.c written by Paul Brook <paul@nowt.org>
   5
   6 This file is part of the GNU Fortran runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Ligbfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <string.h>'
  29
  30 include(iparm.m4)dnl
  31
  32 `#if defined (HAVE_'rtype_name`)
  33
  34 void
  35 spread_'rtype_code` ('rtype` *ret, const 'rtype` *source,
  36                  const index_type along, const index_type pncopies)
  37 {
  38   /* r.* indicates the return array.  */
  39   index_type rstride[GFC_MAX_DIMENSIONS];
  40   index_type rstride0;
  41   index_type rdelta = 0;
  42   index_type rrank;
  43   index_type rs;
  44   'rtype_name` *rptr;
  45   'rtype_name` * restrict dest;
  46   /* s.* indicates the source array.  */
  47   index_type sstride[GFC_MAX_DIMENSIONS];
  48   index_type sstride0;
  49   index_type srank;
  50   const 'rtype_name` *sptr;
  51
  52   index_type count[GFC_MAX_DIMENSIONS];
  53   index_type extent[GFC_MAX_DIMENSIONS];
  54   index_type n;
  55   index_type dim;
  56   index_type ncopies;
  57
  58   srank = GFC_DESCRIPTOR_RANK(source);
  59
  60   rrank = srank + 1;
  61   if (rrank > GFC_MAX_DIMENSIONS)
  62     runtime_error ("return rank too large in spread()");
  63
  64   if (along > rrank)
  65       runtime_error ("dim outside of rank in spread()");
  66
  67   ncopies = pncopies;
  68
  69   if (ret->base_addr == NULL)
  70     {
  71
  72       size_t ub, stride;
  73
  74       /* The front end has signalled that we need to populate the
  75          return array descriptor.  */
  76       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
  77       dim = 0;
  78       rs = 1;
  79       for (n = 0; n < rrank; n++)
  80         {
  81           stride = rs;
  82           if (n == along - 1)
  83             {
  84               ub = ncopies - 1;
  85               rdelta = rs;
  86               rs *= ncopies;
  87             }
  88           else
  89             {
  90               count[dim] = 0;
  91               extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
  92               sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
  93               rstride[dim] = rs;
  94
  95               ub = extent[dim] - 1;
  96               rs *= extent[dim];
  97               dim++;
  98             }
  99           GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
 100         }
 101       ret->offset = 0;
 102
 103       /* xmallocarray allocates a single byte for zero size.  */
 104       ret->base_addr = xmallocarray (rs, sizeof('rtype_name`));
 105       if (rs <= 0)
 106         return;
 107     }
 108   else
 109     {
 110       int zero_sized;
 111
 112       zero_sized = 0;
 113
 114       dim = 0;
 115       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 116         runtime_error ("rank mismatch in spread()");
 117
 118       if (unlikely (compile_options.bounds_check))
 119         {
 120           for (n = 0; n < rrank; n++)
 121             {
 122               index_type ret_extent;
 123
 124               ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 125               if (n == along - 1)
 126                 {
 127                   rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
 128
 129                   if (ret_extent != ncopies)
 130                     runtime_error("Incorrect extent in return value of SPREAD"
 131                                   " intrinsic in dimension %ld: is %ld,"
 132                                   " should be %ld", (long int) n+1,
 133                                   (long int) ret_extent, (long int) ncopies);
 134                 }
 135               else
 136                 {
 137                   count[dim] = 0;
 138                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 139                   if (ret_extent != extent[dim])
 140                     runtime_error("Incorrect extent in return value of SPREAD"
 141                                   " intrinsic in dimension %ld: is %ld,"
 142                                   " should be %ld", (long int) n+1,
 143                                   (long int) ret_extent,
 144                                   (long int) extent[dim]);
 145
 146                   if (extent[dim] <= 0)
 147                     zero_sized = 1;
 148                   sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
 149                   rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
 150                   dim++;
 151                 }
 152             }
 153         }
 154       else
 155         {
 156           for (n = 0; n < rrank; n++)
 157             {
 158               if (n == along - 1)
 159                 {
 160                   rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
 161                 }
 162               else
 163                 {
 164                   count[dim] = 0;
 165                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 166                   if (extent[dim] <= 0)
 167                     zero_sized = 1;
 168                   sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
 169                   rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
 170                   dim++;
 171                 }
 172             }
 173         }
 174
 175       if (zero_sized)
 176         return;
 177
 178       if (sstride[0] == 0)
 179         sstride[0] = 1;
 180     }
 181   sstride0 = sstride[0];
 182   rstride0 = rstride[0];
 183   rptr = ret->base_addr;
 184   sptr = source->base_addr;
 185
 186   while (sptr)
 187     {
 188       /* Spread this element.  */
 189       dest = rptr;
 190       for (n = 0; n < ncopies; n++)
 191         {
 192           *dest = *sptr;
 193           dest += rdelta;
 194         }
 195       /* Advance to the next element.  */
 196       sptr += sstride0;
 197       rptr += rstride0;
 198       count[0]++;
 199       n = 0;
 200       while (count[n] == extent[n])
 201         {
 202           /* When we get to the end of a dimension, reset it and increment
 203              the next dimension.  */
 204           count[n] = 0;
 205           /* We could precalculate these products, but this is a less
 206              frequently used path so probably not worth it.  */
 207           sptr -= sstride[n] * extent[n];
 208           rptr -= rstride[n] * extent[n];
 209           n++;
 210           if (n >= srank)
 211             {
 212               /* Break out of the loop.  */
 213               sptr = NULL;
 214               break;
 215             }
 216           else
 217             {
 218               count[n]++;
 219               sptr += sstride[n];
 220               rptr += rstride[n];
 221             }
 222         }
 223     }
 224 }
 225
 226 /* This version of spread_internal treats the special case of a scalar
 227    source.  This is much simpler than the more general case above.  */
 228
 229 void
 230 spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source,
 231                         const index_type along, const index_type pncopies)
 232 {
 233   int n;
 234   int ncopies = pncopies;
 235   'rtype_name` * restrict dest;
 236   index_type stride;
 237
 238   if (GFC_DESCRIPTOR_RANK (ret) != 1)
 239     runtime_error ("incorrect destination rank in spread()");
 240
 241   if (along > 1)
 242     runtime_error ("dim outside of rank in spread()");
 243
 244   if (ret->base_addr == NULL)
 245     {
 246       ret->base_addr = xmallocarray (ncopies, sizeof ('rtype_name`));
 247       ret->offset = 0;
 248       GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
 249     }
 250   else
 251     {
 252       if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
 253                            / GFC_DESCRIPTOR_STRIDE(ret,0))
 254         runtime_error ("dim too large in spread()");
 255     }
 256
 257   dest = ret->base_addr;
 258   stride = GFC_DESCRIPTOR_STRIDE(ret,0);
 259
 260   for (n = 0; n < ncopies; n++)
 261     {
 262       *dest = *source;
 263       dest += stride;
 264     }
 265 }
 266
 267 #endif
 268 '