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