libgfortran/intrinsics/spread_generic.c

   1 /* Generic implementation of the SPREAD intrinsic
   2    Copyright 2002, 2005, 2006, 2007, 2009, 2010, 2012
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5
   6 This file is part of the GNU Fortran runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Ligbfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <stdlib.h>
  29 #include <assert.h>
  30 #include <string.h>
  31
  32 static void
  33 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
  34                  const index_type *along, const index_type *pncopies)
  35 {
  36   /* r.* indicates the return array.  */
  37   index_type rstride[GFC_MAX_DIMENSIONS];
  38   index_type rstride0;
  39   index_type rdelta = 0;
  40   index_type rrank;
  41   index_type rs;
  42   char *rptr;
  43   char *dest;
  44   /* s.* indicates the source array.  */
  45   index_type sstride[GFC_MAX_DIMENSIONS];
  46   index_type sstride0;
  47   index_type srank;
  48   const char *sptr;
  49
  50   index_type count[GFC_MAX_DIMENSIONS];
  51   index_type extent[GFC_MAX_DIMENSIONS];
  52   index_type n;
  53   index_type dim;
  54   index_type ncopies;
  55   index_type size;
  56
  57   size = GFC_DESCRIPTOR_SIZE(source);
  58
  59   srank = GFC_DESCRIPTOR_RANK(source);
  60
  61   rrank = srank + 1;
  62   if (rrank > GFC_MAX_DIMENSIONS)
  63     runtime_error ("return rank too large in spread()");
  64
  65   if (*along > rrank)
  66       runtime_error ("dim outside of rank in spread()");
  67
  68   ncopies = *pncopies;
  69
  70   if (ret->base_addr == NULL)
  71     {
  72       /* The front end has signalled that we need to populate the
  73          return array descriptor.  */
  74
  75       size_t ub, stride;
  76
  77       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
  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 = xmalloc (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 = xmalloc (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_DERIVED_1:
 281     case GFC_DTYPE_LOGICAL_1:
 282     case GFC_DTYPE_INTEGER_1:
 283       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
 284                  *along, *pncopies);
 285       return;
 286
 287     case GFC_DTYPE_LOGICAL_2:
 288     case GFC_DTYPE_INTEGER_2:
 289       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 290                  *along, *pncopies);
 291       return;
 292
 293     case GFC_DTYPE_LOGICAL_4:
 294     case GFC_DTYPE_INTEGER_4:
 295       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 296                  *along, *pncopies);
 297       return;
 298
 299     case GFC_DTYPE_LOGICAL_8:
 300     case GFC_DTYPE_INTEGER_8:
 301       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 302                  *along, *pncopies);
 303       return;
 304
 305 #ifdef HAVE_GFC_INTEGER_16
 306     case GFC_DTYPE_LOGICAL_16:
 307     case GFC_DTYPE_INTEGER_16:
 308       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 309                  *along, *pncopies);
 310       return;
 311 #endif
 312
 313     case GFC_DTYPE_REAL_4:
 314       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
 315                  *along, *pncopies);
 316       return;
 317
 318     case GFC_DTYPE_REAL_8:
 319       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
 320                  *along, *pncopies);
 321       return;
 322
 323 /* FIXME: This here is a hack, which will have to be removed when
 324    the array descriptor is reworked.  Currently, we don't store the
 325    kind value for the type, but only the size.  Because on targets with
 326    __float128, we have sizeof(logn double) == sizeof(__float128),
 327    we cannot discriminate here and have to fall back to the generic
 328    handling (which is suboptimal).  */
 329 #if !defined(GFC_REAL_16_IS_FLOAT128)
 330 # ifdef GFC_HAVE_REAL_10
 331     case GFC_DTYPE_REAL_10:
 332       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
 333                  *along, *pncopies);
 334       return;
 335 # endif
 336
 337 # ifdef GFC_HAVE_REAL_16
 338     case GFC_DTYPE_REAL_16:
 339       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
 340                  *along, *pncopies);
 341       return;
 342 # endif
 343 #endif
 344
 345     case GFC_DTYPE_COMPLEX_4:
 346       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
 347                  *along, *pncopies);
 348       return;
 349
 350     case GFC_DTYPE_COMPLEX_8:
 351       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
 352                  *along, *pncopies);
 353       return;
 354
 355 /* FIXME: This here is a hack, which will have to be removed when
 356    the array descriptor is reworked.  Currently, we don't store the
 357    kind value for the type, but only the size.  Because on targets with
 358    __float128, we have sizeof(logn double) == sizeof(__float128),
 359    we cannot discriminate here and have to fall back to the generic
 360    handling (which is suboptimal).  */
 361 #if !defined(GFC_REAL_16_IS_FLOAT128)
 362 # ifdef GFC_HAVE_COMPLEX_10
 363     case GFC_DTYPE_COMPLEX_10:
 364       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
 365                  *along, *pncopies);
 366       return;
 367 # endif
 368
 369 # ifdef GFC_HAVE_COMPLEX_16
 370     case GFC_DTYPE_COMPLEX_16:
 371       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
 372                  *along, *pncopies);
 373       return;
 374 # endif
 375 #endif
 376
 377     case GFC_DTYPE_DERIVED_2:
 378       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
 379         break;
 380       else
 381         {
 382           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
 383                      *along, *pncopies);
 384           return;
 385         }
 386
 387     case GFC_DTYPE_DERIVED_4:
 388       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
 389         break;
 390       else
 391         {
 392           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
 393                      *along, *pncopies);
 394           return;
 395         }
 396
 397     case GFC_DTYPE_DERIVED_8:
 398       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
 399         break;
 400       else
 401         {
 402           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
 403                      *along, *pncopies);
 404           return;
 405         }
 406
 407 #ifdef HAVE_GFC_INTEGER_16
 408     case GFC_DTYPE_DERIVED_16:
 409       if (GFC_UNALIGNED_16(ret->base_addr)
 410           || GFC_UNALIGNED_16(source->base_addr))
 411         break;
 412       else
 413         {
 414           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
 415                       *along, *pncopies);
 416           return;
 417         }
 418 #endif
 419     }
 420
 421   spread_internal (ret, source, along, pncopies);
 422 }
 423
 424
 425 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
 426                          const gfc_array_char *, const index_type *,
 427                          const index_type *, GFC_INTEGER_4);
 428 export_proto(spread_char);
 429
 430 void
 431 spread_char (gfc_array_char *ret,
 432              GFC_INTEGER_4 ret_length __attribute__((unused)),
 433              const gfc_array_char *source, const index_type *along,
 434              const index_type *pncopies,
 435              GFC_INTEGER_4 source_length __attribute__((unused)))
 436 {
 437   spread_internal (ret, source, along, pncopies);
 438 }
 439
 440
 441 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
 442                           const gfc_array_char *, const index_type *,
 443                           const index_type *, GFC_INTEGER_4);
 444 export_proto(spread_char4);
 445
 446 void
 447 spread_char4 (gfc_array_char *ret,
 448               GFC_INTEGER_4 ret_length __attribute__((unused)),
 449               const gfc_array_char *source, const index_type *along,
 450               const index_type *pncopies,
 451               GFC_INTEGER_4 source_length __attribute__((unused)))
 452 {
 453   spread_internal (ret, source, along, pncopies);
 454 }
 455
 456
 457 /* The following are the prototypes for the versions of spread with a
 458    scalar source.  */
 459
 460 extern void spread_scalar (gfc_array_char *, const char *,
 461                            const index_type *, const index_type *);
 462 export_proto(spread_scalar);
 463
 464 void
 465 spread_scalar (gfc_array_char *ret, const char *source,
 466                const index_type *along, const index_type *pncopies)
 467 {
 468   index_type type_size;
 469
 470   if (!ret->dtype)
 471     runtime_error ("return array missing descriptor in spread()");
 472
 473   type_size = GFC_DTYPE_TYPE_SIZE(ret);
 474   switch(type_size)
 475     {
 476     case GFC_DTYPE_DERIVED_1:
 477     case GFC_DTYPE_LOGICAL_1:
 478     case GFC_DTYPE_INTEGER_1:
 479       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
 480                         *along, *pncopies);
 481       return;
 482
 483     case GFC_DTYPE_LOGICAL_2:
 484     case GFC_DTYPE_INTEGER_2:
 485       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 486                         *along, *pncopies);
 487       return;
 488
 489     case GFC_DTYPE_LOGICAL_4:
 490     case GFC_DTYPE_INTEGER_4:
 491       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 492                         *along, *pncopies);
 493       return;
 494
 495     case GFC_DTYPE_LOGICAL_8:
 496     case GFC_DTYPE_INTEGER_8:
 497       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 498                         *along, *pncopies);
 499       return;
 500
 501 #ifdef HAVE_GFC_INTEGER_16
 502     case GFC_DTYPE_LOGICAL_16:
 503     case GFC_DTYPE_INTEGER_16:
 504       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 505                         *along, *pncopies);
 506       return;
 507 #endif
 508
 509     case GFC_DTYPE_REAL_4:
 510       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
 511                         *along, *pncopies);
 512       return;
 513
 514     case GFC_DTYPE_REAL_8:
 515       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
 516                         *along, *pncopies);
 517       return;
 518
 519 /* FIXME: This here is a hack, which will have to be removed when
 520    the array descriptor is reworked.  Currently, we don't store the
 521    kind value for the type, but only the size.  Because on targets with
 522    __float128, we have sizeof(logn double) == sizeof(__float128),
 523    we cannot discriminate here and have to fall back to the generic
 524    handling (which is suboptimal).  */
 525 #if !defined(GFC_REAL_16_IS_FLOAT128)
 526 # ifdef HAVE_GFC_REAL_10
 527     case GFC_DTYPE_REAL_10:
 528       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
 529                         *along, *pncopies);
 530       return;
 531 # endif
 532
 533 # ifdef HAVE_GFC_REAL_16
 534     case GFC_DTYPE_REAL_16:
 535       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
 536                         *along, *pncopies);
 537       return;
 538 # endif
 539 #endif
 540
 541     case GFC_DTYPE_COMPLEX_4:
 542       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
 543                         *along, *pncopies);
 544       return;
 545
 546     case GFC_DTYPE_COMPLEX_8:
 547       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
 548                         *along, *pncopies);
 549       return;
 550
 551 /* FIXME: This here is a hack, which will have to be removed when
 552    the array descriptor is reworked.  Currently, we don't store the
 553    kind value for the type, but only the size.  Because on targets with
 554    __float128, we have sizeof(logn double) == sizeof(__float128),
 555    we cannot discriminate here and have to fall back to the generic
 556    handling (which is suboptimal).  */
 557 #if !defined(GFC_REAL_16_IS_FLOAT128)
 558 # ifdef HAVE_GFC_COMPLEX_10
 559     case GFC_DTYPE_COMPLEX_10:
 560       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
 561                         *along, *pncopies);
 562       return;
 563 # endif
 564
 565 # ifdef HAVE_GFC_COMPLEX_16
 566     case GFC_DTYPE_COMPLEX_16:
 567       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
 568                         *along, *pncopies);
 569       return;
 570 # endif
 571 #endif
 572
 573     case GFC_DTYPE_DERIVED_2:
 574       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
 575         break;
 576       else
 577         {
 578           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
 579                             *along, *pncopies);
 580           return;
 581         }
 582
 583     case GFC_DTYPE_DERIVED_4:
 584       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
 585         break;
 586       else
 587         {
 588           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
 589                             *along, *pncopies);
 590           return;
 591         }
 592
 593     case GFC_DTYPE_DERIVED_8:
 594       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
 595         break;
 596       else
 597         {
 598           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
 599                             *along, *pncopies);
 600           return;
 601         }
 602 #ifdef HAVE_GFC_INTEGER_16
 603     case GFC_DTYPE_DERIVED_16:
 604       if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
 605         break;
 606       else
 607         {
 608           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
 609                              *along, *pncopies);
 610           return;
 611         }
 612 #endif
 613     }
 614
 615   spread_internal_scalar (ret, source, along, pncopies);
 616 }
 617
 618
 619 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
 620                                 const char *, const index_type *,
 621                                 const index_type *, GFC_INTEGER_4);
 622 export_proto(spread_char_scalar);
 623
 624 void
 625 spread_char_scalar (gfc_array_char *ret,
 626                     GFC_INTEGER_4 ret_length __attribute__((unused)),
 627                     const char *source, const index_type *along,
 628                     const index_type *pncopies,
 629                     GFC_INTEGER_4 source_length __attribute__((unused)))
 630 {
 631   if (!ret->dtype)
 632     runtime_error ("return array missing descriptor in spread()");
 633   spread_internal_scalar (ret, source, along, pncopies);
 634 }
 635
 636
 637 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
 638                                  const char *, const index_type *,
 639                                  const index_type *, GFC_INTEGER_4);
 640 export_proto(spread_char4_scalar);
 641
 642 void
 643 spread_char4_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 (!ret->dtype)
 650     runtime_error ("return array missing descriptor in spread()");
 651   spread_internal_scalar (ret, source, along, pncopies);
 652
 653 }
 654