libgfortran/intrinsics/unpack_generic.c

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