libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright (C) 2002-2018 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       GFC_DTYPE_COPY_SETRANK(ret,source,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_LOGICAL_1:
 278     case GFC_DTYPE_INTEGER_1:
 279       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 280                  *along, *pncopies);
 281       return;
 282
 283     case GFC_DTYPE_LOGICAL_2:
 284     case GFC_DTYPE_INTEGER_2:
 285       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 286                  *along, *pncopies);
 287       return;
 288
 289     case GFC_DTYPE_LOGICAL_4:
 290     case GFC_DTYPE_INTEGER_4:
 291       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 292                  *along, *pncopies);
 293       return;
 294
 295     case GFC_DTYPE_LOGICAL_8:
 296     case GFC_DTYPE_INTEGER_8:
 297       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 298                  *along, *pncopies);
 299       return;
 300
 301 #ifdef HAVE_GFC_INTEGER_16
 302     case GFC_DTYPE_LOGICAL_16:
 303     case GFC_DTYPE_INTEGER_16:
 304       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 305                  *along, *pncopies);
 306       return;
 307 #endif
 308
 309     case GFC_DTYPE_REAL_4:
 310       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
 311                  *along, *pncopies);
 312       return;
 313
 314     case GFC_DTYPE_REAL_8:
 315       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
 316                  *along, *pncopies);
 317       return;
 318
 319 /* FIXME: This here is a hack, which will have to be removed when
 320    the array descriptor is reworked.  Currently, we don't store the
 321    kind value for the type, but only the size.  Because on targets with
 322    __float128, we have sizeof(logn double) == sizeof(__float128),
 323    we cannot discriminate here and have to fall back to the generic
 324    handling (which is suboptimal).  */
 325 #if !defined(GFC_REAL_16_IS_FLOAT128)
 326 # ifdef GFC_HAVE_REAL_10
 327     case GFC_DTYPE_REAL_10:
 328       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
 329                  *along, *pncopies);
 330       return;
 331 # endif
 332
 333 # ifdef GFC_HAVE_REAL_16
 334     case GFC_DTYPE_REAL_16:
 335       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
 336                  *along, *pncopies);
 337       return;
 338 # endif
 339 #endif
 340
 341     case GFC_DTYPE_COMPLEX_4:
 342       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
 343                  *along, *pncopies);
 344       return;
 345
 346     case GFC_DTYPE_COMPLEX_8:
 347       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
 348                  *along, *pncopies);
 349       return;
 350
 351 /* FIXME: This here is a hack, which will have to be removed when
 352    the array descriptor is reworked.  Currently, we don't store the
 353    kind value for the type, but only the size.  Because on targets with
 354    __float128, we have sizeof(logn double) == sizeof(__float128),
 355    we cannot discriminate here and have to fall back to the generic
 356    handling (which is suboptimal).  */
 357 #if !defined(GFC_REAL_16_IS_FLOAT128)
 358 # ifdef GFC_HAVE_COMPLEX_10
 359     case GFC_DTYPE_COMPLEX_10:
 360       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
 361                  *along, *pncopies);
 362       return;
 363 # endif
 364
 365 # ifdef GFC_HAVE_COMPLEX_16
 366     case GFC_DTYPE_COMPLEX_16:
 367       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
 368                  *along, *pncopies);
 369       return;
 370 # endif
 371 #endif
 372
 373     }
 374
 375   switch (GFC_DESCRIPTOR_SIZE (ret))
 376     {
 377     case 1:
 378       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 379                  *along, *pncopies);
 380       return;
 381
 382     case 2:
 383       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
 384         break;
 385       else
 386         {
 387           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 388                      *along, *pncopies);
 389           return;
 390         }
 391
 392     case 4:
 393       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
 394         break;
 395       else
 396         {
 397           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 398                      *along, *pncopies);
 399           return;
 400         }
 401
 402     case 8:
 403       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
 404         break;
 405       else
 406         {
 407           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 408                      *along, *pncopies);
 409           return;
 410         }
 411 #ifdef HAVE_GFC_INTEGER_16
 412     case 16:
 413       if (GFC_UNALIGNED_16(ret->base_addr)
 414           || GFC_UNALIGNED_16(source->base_addr))
 415         break;
 416       else
 417         {
 418           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 419                       *along, *pncopies);
 420           return;
 421             }
 422 #endif
 423
 424     }
 425
 426   spread_internal (ret, source, along, pncopies);
 427 }
 428
 429
 430 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 431                          const gfc_array_char *, const index_type *,
 432                          const index_type *, GFC_INTEGER_4);
 433 export_proto(spread_char);
 434
 435 void
 436 spread_char (gfc_array_char *ret,
 437              GFC_INTEGER_4 ret_length __attribute__((unused)),
 438              const gfc_array_char *source, const index_type *along,
 439              const index_type *pncopies,
 440              GFC_INTEGER_4 source_length __attribute__((unused)))
 441 {
 442   spread_internal (ret, source, along, pncopies);
 443 }
 444
 445
 446 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
 447                           const gfc_array_char *, const index_type *,
 448                           const index_type *, GFC_INTEGER_4);
 449 export_proto(spread_char4);
 450
 451 void
 452 spread_char4 (gfc_array_char *ret,
 453               GFC_INTEGER_4 ret_length __attribute__((unused)),
 454               const gfc_array_char *source, const index_type *along,
 455               const index_type *pncopies,
 456               GFC_INTEGER_4 source_length __attribute__((unused)))
 457 {
 458   spread_internal (ret, source, along, pncopies);
 459 }
 460
 461
 462 /* The following are the prototypes for the versions of spread with a
 463    scalar source.  */
 464
 465 extern void spread_scalar (gfc_array_char *, const char *,
 466                            const index_type *, const index_type *);
 467 export_proto(spread_scalar);
 468
 469 void
 470 spread_scalar (gfc_array_char *ret, const char *source,
 471                const index_type *along, const index_type *pncopies)
 472 {
 473   index_type type_size;
 474
 475   if (GFC_DTYPE_IS_UNSET(ret))
 476     runtime_error ("return array missing descriptor in spread()");
 477
 478   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 479   switch(type_size)
 480     {
 481     case GFC_DTYPE_LOGICAL_1:
 482     case GFC_DTYPE_INTEGER_1:
 483       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 484                         *along, *pncopies);
 485       return;
 486
 487     case GFC_DTYPE_LOGICAL_2:
 488     case GFC_DTYPE_INTEGER_2:
 489       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 490                         *along, *pncopies);
 491       return;
 492
 493     case GFC_DTYPE_LOGICAL_4:
 494     case GFC_DTYPE_INTEGER_4:
 495       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 496                         *along, *pncopies);
 497       return;
 498
 499     case GFC_DTYPE_LOGICAL_8:
 500     case GFC_DTYPE_INTEGER_8:
 501       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 502                         *along, *pncopies);
 503       return;
 504
 505 #ifdef HAVE_GFC_INTEGER_16
 506     case GFC_DTYPE_LOGICAL_16:
 507     case GFC_DTYPE_INTEGER_16:
 508       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 509                         *along, *pncopies);
 510       return;
 511 #endif
 512
 513     case GFC_DTYPE_REAL_4:
 514       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 515                         *along, *pncopies);
 516       return;
 517
 518     case GFC_DTYPE_REAL_8:
 519       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 520                         *along, *pncopies);
 521       return;
 522
 523 /* FIXME: This here is a hack, which will have to be removed when
 524    the array descriptor is reworked.  Currently, we don't store the
 525    kind value for the type, but only the size.  Because on targets with
 526    __float128, we have sizeof(logn double) == sizeof(__float128),
 527    we cannot discriminate here and have to fall back to the generic
 528    handling (which is suboptimal).  */
 529 #if !defined(GFC_REAL_16_IS_FLOAT128)
 530 # ifdef HAVE_GFC_REAL_10
 531     case GFC_DTYPE_REAL_10:
 532       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 533                         *along, *pncopies);
 534       return;
 535 # endif
 536
 537 # ifdef HAVE_GFC_REAL_16
 538     case GFC_DTYPE_REAL_16:
 539       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 540                         *along, *pncopies);
 541       return;
 542 # endif
 543 #endif
 544
 545     case GFC_DTYPE_COMPLEX_4:
 546       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 547                         *along, *pncopies);
 548       return;
 549
 550     case GFC_DTYPE_COMPLEX_8:
 551       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 552                         *along, *pncopies);
 553       return;
 554
 555 /* FIXME: This here is a hack, which will have to be removed when
 556    the array descriptor is reworked.  Currently, we don't store the
 557    kind value for the type, but only the size.  Because on targets with
 558    __float128, we have sizeof(logn double) == sizeof(__float128),
 559    we cannot discriminate here and have to fall back to the generic
 560    handling (which is suboptimal).  */
 561 #if !defined(GFC_REAL_16_IS_FLOAT128)
 562 # ifdef HAVE_GFC_COMPLEX_10
 563     case GFC_DTYPE_COMPLEX_10:
 564       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 565                         *along, *pncopies);
 566       return;
 567 # endif
 568
 569 # ifdef HAVE_GFC_COMPLEX_16
 570     case GFC_DTYPE_COMPLEX_16:
 571       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 572                         *along, *pncopies);
 573       return;
 574 # endif
 575 #endif
 576
 577     }
 578
 579   switch (GFC_DESCRIPTOR_SIZE(ret))
 580     {
 581     case 1:
 582       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 583                         *along, *pncopies);
 584       return;
 585
 586     case 2:
 587       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
 588         break;
 589       else
 590         {
 591           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 592                             *along, *pncopies);
 593           return;
 594         }
 595
 596     case 4:
 597       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
 598         break;
 599       else
 600         {
 601           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 602                             *along, *pncopies);
 603           return;
 604         }
 605
 606     case 8:
 607       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
 608         break;
 609       else
 610         {
 611           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 612                             *along, *pncopies);
 613           return;
 614         }
 615 #ifdef HAVE_GFC_INTEGER_16
 616     case 16:
 617       if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
 618         break;
 619       else
 620         {
 621           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 622                              *along, *pncopies);
 623           return;
 624         }
 625 #endif
 626     default:
 627       break;
 628     }
 629
 630   spread_internal_scalar (ret, source, along, pncopies);
 631 }
 632
 633
 634 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 635                                 const char *, const index_type *,
 636                                 const index_type *, GFC_INTEGER_4);
 637 export_proto(spread_char_scalar);
 638
 639 void
 640 spread_char_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 (GFC_DTYPE_IS_UNSET(ret))
 647     runtime_error ("return array missing descriptor in spread()");
 648   spread_internal_scalar (ret, source, along, pncopies);
 649 }
 650
 651
 652 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
 653                                  const char *, const index_type *,
 654                                  const index_type *, GFC_INTEGER_4);
 655 export_proto(spread_char4_scalar);
 656
 657 void
 658 spread_char4_scalar (gfc_array_char *ret,
 659                      GFC_INTEGER_4 ret_length __attribute__((unused)),
 660                      const char *source, const index_type *along,
 661                      const index_type *pncopies,
 662                      GFC_INTEGER_4 source_length __attribute__((unused)))
 663 {
 664   if (GFC_DTYPE_IS_UNSET(ret))
 665     runtime_error ("return array missing descriptor in spread()");
 666   spread_internal_scalar (ret, source, along, pncopies);
 667
 668 }
 669