libgfortran/intrinsics/unpack_generic.c

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