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