libgfortran/intrinsics/pack_generic.c

   1 /* Generic implementation of the PACK 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 /* PACK is specified as follows:
  30
  31    13.14.80 PACK (ARRAY, MASK, [VECTOR])
  32
  33    Description: Pack an array into an array of rank one under the
  34    control of a mask.
  35
  36    Class: Transformational function.
  37
  38    Arguments:
  39       ARRAY   may be of any type. It shall not be scalar.
  40       MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
  41       VECTOR  (optional) shall be of the same type and type parameters
  42               as ARRAY. VECTOR shall have at least as many elements as
  43               there are true elements in MASK. If MASK is a scalar
  44               with the value true, VECTOR shall have at least as many
  45               elements as there are in ARRAY.
  46
  47    Result Characteristics: The result is an array of rank one with the
  48    same type and type parameters as ARRAY. If VECTOR is present, the
  49    result size is that of VECTOR; otherwise, the result size is the
  50    number /t/ of true elements in MASK unless MASK is scalar with the
  51    value true, in which case the result size is the size of ARRAY.
  52
  53    Result Value: Element /i/ of the result is the element of ARRAY
  54    that corresponds to the /i/th true element of MASK, taking elements
  55    in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
  56    present and has size /n/ > /t/, element /i/ of the result has the
  57    value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
  58
  59    Examples: The nonzero elements of an array M with the value
  60    | 0 0 0 |
  61    | 9 0 0 | may be "gathered" by the function PACK. The result of
  62    | 0 0 7 |
  63    PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
  64    VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
  65
  66 There are two variants of the PACK intrinsic: one, where MASK is
  67 array valued, and the other one where MASK is scalar.  */
  68
  69 static void
  70 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
  71                const gfc_array_l1 *mask, const gfc_array_char *vector,
  72                index_type size)
  73 {
  74   /* r.* indicates the return array.  */
  75   index_type rstride0;
  76   char * restrict rptr;
  77   /* s.* indicates the source array.  */
  78   index_type sstride[GFC_MAX_DIMENSIONS];
  79   index_type sstride0;
  80   const char *sptr;
  81   /* m.* indicates the mask array.  */
  82   index_type mstride[GFC_MAX_DIMENSIONS];
  83   index_type mstride0;
  84   const GFC_LOGICAL_1 *mptr;
  85
  86   index_type count[GFC_MAX_DIMENSIONS];
  87   index_type extent[GFC_MAX_DIMENSIONS];
  88   bool zero_sized;
  89   index_type n;
  90   index_type dim;
  91   index_type nelem;
  92   index_type total;
  93   int mask_kind;
  94
  95   dim = GFC_DESCRIPTOR_RANK (array);
  96
  97   sstride[0] = 0; /* Avoid warnings if not initialized.  */
  98   mstride[0] = 0;
  99
 100   sptr = array->base_addr;
 101   mptr = mask->base_addr;
 102
 103   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 104      and using shifting to address size and endian issues.  */
 105
 106   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 107
 108   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 109 #ifdef HAVE_GFC_LOGICAL_16
 110       || mask_kind == 16
 111 #endif
 112       )
 113     {
 114       /*  Don't convert a NULL pointer as we use test for NULL below.  */
 115       if (mptr)
 116         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 117     }
 118   else
 119     runtime_error ("Funny sized logical array");
 120
 121   zero_sized = false;
 122   for (n = 0; n < dim; n++)
 123     {
 124       count[n] = 0;
 125       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 126       if (extent[n] <= 0)
 127         zero_sized = true;
 128       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 129       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 130     }
 131   if (sstride[0] == 0)
 132     sstride[0] = size;
 133   if (mstride[0] == 0)
 134     mstride[0] = mask_kind;
 135
 136   if (zero_sized)
 137     sptr = NULL;
 138   else
 139     sptr = array->base_addr;
 140
 141   if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
 142     {
 143       /* Count the elements, either for allocating memory or
 144          for bounds checking.  */
 145
 146       if (vector != NULL)
 147         {
 148           /* The return array will have as many
 149              elements as there are in VECTOR.  */
 150           total = GFC_DESCRIPTOR_EXTENT(vector,0);
 151         }
 152       else
 153         {
 154           /* We have to count the true elements in MASK.  */
 155
 156           total = count_0 (mask);
 157         }
 158
 159       if (ret->base_addr == NULL)
 160         {
 161           /* Setup the array descriptor.  */
 162           GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
 163
 164           ret->offset = 0;
 165           /* xmallocarray allocates a single byte for zero size.  */
 166           ret->base_addr = xmallocarray (total, size);
 167
 168           if (total == 0)
 169             return;      /* In this case, nothing remains to be done.  */
 170         }
 171       else
 172         {
 173           /* We come here because of range checking.  */
 174           index_type ret_extent;
 175
 176           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
 177           if (total != ret_extent)
 178             runtime_error ("Incorrect extent in return value of PACK intrinsic;"
 179                            " is %ld, should be %ld", (long int) total,
 180                            (long int) ret_extent);
 181         }
 182     }
 183
 184   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 185   if (rstride0 == 0)
 186     rstride0 = size;
 187   sstride0 = sstride[0];
 188   mstride0 = mstride[0];
 189   rptr = ret->base_addr;
 190
 191   while (sptr && mptr)
 192     {
 193       /* Test this element.  */
 194       if (*mptr)
 195         {
 196           /* Add it.  */
 197           memcpy (rptr, sptr, size);
 198           rptr += rstride0;
 199         }
 200       /* Advance to the next element.  */
 201       sptr += sstride0;
 202       mptr += mstride0;
 203       count[0]++;
 204       n = 0;
 205       while (count[n] == extent[n])
 206         {
 207           /* When we get to the end of a dimension, reset it and increment
 208              the next dimension.  */
 209           count[n] = 0;
 210           /* We could precalculate these products, but this is a less
 211              frequently used path so probably not worth it.  */
 212           sptr -= sstride[n] * extent[n];
 213           mptr -= mstride[n] * extent[n];
 214           n++;
 215           if (n >= dim)
 216             {
 217               /* Break out of the loop.  */
 218               sptr = NULL;
 219               break;
 220             }
 221           else
 222             {
 223               count[n]++;
 224               sptr += sstride[n];
 225               mptr += mstride[n];
 226             }
 227         }
 228     }
 229
 230   /* Add any remaining elements from VECTOR.  */
 231   if (vector)
 232     {
 233       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 234       nelem = ((rptr - ret->base_addr) / rstride0);
 235       if (n > nelem)
 236         {
 237           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 238           if (sstride0 == 0)
 239             sstride0 = size;
 240
 241           sptr = vector->base_addr + sstride0 * nelem;
 242           n -= nelem;
 243           while (n--)
 244             {
 245               memcpy (rptr, sptr, size);
 246               rptr += rstride0;
 247               sptr += sstride0;
 248             }
 249         }
 250     }
 251 }
 252
 253 extern void pack (gfc_array_char *, const gfc_array_char *,
 254                   const gfc_array_l1 *, const gfc_array_char *);
 255 export_proto(pack);
 256
 257 void
 258 pack (gfc_array_char *ret, const gfc_array_char *array,
 259       const gfc_array_l1 *mask, const gfc_array_char *vector)
 260 {
 261   index_type type_size;
 262   index_type size;
 263
 264   type_size = GFC_DTYPE_TYPE_SIZE(array);
 265
 266   switch(type_size)
 267     {
 268     case GFC_DTYPE_LOGICAL_1:
 269     case GFC_DTYPE_INTEGER_1:
 270       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
 271                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
 272       return;
 273
 274     case GFC_DTYPE_LOGICAL_2:
 275     case GFC_DTYPE_INTEGER_2:
 276       pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 277                (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 278       return;
 279
 280     case GFC_DTYPE_LOGICAL_4:
 281     case GFC_DTYPE_INTEGER_4:
 282       pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 283                (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 284       return;
 285
 286     case GFC_DTYPE_LOGICAL_8:
 287     case GFC_DTYPE_INTEGER_8:
 288       pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 289                (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 290       return;
 291
 292 #ifdef HAVE_GFC_INTEGER_16
 293     case GFC_DTYPE_LOGICAL_16:
 294     case GFC_DTYPE_INTEGER_16:
 295       pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 296                 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 297       return;
 298 #endif
 299
 300     case GFC_DTYPE_REAL_4:
 301       pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
 302                (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
 303       return;
 304
 305     case GFC_DTYPE_REAL_8:
 306       pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
 307                (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
 308       return;
 309
 310 /* FIXME: This here is a hack, which will have to be removed when
 311    the array descriptor is reworked.  Currently, we don't store the
 312    kind value for the type, but only the size.  Because on targets with
 313    _Float128, we have sizeof(long double) == sizeof(_Float128),
 314    we cannot discriminate here and have to fall back to the generic
 315    handling (which is suboptimal).  */
 316 #if !defined(GFC_REAL_16_IS_FLOAT128)
 317 # ifdef HAVE_GFC_REAL_10
 318     case GFC_DTYPE_REAL_10:
 319       pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
 320                 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
 321       return;
 322 # endif
 323
 324 # ifdef HAVE_GFC_REAL_16
 325     case GFC_DTYPE_REAL_16:
 326       pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
 327                 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
 328       return;
 329 # endif
 330 #endif
 331
 332     case GFC_DTYPE_COMPLEX_4:
 333       pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
 334                (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
 335       return;
 336
 337     case GFC_DTYPE_COMPLEX_8:
 338       pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
 339                (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
 340       return;
 341
 342 /* FIXME: This here is a hack, which will have to be removed when
 343    the array descriptor is reworked.  Currently, we don't store the
 344    kind value for the type, but only the size.  Because on targets with
 345    _Float128, we have sizeof(long double) == sizeof(_Float128),
 346    we cannot discriminate here and have to fall back to the generic
 347    handling (which is suboptimal).  */
 348 #if !defined(GFC_REAL_16_IS_FLOAT128)
 349 # ifdef HAVE_GFC_COMPLEX_10
 350     case GFC_DTYPE_COMPLEX_10:
 351       pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
 352                 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
 353       return;
 354 # endif
 355
 356 # ifdef HAVE_GFC_COMPLEX_16
 357     case GFC_DTYPE_COMPLEX_16:
 358       pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
 359                 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
 360       return;
 361 # endif
 362 #endif
 363     }
 364
 365   /* For other types, let's check the actual alignment of the data pointers.
 366      If they are aligned, we can safely call the unpack functions.  */
 367
 368   switch (GFC_DESCRIPTOR_SIZE (array))
 369     {
 370     case 1:
 371       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
 372                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
 373       return;
 374
 375     case 2:
 376       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
 377           || (vector && GFC_UNALIGNED_2(vector->base_addr)))
 378         break;
 379       else
 380         {
 381           pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 382                    (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 383           return;
 384         }
 385
 386     case 4:
 387       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
 388           || (vector && GFC_UNALIGNED_4(vector->base_addr)))
 389         break;
 390       else
 391         {
 392           pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 393                    (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 394           return;
 395         }
 396
 397     case 8:
 398       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
 399           || (vector && GFC_UNALIGNED_8(vector->base_addr)))
 400         break;
 401       else
 402         {
 403           pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 404                    (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 405           return;
 406         }
 407
 408 #ifdef HAVE_GFC_INTEGER_16
 409     case 16:
 410       if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
 411           || (vector && GFC_UNALIGNED_16(vector->base_addr)))
 412         break;
 413       else
 414         {
 415           pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 416                     (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 417           return;
 418         }
 419 #endif
 420     default:
 421       break;
 422     }
 423
 424   size = GFC_DESCRIPTOR_SIZE (array);
 425   pack_internal (ret, array, mask, vector, size);
 426 }
 427
 428
 429 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 430                        const gfc_array_l1 *, const gfc_array_char *,
 431                        GFC_INTEGER_4, GFC_INTEGER_4);
 432 export_proto(pack_char);
 433
 434 void
 435 pack_char (gfc_array_char *ret,
 436            GFC_INTEGER_4 ret_length __attribute__((unused)),
 437            const gfc_array_char *array, const gfc_array_l1 *mask,
 438            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 439            GFC_INTEGER_4 vector_length __attribute__((unused)))
 440 {
 441   pack_internal (ret, array, mask, vector, array_length);
 442 }
 443
 444
 445 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 446                         const gfc_array_l1 *, const gfc_array_char *,
 447                         GFC_INTEGER_4, GFC_INTEGER_4);
 448 export_proto(pack_char4);
 449
 450 void
 451 pack_char4 (gfc_array_char *ret,
 452             GFC_INTEGER_4 ret_length __attribute__((unused)),
 453             const gfc_array_char *array, const gfc_array_l1 *mask,
 454             const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 455             GFC_INTEGER_4 vector_length __attribute__((unused)))
 456 {
 457   pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
 458 }
 459
 460
 461 static void
 462 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
 463                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
 464                  index_type size)
 465 {
 466   /* r.* indicates the return array.  */
 467   index_type rstride0;
 468   char *rptr;
 469   /* s.* indicates the source array.  */
 470   index_type sstride[GFC_MAX_DIMENSIONS];
 471   index_type sstride0;
 472   const char *sptr;
 473
 474   index_type count[GFC_MAX_DIMENSIONS];
 475   index_type extent[GFC_MAX_DIMENSIONS];
 476   index_type n;
 477   index_type dim;
 478   index_type ssize;
 479   index_type nelem;
 480   index_type total;
 481
 482   dim = GFC_DESCRIPTOR_RANK (array);
 483   /* Initialize sstride[0] to avoid -Wmaybe-uninitialized
 484      complaints.  */
 485   sstride[0] = size;
 486   ssize = 1;
 487   for (n = 0; n < dim; n++)
 488     {
 489       count[n] = 0;
 490       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 491       if (extent[n] < 0)
 492         extent[n] = 0;
 493
 494       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 495       ssize *= extent[n];
 496     }
 497   if (sstride[0] == 0)
 498     sstride[0] = size;
 499
 500   sstride0 = sstride[0];
 501
 502   if (ssize != 0)
 503     sptr = array->base_addr;
 504   else
 505     sptr = NULL;
 506
 507   if (ret->base_addr == NULL)
 508     {
 509       /* Allocate the memory for the result.  */
 510
 511       if (vector != NULL)
 512         {
 513           /* The return array will have as many elements as there are
 514              in vector.  */
 515           total = GFC_DESCRIPTOR_EXTENT(vector,0);
 516           if (total <= 0)
 517             {
 518               total = 0;
 519               vector = NULL;
 520             }
 521         }
 522       else
 523         {
 524           if (*mask)
 525             {
 526               /* The result array will have as many elements as the input
 527                  array.  */
 528               total = extent[0];
 529               for (n = 1; n < dim; n++)
 530                 total *= extent[n];
 531             }
 532           else
 533             /* The result array will be empty.  */
 534             total = 0;
 535         }
 536
 537       /* Setup the array descriptor.  */
 538       GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
 539
 540       ret->offset = 0;
 541
 542       ret->base_addr = xmallocarray (total, size);
 543
 544       if (total == 0)
 545         return;
 546     }
 547
 548   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 549   if (rstride0 == 0)
 550     rstride0 = size;
 551   rptr = ret->base_addr;
 552
 553   /* The remaining possibilities are now:
 554        If MASK is .TRUE., we have to copy the source array into the
 555      result array. We then have to fill it up with elements from VECTOR.
 556        If MASK is .FALSE., we have to copy VECTOR into the result
 557      array. If VECTOR were not present we would have already returned.  */
 558
 559   if (*mask && ssize != 0)
 560     {
 561       while (sptr)
 562         {
 563           /* Add this element.  */
 564           memcpy (rptr, sptr, size);
 565           rptr += rstride0;
 566
 567           /* Advance to the next element.  */
 568           sptr += sstride0;
 569           count[0]++;
 570           n = 0;
 571           while (count[n] == extent[n])
 572             {
 573               /* When we get to the end of a dimension, reset it and
 574                  increment the next dimension.  */
 575               count[n] = 0;
 576               /* We could precalculate these products, but this is a
 577                  less frequently used path so probably not worth it.  */
 578               sptr -= sstride[n] * extent[n];
 579               n++;
 580               if (n >= dim)
 581                 {
 582                   /* Break out of the loop.  */
 583                   sptr = NULL;
 584                   break;
 585                 }
 586               else
 587                 {
 588                   count[n]++;
 589                   sptr += sstride[n];
 590                 }
 591             }
 592         }
 593     }
 594
 595   /* Add any remaining elements from VECTOR.  */
 596   if (vector)
 597     {
 598       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 599       nelem = ((rptr - ret->base_addr) / rstride0);
 600       if (n > nelem)
 601         {
 602           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 603           if (sstride0 == 0)
 604             sstride0 = size;
 605
 606           sptr = vector->base_addr + sstride0 * nelem;
 607           n -= nelem;
 608           while (n--)
 609             {
 610               memcpy (rptr, sptr, size);
 611               rptr += rstride0;
 612               sptr += sstride0;
 613             }
 614         }
 615     }
 616 }
 617
 618 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
 619                     const GFC_LOGICAL_4 *, const gfc_array_char *);
 620 export_proto(pack_s);
 621
 622 void
 623 pack_s (gfc_array_char *ret, const gfc_array_char *array,
 624         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
 625 {
 626   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 627 }
 628
 629
 630 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
 631                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
 632                          const gfc_array_char *, GFC_INTEGER_4,
 633                          GFC_INTEGER_4);
 634 export_proto(pack_s_char);
 635
 636 void
 637 pack_s_char (gfc_array_char *ret,
 638              GFC_INTEGER_4 ret_length __attribute__((unused)),
 639              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 640              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 641              GFC_INTEGER_4 vector_length __attribute__((unused)))
 642 {
 643   pack_s_internal (ret, array, mask, vector, array_length);
 644 }
 645
 646
 647 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
 648                           const gfc_array_char *array, const GFC_LOGICAL_4 *,
 649                           const gfc_array_char *, GFC_INTEGER_4,
 650                           GFC_INTEGER_4);
 651 export_proto(pack_s_char4);
 652
 653 void
 654 pack_s_char4 (gfc_array_char *ret,
 655               GFC_INTEGER_4 ret_length __attribute__((unused)),
 656               const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 657               const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 658               GFC_INTEGER_4 vector_length __attribute__((unused)))
 659 {
 660   pack_s_internal (ret, array, mask, vector,
 661                    array_length * sizeof (gfc_char4_t));
 662 }