libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Ligbfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35
  36 static void
  37 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
  38                  const index_type *along, const index_type *pncopies,
  39                  index_type size)
  40 {
  41   /* r.* indicates the return array.  */
  42   index_type rstride[GFC_MAX_DIMENSIONS];
  43   index_type rstride0;
  44   index_type rdelta = 0;
  45   index_type rrank;
  46   index_type rs;
  47   char *rptr;
  48   char *dest;
  49   /* s.* indicates the source array.  */
  50   index_type sstride[GFC_MAX_DIMENSIONS];
  51   index_type sstride0;
  52   index_type srank;
  53   const char *sptr;
  54
  55   index_type count[GFC_MAX_DIMENSIONS];
  56   index_type extent[GFC_MAX_DIMENSIONS];
  57   index_type n;
  58   index_type dim;
  59   index_type ncopies;
  60
  61   srank = GFC_DESCRIPTOR_RANK(source);
  62
  63   rrank = srank + 1;
  64   if (rrank > GFC_MAX_DIMENSIONS)
  65     runtime_error ("return rank too large in spread()");
  66
  67   if (*along > rrank)
  68       runtime_error ("dim outside of rank in spread()");
  69
  70   ncopies = *pncopies;
  71
  72   if (ret->data == NULL)
  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           ret->dim[n].stride = rs;
  82           ret->dim[n].lbound = 0;
  83           if (n == *along - 1)
  84             {
  85               ret->dim[n].ubound = ncopies - 1;
  86               rdelta = rs * size;
  87               rs *= ncopies;
  88             }
  89           else
  90             {
  91               count[dim] = 0;
  92               extent[dim] = source->dim[dim].ubound + 1
  93                 - source->dim[dim].lbound;
  94               sstride[dim] = source->dim[dim].stride * size;
  95               rstride[dim] = rs * size;
  96
  97               ret->dim[n].ubound = extent[dim]-1;
  98               rs *= extent[dim];
  99               dim++;
 100             }
 101         }
 102       ret->offset = 0;
 103       if (rs > 0)
 104         ret->data = internal_malloc_size (rs * size);
 105       else
 106         {
 107           ret->data = internal_malloc_size (1);
 108           return;
 109         }
 110     }
 111   else
 112     {
 113       int zero_sized;
 114
 115       zero_sized = 0;
 116
 117       dim = 0;
 118       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 119         runtime_error ("rank mismatch in spread()");
 120
 121       if (compile_options.bounds_check)
 122         {
 123           for (n = 0; n < rrank; n++)
 124             {
 125               index_type ret_extent;
 126
 127               ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 128               if (n == *along - 1)
 129                 {
 130                   rdelta = ret->dim[n].stride * size;
 131
 132                   if (ret_extent != ncopies)
 133                     runtime_error("Incorrect extent in return value of SPREAD"
 134                                   " intrinsic in dimension %d: is %ld,"
 135                                   " should be %ld", n+1, (long int) ret_extent,
 136                                   (long int) ncopies);
 137                 }
 138               else
 139                 {
 140                   count[dim] = 0;
 141                   extent[dim] = source->dim[dim].ubound + 1
 142                     - source->dim[dim].lbound;
 143                   if (ret_extent != extent[dim])
 144                     runtime_error("Incorrect extent in return value of SPREAD"
 145                                   " intrinsic in dimension %d: is %ld,"
 146                                   " should be %ld", n+1, (long int) ret_extent,
 147                                   (long int) extent[dim]);
 148
 149                   if (extent[dim] <= 0)
 150                     zero_sized = 1;
 151                   sstride[dim] = source->dim[dim].stride * size;
 152                   rstride[dim] = ret->dim[n].stride * size;
 153                   dim++;
 154                 }
 155             }
 156         }
 157       else
 158         {
 159           for (n = 0; n < rrank; n++)
 160             {
 161               if (n == *along - 1)
 162                 {
 163                   rdelta = ret->dim[n].stride * size;
 164                 }
 165               else
 166                 {
 167                   count[dim] = 0;
 168                   extent[dim] = source->dim[dim].ubound + 1
 169                     - source->dim[dim].lbound;
 170                   if (extent[dim] <= 0)
 171                     zero_sized = 1;
 172                   sstride[dim] = source->dim[dim].stride * size;
 173                   rstride[dim] = ret->dim[n].stride * size;
 174                   dim++;
 175                 }
 176             }
 177         }
 178
 179       if (zero_sized)
 180         return;
 181
 182       if (sstride[0] == 0)
 183         sstride[0] = size;
 184     }
 185   sstride0 = sstride[0];
 186   rstride0 = rstride[0];
 187   rptr = ret->data;
 188   sptr = source->data;
 189
 190   while (sptr)
 191     {
 192       /* Spread this element.  */
 193       dest = rptr;
 194       for (n = 0; n < ncopies; n++)
 195         {
 196           memcpy (dest, sptr, size);
 197           dest += rdelta;
 198         }
 199       /* Advance to the next element.  */
 200       sptr += sstride0;
 201       rptr += rstride0;
 202       count[0]++;
 203       n = 0;
 204       while (count[n] == extent[n])
 205         {
 206           /* When we get to the end of a dimension, reset it and increment
 207              the next dimension.  */
 208           count[n] = 0;
 209           /* We could precalculate these products, but this is a less
 210              frequently used path so probably not worth it.  */
 211           sptr -= sstride[n] * extent[n];
 212           rptr -= rstride[n] * extent[n];
 213           n++;
 214           if (n >= srank)
 215             {
 216               /* Break out of the loop.  */
 217               sptr = NULL;
 218               break;
 219             }
 220           else
 221             {
 222               count[n]++;
 223               sptr += sstride[n];
 224               rptr += rstride[n];
 225             }
 226         }
 227     }
 228 }
 229
 230 /* This version of spread_internal treats the special case of a scalar
 231    source.  This is much simpler than the more general case above.  */
 232
 233 static void
 234 spread_internal_scalar (gfc_array_char *ret, const char *source,
 235                         const index_type *along, const index_type *pncopies,
 236                         index_type size)
 237 {
 238   int n;
 239   int ncopies = *pncopies;
 240   char * dest;
 241
 242   if (GFC_DESCRIPTOR_RANK (ret) != 1)
 243     runtime_error ("incorrect destination rank in spread()");
 244
 245   if (*along > 1)
 246     runtime_error ("dim outside of rank in spread()");
 247
 248   if (ret->data == NULL)
 249     {
 250       ret->data = internal_malloc_size (ncopies * size);
 251       ret->offset = 0;
 252       ret->dim[0].stride = 1;
 253       ret->dim[0].lbound = 0;
 254       ret->dim[0].ubound = ncopies - 1;
 255     }
 256   else
 257     {
 258       if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
 259                            / ret->dim[0].stride)
 260         runtime_error ("dim too large in spread()");
 261     }
 262
 263   for (n = 0; n < ncopies; n++)
 264     {
 265       dest = (char*)(ret->data + n*size*ret->dim[0].stride);
 266       memcpy (dest , source, size);
 267     }
 268 }
 269
 270 extern void spread (gfc_array_char *, const gfc_array_char *,
 271                     const index_type *, const index_type *);
 272 export_proto(spread);
 273
 274 void
 275 spread (gfc_array_char *ret, const gfc_array_char *source,
 276         const index_type *along, const index_type *pncopies)
 277 {
 278   spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
 279 }
 280
 281 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 282                          const gfc_array_char *, const index_type *,
 283                          const index_type *, GFC_INTEGER_4);
 284 export_proto(spread_char);
 285
 286 void
 287 spread_char (gfc_array_char *ret,
 288              GFC_INTEGER_4 ret_length __attribute__((unused)),
 289              const gfc_array_char *source, const index_type *along,
 290              const index_type *pncopies, GFC_INTEGER_4 source_length)
 291 {
 292   spread_internal (ret, source, along, pncopies, source_length);
 293 }
 294
 295 /* The following are the prototypes for the versions of spread with a
 296    scalar source.  */
 297
 298 extern void spread_scalar (gfc_array_char *, const char *,
 299                            const index_type *, const index_type *);
 300 export_proto(spread_scalar);
 301
 302 void
 303 spread_scalar (gfc_array_char *ret, const char *source,
 304                const index_type *along, const index_type *pncopies)
 305 {
 306   if (!ret->dtype)
 307     runtime_error ("return array missing descriptor in spread()");
 308   spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
 309 }
 310
 311
 312 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 313                                 const char *, const index_type *,
 314                                 const index_type *, GFC_INTEGER_4);
 315 export_proto(spread_char_scalar);
 316
 317 void
 318 spread_char_scalar (gfc_array_char *ret,
 319                     GFC_INTEGER_4 ret_length __attribute__((unused)),
 320                     const char *source, const index_type *along,
 321                     const index_type *pncopies, GFC_INTEGER_4 source_length)
 322 {
 323   if (!ret->dtype)
 324     runtime_error ("return array missing descriptor in spread()");
 325   spread_internal_scalar (ret, source, along, pncopies, source_length);
 326 }
 327