l4/pkg/libgfortran/lib/contrib/m4/spread.m4

   1 `/* Special implementation of the SPREAD intrinsic
   2    Copyright (C) 2008-2015 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 <stdlib.h>
  29 #include <assert.h>
  30 #include <string.h>'
  31
  32 include(iparm.m4)dnl
  33
  34 `#if defined (HAVE_'rtype_name`)
  35
  36 void
  37 spread_'rtype_code` ('rtype` *ret, const 'rtype` *source,
  38                  const index_type along, const index_type pncopies)
  39 {
  40   /* r.* indicates the return array.  */
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type rdelta = 0;
  44   index_type rrank;
  45   index_type rs;
  46   'rtype_name` *rptr;
  47   'rtype_name` * restrict dest;
  48   /* s.* indicates the source array.  */
  49   index_type sstride[GFC_MAX_DIMENSIONS];
  50   index_type sstride0;
  51   index_type srank;
  52   const 'rtype_name` *sptr;
  53
  54   index_type count[GFC_MAX_DIMENSIONS];
  55   index_type extent[GFC_MAX_DIMENSIONS];
  56   index_type n;
  57   index_type dim;
  58   index_type ncopies;
  59
  60   srank = GFC_DESCRIPTOR_RANK(source);
  61
  62   rrank = srank + 1;
  63   if (rrank > GFC_MAX_DIMENSIONS)
  64     runtime_error ("return rank too large in spread()");
  65
  66   if (along > rrank)
  67       runtime_error ("dim outside of rank in spread()");
  68
  69   ncopies = pncopies;
  70
  71   if (ret->base_addr == NULL)
  72     {
  73
  74       size_t ub, stride;
  75
  76       /* The front end has signalled that we need to populate the
  77          return array descriptor.  */
  78       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
  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('rtype_name`));
 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_'rtype_code` ('rtype` *ret, const 'rtype_name` *source,
 233                         const index_type along, const index_type pncopies)
 234 {
 235   int n;
 236   int ncopies = pncopies;
 237   'rtype_name` * restrict dest;
 238   index_type stride;
 239
 240   if (GFC_DESCRIPTOR_RANK (ret) != 1)
 241     runtime_error ("incorrect destination rank in spread()");
 242
 243   if (along > 1)
 244     runtime_error ("dim outside of rank in spread()");
 245
 246   if (ret->base_addr == NULL)
 247     {
 248       ret->base_addr = xmallocarray (ncopies, sizeof ('rtype_name`));
 249       ret->offset = 0;
 250       GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
 251     }
 252   else
 253     {
 254       if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
 255                            / GFC_DESCRIPTOR_STRIDE(ret,0))
 256         runtime_error ("dim too large in spread()");
 257     }
 258
 259   dest = ret->base_addr;
 260   stride = GFC_DESCRIPTOR_STRIDE(ret,0);
 261
 262   for (n = 0; n < ncopies; n++)
 263     {
 264       *dest = *source;
 265       dest += stride;
 266     }
 267 }
 268
 269 #endif
 270 '