libgfortran/intrinsics/pack_generic.c

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