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