libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright (C) 2002-2013 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 = xmalloc (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   vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 148   rstride0 = rstride[0];
 149   fstride0 = fstride[0];
 150   mstride0 = mstride[0];
 151   rptr = ret->base_addr;
 152   fptr = field->base_addr;
 153   vptr = vector->base_addr;
 154
 155   while (rptr)
 156     {
 157       if (*mptr)
 158         {
 159           /* From vector.  */
 160           memcpy (rptr, vptr, size);
 161           vptr += vstride0;
 162         }
 163       else
 164         {
 165           /* From field.  */
 166           memcpy (rptr, fptr, size);
 167         }
 168       /* Advance to the next element.  */
 169       rptr += rstride0;
 170       fptr += fstride0;
 171       mptr += mstride0;
 172       count[0]++;
 173       n = 0;
 174       while (count[n] == extent[n])
 175         {
 176           /* When we get to the end of a dimension, reset it and increment
 177              the next dimension.  */
 178           count[n] = 0;
 179           /* We could precalculate these products, but this is a less
 180              frequently used path so probably not worth it.  */
 181           rptr -= rstride[n] * extent[n];
 182           fptr -= fstride[n] * extent[n];
 183           mptr -= mstride[n] * extent[n];
 184           n++;
 185           if (n >= dim)
 186             {
 187               /* Break out of the loop.  */
 188               rptr = NULL;
 189               break;
 190             }
 191           else
 192             {
 193               count[n]++;
 194               rptr += rstride[n];
 195               fptr += fstride[n];
 196               mptr += mstride[n];
 197             }
 198         }
 199     }
 200 }
 201
 202 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 203                      const gfc_array_l1 *, const gfc_array_char *);
 204 export_proto(unpack1);
 205
 206 void
 207 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 208          const gfc_array_l1 *mask, const gfc_array_char *field)
 209 {
 210   index_type type_size;
 211   index_type size;
 212
 213   if (unlikely(compile_options.bounds_check))
 214     unpack_bounds (ret, vector, mask, field);
 215
 216   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 217   size = GFC_DESCRIPTOR_SIZE (vector);
 218
 219   switch(type_size)
 220     {
 221     case GFC_DTYPE_LOGICAL_1:
 222     case GFC_DTYPE_INTEGER_1:
 223     case GFC_DTYPE_DERIVED_1:
 224       unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 225                   mask, (gfc_array_i1 *) field);
 226       return;
 227
 228     case GFC_DTYPE_LOGICAL_2:
 229     case GFC_DTYPE_INTEGER_2:
 230       unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 231                   mask, (gfc_array_i2 *) field);
 232       return;
 233
 234     case GFC_DTYPE_LOGICAL_4:
 235     case GFC_DTYPE_INTEGER_4:
 236       unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 237                   mask, (gfc_array_i4 *) field);
 238       return;
 239
 240     case GFC_DTYPE_LOGICAL_8:
 241     case GFC_DTYPE_INTEGER_8:
 242       unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 243                   mask, (gfc_array_i8 *) field);
 244       return;
 245
 246 #ifdef HAVE_GFC_INTEGER_16
 247     case GFC_DTYPE_LOGICAL_16:
 248     case GFC_DTYPE_INTEGER_16:
 249       unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 250                    mask, (gfc_array_i16 *) field);
 251       return;
 252 #endif
 253
 254     case GFC_DTYPE_REAL_4:
 255       unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 256                   mask, (gfc_array_r4 *) field);
 257       return;
 258
 259     case GFC_DTYPE_REAL_8:
 260       unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
 261                   mask, (gfc_array_r8 *) field);
 262       return;
 263
 264 /* FIXME: This here is a hack, which will have to be removed when
 265    the array descriptor is reworked.  Currently, we don't store the
 266    kind value for the type, but only the size.  Because on targets with
 267    __float128, we have sizeof(logn double) == sizeof(__float128),
 268    we cannot discriminate here and have to fall back to the generic
 269    handling (which is suboptimal).  */
 270 #if !defined(GFC_REAL_16_IS_FLOAT128)
 271 # ifdef HAVE_GFC_REAL_10
 272     case GFC_DTYPE_REAL_10:
 273       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 274                    mask, (gfc_array_r10 *) field);
 275       return;
 276 # endif
 277
 278 # ifdef HAVE_GFC_REAL_16
 279     case GFC_DTYPE_REAL_16:
 280       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 281                    mask, (gfc_array_r16 *) field);
 282       return;
 283 # endif
 284 #endif
 285
 286     case GFC_DTYPE_COMPLEX_4:
 287       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 288                   mask, (gfc_array_c4 *) field);
 289       return;
 290
 291     case GFC_DTYPE_COMPLEX_8:
 292       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 293                   mask, (gfc_array_c8 *) field);
 294       return;
 295
 296 /* FIXME: This here is a hack, which will have to be removed when
 297    the array descriptor is reworked.  Currently, we don't store the
 298    kind value for the type, but only the size.  Because on targets with
 299    __float128, we have sizeof(logn double) == sizeof(__float128),
 300    we cannot discriminate here and have to fall back to the generic
 301    handling (which is suboptimal).  */
 302 #if !defined(GFC_REAL_16_IS_FLOAT128)
 303 # ifdef HAVE_GFC_COMPLEX_10
 304     case GFC_DTYPE_COMPLEX_10:
 305       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 306                    mask, (gfc_array_c10 *) field);
 307       return;
 308 # endif
 309
 310 # ifdef HAVE_GFC_COMPLEX_16
 311     case GFC_DTYPE_COMPLEX_16:
 312       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 313                    mask, (gfc_array_c16 *) field);
 314       return;
 315 # endif
 316 #endif
 317
 318     case GFC_DTYPE_DERIVED_2:
 319       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
 320           || GFC_UNALIGNED_2(field->base_addr))
 321         break;
 322       else
 323         {
 324           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 325                       mask, (gfc_array_i2 *) field);
 326           return;
 327         }
 328
 329     case GFC_DTYPE_DERIVED_4:
 330       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
 331           || GFC_UNALIGNED_4(field->base_addr))
 332         break;
 333       else
 334         {
 335           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 336                       mask, (gfc_array_i4 *) field);
 337           return;
 338         }
 339
 340     case GFC_DTYPE_DERIVED_8:
 341       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
 342           || GFC_UNALIGNED_8(field->base_addr))
 343         break;
 344       else
 345         {
 346           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 347                       mask, (gfc_array_i8 *) field);
 348           return;
 349         }
 350
 351 #ifdef HAVE_GFC_INTEGER_16
 352     case GFC_DTYPE_DERIVED_16:
 353       if (GFC_UNALIGNED_16(ret->base_addr)
 354           || GFC_UNALIGNED_16(vector->base_addr)
 355           || GFC_UNALIGNED_16(field->base_addr))
 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->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
 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->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
 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->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
 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->base_addr)
 565           || GFC_UNALIGNED_16(vector->base_addr)
 566           || GFC_UNALIGNED_16(field))
 567         break;
 568       else
 569         {
 570           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 571                        mask, (GFC_INTEGER_16 *) field);
 572           return;
 573         }
 574 #endif
 575
 576     }
 577
 578   memset (&tmp, 0, sizeof (tmp));
 579   tmp.dtype = 0;
 580   tmp.base_addr = field;
 581   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
 582 }
 583
 584
 585 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 586                           const gfc_array_char *, const gfc_array_l1 *,
 587                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 588 export_proto(unpack0_char);
 589
 590 void
 591 unpack0_char (gfc_array_char *ret,
 592               GFC_INTEGER_4 ret_length __attribute__((unused)),
 593               const gfc_array_char *vector, const gfc_array_l1 *mask,
 594               char *field, GFC_INTEGER_4 vector_length,
 595               GFC_INTEGER_4 field_length __attribute__((unused)))
 596 {
 597   gfc_array_char tmp;
 598
 599   if (unlikely(compile_options.bounds_check))
 600     unpack_bounds (ret, vector, mask, NULL);
 601
 602   memset (&tmp, 0, sizeof (tmp));
 603   tmp.dtype = 0;
 604   tmp.base_addr = field;
 605   unpack_internal (ret, vector, mask, &tmp, vector_length);
 606 }
 607
 608
 609 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
 610                            const gfc_array_char *, const gfc_array_l1 *,
 611                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
 612 export_proto(unpack0_char4);
 613
 614 void
 615 unpack0_char4 (gfc_array_char *ret,
 616                GFC_INTEGER_4 ret_length __attribute__((unused)),
 617                const gfc_array_char *vector, const gfc_array_l1 *mask,
 618                char *field, GFC_INTEGER_4 vector_length,
 619                GFC_INTEGER_4 field_length __attribute__((unused)))
 620 {
 621   gfc_array_char tmp;
 622
 623   if (unlikely(compile_options.bounds_check))
 624     unpack_bounds (ret, vector, mask, NULL);
 625
 626   memset (&tmp, 0, sizeof (tmp));
 627   tmp.dtype = 0;
 628   tmp.base_addr = field;
 629   unpack_internal (ret, vector, mask, &tmp,
 630                    vector_length * sizeof (gfc_char4_t));
 631 }