libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 2004, 2005, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 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->data != 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->data;
  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->data == 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->data = internal_malloc_size (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->data;
 152   fptr = field->data;
 153   vptr = vector->data;
 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 #ifdef HAVE_GFC_REAL_10
 265     case GFC_DTYPE_REAL_10:
 266       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 267                    mask, (gfc_array_r10 *) field);
 268       return;
 269 #endif
 270
 271 #ifdef HAVE_GFC_REAL_16
 272     case GFC_DTYPE_REAL_16:
 273       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 274                    mask, (gfc_array_r16 *) field);
 275       return;
 276 #endif
 277
 278     case GFC_DTYPE_COMPLEX_4:
 279       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 280                   mask, (gfc_array_c4 *) field);
 281       return;
 282
 283     case GFC_DTYPE_COMPLEX_8:
 284       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 285                   mask, (gfc_array_c8 *) field);
 286       return;
 287
 288 #ifdef HAVE_GFC_COMPLEX_10
 289     case GFC_DTYPE_COMPLEX_10:
 290       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 291                    mask, (gfc_array_c10 *) field);
 292       return;
 293 #endif
 294
 295 #ifdef HAVE_GFC_COMPLEX_16
 296     case GFC_DTYPE_COMPLEX_16:
 297       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 298                    mask, (gfc_array_c16 *) field);
 299       return;
 300 #endif
 301
 302     case GFC_DTYPE_DERIVED_2:
 303       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 304           || GFC_UNALIGNED_2(field->data))
 305         break;
 306       else
 307         {
 308           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 309                       mask, (gfc_array_i2 *) field);
 310           return;
 311         }
 312
 313     case GFC_DTYPE_DERIVED_4:
 314       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 315           || GFC_UNALIGNED_4(field->data))
 316         break;
 317       else
 318         {
 319           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 320                       mask, (gfc_array_i4 *) field);
 321           return;
 322         }
 323
 324     case GFC_DTYPE_DERIVED_8:
 325       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 326           || GFC_UNALIGNED_8(field->data))
 327         break;
 328       else
 329         {
 330           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 331                       mask, (gfc_array_i8 *) field);
 332           return;
 333         }
 334
 335 #ifdef HAVE_GFC_INTEGER_16
 336     case GFC_DTYPE_DERIVED_16:
 337       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 338           || GFC_UNALIGNED_16(field->data))
 339         break;
 340       else
 341         {
 342           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 343                        mask, (gfc_array_i16 *) field);
 344           return;
 345         }
 346 #endif
 347     }
 348
 349   unpack_internal (ret, vector, mask, field, size);
 350 }
 351
 352
 353 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 354                           const gfc_array_char *, const gfc_array_l1 *,
 355                           const gfc_array_char *, GFC_INTEGER_4,
 356                           GFC_INTEGER_4);
 357 export_proto(unpack1_char);
 358
 359 void
 360 unpack1_char (gfc_array_char *ret,
 361               GFC_INTEGER_4 ret_length __attribute__((unused)),
 362               const gfc_array_char *vector, const gfc_array_l1 *mask,
 363               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 364               GFC_INTEGER_4 field_length __attribute__((unused)))
 365 {
 366
 367   if (unlikely(compile_options.bounds_check))
 368     unpack_bounds (ret, vector, mask, field);
 369
 370   unpack_internal (ret, vector, mask, field, vector_length);
 371 }
 372
 373
 374 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
 375                            const gfc_array_char *, const gfc_array_l1 *,
 376                            const gfc_array_char *, GFC_INTEGER_4,
 377                            GFC_INTEGER_4);
 378 export_proto(unpack1_char4);
 379
 380 void
 381 unpack1_char4 (gfc_array_char *ret,
 382                GFC_INTEGER_4 ret_length __attribute__((unused)),
 383                const gfc_array_char *vector, const gfc_array_l1 *mask,
 384                const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 385                GFC_INTEGER_4 field_length __attribute__((unused)))
 386 {
 387
 388   if (unlikely(compile_options.bounds_check))
 389     unpack_bounds (ret, vector, mask, field);
 390
 391   unpack_internal (ret, vector, mask, field,
 392                    vector_length * sizeof (gfc_char4_t));
 393 }
 394
 395
 396 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 397                      const gfc_array_l1 *, char *);
 398 export_proto(unpack0);
 399
 400 void
 401 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 402          const gfc_array_l1 *mask, char *field)
 403 {
 404   gfc_array_char tmp;
 405
 406   index_type type_size;
 407
 408   if (unlikely(compile_options.bounds_check))
 409     unpack_bounds (ret, vector, mask, NULL);
 410
 411   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 412
 413   switch (type_size)
 414     {
 415     case GFC_DTYPE_LOGICAL_1:
 416     case GFC_DTYPE_INTEGER_1:
 417     case GFC_DTYPE_DERIVED_1:
 418       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 419                   mask, (GFC_INTEGER_1 *) field);
 420       return;
 421
 422     case GFC_DTYPE_LOGICAL_2:
 423     case GFC_DTYPE_INTEGER_2:
 424       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 425                   mask, (GFC_INTEGER_2 *) field);
 426       return;
 427
 428     case GFC_DTYPE_LOGICAL_4:
 429     case GFC_DTYPE_INTEGER_4:
 430       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 431                   mask, (GFC_INTEGER_4 *) field);
 432       return;
 433
 434     case GFC_DTYPE_LOGICAL_8:
 435     case GFC_DTYPE_INTEGER_8:
 436       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 437                   mask, (GFC_INTEGER_8 *) field);
 438       return;
 439
 440 #ifdef HAVE_GFC_INTEGER_16
 441     case GFC_DTYPE_LOGICAL_16:
 442     case GFC_DTYPE_INTEGER_16:
 443       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 444                    mask, (GFC_INTEGER_16 *) field);
 445       return;
 446 #endif
 447
 448     case GFC_DTYPE_REAL_4:
 449       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 450                   mask, (GFC_REAL_4 *) field);
 451       return;
 452
 453     case GFC_DTYPE_REAL_8:
 454       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 455                   mask, (GFC_REAL_8  *) field);
 456       return;
 457
 458 #ifdef HAVE_GFC_REAL_10
 459     case GFC_DTYPE_REAL_10:
 460       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 461                    mask, (GFC_REAL_10 *) field);
 462       return;
 463 #endif
 464
 465 #ifdef HAVE_GFC_REAL_16
 466     case GFC_DTYPE_REAL_16:
 467       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 468                    mask, (GFC_REAL_16 *) field);
 469       return;
 470 #endif
 471
 472     case GFC_DTYPE_COMPLEX_4:
 473       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 474                   mask, (GFC_COMPLEX_4 *) field);
 475       return;
 476
 477     case GFC_DTYPE_COMPLEX_8:
 478       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 479                   mask, (GFC_COMPLEX_8 *) field);
 480       return;
 481
 482 #ifdef HAVE_GFC_COMPLEX_10
 483     case GFC_DTYPE_COMPLEX_10:
 484       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 485                    mask, (GFC_COMPLEX_10 *) field);
 486       return;
 487 #endif
 488
 489 #ifdef HAVE_GFC_COMPLEX_16
 490     case GFC_DTYPE_COMPLEX_16:
 491       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 492                    mask, (GFC_COMPLEX_16 *) field);
 493       return;
 494 #endif
 495
 496     case GFC_DTYPE_DERIVED_2:
 497       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 498           || GFC_UNALIGNED_2(field))
 499         break;
 500       else
 501         {
 502           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 503                       mask, (GFC_INTEGER_2 *) field);
 504           return;
 505         }
 506
 507     case GFC_DTYPE_DERIVED_4:
 508       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 509           || GFC_UNALIGNED_4(field))
 510         break;
 511       else
 512         {
 513           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 514                       mask, (GFC_INTEGER_4 *) field);
 515           return;
 516         }
 517
 518     case GFC_DTYPE_DERIVED_8:
 519       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 520           || GFC_UNALIGNED_8(field))
 521         break;
 522       else
 523         {
 524           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 525                       mask, (GFC_INTEGER_8 *) field);
 526           return;
 527         }
 528
 529 #ifdef HAVE_GFC_INTEGER_16
 530     case GFC_DTYPE_DERIVED_16:
 531       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 532           || GFC_UNALIGNED_16(field))
 533         break;
 534       else
 535         {
 536           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 537                        mask, (GFC_INTEGER_16 *) field);
 538           return;
 539         }
 540 #endif
 541
 542     }
 543
 544   memset (&tmp, 0, sizeof (tmp));
 545   tmp.dtype = 0;
 546   tmp.data = field;
 547   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
 548 }
 549
 550
 551 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 552                           const gfc_array_char *, const gfc_array_l1 *,
 553                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 554 export_proto(unpack0_char);
 555
 556 void
 557 unpack0_char (gfc_array_char *ret,
 558               GFC_INTEGER_4 ret_length __attribute__((unused)),
 559               const gfc_array_char *vector, const gfc_array_l1 *mask,
 560               char *field, GFC_INTEGER_4 vector_length,
 561               GFC_INTEGER_4 field_length __attribute__((unused)))
 562 {
 563   gfc_array_char tmp;
 564
 565   if (unlikely(compile_options.bounds_check))
 566     unpack_bounds (ret, vector, mask, NULL);
 567
 568   memset (&tmp, 0, sizeof (tmp));
 569   tmp.dtype = 0;
 570   tmp.data = field;
 571   unpack_internal (ret, vector, mask, &tmp, vector_length);
 572 }
 573
 574
 575 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
 576                            const gfc_array_char *, const gfc_array_l1 *,
 577                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
 578 export_proto(unpack0_char4);
 579
 580 void
 581 unpack0_char4 (gfc_array_char *ret,
 582                GFC_INTEGER_4 ret_length __attribute__((unused)),
 583                const gfc_array_char *vector, const gfc_array_l1 *mask,
 584                char *field, GFC_INTEGER_4 vector_length,
 585                GFC_INTEGER_4 field_length __attribute__((unused)))
 586 {
 587   gfc_array_char tmp;
 588
 589   if (unlikely(compile_options.bounds_check))
 590     unpack_bounds (ret, vector, mask, NULL);
 591
 592   memset (&tmp, 0, sizeof (tmp));
 593   tmp.dtype = 0;
 594   tmp.data = field;
 595   unpack_internal (ret, vector, mask, &tmp,
 596                    vector_length * sizeof (gfc_char4_t));
 597 }