libgfortran/intrinsics/unpack_generic.c

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