libgfortran/intrinsics/pack_generic.c

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