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