libgfortran/intrinsics/spread_generic.c

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