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           if (total == 0)
 157             {
 158               /* In this case, nothing remains to be done.  */
 159               ret->data = internal_malloc_size (1);
 160               return;
 161             }
 162           else
 163             ret->data = internal_malloc_size (size * total);
 164         }
 165       else
 166         {
 167           /* We come here because of range checking.  */
 168           index_type ret_extent;
 169
 170           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
 171           if (total != ret_extent)
 172             runtime_error ("Incorrect extent in return value of PACK intrinsic;"
 173                            " is %ld, should be %ld", (long int) total,
 174                            (long int) ret_extent);
 175         }
 176     }
 177
 178   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 179   if (rstride0 == 0)
 180     rstride0 = size;
 181   sstride0 = sstride[0];
 182   mstride0 = mstride[0];
 183   rptr = ret->data;
 184
 185   while (sptr && mptr)
 186     {
 187       /* Test this element.  */
 188       if (*mptr)
 189         {
 190           /* Add it.  */
 191           memcpy (rptr, sptr, size);
 192           rptr += rstride0;
 193         }
 194       /* Advance to the next element.  */
 195       sptr += sstride0;
 196       mptr += mstride0;
 197       count[0]++;
 198       n = 0;
 199       while (count[n] == extent[n])
 200         {
 201           /* When we get to the end of a dimension, reset it and increment
 202              the next dimension.  */
 203           count[n] = 0;
 204           /* We could precalculate these products, but this is a less
 205              frequently used path so probably not worth it.  */
 206           sptr -= sstride[n] * extent[n];
 207           mptr -= mstride[n] * extent[n];
 208           n++;
 209           if (n >= dim)
 210             {
 211               /* Break out of the loop.  */
 212               sptr = NULL;
 213               break;
 214             }
 215           else
 216             {
 217               count[n]++;
 218               sptr += sstride[n];
 219               mptr += mstride[n];
 220             }
 221         }
 222     }
 223
 224   /* Add any remaining elements from VECTOR.  */
 225   if (vector)
 226     {
 227       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 228       nelem = ((rptr - ret->data) / rstride0);
 229       if (n > nelem)
 230         {
 231           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 232           if (sstride0 == 0)
 233             sstride0 = size;
 234
 235           sptr = vector->data + sstride0 * nelem;
 236           n -= nelem;
 237           while (n--)
 238             {
 239               memcpy (rptr, sptr, size);
 240               rptr += rstride0;
 241               sptr += sstride0;
 242             }
 243         }
 244     }
 245 }
 246
 247 extern void pack (gfc_array_char *, const gfc_array_char *,
 248                   const gfc_array_l1 *, const gfc_array_char *);
 249 export_proto(pack);
 250
 251 void
 252 pack (gfc_array_char *ret, const gfc_array_char *array,
 253       const gfc_array_l1 *mask, const gfc_array_char *vector)
 254 {
 255   index_type type_size;
 256   index_type size;
 257
 258   type_size = GFC_DTYPE_TYPE_SIZE(array);
 259
 260   switch(type_size)
 261     {
 262     case GFC_DTYPE_LOGICAL_1:
 263     case GFC_DTYPE_INTEGER_1:
 264     case GFC_DTYPE_DERIVED_1:
 265       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
 266                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
 267       return;
 268
 269     case GFC_DTYPE_LOGICAL_2:
 270     case GFC_DTYPE_INTEGER_2:
 271       pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 272                (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 273       return;
 274
 275     case GFC_DTYPE_LOGICAL_4:
 276     case GFC_DTYPE_INTEGER_4:
 277       pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 278                (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 279       return;
 280
 281     case GFC_DTYPE_LOGICAL_8:
 282     case GFC_DTYPE_INTEGER_8:
 283       pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 284                (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 285       return;
 286
 287 #ifdef HAVE_GFC_INTEGER_16
 288     case GFC_DTYPE_LOGICAL_16:
 289     case GFC_DTYPE_INTEGER_16:
 290       pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 291                 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 292       return;
 293 #endif
 294
 295     case GFC_DTYPE_REAL_4:
 296       pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
 297                (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
 298       return;
 299
 300     case GFC_DTYPE_REAL_8:
 301       pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
 302                (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
 303       return;
 304
 305 /* FIXME: This here is a hack, which will have to be removed when
 306    the array descriptor is reworked.  Currently, we don't store the
 307    kind value for the type, but only the size.  Because on targets with
 308    __float128, we have sizeof(logn double) == sizeof(__float128),
 309    we cannot discriminate here and have to fall back to the generic
 310    handling (which is suboptimal).  */
 311 #if !defined(GFC_REAL_16_IS_FLOAT128)
 312 # ifdef HAVE_GFC_REAL_10
 313     case GFC_DTYPE_REAL_10:
 314       pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
 315                 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
 316       return;
 317 # endif
 318
 319 # ifdef HAVE_GFC_REAL_16
 320     case GFC_DTYPE_REAL_16:
 321       pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
 322                 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
 323       return;
 324 # endif
 325 #endif
 326
 327     case GFC_DTYPE_COMPLEX_4:
 328       pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
 329                (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
 330       return;
 331
 332     case GFC_DTYPE_COMPLEX_8:
 333       pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
 334                (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
 335       return;
 336
 337 /* FIXME: This here is a hack, which will have to be removed when
 338    the array descriptor is reworked.  Currently, we don't store the
 339    kind value for the type, but only the size.  Because on targets with
 340    __float128, we have sizeof(logn double) == sizeof(__float128),
 341    we cannot discriminate here and have to fall back to the generic
 342    handling (which is suboptimal).  */
 343 #if !defined(GFC_REAL_16_IS_FLOAT128)
 344 # ifdef HAVE_GFC_COMPLEX_10
 345     case GFC_DTYPE_COMPLEX_10:
 346       pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
 347                 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
 348       return;
 349 # endif
 350
 351 # ifdef HAVE_GFC_COMPLEX_16
 352     case GFC_DTYPE_COMPLEX_16:
 353       pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
 354                 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
 355       return;
 356 # endif
 357 #endif
 358
 359       /* For derived types, let's check the actual alignment of the
 360          data pointers.  If they are aligned, we can safely call
 361          the unpack functions.  */
 362
 363     case GFC_DTYPE_DERIVED_2:
 364       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data)
 365           || (vector && GFC_UNALIGNED_2(vector->data)))
 366         break;
 367       else
 368         {
 369           pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 370                    (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 371           return;
 372         }
 373
 374     case GFC_DTYPE_DERIVED_4:
 375       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data)
 376           || (vector && GFC_UNALIGNED_4(vector->data)))
 377         break;
 378       else
 379         {
 380           pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 381                    (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 382           return;
 383         }
 384
 385     case GFC_DTYPE_DERIVED_8:
 386       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data)
 387           || (vector && GFC_UNALIGNED_8(vector->data)))
 388         break;
 389       else
 390         {
 391           pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 392                    (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 393           return;
 394         }
 395
 396 #ifdef HAVE_GFC_INTEGER_16
 397     case GFC_DTYPE_DERIVED_16:
 398       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)
 399           || (vector && GFC_UNALIGNED_16(vector->data)))
 400         break;
 401       else
 402         {
 403           pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 404                    (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 405           return;
 406         }
 407 #endif
 408
 409     }
 410
 411   size = GFC_DESCRIPTOR_SIZE (array);
 412   pack_internal (ret, array, mask, vector, size);
 413 }
 414
 415
 416 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 417                        const gfc_array_l1 *, const gfc_array_char *,
 418                        GFC_INTEGER_4, GFC_INTEGER_4);
 419 export_proto(pack_char);
 420
 421 void
 422 pack_char (gfc_array_char *ret,
 423            GFC_INTEGER_4 ret_length __attribute__((unused)),
 424            const gfc_array_char *array, const gfc_array_l1 *mask,
 425            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 426            GFC_INTEGER_4 vector_length __attribute__((unused)))
 427 {
 428   pack_internal (ret, array, mask, vector, array_length);
 429 }
 430
 431
 432 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 433                         const gfc_array_l1 *, const gfc_array_char *,
 434                         GFC_INTEGER_4, GFC_INTEGER_4);
 435 export_proto(pack_char4);
 436
 437 void
 438 pack_char4 (gfc_array_char *ret,
 439             GFC_INTEGER_4 ret_length __attribute__((unused)),
 440             const gfc_array_char *array, const gfc_array_l1 *mask,
 441             const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 442             GFC_INTEGER_4 vector_length __attribute__((unused)))
 443 {
 444   pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
 445 }
 446
 447
 448 static void
 449 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
 450                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
 451                  index_type size)
 452 {
 453   /* r.* indicates the return array.  */
 454   index_type rstride0;
 455   char *rptr;
 456   /* s.* indicates the source array.  */
 457   index_type sstride[GFC_MAX_DIMENSIONS];
 458   index_type sstride0;
 459   const char *sptr;
 460
 461   index_type count[GFC_MAX_DIMENSIONS];
 462   index_type extent[GFC_MAX_DIMENSIONS];
 463   index_type n;
 464   index_type dim;
 465   index_type ssize;
 466   index_type nelem;
 467   index_type total;
 468
 469   dim = GFC_DESCRIPTOR_RANK (array);
 470   ssize = 1;
 471   for (n = 0; n < dim; n++)
 472     {
 473       count[n] = 0;
 474       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 475       if (extent[n] < 0)
 476         extent[n] = 0;
 477
 478       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 479       ssize *= extent[n];
 480     }
 481   if (sstride[0] == 0)
 482     sstride[0] = size;
 483
 484   sstride0 = sstride[0];
 485
 486   if (ssize != 0)
 487     sptr = array->data;
 488   else
 489     sptr = NULL;
 490
 491   if (ret->data == NULL)
 492     {
 493       /* Allocate the memory for the result.  */
 494
 495       if (vector != NULL)
 496         {
 497           /* The return array will have as many elements as there are
 498              in vector.  */
 499           total = GFC_DESCRIPTOR_EXTENT(vector,0);
 500           if (total <= 0)
 501             {
 502               total = 0;
 503               vector = NULL;
 504             }
 505         }
 506       else
 507         {
 508           if (*mask)
 509             {
 510               /* The result array will have as many elements as the input
 511                  array.  */
 512               total = extent[0];
 513               for (n = 1; n < dim; n++)
 514                 total *= extent[n];
 515             }
 516           else
 517             /* The result array will be empty.  */
 518             total = 0;
 519         }
 520
 521       /* Setup the array descriptor.  */
 522       GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
 523
 524       ret->offset = 0;
 525
 526       if (total == 0)
 527         {
 528           ret->data = internal_malloc_size (1);
 529           return;
 530         }
 531       else
 532         ret->data = internal_malloc_size (size * total);
 533     }
 534
 535   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 536   if (rstride0 == 0)
 537     rstride0 = size;
 538   rptr = ret->data;
 539
 540   /* The remaining possibilities are now:
 541        If MASK is .TRUE., we have to copy the source array into the
 542      result array. We then have to fill it up with elements from VECTOR.
 543        If MASK is .FALSE., we have to copy VECTOR into the result
 544      array. If VECTOR were not present we would have already returned.  */
 545
 546   if (*mask && ssize != 0)
 547     {
 548       while (sptr)
 549         {
 550           /* Add this element.  */
 551           memcpy (rptr, sptr, size);
 552           rptr += rstride0;
 553
 554           /* Advance to the next element.  */
 555           sptr += sstride0;
 556           count[0]++;
 557           n = 0;
 558           while (count[n] == extent[n])
 559             {
 560               /* When we get to the end of a dimension, reset it and
 561                  increment the next dimension.  */
 562               count[n] = 0;
 563               /* We could precalculate these products, but this is a
 564                  less frequently used path so probably not worth it.  */
 565               sptr -= sstride[n] * extent[n];
 566               n++;
 567               if (n >= dim)
 568                 {
 569                   /* Break out of the loop.  */
 570                   sptr = NULL;
 571                   break;
 572                 }
 573               else
 574                 {
 575                   count[n]++;
 576                   sptr += sstride[n];
 577                 }
 578             }
 579         }
 580     }
 581
 582   /* Add any remaining elements from VECTOR.  */
 583   if (vector)
 584     {
 585       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 586       nelem = ((rptr - ret->data) / rstride0);
 587       if (n > nelem)
 588         {
 589           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 590           if (sstride0 == 0)
 591             sstride0 = size;
 592
 593           sptr = vector->data + sstride0 * nelem;
 594           n -= nelem;
 595           while (n--)
 596             {
 597               memcpy (rptr, sptr, size);
 598               rptr += rstride0;
 599               sptr += sstride0;
 600             }
 601         }
 602     }
 603 }
 604
 605 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
 606                     const GFC_LOGICAL_4 *, const gfc_array_char *);
 607 export_proto(pack_s);
 608
 609 void
 610 pack_s (gfc_array_char *ret, const gfc_array_char *array,
 611         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
 612 {
 613   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 614 }
 615
 616
 617 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
 618                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
 619                          const gfc_array_char *, GFC_INTEGER_4,
 620                          GFC_INTEGER_4);
 621 export_proto(pack_s_char);
 622
 623 void
 624 pack_s_char (gfc_array_char *ret,
 625              GFC_INTEGER_4 ret_length __attribute__((unused)),
 626              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 627              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 628              GFC_INTEGER_4 vector_length __attribute__((unused)))
 629 {
 630   pack_s_internal (ret, array, mask, vector, array_length);
 631 }
 632
 633
 634 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
 635                           const gfc_array_char *array, const GFC_LOGICAL_4 *,
 636                           const gfc_array_char *, GFC_INTEGER_4,
 637                           GFC_INTEGER_4);
 638 export_proto(pack_s_char4);
 639
 640 void
 641 pack_s_char4 (gfc_array_char *ret,
 642               GFC_INTEGER_4 ret_length __attribute__((unused)),
 643               const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 644               const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 645               GFC_INTEGER_4 vector_length __attribute__((unused)))
 646 {
 647   pack_s_internal (ret, array, mask, vector,
 648                    array_length * sizeof (gfc_char4_t));
 649 }