libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010, 2012
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5
   6 This file is part of the GNU Fortran 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->base_addr != 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->base_addr;
  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->base_addr == 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->base_addr = xmalloc (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->base_addr;
 153   fptr = field->base_addr;
 154   vptr = vector->base_addr;
 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->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
 321           || GFC_UNALIGNED_2(field->base_addr))
 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->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
 332           || GFC_UNALIGNED_4(field->base_addr))
 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->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
 343           || GFC_UNALIGNED_8(field->base_addr))
 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->base_addr)
 355           || GFC_UNALIGNED_16(vector->base_addr)
 356           || GFC_UNALIGNED_16(field->base_addr))
 357         break;
 358       else
 359         {
 360           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 361                        mask, (gfc_array_i16 *) field);
 362           return;
 363         }
 364 #endif
 365     }
 366
 367   unpack_internal (ret, vector, mask, field, size);
 368 }
 369
 370
 371 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 372                           const gfc_array_char *, const gfc_array_l1 *,
 373                           const gfc_array_char *, GFC_INTEGER_4,
 374                           GFC_INTEGER_4);
 375 export_proto(unpack1_char);
 376
 377 void
 378 unpack1_char (gfc_array_char *ret,
 379               GFC_INTEGER_4 ret_length __attribute__((unused)),
 380               const gfc_array_char *vector, const gfc_array_l1 *mask,
 381               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 382               GFC_INTEGER_4 field_length __attribute__((unused)))
 383 {
 384
 385   if (unlikely(compile_options.bounds_check))
 386     unpack_bounds (ret, vector, mask, field);
 387
 388   unpack_internal (ret, vector, mask, field, vector_length);
 389 }
 390
 391
 392 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
 393                            const gfc_array_char *, const gfc_array_l1 *,
 394                            const gfc_array_char *, GFC_INTEGER_4,
 395                            GFC_INTEGER_4);
 396 export_proto(unpack1_char4);
 397
 398 void
 399 unpack1_char4 (gfc_array_char *ret,
 400                GFC_INTEGER_4 ret_length __attribute__((unused)),
 401                const gfc_array_char *vector, const gfc_array_l1 *mask,
 402                const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 403                GFC_INTEGER_4 field_length __attribute__((unused)))
 404 {
 405
 406   if (unlikely(compile_options.bounds_check))
 407     unpack_bounds (ret, vector, mask, field);
 408
 409   unpack_internal (ret, vector, mask, field,
 410                    vector_length * sizeof (gfc_char4_t));
 411 }
 412
 413
 414 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 415                      const gfc_array_l1 *, char *);
 416 export_proto(unpack0);
 417
 418 void
 419 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 420          const gfc_array_l1 *mask, char *field)
 421 {
 422   gfc_array_char tmp;
 423
 424   index_type type_size;
 425
 426   if (unlikely(compile_options.bounds_check))
 427     unpack_bounds (ret, vector, mask, NULL);
 428
 429   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 430
 431   switch (type_size)
 432     {
 433     case GFC_DTYPE_LOGICAL_1:
 434     case GFC_DTYPE_INTEGER_1:
 435     case GFC_DTYPE_DERIVED_1:
 436       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 437                   mask, (GFC_INTEGER_1 *) field);
 438       return;
 439
 440     case GFC_DTYPE_LOGICAL_2:
 441     case GFC_DTYPE_INTEGER_2:
 442       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 443                   mask, (GFC_INTEGER_2 *) field);
 444       return;
 445
 446     case GFC_DTYPE_LOGICAL_4:
 447     case GFC_DTYPE_INTEGER_4:
 448       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 449                   mask, (GFC_INTEGER_4 *) field);
 450       return;
 451
 452     case GFC_DTYPE_LOGICAL_8:
 453     case GFC_DTYPE_INTEGER_8:
 454       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 455                   mask, (GFC_INTEGER_8 *) field);
 456       return;
 457
 458 #ifdef HAVE_GFC_INTEGER_16
 459     case GFC_DTYPE_LOGICAL_16:
 460     case GFC_DTYPE_INTEGER_16:
 461       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 462                    mask, (GFC_INTEGER_16 *) field);
 463       return;
 464 #endif
 465
 466     case GFC_DTYPE_REAL_4:
 467       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 468                   mask, (GFC_REAL_4 *) field);
 469       return;
 470
 471     case GFC_DTYPE_REAL_8:
 472       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 473                   mask, (GFC_REAL_8  *) field);
 474       return;
 475
 476 /* FIXME: This here is a hack, which will have to be removed when
 477    the array descriptor is reworked.  Currently, we don't store the
 478    kind value for the type, but only the size.  Because on targets with
 479    __float128, we have sizeof(logn double) == sizeof(__float128),
 480    we cannot discriminate here and have to fall back to the generic
 481    handling (which is suboptimal).  */
 482 #if !defined(GFC_REAL_16_IS_FLOAT128)
 483 # ifdef HAVE_GFC_REAL_10
 484     case GFC_DTYPE_REAL_10:
 485       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 486                    mask, (GFC_REAL_10 *) field);
 487       return;
 488 # endif
 489
 490 # ifdef HAVE_GFC_REAL_16
 491     case GFC_DTYPE_REAL_16:
 492       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 493                    mask, (GFC_REAL_16 *) field);
 494       return;
 495 # endif
 496 #endif
 497
 498     case GFC_DTYPE_COMPLEX_4:
 499       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 500                   mask, (GFC_COMPLEX_4 *) field);
 501       return;
 502
 503     case GFC_DTYPE_COMPLEX_8:
 504       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 505                   mask, (GFC_COMPLEX_8 *) field);
 506       return;
 507
 508 /* FIXME: This here is a hack, which will have to be removed when
 509    the array descriptor is reworked.  Currently, we don't store the
 510    kind value for the type, but only the size.  Because on targets with
 511    __float128, we have sizeof(logn double) == sizeof(__float128),
 512    we cannot discriminate here and have to fall back to the generic
 513    handling (which is suboptimal).  */
 514 #if !defined(GFC_REAL_16_IS_FLOAT128)
 515 # ifdef HAVE_GFC_COMPLEX_10
 516     case GFC_DTYPE_COMPLEX_10:
 517       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 518                    mask, (GFC_COMPLEX_10 *) field);
 519       return;
 520 # endif
 521
 522 # ifdef HAVE_GFC_COMPLEX_16
 523     case GFC_DTYPE_COMPLEX_16:
 524       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 525                    mask, (GFC_COMPLEX_16 *) field);
 526       return;
 527 # endif
 528 #endif
 529
 530     case GFC_DTYPE_DERIVED_2:
 531       if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
 532           || GFC_UNALIGNED_2(field))
 533         break;
 534       else
 535         {
 536           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 537                       mask, (GFC_INTEGER_2 *) field);
 538           return;
 539         }
 540
 541     case GFC_DTYPE_DERIVED_4:
 542       if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
 543           || GFC_UNALIGNED_4(field))
 544         break;
 545       else
 546         {
 547           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 548                       mask, (GFC_INTEGER_4 *) field);
 549           return;
 550         }
 551
 552     case GFC_DTYPE_DERIVED_8:
 553       if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
 554           || GFC_UNALIGNED_8(field))
 555         break;
 556       else
 557         {
 558           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 559                       mask, (GFC_INTEGER_8 *) field);
 560           return;
 561         }
 562
 563 #ifdef HAVE_GFC_INTEGER_16
 564     case GFC_DTYPE_DERIVED_16:
 565       if (GFC_UNALIGNED_16(ret->base_addr)
 566           || GFC_UNALIGNED_16(vector->base_addr)
 567           || GFC_UNALIGNED_16(field))
 568         break;
 569       else
 570         {
 571           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 572                        mask, (GFC_INTEGER_16 *) field);
 573           return;
 574         }
 575 #endif
 576
 577     }
 578
 579   memset (&tmp, 0, sizeof (tmp));
 580   tmp.dtype = 0;
 581   tmp.base_addr = field;
 582   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
 583 }
 584
 585
 586 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 587                           const gfc_array_char *, const gfc_array_l1 *,
 588                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 589 export_proto(unpack0_char);
 590
 591 void
 592 unpack0_char (gfc_array_char *ret,
 593               GFC_INTEGER_4 ret_length __attribute__((unused)),
 594               const gfc_array_char *vector, const gfc_array_l1 *mask,
 595               char *field, GFC_INTEGER_4 vector_length,
 596               GFC_INTEGER_4 field_length __attribute__((unused)))
 597 {
 598   gfc_array_char tmp;
 599
 600   if (unlikely(compile_options.bounds_check))
 601     unpack_bounds (ret, vector, mask, NULL);
 602
 603   memset (&tmp, 0, sizeof (tmp));
 604   tmp.dtype = 0;
 605   tmp.base_addr = field;
 606   unpack_internal (ret, vector, mask, &tmp, vector_length);
 607 }
 608
 609
 610 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
 611                            const gfc_array_char *, const gfc_array_l1 *,
 612                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
 613 export_proto(unpack0_char4);
 614
 615 void
 616 unpack0_char4 (gfc_array_char *ret,
 617                GFC_INTEGER_4 ret_length __attribute__((unused)),
 618                const gfc_array_char *vector, const gfc_array_l1 *mask,
 619                char *field, GFC_INTEGER_4 vector_length,
 620                GFC_INTEGER_4 field_length __attribute__((unused)))
 621 {
 622   gfc_array_char tmp;
 623
 624   if (unlikely(compile_options.bounds_check))
 625     unpack_bounds (ret, vector, mask, NULL);
 626
 627   memset (&tmp, 0, sizeof (tmp));
 628   tmp.dtype = 0;
 629   tmp.base_addr = field;
 630   unpack_internal (ret, vector, mask, &tmp,
 631                    vector_length * sizeof (gfc_char4_t));
 632 }