libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright 2002, 2005, 2006, 2007, 2009, 2010 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 3 of the License, or (at your option) any later version.
  11
  12 Ligbfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <assert.h>
  29 #include <string.h>
  30
  31 static void
  32 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
  33                  const index_type *along, const index_type *pncopies)
  34 {
  35   /* r.* indicates the return array.  */
  36   index_type rstride[GFC_MAX_DIMENSIONS];
  37   index_type rstride0;
  38   index_type rdelta = 0;
  39   index_type rrank;
  40   index_type rs;
  41   char *rptr;
  42   char *dest;
  43   /* s.* indicates the source array.  */
  44   index_type sstride[GFC_MAX_DIMENSIONS];
  45   index_type sstride0;
  46   index_type srank;
  47   const char *sptr;
  48
  49   index_type count[GFC_MAX_DIMENSIONS];
  50   index_type extent[GFC_MAX_DIMENSIONS];
  51   index_type n;
  52   index_type dim;
  53   index_type ncopies;
  54   index_type size;
  55
  56   size = GFC_DESCRIPTOR_SIZE(source);
  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->data == NULL)
  70     {
  71       /* The front end has signalled that we need to populate the
  72          return array descriptor.  */
  73
  74       size_t ub, stride;
  75
  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 * size;
  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_BYTES(source,dim);
  93               rstride[dim] = rs * size;
  94
  95               ub = extent[dim]-1;
  96               rs *= extent[dim];
  97               dim++;
  98             }
  99
 100           GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
 101         }
 102       ret->offset = 0;
 103       ret->data = internal_malloc_size (rs * size);
 104
 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 (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_BYTES(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_BYTES(source,dim);
 149                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(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_BYTES(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_BYTES(source,dim);
 169                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 170                   dim++;
 171                 }
 172             }
 173         }
 174
 175       if (zero_sized)
 176         return;
 177
 178       if (sstride[0] == 0)
 179         sstride[0] = size;
 180     }
 181   sstride0 = sstride[0];
 182   rstride0 = rstride[0];
 183   rptr = ret->data;
 184   sptr = source->data;
 185
 186   while (sptr)
 187     {
 188       /* Spread this element.  */
 189       dest = rptr;
 190       for (n = 0; n < ncopies; n++)
 191         {
 192           memcpy (dest, sptr, size);
 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 static void
 230 spread_internal_scalar (gfc_array_char *ret, const char *source,
 231                         const index_type *along, const index_type *pncopies)
 232 {
 233   int n;
 234   int ncopies = *pncopies;
 235   char * dest;
 236   size_t size;
 237
 238   size = GFC_DESCRIPTOR_SIZE(ret);
 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->data == NULL)
 247     {
 248       ret->data = internal_malloc_size (ncopies * size);
 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   for (n = 0; n < ncopies; n++)
 260     {
 261       dest = (char*)(ret->data + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
 262       memcpy (dest , source, size);
 263     }
 264 }
 265
 266 extern void spread (gfc_array_char *, const gfc_array_char *,
 267                     const index_type *, const index_type *);
 268 export_proto(spread);
 269
 270 void
 271 spread (gfc_array_char *ret, const gfc_array_char *source,
 272         const index_type *along, const index_type *pncopies)
 273 {
 274   index_type type_size;
 275
 276   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 277   switch(type_size)
 278     {
 279     case GFC_DTYPE_DERIVED_1:
 280     case GFC_DTYPE_LOGICAL_1:
 281     case GFC_DTYPE_INTEGER_1:
 282       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 283                  *along, *pncopies);
 284       return;
 285
 286     case GFC_DTYPE_LOGICAL_2:
 287     case GFC_DTYPE_INTEGER_2:
 288       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 289                  *along, *pncopies);
 290       return;
 291
 292     case GFC_DTYPE_LOGICAL_4:
 293     case GFC_DTYPE_INTEGER_4:
 294       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 295                  *along, *pncopies);
 296       return;
 297
 298     case GFC_DTYPE_LOGICAL_8:
 299     case GFC_DTYPE_INTEGER_8:
 300       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 301                  *along, *pncopies);
 302       return;
 303
 304 #ifdef HAVE_GFC_INTEGER_16
 305     case GFC_DTYPE_LOGICAL_16:
 306     case GFC_DTYPE_INTEGER_16:
 307       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 308                  *along, *pncopies);
 309       return;
 310 #endif
 311
 312     case GFC_DTYPE_REAL_4:
 313       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
 314                  *along, *pncopies);
 315       return;
 316
 317     case GFC_DTYPE_REAL_8:
 318       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
 319                  *along, *pncopies);
 320       return;
 321
 322 /* FIXME: This here is a hack, which will have to be removed when
 323    the array descriptor is reworked.  Currently, we don't store the
 324    kind value for the type, but only the size.  Because on targets with
 325    __float128, we have sizeof(logn double) == sizeof(__float128),
 326    we cannot discriminate here and have to fall back to the generic
 327    handling (which is suboptimal).  */
 328 #if !defined(GFC_REAL_16_IS_FLOAT128)
 329 # ifdef GFC_HAVE_REAL_10
 330     case GFC_DTYPE_REAL_10:
 331       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
 332                  *along, *pncopies);
 333       return;
 334 # endif
 335
 336 # ifdef GFC_HAVE_REAL_16
 337     case GFC_DTYPE_REAL_16:
 338       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
 339                  *along, *pncopies);
 340       return;
 341 # endif
 342 #endif
 343
 344     case GFC_DTYPE_COMPLEX_4:
 345       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
 346                  *along, *pncopies);
 347       return;
 348
 349     case GFC_DTYPE_COMPLEX_8:
 350       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
 351                  *along, *pncopies);
 352       return;
 353
 354 /* FIXME: This here is a hack, which will have to be removed when
 355    the array descriptor is reworked.  Currently, we don't store the
 356    kind value for the type, but only the size.  Because on targets with
 357    __float128, we have sizeof(logn double) == sizeof(__float128),
 358    we cannot discriminate here and have to fall back to the generic
 359    handling (which is suboptimal).  */
 360 #if !defined(GFC_REAL_16_IS_FLOAT128)
 361 # ifdef GFC_HAVE_COMPLEX_10
 362     case GFC_DTYPE_COMPLEX_10:
 363       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
 364                  *along, *pncopies);
 365       return;
 366 # endif
 367
 368 # ifdef GFC_HAVE_COMPLEX_16
 369     case GFC_DTYPE_COMPLEX_16:
 370       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
 371                  *along, *pncopies);
 372       return;
 373 # endif
 374 #endif
 375
 376     case GFC_DTYPE_DERIVED_2:
 377       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source->data))
 378         break;
 379       else
 380         {
 381           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 382                      *along, *pncopies);
 383           return;
 384         }
 385
 386     case GFC_DTYPE_DERIVED_4:
 387       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source->data))
 388         break;
 389       else
 390         {
 391           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 392                      *along, *pncopies);
 393           return;
 394         }
 395
 396     case GFC_DTYPE_DERIVED_8:
 397       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source->data))
 398         break;
 399       else
 400         {
 401           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 402                      *along, *pncopies);
 403           return;
 404         }
 405
 406 #ifdef HAVE_GFC_INTEGER_16
 407     case GFC_DTYPE_DERIVED_16:
 408       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source->data))
 409         break;
 410       else
 411         {
 412           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 413                       *along, *pncopies);
 414           return;
 415         }
 416 #endif
 417     }
 418
 419   spread_internal (ret, source, along, pncopies);
 420 }
 421
 422
 423 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 424                          const gfc_array_char *, const index_type *,
 425                          const index_type *, GFC_INTEGER_4);
 426 export_proto(spread_char);
 427
 428 void
 429 spread_char (gfc_array_char *ret,
 430              GFC_INTEGER_4 ret_length __attribute__((unused)),
 431              const gfc_array_char *source, const index_type *along,
 432              const index_type *pncopies,
 433              GFC_INTEGER_4 source_length __attribute__((unused)))
 434 {
 435   spread_internal (ret, source, along, pncopies);
 436 }
 437
 438
 439 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
 440                           const gfc_array_char *, const index_type *,
 441                           const index_type *, GFC_INTEGER_4);
 442 export_proto(spread_char4);
 443
 444 void
 445 spread_char4 (gfc_array_char *ret,
 446               GFC_INTEGER_4 ret_length __attribute__((unused)),
 447               const gfc_array_char *source, const index_type *along,
 448               const index_type *pncopies,
 449               GFC_INTEGER_4 source_length __attribute__((unused)))
 450 {
 451   spread_internal (ret, source, along, pncopies);
 452 }
 453
 454
 455 /* The following are the prototypes for the versions of spread with a
 456    scalar source.  */
 457
 458 extern void spread_scalar (gfc_array_char *, const char *,
 459                            const index_type *, const index_type *);
 460 export_proto(spread_scalar);
 461
 462 void
 463 spread_scalar (gfc_array_char *ret, const char *source,
 464                const index_type *along, const index_type *pncopies)
 465 {
 466   index_type type_size;
 467
 468   if (!ret->dtype)
 469     runtime_error ("return array missing descriptor in spread()");
 470
 471   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 472   switch(type_size)
 473     {
 474     case GFC_DTYPE_DERIVED_1:
 475     case GFC_DTYPE_LOGICAL_1:
 476     case GFC_DTYPE_INTEGER_1:
 477       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 478                         *along, *pncopies);
 479       return;
 480
 481     case GFC_DTYPE_LOGICAL_2:
 482     case GFC_DTYPE_INTEGER_2:
 483       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 484                         *along, *pncopies);
 485       return;
 486
 487     case GFC_DTYPE_LOGICAL_4:
 488     case GFC_DTYPE_INTEGER_4:
 489       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 490                         *along, *pncopies);
 491       return;
 492
 493     case GFC_DTYPE_LOGICAL_8:
 494     case GFC_DTYPE_INTEGER_8:
 495       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 496                         *along, *pncopies);
 497       return;
 498
 499 #ifdef HAVE_GFC_INTEGER_16
 500     case GFC_DTYPE_LOGICAL_16:
 501     case GFC_DTYPE_INTEGER_16:
 502       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 503                         *along, *pncopies);
 504       return;
 505 #endif
 506
 507     case GFC_DTYPE_REAL_4:
 508       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 509                         *along, *pncopies);
 510       return;
 511
 512     case GFC_DTYPE_REAL_8:
 513       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 514                         *along, *pncopies);
 515       return;
 516
 517 /* FIXME: This here is a hack, which will have to be removed when
 518    the array descriptor is reworked.  Currently, we don't store the
 519    kind value for the type, but only the size.  Because on targets with
 520    __float128, we have sizeof(logn double) == sizeof(__float128),
 521    we cannot discriminate here and have to fall back to the generic
 522    handling (which is suboptimal).  */
 523 #if !defined(GFC_REAL_16_IS_FLOAT128)
 524 # ifdef HAVE_GFC_REAL_10
 525     case GFC_DTYPE_REAL_10:
 526       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 527                         *along, *pncopies);
 528       return;
 529 # endif
 530
 531 # ifdef HAVE_GFC_REAL_16
 532     case GFC_DTYPE_REAL_16:
 533       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 534                         *along, *pncopies);
 535       return;
 536 # endif
 537 #endif
 538
 539     case GFC_DTYPE_COMPLEX_4:
 540       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 541                         *along, *pncopies);
 542       return;
 543
 544     case GFC_DTYPE_COMPLEX_8:
 545       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 546                         *along, *pncopies);
 547       return;
 548
 549 /* FIXME: This here is a hack, which will have to be removed when
 550    the array descriptor is reworked.  Currently, we don't store the
 551    kind value for the type, but only the size.  Because on targets with
 552    __float128, we have sizeof(logn double) == sizeof(__float128),
 553    we cannot discriminate here and have to fall back to the generic
 554    handling (which is suboptimal).  */
 555 #if !defined(GFC_REAL_16_IS_FLOAT128)
 556 # ifdef HAVE_GFC_COMPLEX_10
 557     case GFC_DTYPE_COMPLEX_10:
 558       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 559                         *along, *pncopies);
 560       return;
 561 # endif
 562
 563 # ifdef HAVE_GFC_COMPLEX_16
 564     case GFC_DTYPE_COMPLEX_16:
 565       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 566                         *along, *pncopies);
 567       return;
 568 # endif
 569 #endif
 570
 571     case GFC_DTYPE_DERIVED_2:
 572       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source))
 573         break;
 574       else
 575         {
 576           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 577                             *along, *pncopies);
 578           return;
 579         }
 580
 581     case GFC_DTYPE_DERIVED_4:
 582       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source))
 583         break;
 584       else
 585         {
 586           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 587                             *along, *pncopies);
 588           return;
 589         }
 590
 591     case GFC_DTYPE_DERIVED_8:
 592       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source))
 593         break;
 594       else
 595         {
 596           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 597                             *along, *pncopies);
 598           return;
 599         }
 600 #ifdef HAVE_GFC_INTEGER_16
 601     case GFC_DTYPE_DERIVED_16:
 602       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source))
 603         break;
 604       else
 605         {
 606           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 607                              *along, *pncopies);
 608           return;
 609         }
 610 #endif
 611     }
 612
 613   spread_internal_scalar (ret, source, along, pncopies);
 614 }
 615
 616
 617 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 618                                 const char *, const index_type *,
 619                                 const index_type *, GFC_INTEGER_4);
 620 export_proto(spread_char_scalar);
 621
 622 void
 623 spread_char_scalar (gfc_array_char *ret,
 624                     GFC_INTEGER_4 ret_length __attribute__((unused)),
 625                     const char *source, const index_type *along,
 626                     const index_type *pncopies,
 627                     GFC_INTEGER_4 source_length __attribute__((unused)))
 628 {
 629   if (!ret->dtype)
 630     runtime_error ("return array missing descriptor in spread()");
 631   spread_internal_scalar (ret, source, along, pncopies);
 632 }
 633
 634
 635 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
 636                                  const char *, const index_type *,
 637                                  const index_type *, GFC_INTEGER_4);
 638 export_proto(spread_char4_scalar);
 639
 640 void
 641 spread_char4_scalar (gfc_array_char *ret,
 642                      GFC_INTEGER_4 ret_length __attribute__((unused)),
 643                      const char *source, const index_type *along,
 644                      const index_type *pncopies,
 645                      GFC_INTEGER_4 source_length __attribute__((unused)))
 646 {
 647   if (!ret->dtype)
 648     runtime_error ("return array missing descriptor in spread()");
 649   spread_internal_scalar (ret, source, along, pncopies);
 650
 651 }
 652