libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright (C) 2002-2020 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.rank = rrank;
  75
  76       dim = 0;
  77       rs = 1;
  78       for (n = 0; n < rrank; n++)
  79         {
  80           stride = rs;
  81           if (n == *along - 1)
  82             {
  83               ub = ncopies - 1;
  84               rdelta = rs * size;
  85               rs *= ncopies;
  86             }
  87           else
  88             {
  89               count[dim] = 0;
  90               extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
  91               sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
  92               rstride[dim] = rs * size;
  93
  94               ub = extent[dim]-1;
  95               rs *= extent[dim];
  96               dim++;
  97             }
  98
  99           GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
 100         }
 101       ret->offset = 0;
 102       ret->base_addr = xmallocarray (rs, size);
 103
 104       if (rs <= 0)
 105         return;
 106     }
 107   else
 108     {
 109       int zero_sized;
 110
 111       zero_sized = 0;
 112
 113       dim = 0;
 114       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
 115         runtime_error ("rank mismatch in spread()");
 116
 117       if (compile_options.bounds_check)
 118         {
 119           for (n = 0; n < rrank; n++)
 120             {
 121               index_type ret_extent;
 122
 123               ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
 124               if (n == *along - 1)
 125                 {
 126                   rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 127
 128                   if (ret_extent != ncopies)
 129                     runtime_error("Incorrect extent in return value of SPREAD"
 130                                   " intrinsic in dimension %ld: is %ld,"
 131                                   " should be %ld", (long int) n+1,
 132                                   (long int) ret_extent, (long int) ncopies);
 133                 }
 134               else
 135                 {
 136                   count[dim] = 0;
 137                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 138                   if (ret_extent != extent[dim])
 139                     runtime_error("Incorrect extent in return value of SPREAD"
 140                                   " intrinsic in dimension %ld: is %ld,"
 141                                   " should be %ld", (long int) n+1,
 142                                   (long int) ret_extent,
 143                                   (long int) extent[dim]);
 144
 145                   if (extent[dim] <= 0)
 146                     zero_sized = 1;
 147                   sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
 148                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 149                   dim++;
 150                 }
 151             }
 152         }
 153       else
 154         {
 155           for (n = 0; n < rrank; n++)
 156             {
 157               if (n == *along - 1)
 158                 {
 159                   rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 160                 }
 161               else
 162                 {
 163                   count[dim] = 0;
 164                   extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
 165                   if (extent[dim] <= 0)
 166                     zero_sized = 1;
 167                   sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
 168                   rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 169                   dim++;
 170                 }
 171             }
 172         }
 173
 174       if (zero_sized)
 175         return;
 176
 177       if (sstride[0] == 0)
 178         sstride[0] = size;
 179     }
 180   sstride0 = sstride[0];
 181   rstride0 = rstride[0];
 182   rptr = ret->base_addr;
 183   sptr = source->base_addr;
 184
 185   while (sptr)
 186     {
 187       /* Spread this element.  */
 188       dest = rptr;
 189       for (n = 0; n < ncopies; n++)
 190         {
 191           memcpy (dest, sptr, size);
 192           dest += rdelta;
 193         }
 194       /* Advance to the next element.  */
 195       sptr += sstride0;
 196       rptr += rstride0;
 197       count[0]++;
 198       n = 0;
 199       while (count[n] == extent[n])
 200         {
 201           /* When we get to the end of a dimension, reset it and increment
 202              the next dimension.  */
 203           count[n] = 0;
 204           /* We could precalculate these products, but this is a less
 205              frequently used path so probably not worth it.  */
 206           sptr -= sstride[n] * extent[n];
 207           rptr -= rstride[n] * extent[n];
 208           n++;
 209           if (n >= srank)
 210             {
 211               /* Break out of the loop.  */
 212               sptr = NULL;
 213               break;
 214             }
 215           else
 216             {
 217               count[n]++;
 218               sptr += sstride[n];
 219               rptr += rstride[n];
 220             }
 221         }
 222     }
 223 }
 224
 225 /* This version of spread_internal treats the special case of a scalar
 226    source.  This is much simpler than the more general case above.  */
 227
 228 static void
 229 spread_internal_scalar (gfc_array_char *ret, const char *source,
 230                         const index_type *along, const index_type *pncopies)
 231 {
 232   int n;
 233   int ncopies = *pncopies;
 234   char * dest;
 235   size_t size;
 236
 237   size = GFC_DESCRIPTOR_SIZE(ret);
 238
 239   if (GFC_DESCRIPTOR_RANK (ret) != 1)
 240     runtime_error ("incorrect destination rank in spread()");
 241
 242   if (*along > 1)
 243     runtime_error ("dim outside of rank in spread()");
 244
 245   if (ret->base_addr == NULL)
 246     {
 247       ret->base_addr = xmallocarray (ncopies, size);
 248       ret->offset = 0;
 249       GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
 250     }
 251   else
 252     {
 253       if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0)  - 1)
 254                            / GFC_DESCRIPTOR_STRIDE(ret,0))
 255         runtime_error ("dim too large in spread()");
 256     }
 257
 258   for (n = 0; n < ncopies; n++)
 259     {
 260       dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
 261       memcpy (dest , source, size);
 262     }
 263 }
 264
 265 extern void spread (gfc_array_char *, const gfc_array_char *,
 266                     const index_type *, const index_type *);
 267 export_proto(spread);
 268
 269 void
 270 spread (gfc_array_char *ret, const gfc_array_char *source,
 271         const index_type *along, const index_type *pncopies)
 272 {
 273   index_type type_size;
 274
 275   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 276   switch(type_size)
 277     {
 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     }
 375
 376   switch (GFC_DESCRIPTOR_SIZE (ret))
 377     {
 378     case 1:
 379       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 380                  *along, *pncopies);
 381       return;
 382
 383     case 2:
 384       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
 385         break;
 386       else
 387         {
 388           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 389                      *along, *pncopies);
 390           return;
 391         }
 392
 393     case 4:
 394       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
 395         break;
 396       else
 397         {
 398           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 399                      *along, *pncopies);
 400           return;
 401         }
 402
 403     case 8:
 404       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
 405         break;
 406       else
 407         {
 408           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 409                      *along, *pncopies);
 410           return;
 411         }
 412 #ifdef HAVE_GFC_INTEGER_16
 413     case 16:
 414       if (GFC_UNALIGNED_16(ret->base_addr)
 415           || GFC_UNALIGNED_16(source->base_addr))
 416         break;
 417       else
 418         {
 419           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 420                       *along, *pncopies);
 421           return;
 422             }
 423 #endif
 424
 425     }
 426
 427   spread_internal (ret, source, along, pncopies);
 428 }
 429
 430
 431 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 432                          const gfc_array_char *, const index_type *,
 433                          const index_type *, GFC_INTEGER_4);
 434 export_proto(spread_char);
 435
 436 void
 437 spread_char (gfc_array_char *ret,
 438              GFC_INTEGER_4 ret_length __attribute__((unused)),
 439              const gfc_array_char *source, const index_type *along,
 440              const index_type *pncopies,
 441              GFC_INTEGER_4 source_length __attribute__((unused)))
 442 {
 443   spread_internal (ret, source, along, pncopies);
 444 }
 445
 446
 447 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
 448                           const gfc_array_char *, const index_type *,
 449                           const index_type *, GFC_INTEGER_4);
 450 export_proto(spread_char4);
 451
 452 void
 453 spread_char4 (gfc_array_char *ret,
 454               GFC_INTEGER_4 ret_length __attribute__((unused)),
 455               const gfc_array_char *source, const index_type *along,
 456               const index_type *pncopies,
 457               GFC_INTEGER_4 source_length __attribute__((unused)))
 458 {
 459   spread_internal (ret, source, along, pncopies);
 460 }
 461
 462
 463 /* The following are the prototypes for the versions of spread with a
 464    scalar source.  */
 465
 466 extern void spread_scalar (gfc_array_char *, const char *,
 467                            const index_type *, const index_type *);
 468 export_proto(spread_scalar);
 469
 470 void
 471 spread_scalar (gfc_array_char *ret, const char *source,
 472                const index_type *along, const index_type *pncopies)
 473 {
 474   index_type type_size;
 475
 476   if (GFC_DTYPE_IS_UNSET(ret))
 477     runtime_error ("return array missing descriptor in spread()");
 478
 479   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 480   switch(type_size)
 481     {
 482     case GFC_DTYPE_LOGICAL_1:
 483     case GFC_DTYPE_INTEGER_1:
 484       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 485                         *along, *pncopies);
 486       return;
 487
 488     case GFC_DTYPE_LOGICAL_2:
 489     case GFC_DTYPE_INTEGER_2:
 490       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 491                         *along, *pncopies);
 492       return;
 493
 494     case GFC_DTYPE_LOGICAL_4:
 495     case GFC_DTYPE_INTEGER_4:
 496       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 497                         *along, *pncopies);
 498       return;
 499
 500     case GFC_DTYPE_LOGICAL_8:
 501     case GFC_DTYPE_INTEGER_8:
 502       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 503                         *along, *pncopies);
 504       return;
 505
 506 #ifdef HAVE_GFC_INTEGER_16
 507     case GFC_DTYPE_LOGICAL_16:
 508     case GFC_DTYPE_INTEGER_16:
 509       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 510                         *along, *pncopies);
 511       return;
 512 #endif
 513
 514     case GFC_DTYPE_REAL_4:
 515       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 516                         *along, *pncopies);
 517       return;
 518
 519     case GFC_DTYPE_REAL_8:
 520       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 521                         *along, *pncopies);
 522       return;
 523
 524 /* FIXME: This here is a hack, which will have to be removed when
 525    the array descriptor is reworked.  Currently, we don't store the
 526    kind value for the type, but only the size.  Because on targets with
 527    __float128, we have sizeof(logn double) == sizeof(__float128),
 528    we cannot discriminate here and have to fall back to the generic
 529    handling (which is suboptimal).  */
 530 #if !defined(GFC_REAL_16_IS_FLOAT128)
 531 # ifdef HAVE_GFC_REAL_10
 532     case GFC_DTYPE_REAL_10:
 533       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 534                         *along, *pncopies);
 535       return;
 536 # endif
 537
 538 # ifdef HAVE_GFC_REAL_16
 539     case GFC_DTYPE_REAL_16:
 540       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 541                         *along, *pncopies);
 542       return;
 543 # endif
 544 #endif
 545
 546     case GFC_DTYPE_COMPLEX_4:
 547       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 548                         *along, *pncopies);
 549       return;
 550
 551     case GFC_DTYPE_COMPLEX_8:
 552       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 553                         *along, *pncopies);
 554       return;
 555
 556 /* FIXME: This here is a hack, which will have to be removed when
 557    the array descriptor is reworked.  Currently, we don't store the
 558    kind value for the type, but only the size.  Because on targets with
 559    __float128, we have sizeof(logn double) == sizeof(__float128),
 560    we cannot discriminate here and have to fall back to the generic
 561    handling (which is suboptimal).  */
 562 #if !defined(GFC_REAL_16_IS_FLOAT128)
 563 # ifdef HAVE_GFC_COMPLEX_10
 564     case GFC_DTYPE_COMPLEX_10:
 565       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 566                         *along, *pncopies);
 567       return;
 568 # endif
 569
 570 # ifdef HAVE_GFC_COMPLEX_16
 571     case GFC_DTYPE_COMPLEX_16:
 572       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 573                         *along, *pncopies);
 574       return;
 575 # endif
 576 #endif
 577
 578     }
 579
 580   switch (GFC_DESCRIPTOR_SIZE(ret))
 581     {
 582     case 1:
 583       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 584                         *along, *pncopies);
 585       return;
 586
 587     case 2:
 588       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
 589         break;
 590       else
 591         {
 592           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 593                             *along, *pncopies);
 594           return;
 595         }
 596
 597     case 4:
 598       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
 599         break;
 600       else
 601         {
 602           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 603                             *along, *pncopies);
 604           return;
 605         }
 606
 607     case 8:
 608       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
 609         break;
 610       else
 611         {
 612           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 613                             *along, *pncopies);
 614           return;
 615         }
 616 #ifdef HAVE_GFC_INTEGER_16
 617     case 16:
 618       if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
 619         break;
 620       else
 621         {
 622           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 623                              *along, *pncopies);
 624           return;
 625         }
 626 #endif
 627     default:
 628       break;
 629     }
 630
 631   spread_internal_scalar (ret, source, along, pncopies);
 632 }
 633
 634
 635 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 636                                 const char *, const index_type *,
 637                                 const index_type *, GFC_INTEGER_4);
 638 export_proto(spread_char_scalar);
 639
 640 void
 641 spread_char_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 (GFC_DTYPE_IS_UNSET(ret))
 648     runtime_error ("return array missing descriptor in spread()");
 649   spread_internal_scalar (ret, source, along, pncopies);
 650 }
 651
 652
 653 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
 654                                  const char *, const index_type *,
 655                                  const index_type *, GFC_INTEGER_4);
 656 export_proto(spread_char4_scalar);
 657
 658 void
 659 spread_char4_scalar (gfc_array_char *ret,
 660                      GFC_INTEGER_4 ret_length __attribute__((unused)),
 661                      const char *source, const index_type *along,
 662                      const index_type *pncopies,
 663                      GFC_INTEGER_4 source_length __attribute__((unused)))
 664 {
 665   if (GFC_DTYPE_IS_UNSET(ret))
 666     runtime_error ("return array missing descriptor in spread()");
 667   spread_internal_scalar (ret, source, along, pncopies);
 668
 669 }
 670