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 %ld: is %ld,"
 135                                   " should be %ld", (long int) n+1,
 136                                   (long int) ret_extent, (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 %ld: is %ld,"
 146                                   " should be %ld", (long int) n+1,
 147                                   (long int) ret_extent,
 148                                   (long int) extent[dim]);
 149
 150                   if (extent[dim] <= 0)
 151                     zero_sized = 1;
 152                   sstride[dim] = source->dim[dim].stride * size;
 153                   rstride[dim] = ret->dim[n].stride * size;
 154                   dim++;
 155                 }
 156             }
 157         }
 158       else
 159         {
 160           for (n = 0; n < rrank; n++)
 161             {
 162               if (n == *along - 1)
 163                 {
 164                   rdelta = ret->dim[n].stride * size;
 165                 }
 166               else
 167                 {
 168                   count[dim] = 0;
 169                   extent[dim] = source->dim[dim].ubound + 1
 170                     - source->dim[dim].lbound;
 171                   if (extent[dim] <= 0)
 172                     zero_sized = 1;
 173                   sstride[dim] = source->dim[dim].stride * size;
 174                   rstride[dim] = ret->dim[n].stride * size;
 175                   dim++;
 176                 }
 177             }
 178         }
 179
 180       if (zero_sized)
 181         return;
 182
 183       if (sstride[0] == 0)
 184         sstride[0] = size;
 185     }
 186   sstride0 = sstride[0];
 187   rstride0 = rstride[0];
 188   rptr = ret->data;
 189   sptr = source->data;
 190
 191   while (sptr)
 192     {
 193       /* Spread this element.  */
 194       dest = rptr;
 195       for (n = 0; n < ncopies; n++)
 196         {
 197           memcpy (dest, sptr, size);
 198           dest += rdelta;
 199         }
 200       /* Advance to the next element.  */
 201       sptr += sstride0;
 202       rptr += rstride0;
 203       count[0]++;
 204       n = 0;
 205       while (count[n] == extent[n])
 206         {
 207           /* When we get to the end of a dimension, reset it and increment
 208              the next dimension.  */
 209           count[n] = 0;
 210           /* We could precalculate these products, but this is a less
 211              frequently used path so probably not worth it.  */
 212           sptr -= sstride[n] * extent[n];
 213           rptr -= rstride[n] * extent[n];
 214           n++;
 215           if (n >= srank)
 216             {
 217               /* Break out of the loop.  */
 218               sptr = NULL;
 219               break;
 220             }
 221           else
 222             {
 223               count[n]++;
 224               sptr += sstride[n];
 225               rptr += rstride[n];
 226             }
 227         }
 228     }
 229 }
 230
 231 /* This version of spread_internal treats the special case of a scalar
 232    source.  This is much simpler than the more general case above.  */
 233
 234 static void
 235 spread_internal_scalar (gfc_array_char *ret, const char *source,
 236                         const index_type *along, const index_type *pncopies,
 237                         index_type size)
 238 {
 239   int n;
 240   int ncopies = *pncopies;
 241   char * dest;
 242
 243   if (GFC_DESCRIPTOR_RANK (ret) != 1)
 244     runtime_error ("incorrect destination rank in spread()");
 245
 246   if (*along > 1)
 247     runtime_error ("dim outside of rank in spread()");
 248
 249   if (ret->data == NULL)
 250     {
 251       ret->data = internal_malloc_size (ncopies * size);
 252       ret->offset = 0;
 253       ret->dim[0].stride = 1;
 254       ret->dim[0].lbound = 0;
 255       ret->dim[0].ubound = ncopies - 1;
 256     }
 257   else
 258     {
 259       if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
 260                            / ret->dim[0].stride)
 261         runtime_error ("dim too large in spread()");
 262     }
 263
 264   for (n = 0; n < ncopies; n++)
 265     {
 266       dest = (char*)(ret->data + n*size*ret->dim[0].stride);
 267       memcpy (dest , source, size);
 268     }
 269 }
 270
 271 extern void spread (gfc_array_char *, const gfc_array_char *,
 272                     const index_type *, const index_type *);
 273 export_proto(spread);
 274
 275 void
 276 spread (gfc_array_char *ret, const gfc_array_char *source,
 277         const index_type *along, const index_type *pncopies)
 278 {
 279   index_type type_size;
 280
 281   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 282   switch(type_size)
 283     {
 284     case GFC_DTYPE_LOGICAL_1:
 285     case GFC_DTYPE_INTEGER_1:
 286       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 287                  *along, *pncopies);
 288       return;
 289
 290     case GFC_DTYPE_LOGICAL_2:
 291     case GFC_DTYPE_INTEGER_2:
 292       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 293                  *along, *pncopies);
 294       return;
 295
 296     case GFC_DTYPE_LOGICAL_4:
 297     case GFC_DTYPE_INTEGER_4:
 298       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 299                  *along, *pncopies);
 300       return;
 301
 302     case GFC_DTYPE_LOGICAL_8:
 303     case GFC_DTYPE_INTEGER_8:
 304       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 305                  *along, *pncopies);
 306       return;
 307
 308 #ifdef HAVE_GFC_INTEGER_16
 309     case GFC_DTYPE_LOGICAL_16:
 310     case GFC_DTYPE_INTEGER_16:
 311       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 312                  *along, *pncopies);
 313       return;
 314 #endif
 315
 316     case GFC_DTYPE_REAL_4:
 317       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
 318                  *along, *pncopies);
 319       return;
 320
 321     case GFC_DTYPE_REAL_8:
 322       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
 323                  *along, *pncopies);
 324       return;
 325
 326 #ifdef GFC_HAVE_REAL_10
 327     case GFC_DTYPE_REAL_10:
 328       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
 329                  *along, *pncopies);
 330       return;
 331 #endif
 332
 333 #ifdef GFC_HAVE_REAL_16
 334     case GFC_DTYPE_REAL_16:
 335       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
 336                  *along, *pncopies);
 337       return;
 338 #endif
 339
 340     case GFC_DTYPE_COMPLEX_4:
 341       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
 342                  *along, *pncopies);
 343       return;
 344
 345     case GFC_DTYPE_COMPLEX_8:
 346       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
 347                  *along, *pncopies);
 348       return;
 349
 350 #ifdef GFC_HAVE_COMPLEX_10
 351     case GFC_DTYPE_COMPLEX_10:
 352       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
 353                  *along, *pncopies);
 354       return;
 355 #endif
 356
 357 #ifdef GFC_HAVE_COMPLEX_16
 358     case GFC_DTYPE_COMPLEX_16:
 359       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
 360                  *along, *pncopies);
 361       return;
 362 #endif
 363
 364     }
 365   spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
 366 }
 367
 368 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 369                          const gfc_array_char *, const index_type *,
 370                          const index_type *, GFC_INTEGER_4);
 371 export_proto(spread_char);
 372
 373 void
 374 spread_char (gfc_array_char *ret,
 375              GFC_INTEGER_4 ret_length __attribute__((unused)),
 376              const gfc_array_char *source, const index_type *along,
 377              const index_type *pncopies, GFC_INTEGER_4 source_length)
 378 {
 379   spread_internal (ret, source, along, pncopies, source_length);
 380 }
 381
 382 /* The following are the prototypes for the versions of spread with a
 383    scalar source.  */
 384
 385 extern void spread_scalar (gfc_array_char *, const char *,
 386                            const index_type *, const index_type *);
 387 export_proto(spread_scalar);
 388
 389 void
 390 spread_scalar (gfc_array_char *ret, const char *source,
 391                const index_type *along, const index_type *pncopies)
 392 {
 393   index_type type_size;
 394
 395   if (!ret->dtype)
 396     runtime_error ("return array missing descriptor in spread()");
 397
 398   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 399   switch(type_size)
 400     {
 401     case GFC_DTYPE_LOGICAL_1:
 402     case GFC_DTYPE_INTEGER_1:
 403       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 404                         *along, *pncopies);
 405       return;
 406
 407     case GFC_DTYPE_LOGICAL_2:
 408     case GFC_DTYPE_INTEGER_2:
 409       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 410                         *along, *pncopies);
 411       return;
 412
 413     case GFC_DTYPE_LOGICAL_4:
 414     case GFC_DTYPE_INTEGER_4:
 415       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 416                         *along, *pncopies);
 417       return;
 418
 419     case GFC_DTYPE_LOGICAL_8:
 420     case GFC_DTYPE_INTEGER_8:
 421       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 422                         *along, *pncopies);
 423       return;
 424
 425 #ifdef HAVE_GFC_INTEGER_16
 426     case GFC_DTYPE_LOGICAL_16:
 427     case GFC_DTYPE_INTEGER_16:
 428       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 429                         *along, *pncopies);
 430       return;
 431 #endif
 432
 433     case GFC_DTYPE_REAL_4:
 434       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 435                         *along, *pncopies);
 436       return;
 437
 438     case GFC_DTYPE_REAL_8:
 439       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 440                         *along, *pncopies);
 441       return;
 442
 443 #ifdef HAVE_GFC_REAL_10
 444     case GFC_DTYPE_REAL_10:
 445       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 446                         *along, *pncopies);
 447       return;
 448 #endif
 449
 450 #ifdef HAVE_GFC_REAL_16
 451     case GFC_DTYPE_REAL_16:
 452       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 453                         *along, *pncopies);
 454       return;
 455 #endif
 456
 457     case GFC_DTYPE_COMPLEX_4:
 458       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 459                         *along, *pncopies);
 460       return;
 461
 462     case GFC_DTYPE_COMPLEX_8:
 463       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 464                         *along, *pncopies);
 465       return;
 466
 467 #ifdef HAVE_GFC_COMPLEX_10
 468     case GFC_DTYPE_COMPLEX_10:
 469       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 470                         *along, *pncopies);
 471       return;
 472 #endif
 473
 474 #ifdef HAVE_GFC_COMPLEX_16
 475     case GFC_DTYPE_COMPLEX_16:
 476       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 477                         *along, *pncopies);
 478       return;
 479 #endif
 480
 481     }
 482
 483   spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
 484 }
 485
 486
 487 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 488                                 const char *, const index_type *,
 489                                 const index_type *, GFC_INTEGER_4);
 490 export_proto(spread_char_scalar);
 491
 492 void
 493 spread_char_scalar (gfc_array_char *ret,
 494                     GFC_INTEGER_4 ret_length __attribute__((unused)),
 495                     const char *source, const index_type *along,
 496                     const index_type *pncopies, GFC_INTEGER_4 source_length)
 497 {
 498   if (!ret->dtype)
 499     runtime_error ("return array missing descriptor in spread()");
 500   spread_internal_scalar (ret, source, along, pncopies, source_length);
 501 }
 502