libgfortran/intrinsics/spread_generic.c

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