libgfortran/generated/spread_i2.c

   1 /* Special implementation of the SPREAD intrinsic
   2    Copyright (C) 2008-2024 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
  31 #if defined (HAVE_GFC_INTEGER_2)
  32
  33 void
  34 spread_i2 (gfc_array_i2 *ret, const gfc_array_i2 *source,
  35                  const index_type along, const index_type pncopies)
  36 {
  37   /* r.* indicates the return array.  */
  38   index_type rstride[GFC_MAX_DIMENSIONS];
  39   index_type rstride0;
  40   index_type rdelta = 0;
  41   index_type rrank;
  42   index_type rs;
  43   GFC_INTEGER_2 *rptr;
  44   GFC_INTEGER_2 * restrict dest;
  45   /* s.* indicates the source array.  */
  46   index_type sstride[GFC_MAX_DIMENSIONS];
  47   index_type sstride0;
  48   index_type srank;
  49   const GFC_INTEGER_2 *sptr;
  50
  51   index_type count[GFC_MAX_DIMENSIONS];
  52   index_type extent[GFC_MAX_DIMENSIONS];
  53   index_type n;
  54   index_type dim;
  55   index_type ncopies;
  56
  57   srank = GFC_DESCRIPTOR_RANK(source);
  58
  59   sstride[0] = 0; /* Avoid warnings if not initialized.  */
  60
  61   rrank = srank + 1;
  62   if (rrank > GFC_MAX_DIMENSIONS)
  63     runtime_error ("return rank too large in spread()");
  64
  65   if (along > rrank)
  66       runtime_error ("dim outside of rank in spread()");
  67
  68   ncopies = pncopies;
  69
  70   if (ret->base_addr == NULL)
  71     {
  72
  73       size_t ub, stride;
  74
  75       /* The front end has signalled that we need to populate the
  76          return array descriptor.  */
  77       ret->dtype.rank = rrank;
  78
  79       dim = 0;
  80       rs = 1;
  81       for (n = 0; n < rrank; n++)
  82         {
  83           stride = rs;
  84           if (n == along - 1)
  85             {
  86               ub = ncopies - 1;
  87               rdelta = rs;
  88               rs *= ncopies;
  89             }
  90           else
  91             {
  92               count[dim] = 0;
  93               extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
  94               sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
  95               rstride[dim] = rs;
  96
  97               ub = extent[dim] - 1;
  98               rs *= extent[dim];
  99               dim++;
 100             }
 101           GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
 102         }
 103       ret->offset = 0;
 104
 105       /* xmallocarray allocates a single byte for zero size.  */
 106       ret->base_addr = xmallocarray (rs, sizeof(GFC_INTEGER_2));
 107       if (rs <= 0)
 108         return;
 109     }
 110   else
 111     {
 112       int zero_sized;
 113
 114       zero_sized = 0;
 115
 116       dim = 0;
 117       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 118         runtime_error ("rank mismatch in spread()");
 119
 120       if (unlikely (compile_options.bounds_check))
 121         {
 122           for (n = 0; n < rrank; n++)
 123             {
 124               index_type ret_extent;
 125
 126               ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 127               if (n == along - 1)
 128                 {
 129                   rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
 130
 131                   if (ret_extent != ncopies)
 132                     runtime_error("Incorrect extent in return value of SPREAD"
 133                                   " intrinsic in dimension %ld: is %ld,"
 134                                   " should be %ld", (long int) n+1,
 135                                   (long int) ret_extent, (long int) ncopies);
 136                 }
 137               else
 138                 {
 139                   count[dim] = 0;
 140                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 141                   if (ret_extent != extent[dim])
 142                     runtime_error("Incorrect extent in return value of SPREAD"
 143                                   " intrinsic in dimension %ld: is %ld,"
 144                                   " should be %ld", (long int) n+1,
 145                                   (long int) ret_extent,
 146                                   (long int) extent[dim]);
 147
 148                   if (extent[dim] <= 0)
 149                     zero_sized = 1;
 150                   sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
 151                   rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
 152                   dim++;
 153                 }
 154             }
 155         }
 156       else
 157         {
 158           for (n = 0; n < rrank; n++)
 159             {
 160               if (n == along - 1)
 161                 {
 162                   rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
 163                 }
 164               else
 165                 {
 166                   count[dim] = 0;
 167                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 168                   if (extent[dim] <= 0)
 169                     zero_sized = 1;
 170                   sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
 171                   rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
 172                   dim++;
 173                 }
 174             }
 175         }
 176
 177       if (zero_sized)
 178         return;
 179
 180       if (sstride[0] == 0)
 181         sstride[0] = 1;
 182     }
 183   sstride0 = sstride[0];
 184   rstride0 = rstride[0];
 185   rptr = ret->base_addr;
 186   sptr = source->base_addr;
 187
 188   while (sptr)
 189     {
 190       /* Spread this element.  */
 191       dest = rptr;
 192       for (n = 0; n < ncopies; n++)
 193         {
 194           *dest = *sptr;
 195           dest += rdelta;
 196         }
 197       /* Advance to the next element.  */
 198       sptr += sstride0;
 199       rptr += rstride0;
 200       count[0]++;
 201       n = 0;
 202       while (count[n] == extent[n])
 203         {
 204           /* When we get to the end of a dimension, reset it and increment
 205              the next dimension.  */
 206           count[n] = 0;
 207           /* We could precalculate these products, but this is a less
 208              frequently used path so probably not worth it.  */
 209           sptr -= sstride[n] * extent[n];
 210           rptr -= rstride[n] * extent[n];
 211           n++;
 212           if (n >= srank)
 213             {
 214               /* Break out of the loop.  */
 215               sptr = NULL;
 216               break;
 217             }
 218           else
 219             {
 220               count[n]++;
 221               sptr += sstride[n];
 222               rptr += rstride[n];
 223             }
 224         }
 225     }
 226 }
 227
 228 /* This version of spread_internal treats the special case of a scalar
 229    source.  This is much simpler than the more general case above.  */
 230
 231 void
 232 spread_scalar_i2 (gfc_array_i2 *ret, const GFC_INTEGER_2 *source,
 233                         const index_type along, const index_type ncopies)
 234 {
 235   GFC_INTEGER_2 * 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 (GFC_INTEGER_2));
 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 (index_type n = 0; n < ncopies; n++)
 261     {
 262       *dest = *source;
 263       dest += stride;
 264     }
 265 }
 266
 267 #endif
 268