libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright (C) 2002-2017 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 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 <string.h>
  28
  29 static void
  30 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
  31                  const index_type *along, const index_type *pncopies)
  32 {
  33   /* r.* indicates the return array.  */
  34   index_type rstride[GFC_MAX_DIMENSIONS];
  35   index_type rstride0;
  36   index_type rdelta = 0;
  37   index_type rrank;
  38   index_type rs;
  39   char *rptr;
  40   char *dest;
  41   /* s.* indicates the source array.  */
  42   index_type sstride[GFC_MAX_DIMENSIONS];
  43   index_type sstride0;
  44   index_type srank;
  45   const char *sptr;
  46
  47   index_type count[GFC_MAX_DIMENSIONS];
  48   index_type extent[GFC_MAX_DIMENSIONS];
  49   index_type n;
  50   index_type dim;
  51   index_type ncopies;
  52   index_type size;
  53
  54   size = GFC_DESCRIPTOR_SIZE(source);
  55
  56   srank = GFC_DESCRIPTOR_RANK(source);
  57
  58   rrank = srank + 1;
  59   if (rrank > GFC_MAX_DIMENSIONS)
  60     runtime_error ("return rank too large in spread()");
  61
  62   if (*along > rrank)
  63       runtime_error ("dim outside of rank in spread()");
  64
  65   ncopies = *pncopies;
  66
  67   if (ret->base_addr == NULL)
  68     {
  69       /* The front end has signalled that we need to populate the
  70          return array descriptor.  */
  71
  72       size_t ub, stride;
  73
  74       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
  75       dim = 0;
  76       rs = 1;
  77       for (n = 0; n < rrank; n++)
  78         {
  79           stride = rs;
  80           if (n == *along - 1)
  81             {
  82               ub = ncopies - 1;
  83               rdelta = rs * size;
  84               rs *= ncopies;
  85             }
  86           else
  87             {
  88               count[dim] = 0;
  89               extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
  90               sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
  91               rstride[dim] = rs * size;
  92
  93               ub = extent[dim]-1;
  94               rs *= extent[dim];
  95               dim++;
  96             }
  97
  98           GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
  99         }
 100       ret->offset = 0;
 101       ret->base_addr = xmallocarray (rs, size);
 102
 103       if (rs <= 0)
 104         return;
 105     }
 106   else
 107     {
 108       int zero_sized;
 109
 110       zero_sized = 0;
 111
 112       dim = 0;
 113       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 114         runtime_error ("rank mismatch in spread()");
 115
 116       if (compile_options.bounds_check)
 117         {
 118           for (n = 0; n < rrank; n++)
 119             {
 120               index_type ret_extent;
 121
 122               ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 123               if (n == *along - 1)
 124                 {
 125                   rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 126
 127                   if (ret_extent != ncopies)
 128                     runtime_error("Incorrect extent in return value of SPREAD"
 129                                   " intrinsic in dimension %ld: is %ld,"
 130                                   " should be %ld", (long int) n+1,
 131                                   (long int) ret_extent, (long int) ncopies);
 132                 }
 133               else
 134                 {
 135                   count[dim] = 0;
 136                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 137                   if (ret_extent != extent[dim])
 138                     runtime_error("Incorrect extent in return value of SPREAD"
 139                                   " intrinsic in dimension %ld: is %ld,"
 140                                   " should be %ld", (long int) n+1,
 141                                   (long int) ret_extent,
 142                                   (long int) extent[dim]);
 143
 144                   if (extent[dim] <= 0)
 145                     zero_sized = 1;
 146                   sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
 147                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 148                   dim++;
 149                 }
 150             }
 151         }
 152       else
 153         {
 154           for (n = 0; n < rrank; n++)
 155             {
 156               if (n == *along - 1)
 157                 {
 158                   rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 159                 }
 160               else
 161                 {
 162                   count[dim] = 0;
 163                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 164                   if (extent[dim] <= 0)
 165                     zero_sized = 1;
 166                   sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
 167                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 168                   dim++;
 169                 }
 170             }
 171         }
 172
 173       if (zero_sized)
 174         return;
 175
 176       if (sstride[0] == 0)
 177         sstride[0] = size;
 178     }
 179   sstride0 = sstride[0];
 180   rstride0 = rstride[0];
 181   rptr = ret->base_addr;
 182   sptr = source->base_addr;
 183
 184   while (sptr)
 185     {
 186       /* Spread this element.  */
 187       dest = rptr;
 188       for (n = 0; n < ncopies; n++)
 189         {
 190           memcpy (dest, sptr, size);
 191           dest += rdelta;
 192         }
 193       /* Advance to the next element.  */
 194       sptr += sstride0;
 195       rptr += rstride0;
 196       count[0]++;
 197       n = 0;
 198       while (count[n] == extent[n])
 199         {
 200           /* When we get to the end of a dimension, reset it and increment
 201              the next dimension.  */
 202           count[n] = 0;
 203           /* We could precalculate these products, but this is a less
 204              frequently used path so probably not worth it.  */
 205           sptr -= sstride[n] * extent[n];
 206           rptr -= rstride[n] * extent[n];
 207           n++;
 208           if (n >= srank)
 209             {
 210               /* Break out of the loop.  */
 211               sptr = NULL;
 212               break;
 213             }
 214           else
 215             {
 216               count[n]++;
 217               sptr += sstride[n];
 218               rptr += rstride[n];
 219             }
 220         }
 221     }
 222 }
 223
 224 /* This version of spread_internal treats the special case of a scalar
 225    source.  This is much simpler than the more general case above.  */
 226
 227 static void
 228 spread_internal_scalar (gfc_array_char *ret, const char *source,
 229                         const index_type *along, const index_type *pncopies)
 230 {
 231   int n;
 232   int ncopies = *pncopies;
 233   char * dest;
 234   size_t size;
 235
 236   size = GFC_DESCRIPTOR_SIZE(ret);
 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, size);
 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   for (n = 0; n < ncopies; n++)
 258     {
 259       dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
 260       memcpy (dest , source, size);
 261     }
 262 }
 263
 264 extern void spread (gfc_array_char *, const gfc_array_char *,
 265                     const index_type *, const index_type *);
 266 export_proto(spread);
 267
 268 void
 269 spread (gfc_array_char *ret, const gfc_array_char *source,
 270         const index_type *along, const index_type *pncopies)
 271 {
 272   index_type type_size;
 273
 274   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 275   switch(type_size)
 276     {
 277     case GFC_DTYPE_DERIVED_1:
 278     case GFC_DTYPE_LOGICAL_1:
 279     case GFC_DTYPE_INTEGER_1:
 280       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 281                  *along, *pncopies);
 282       return;
 283
 284     case GFC_DTYPE_LOGICAL_2:
 285     case GFC_DTYPE_INTEGER_2:
 286       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 287                  *along, *pncopies);
 288       return;
 289
 290     case GFC_DTYPE_LOGICAL_4:
 291     case GFC_DTYPE_INTEGER_4:
 292       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 293                  *along, *pncopies);
 294       return;
 295
 296     case GFC_DTYPE_LOGICAL_8:
 297     case GFC_DTYPE_INTEGER_8:
 298       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 299                  *along, *pncopies);
 300       return;
 301
 302 #ifdef HAVE_GFC_INTEGER_16
 303     case GFC_DTYPE_LOGICAL_16:
 304     case GFC_DTYPE_INTEGER_16:
 305       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 306                  *along, *pncopies);
 307       return;
 308 #endif
 309
 310     case GFC_DTYPE_REAL_4:
 311       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
 312                  *along, *pncopies);
 313       return;
 314
 315     case GFC_DTYPE_REAL_8:
 316       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
 317                  *along, *pncopies);
 318       return;
 319
 320 /* FIXME: This here is a hack, which will have to be removed when
 321    the array descriptor is reworked.  Currently, we don't store the
 322    kind value for the type, but only the size.  Because on targets with
 323    __float128, we have sizeof(logn double) == sizeof(__float128),
 324    we cannot discriminate here and have to fall back to the generic
 325    handling (which is suboptimal).  */
 326 #if !defined(GFC_REAL_16_IS_FLOAT128)
 327 # ifdef GFC_HAVE_REAL_10
 328     case GFC_DTYPE_REAL_10:
 329       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
 330                  *along, *pncopies);
 331       return;
 332 # endif
 333
 334 # ifdef GFC_HAVE_REAL_16
 335     case GFC_DTYPE_REAL_16:
 336       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
 337                  *along, *pncopies);
 338       return;
 339 # endif
 340 #endif
 341
 342     case GFC_DTYPE_COMPLEX_4:
 343       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
 344                  *along, *pncopies);
 345       return;
 346
 347     case GFC_DTYPE_COMPLEX_8:
 348       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
 349                  *along, *pncopies);
 350       return;
 351
 352 /* FIXME: This here is a hack, which will have to be removed when
 353    the array descriptor is reworked.  Currently, we don't store the
 354    kind value for the type, but only the size.  Because on targets with
 355    __float128, we have sizeof(logn double) == sizeof(__float128),
 356    we cannot discriminate here and have to fall back to the generic
 357    handling (which is suboptimal).  */
 358 #if !defined(GFC_REAL_16_IS_FLOAT128)
 359 # ifdef GFC_HAVE_COMPLEX_10
 360     case GFC_DTYPE_COMPLEX_10:
 361       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
 362                  *along, *pncopies);
 363       return;
 364 # endif
 365
 366 # ifdef GFC_HAVE_COMPLEX_16
 367     case GFC_DTYPE_COMPLEX_16:
 368       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
 369                  *along, *pncopies);
 370       return;
 371 # endif
 372 #endif
 373
 374     case GFC_DTYPE_DERIVED_2:
 375       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
 376         break;
 377       else
 378         {
 379           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 380                      *along, *pncopies);
 381           return;
 382         }
 383
 384     case GFC_DTYPE_DERIVED_4:
 385       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
 386         break;
 387       else
 388         {
 389           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 390                      *along, *pncopies);
 391           return;
 392         }
 393
 394     case GFC_DTYPE_DERIVED_8:
 395       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
 396         break;
 397       else
 398         {
 399           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 400                      *along, *pncopies);
 401           return;
 402         }
 403
 404 #ifdef HAVE_GFC_INTEGER_16
 405     case GFC_DTYPE_DERIVED_16:
 406       if (GFC_UNALIGNED_16(ret->base_addr)
 407           || GFC_UNALIGNED_16(source->base_addr))
 408         break;
 409       else
 410         {
 411           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 412                       *along, *pncopies);
 413           return;
 414         }
 415 #endif
 416     }
 417
 418   spread_internal (ret, source, along, pncopies);
 419 }
 420
 421
 422 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 423                          const gfc_array_char *, const index_type *,
 424                          const index_type *, GFC_INTEGER_4);
 425 export_proto(spread_char);
 426
 427 void
 428 spread_char (gfc_array_char *ret,
 429              GFC_INTEGER_4 ret_length __attribute__((unused)),
 430              const gfc_array_char *source, const index_type *along,
 431              const index_type *pncopies,
 432              GFC_INTEGER_4 source_length __attribute__((unused)))
 433 {
 434   spread_internal (ret, source, along, pncopies);
 435 }
 436
 437
 438 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
 439                           const gfc_array_char *, const index_type *,
 440                           const index_type *, GFC_INTEGER_4);
 441 export_proto(spread_char4);
 442
 443 void
 444 spread_char4 (gfc_array_char *ret,
 445               GFC_INTEGER_4 ret_length __attribute__((unused)),
 446               const gfc_array_char *source, const index_type *along,
 447               const index_type *pncopies,
 448               GFC_INTEGER_4 source_length __attribute__((unused)))
 449 {
 450   spread_internal (ret, source, along, pncopies);
 451 }
 452
 453
 454 /* The following are the prototypes for the versions of spread with a
 455    scalar source.  */
 456
 457 extern void spread_scalar (gfc_array_char *, const char *,
 458                            const index_type *, const index_type *);
 459 export_proto(spread_scalar);
 460
 461 void
 462 spread_scalar (gfc_array_char *ret, const char *source,
 463                const index_type *along, const index_type *pncopies)
 464 {
 465   index_type type_size;
 466
 467   if (!ret->dtype)
 468     runtime_error ("return array missing descriptor in spread()");
 469
 470   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 471   switch(type_size)
 472     {
 473     case GFC_DTYPE_DERIVED_1:
 474     case GFC_DTYPE_LOGICAL_1:
 475     case GFC_DTYPE_INTEGER_1:
 476       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 477                         *along, *pncopies);
 478       return;
 479
 480     case GFC_DTYPE_LOGICAL_2:
 481     case GFC_DTYPE_INTEGER_2:
 482       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 483                         *along, *pncopies);
 484       return;
 485
 486     case GFC_DTYPE_LOGICAL_4:
 487     case GFC_DTYPE_INTEGER_4:
 488       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 489                         *along, *pncopies);
 490       return;
 491
 492     case GFC_DTYPE_LOGICAL_8:
 493     case GFC_DTYPE_INTEGER_8:
 494       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 495                         *along, *pncopies);
 496       return;
 497
 498 #ifdef HAVE_GFC_INTEGER_16
 499     case GFC_DTYPE_LOGICAL_16:
 500     case GFC_DTYPE_INTEGER_16:
 501       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 502                         *along, *pncopies);
 503       return;
 504 #endif
 505
 506     case GFC_DTYPE_REAL_4:
 507       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 508                         *along, *pncopies);
 509       return;
 510
 511     case GFC_DTYPE_REAL_8:
 512       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 513                         *along, *pncopies);
 514       return;
 515
 516 /* FIXME: This here is a hack, which will have to be removed when
 517    the array descriptor is reworked.  Currently, we don't store the
 518    kind value for the type, but only the size.  Because on targets with
 519    __float128, we have sizeof(logn double) == sizeof(__float128),
 520    we cannot discriminate here and have to fall back to the generic
 521    handling (which is suboptimal).  */
 522 #if !defined(GFC_REAL_16_IS_FLOAT128)
 523 # ifdef HAVE_GFC_REAL_10
 524     case GFC_DTYPE_REAL_10:
 525       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 526                         *along, *pncopies);
 527       return;
 528 # endif
 529
 530 # ifdef HAVE_GFC_REAL_16
 531     case GFC_DTYPE_REAL_16:
 532       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 533                         *along, *pncopies);
 534       return;
 535 # endif
 536 #endif
 537
 538     case GFC_DTYPE_COMPLEX_4:
 539       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 540                         *along, *pncopies);
 541       return;
 542
 543     case GFC_DTYPE_COMPLEX_8:
 544       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 545                         *along, *pncopies);
 546       return;
 547
 548 /* FIXME: This here is a hack, which will have to be removed when
 549    the array descriptor is reworked.  Currently, we don't store the
 550    kind value for the type, but only the size.  Because on targets with
 551    __float128, we have sizeof(logn double) == sizeof(__float128),
 552    we cannot discriminate here and have to fall back to the generic
 553    handling (which is suboptimal).  */
 554 #if !defined(GFC_REAL_16_IS_FLOAT128)
 555 # ifdef HAVE_GFC_COMPLEX_10
 556     case GFC_DTYPE_COMPLEX_10:
 557       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 558                         *along, *pncopies);
 559       return;
 560 # endif
 561
 562 # ifdef HAVE_GFC_COMPLEX_16
 563     case GFC_DTYPE_COMPLEX_16:
 564       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 565                         *along, *pncopies);
 566       return;
 567 # endif
 568 #endif
 569
 570     case GFC_DTYPE_DERIVED_2:
 571       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
 572         break;
 573       else
 574         {
 575           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 576                             *along, *pncopies);
 577           return;
 578         }
 579
 580     case GFC_DTYPE_DERIVED_4:
 581       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
 582         break;
 583       else
 584         {
 585           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 586                             *along, *pncopies);
 587           return;
 588         }
 589
 590     case GFC_DTYPE_DERIVED_8:
 591       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
 592         break;
 593       else
 594         {
 595           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 596                             *along, *pncopies);
 597           return;
 598         }
 599 #ifdef HAVE_GFC_INTEGER_16
 600     case GFC_DTYPE_DERIVED_16:
 601       if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
 602         break;
 603       else
 604         {
 605           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 606                              *along, *pncopies);
 607           return;
 608         }
 609 #endif
 610     }
 611
 612   spread_internal_scalar (ret, source, along, pncopies);
 613 }
 614
 615
 616 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 617                                 const char *, const index_type *,
 618                                 const index_type *, GFC_INTEGER_4);
 619 export_proto(spread_char_scalar);
 620
 621 void
 622 spread_char_scalar (gfc_array_char *ret,
 623                     GFC_INTEGER_4 ret_length __attribute__((unused)),
 624                     const char *source, const index_type *along,
 625                     const index_type *pncopies,
 626                     GFC_INTEGER_4 source_length __attribute__((unused)))
 627 {
 628   if (!ret->dtype)
 629     runtime_error ("return array missing descriptor in spread()");
 630   spread_internal_scalar (ret, source, along, pncopies);
 631 }
 632
 633
 634 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
 635                                  const char *, const index_type *,
 636                                  const index_type *, GFC_INTEGER_4);
 637 export_proto(spread_char4_scalar);
 638
 639 void
 640 spread_char4_scalar (gfc_array_char *ret,
 641                      GFC_INTEGER_4 ret_length __attribute__((unused)),
 642                      const char *source, const index_type *along,
 643                      const index_type *pncopies,
 644                      GFC_INTEGER_4 source_length __attribute__((unused)))
 645 {
 646   if (!ret->dtype)
 647     runtime_error ("return array missing descriptor in spread()");
 648   spread_internal_scalar (ret, source, along, pncopies);
 649
 650 }
 651