libgfortran/intrinsics/pack_generic.c

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