libgfortran/intrinsics/pack_generic.c

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