libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 2004, 2005, 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 /* All the bounds checking for unpack in one function.  If field is NULL,
  33    we don't check it, for the unpack0 functions.  */
  34
  35 static void
  36 unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
  37          const gfc_array_l1 *mask, const gfc_array_char *field)
  38 {
  39   index_type vec_size, mask_count;
  40   vec_size = size0 ((array_t *) vector);
  41   mask_count = count_0 (mask);
  42   if (vec_size < mask_count)
  43     runtime_error ("Incorrect size of return value in UNPACK"
  44                    " intrinsic: should be at least %ld, is"
  45                    " %ld", (long int) mask_count,
  46                    (long int) vec_size);
  47
  48   if (field != NULL)
  49     bounds_equal_extents ((array_t *) field, (array_t *) mask,
  50                           "FIELD", "UNPACK");
  51
  52   if (ret->data != NULL)
  53     bounds_equal_extents ((array_t *) ret, (array_t *) mask,
  54                           "return value", "UNPACK");
  55
  56 }
  57
  58 static void
  59 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
  60                  const gfc_array_l1 *mask, const gfc_array_char *field,
  61                  index_type size)
  62 {
  63   /* r.* indicates the return array.  */
  64   index_type rstride[GFC_MAX_DIMENSIONS];
  65   index_type rstride0;
  66   index_type rs;
  67   char * restrict rptr;
  68   /* v.* indicates the vector array.  */
  69   index_type vstride0;
  70   char *vptr;
  71   /* f.* indicates the field array.  */
  72   index_type fstride[GFC_MAX_DIMENSIONS];
  73   index_type fstride0;
  74   const char *fptr;
  75   /* m.* indicates the mask array.  */
  76   index_type mstride[GFC_MAX_DIMENSIONS];
  77   index_type mstride0;
  78   const GFC_LOGICAL_1 *mptr;
  79
  80   index_type count[GFC_MAX_DIMENSIONS];
  81   index_type extent[GFC_MAX_DIMENSIONS];
  82   index_type n;
  83   index_type dim;
  84
  85   int empty;
  86   int mask_kind;
  87
  88   empty = 0;
  89
  90   mptr = mask->data;
  91
  92   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  93      and using shifting to address size and endian issues.  */
  94
  95   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  96
  97   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  98 #ifdef HAVE_GFC_LOGICAL_16
  99       || mask_kind == 16
 100 #endif
 101       )
 102     {
 103       /*  Don't convert a NULL pointer as we use test for NULL below.  */
 104       if (mptr)
 105         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 106     }
 107   else
 108     runtime_error ("Funny sized logical array");
 109
 110   if (ret->data == NULL)
 111     {
 112       /* The front end has signalled that we need to populate the
 113          return array descriptor.  */
 114       dim = GFC_DESCRIPTOR_RANK (mask);
 115       rs = 1;
 116       for (n = 0; n < dim; n++)
 117         {
 118           count[n] = 0;
 119           GFC_DIMENSION_SET(ret->dim[n], 0,
 120                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 121           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 122           empty = empty || extent[n] <= 0;
 123           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
 124           fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
 125           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
 126           rs *= extent[n];
 127         }
 128       ret->offset = 0;
 129       ret->data = internal_malloc_size (rs * size);
 130     }
 131   else
 132     {
 133       dim = GFC_DESCRIPTOR_RANK (ret);
 134       for (n = 0; n < dim; n++)
 135         {
 136           count[n] = 0;
 137           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 138           empty = empty || extent[n] <= 0;
 139           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
 140           fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
 141           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
 142         }
 143     }
 144
 145   if (empty)
 146     return;
 147
 148   vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 149   rstride0 = rstride[0];
 150   fstride0 = fstride[0];
 151   mstride0 = mstride[0];
 152   rptr = ret->data;
 153   fptr = field->data;
 154   vptr = vector->data;
 155
 156   while (rptr)
 157     {
 158       if (*mptr)
 159         {
 160           /* From vector.  */
 161           memcpy (rptr, vptr, size);
 162           vptr += vstride0;
 163         }
 164       else
 165         {
 166           /* From field.  */
 167           memcpy (rptr, fptr, size);
 168         }
 169       /* Advance to the next element.  */
 170       rptr += rstride0;
 171       fptr += fstride0;
 172       mptr += mstride0;
 173       count[0]++;
 174       n = 0;
 175       while (count[n] == extent[n])
 176         {
 177           /* When we get to the end of a dimension, reset it and increment
 178              the next dimension.  */
 179           count[n] = 0;
 180           /* We could precalculate these products, but this is a less
 181              frequently used path so probably not worth it.  */
 182           rptr -= rstride[n] * extent[n];
 183           fptr -= fstride[n] * extent[n];
 184           mptr -= mstride[n] * extent[n];
 185           n++;
 186           if (n >= dim)
 187             {
 188               /* Break out of the loop.  */
 189               rptr = NULL;
 190               break;
 191             }
 192           else
 193             {
 194               count[n]++;
 195               rptr += rstride[n];
 196               fptr += fstride[n];
 197               mptr += mstride[n];
 198             }
 199         }
 200     }
 201 }
 202
 203 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 204                      const gfc_array_l1 *, const gfc_array_char *);
 205 export_proto(unpack1);
 206
 207 void
 208 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 209          const gfc_array_l1 *mask, const gfc_array_char *field)
 210 {
 211   index_type type_size;
 212   index_type size;
 213
 214   if (unlikely(compile_options.bounds_check))
 215     unpack_bounds (ret, vector, mask, field);
 216
 217   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 218   size = GFC_DESCRIPTOR_SIZE (vector);
 219
 220   switch(type_size)
 221     {
 222     case GFC_DTYPE_LOGICAL_1:
 223     case GFC_DTYPE_INTEGER_1:
 224     case GFC_DTYPE_DERIVED_1:
 225       unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 226                   mask, (gfc_array_i1 *) field);
 227       return;
 228
 229     case GFC_DTYPE_LOGICAL_2:
 230     case GFC_DTYPE_INTEGER_2:
 231       unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 232                   mask, (gfc_array_i2 *) field);
 233       return;
 234
 235     case GFC_DTYPE_LOGICAL_4:
 236     case GFC_DTYPE_INTEGER_4:
 237       unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 238                   mask, (gfc_array_i4 *) field);
 239       return;
 240
 241     case GFC_DTYPE_LOGICAL_8:
 242     case GFC_DTYPE_INTEGER_8:
 243       unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 244                   mask, (gfc_array_i8 *) field);
 245       return;
 246
 247 #ifdef HAVE_GFC_INTEGER_16
 248     case GFC_DTYPE_LOGICAL_16:
 249     case GFC_DTYPE_INTEGER_16:
 250       unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 251                    mask, (gfc_array_i16 *) field);
 252       return;
 253 #endif
 254
 255     case GFC_DTYPE_REAL_4:
 256       unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 257                   mask, (gfc_array_r4 *) field);
 258       return;
 259
 260     case GFC_DTYPE_REAL_8:
 261       unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
 262                   mask, (gfc_array_r8 *) field);
 263       return;
 264
 265 /* FIXME: This here is a hack, which will have to be removed when
 266    the array descriptor is reworked.  Currently, we don't store the
 267    kind value for the type, but only the size.  Because on targets with
 268    __float128, we have sizeof(logn double) == sizeof(__float128),
 269    we cannot discriminate here and have to fall back to the generic
 270    handling (which is suboptimal).  */
 271 #if !defined(GFC_REAL_16_IS_FLOAT128)
 272 # ifdef HAVE_GFC_REAL_10
 273     case GFC_DTYPE_REAL_10:
 274       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 275                    mask, (gfc_array_r10 *) field);
 276       return;
 277 # endif
 278
 279 # ifdef HAVE_GFC_REAL_16
 280     case GFC_DTYPE_REAL_16:
 281       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 282                    mask, (gfc_array_r16 *) field);
 283       return;
 284 # endif
 285 #endif
 286
 287     case GFC_DTYPE_COMPLEX_4:
 288       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 289                   mask, (gfc_array_c4 *) field);
 290       return;
 291
 292     case GFC_DTYPE_COMPLEX_8:
 293       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 294                   mask, (gfc_array_c8 *) field);
 295       return;
 296
 297 /* FIXME: This here is a hack, which will have to be removed when
 298    the array descriptor is reworked.  Currently, we don't store the
 299    kind value for the type, but only the size.  Because on targets with
 300    __float128, we have sizeof(logn double) == sizeof(__float128),
 301    we cannot discriminate here and have to fall back to the generic
 302    handling (which is suboptimal).  */
 303 #if !defined(GFC_REAL_16_IS_FLOAT128)
 304 # ifdef HAVE_GFC_COMPLEX_10
 305     case GFC_DTYPE_COMPLEX_10:
 306       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 307                    mask, (gfc_array_c10 *) field);
 308       return;
 309 # endif
 310
 311 # ifdef HAVE_GFC_COMPLEX_16
 312     case GFC_DTYPE_COMPLEX_16:
 313       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 314                    mask, (gfc_array_c16 *) field);
 315       return;
 316 # endif
 317 #endif
 318
 319     case GFC_DTYPE_DERIVED_2:
 320       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 321           || GFC_UNALIGNED_2(field->data))
 322         break;
 323       else
 324         {
 325           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 326                       mask, (gfc_array_i2 *) field);
 327           return;
 328         }
 329
 330     case GFC_DTYPE_DERIVED_4:
 331       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 332           || GFC_UNALIGNED_4(field->data))
 333         break;
 334       else
 335         {
 336           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 337                       mask, (gfc_array_i4 *) field);
 338           return;
 339         }
 340
 341     case GFC_DTYPE_DERIVED_8:
 342       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 343           || GFC_UNALIGNED_8(field->data))
 344         break;
 345       else
 346         {
 347           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 348                       mask, (gfc_array_i8 *) field);
 349           return;
 350         }
 351
 352 #ifdef HAVE_GFC_INTEGER_16
 353     case GFC_DTYPE_DERIVED_16:
 354       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 355           || GFC_UNALIGNED_16(field->data))
 356         break;
 357       else
 358         {
 359           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 360                        mask, (gfc_array_i16 *) field);
 361           return;
 362         }
 363 #endif
 364     }
 365
 366   unpack_internal (ret, vector, mask, field, size);
 367 }
 368
 369
 370 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 371                           const gfc_array_char *, const gfc_array_l1 *,
 372                           const gfc_array_char *, GFC_INTEGER_4,
 373                           GFC_INTEGER_4);
 374 export_proto(unpack1_char);
 375
 376 void
 377 unpack1_char (gfc_array_char *ret,
 378               GFC_INTEGER_4 ret_length __attribute__((unused)),
 379               const gfc_array_char *vector, const gfc_array_l1 *mask,
 380               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 381               GFC_INTEGER_4 field_length __attribute__((unused)))
 382 {
 383
 384   if (unlikely(compile_options.bounds_check))
 385     unpack_bounds (ret, vector, mask, field);
 386
 387   unpack_internal (ret, vector, mask, field, vector_length);
 388 }
 389
 390
 391 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
 392                            const gfc_array_char *, const gfc_array_l1 *,
 393                            const gfc_array_char *, GFC_INTEGER_4,
 394                            GFC_INTEGER_4);
 395 export_proto(unpack1_char4);
 396
 397 void
 398 unpack1_char4 (gfc_array_char *ret,
 399                GFC_INTEGER_4 ret_length __attribute__((unused)),
 400                const gfc_array_char *vector, const gfc_array_l1 *mask,
 401                const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 402                GFC_INTEGER_4 field_length __attribute__((unused)))
 403 {
 404
 405   if (unlikely(compile_options.bounds_check))
 406     unpack_bounds (ret, vector, mask, field);
 407
 408   unpack_internal (ret, vector, mask, field,
 409                    vector_length * sizeof (gfc_char4_t));
 410 }
 411
 412
 413 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 414                      const gfc_array_l1 *, char *);
 415 export_proto(unpack0);
 416
 417 void
 418 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 419          const gfc_array_l1 *mask, char *field)
 420 {
 421   gfc_array_char tmp;
 422
 423   index_type type_size;
 424
 425   if (unlikely(compile_options.bounds_check))
 426     unpack_bounds (ret, vector, mask, NULL);
 427
 428   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 429
 430   switch (type_size)
 431     {
 432     case GFC_DTYPE_LOGICAL_1:
 433     case GFC_DTYPE_INTEGER_1:
 434     case GFC_DTYPE_DERIVED_1:
 435       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 436                   mask, (GFC_INTEGER_1 *) field);
 437       return;
 438
 439     case GFC_DTYPE_LOGICAL_2:
 440     case GFC_DTYPE_INTEGER_2:
 441       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 442                   mask, (GFC_INTEGER_2 *) field);
 443       return;
 444
 445     case GFC_DTYPE_LOGICAL_4:
 446     case GFC_DTYPE_INTEGER_4:
 447       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 448                   mask, (GFC_INTEGER_4 *) field);
 449       return;
 450
 451     case GFC_DTYPE_LOGICAL_8:
 452     case GFC_DTYPE_INTEGER_8:
 453       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 454                   mask, (GFC_INTEGER_8 *) field);
 455       return;
 456
 457 #ifdef HAVE_GFC_INTEGER_16
 458     case GFC_DTYPE_LOGICAL_16:
 459     case GFC_DTYPE_INTEGER_16:
 460       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 461                    mask, (GFC_INTEGER_16 *) field);
 462       return;
 463 #endif
 464
 465     case GFC_DTYPE_REAL_4:
 466       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 467                   mask, (GFC_REAL_4 *) field);
 468       return;
 469
 470     case GFC_DTYPE_REAL_8:
 471       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 472                   mask, (GFC_REAL_8  *) field);
 473       return;
 474
 475 /* FIXME: This here is a hack, which will have to be removed when
 476    the array descriptor is reworked.  Currently, we don't store the
 477    kind value for the type, but only the size.  Because on targets with
 478    __float128, we have sizeof(logn double) == sizeof(__float128),
 479    we cannot discriminate here and have to fall back to the generic
 480    handling (which is suboptimal).  */
 481 #if !defined(GFC_REAL_16_IS_FLOAT128)
 482 # ifdef HAVE_GFC_REAL_10
 483     case GFC_DTYPE_REAL_10:
 484       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 485                    mask, (GFC_REAL_10 *) field);
 486       return;
 487 # endif
 488
 489 # ifdef HAVE_GFC_REAL_16
 490     case GFC_DTYPE_REAL_16:
 491       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 492                    mask, (GFC_REAL_16 *) field);
 493       return;
 494 # endif
 495 #endif
 496
 497     case GFC_DTYPE_COMPLEX_4:
 498       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 499                   mask, (GFC_COMPLEX_4 *) field);
 500       return;
 501
 502     case GFC_DTYPE_COMPLEX_8:
 503       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 504                   mask, (GFC_COMPLEX_8 *) field);
 505       return;
 506
 507 /* FIXME: This here is a hack, which will have to be removed when
 508    the array descriptor is reworked.  Currently, we don't store the
 509    kind value for the type, but only the size.  Because on targets with
 510    __float128, we have sizeof(logn double) == sizeof(__float128),
 511    we cannot discriminate here and have to fall back to the generic
 512    handling (which is suboptimal).  */
 513 #if !defined(GFC_REAL_16_IS_FLOAT128)
 514 # ifdef HAVE_GFC_COMPLEX_10
 515     case GFC_DTYPE_COMPLEX_10:
 516       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 517                    mask, (GFC_COMPLEX_10 *) field);
 518       return;
 519 # endif
 520
 521 # ifdef HAVE_GFC_COMPLEX_16
 522     case GFC_DTYPE_COMPLEX_16:
 523       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 524                    mask, (GFC_COMPLEX_16 *) field);
 525       return;
 526 # endif
 527 #endif
 528
 529     case GFC_DTYPE_DERIVED_2:
 530       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 531           || GFC_UNALIGNED_2(field))
 532         break;
 533       else
 534         {
 535           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 536                       mask, (GFC_INTEGER_2 *) field);
 537           return;
 538         }
 539
 540     case GFC_DTYPE_DERIVED_4:
 541       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 542           || GFC_UNALIGNED_4(field))
 543         break;
 544       else
 545         {
 546           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 547                       mask, (GFC_INTEGER_4 *) field);
 548           return;
 549         }
 550
 551     case GFC_DTYPE_DERIVED_8:
 552       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 553           || GFC_UNALIGNED_8(field))
 554         break;
 555       else
 556         {
 557           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 558                       mask, (GFC_INTEGER_8 *) field);
 559           return;
 560         }
 561
 562 #ifdef HAVE_GFC_INTEGER_16
 563     case GFC_DTYPE_DERIVED_16:
 564       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 565           || GFC_UNALIGNED_16(field))
 566         break;
 567       else
 568         {
 569           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 570                        mask, (GFC_INTEGER_16 *) field);
 571           return;
 572         }
 573 #endif
 574
 575     }
 576
 577   memset (&tmp, 0, sizeof (tmp));
 578   tmp.dtype = 0;
 579   tmp.data = field;
 580   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
 581 }
 582
 583
 584 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 585                           const gfc_array_char *, const gfc_array_l1 *,
 586                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 587 export_proto(unpack0_char);
 588
 589 void
 590 unpack0_char (gfc_array_char *ret,
 591               GFC_INTEGER_4 ret_length __attribute__((unused)),
 592               const gfc_array_char *vector, const gfc_array_l1 *mask,
 593               char *field, GFC_INTEGER_4 vector_length,
 594               GFC_INTEGER_4 field_length __attribute__((unused)))
 595 {
 596   gfc_array_char tmp;
 597
 598   if (unlikely(compile_options.bounds_check))
 599     unpack_bounds (ret, vector, mask, NULL);
 600
 601   memset (&tmp, 0, sizeof (tmp));
 602   tmp.dtype = 0;
 603   tmp.data = field;
 604   unpack_internal (ret, vector, mask, &tmp, vector_length);
 605 }
 606
 607
 608 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
 609                            const gfc_array_char *, const gfc_array_l1 *,
 610                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
 611 export_proto(unpack0_char4);
 612
 613 void
 614 unpack0_char4 (gfc_array_char *ret,
 615                GFC_INTEGER_4 ret_length __attribute__((unused)),
 616                const gfc_array_char *vector, const gfc_array_l1 *mask,
 617                char *field, GFC_INTEGER_4 vector_length,
 618                GFC_INTEGER_4 field_length __attribute__((unused)))
 619 {
 620   gfc_array_char tmp;
 621
 622   if (unlikely(compile_options.bounds_check))
 623     unpack_bounds (ret, vector, mask, NULL);
 624
 625   memset (&tmp, 0, sizeof (tmp));
 626   tmp.dtype = 0;
 627   tmp.data = field;
 628   unpack_internal (ret, vector, mask, &tmp,
 629                    vector_length * sizeof (gfc_char4_t));
 630 }