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