libgfortran/intrinsics/pack_generic.c

   1 /* Generic implementation of the PACK intrinsic
   2    Copyright (C) 2002, 2004, 2005, 2006, 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 /* PACK is specified as follows:
  32
  33    13.14.80 PACK (ARRAY, MASK, [VECTOR])
  34
  35    Description: Pack an array into an array of rank one under the
  36    control of a mask.
  37
  38    Class: Transformational function.
  39
  40    Arguments:
  41       ARRAY   may be of any type. It shall not be scalar.
  42       MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
  43       VECTOR  (optional) shall be of the same type and type parameters
  44               as ARRAY. VECTOR shall have at least as many elements as
  45               there are true elements in MASK. If MASK is a scalar
  46               with the value true, VECTOR shall have at least as many
  47               elements as there are in ARRAY.
  48
  49    Result Characteristics: The result is an array of rank one with the
  50    same type and type parameters as ARRAY. If VECTOR is present, the
  51    result size is that of VECTOR; otherwise, the result size is the
  52    number /t/ of true elements in MASK unless MASK is scalar with the
  53    value true, in which case the result size is the size of ARRAY.
  54
  55    Result Value: Element /i/ of the result is the element of ARRAY
  56    that corresponds to the /i/th true element of MASK, taking elements
  57    in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
  58    present and has size /n/ > /t/, element /i/ of the result has the
  59    value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
  60
  61    Examples: The nonzero elements of an array M with the value
  62    | 0 0 0 |
  63    | 9 0 0 | may be "gathered" by the function PACK. The result of
  64    | 0 0 7 |
  65    PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
  66    VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
  67
  68 There are two variants of the PACK intrinsic: one, where MASK is
  69 array valued, and the other one where MASK is scalar.  */
  70
  71 static void
  72 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
  73                const gfc_array_l1 *mask, const gfc_array_char *vector,
  74                index_type size)
  75 {
  76   /* r.* indicates the return array.  */
  77   index_type rstride0;
  78   char * restrict rptr;
  79   /* s.* indicates the source array.  */
  80   index_type sstride[GFC_MAX_DIMENSIONS];
  81   index_type sstride0;
  82   const char *sptr;
  83   /* m.* indicates the mask array.  */
  84   index_type mstride[GFC_MAX_DIMENSIONS];
  85   index_type mstride0;
  86   const GFC_LOGICAL_1 *mptr;
  87
  88   index_type count[GFC_MAX_DIMENSIONS];
  89   index_type extent[GFC_MAX_DIMENSIONS];
  90   index_type n;
  91   index_type dim;
  92   index_type nelem;
  93   index_type total;
  94   int mask_kind;
  95
  96   dim = GFC_DESCRIPTOR_RANK (array);
  97
  98   sptr = array->data;
  99   mptr = mask->data;
 100
 101   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 102      and using shifting to address size and endian issues.  */
 103
 104   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 105
 106   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 107 #ifdef HAVE_GFC_LOGICAL_16
 108       || mask_kind == 16
 109 #endif
 110       )
 111     {
 112       /*  Don't convert a NULL pointer as we use test for NULL below.  */
 113       if (mptr)
 114         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 115     }
 116   else
 117     runtime_error ("Funny sized logical array");
 118
 119   for (n = 0; n < dim; n++)
 120     {
 121       count[n] = 0;
 122       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 123       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 124       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 125     }
 126   if (sstride[0] == 0)
 127     sstride[0] = size;
 128   if (mstride[0] == 0)
 129     mstride[0] = mask_kind;
 130
 131   if (ret->data == NULL || unlikely (compile_options.bounds_check))
 132     {
 133       /* Count the elements, either for allocating memory or
 134          for bounds checking.  */
 135
 136       if (vector != NULL)
 137         {
 138           /* The return array will have as many
 139              elements as there are in VECTOR.  */
 140           total = GFC_DESCRIPTOR_EXTENT(vector,0);
 141         }
 142       else
 143         {
 144           /* We have to count the true elements in MASK.  */
 145
 146           total = count_0 (mask);
 147         }
 148
 149       if (ret->data == NULL)
 150         {
 151           /* Setup the array descriptor.  */
 152           GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
 153
 154           ret->offset = 0;
 155           if (total == 0)
 156             {
 157               /* In this case, nothing remains to be done.  */
 158               ret->data = internal_malloc_size (1);
 159               return;
 160             }
 161           else
 162             ret->data = internal_malloc_size (size * total);
 163         }
 164       else
 165         {
 166           /* We come here because of range checking.  */
 167           index_type ret_extent;
 168
 169           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
 170           if (total != ret_extent)
 171             runtime_error ("Incorrect extent in return value of PACK intrinsic;"
 172                            " is %ld, should be %ld", (long int) total,
 173                            (long int) ret_extent);
 174         }
 175     }
 176
 177   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 178   if (rstride0 == 0)
 179     rstride0 = size;
 180   sstride0 = sstride[0];
 181   mstride0 = mstride[0];
 182   rptr = ret->data;
 183
 184   while (sptr && mptr)
 185     {
 186       /* Test this element.  */
 187       if (*mptr)
 188         {
 189           /* Add it.  */
 190           memcpy (rptr, sptr, size);
 191           rptr += rstride0;
 192         }
 193       /* Advance to the next element.  */
 194       sptr += sstride0;
 195       mptr += mstride0;
 196       count[0]++;
 197       n = 0;
 198       while (count[n] == extent[n])
 199         {
 200           /* When we get to the end of a dimension, reset it and increment
 201              the next dimension.  */
 202           count[n] = 0;
 203           /* We could precalculate these products, but this is a less
 204              frequently used path so probably not worth it.  */
 205           sptr -= sstride[n] * extent[n];
 206           mptr -= mstride[n] * extent[n];
 207           n++;
 208           if (n >= dim)
 209             {
 210               /* Break out of the loop.  */
 211               sptr = NULL;
 212               break;
 213             }
 214           else
 215             {
 216               count[n]++;
 217               sptr += sstride[n];
 218               mptr += mstride[n];
 219             }
 220         }
 221     }
 222
 223   /* Add any remaining elements from VECTOR.  */
 224   if (vector)
 225     {
 226       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 227       nelem = ((rptr - ret->data) / rstride0);
 228       if (n > nelem)
 229         {
 230           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 231           if (sstride0 == 0)
 232             sstride0 = size;
 233
 234           sptr = vector->data + sstride0 * nelem;
 235           n -= nelem;
 236           while (n--)
 237             {
 238               memcpy (rptr, sptr, size);
 239               rptr += rstride0;
 240               sptr += sstride0;
 241             }
 242         }
 243     }
 244 }
 245
 246 extern void pack (gfc_array_char *, const gfc_array_char *,
 247                   const gfc_array_l1 *, const gfc_array_char *);
 248 export_proto(pack);
 249
 250 void
 251 pack (gfc_array_char *ret, const gfc_array_char *array,
 252       const gfc_array_l1 *mask, const gfc_array_char *vector)
 253 {
 254   index_type type_size;
 255   index_type size;
 256
 257   type_size = GFC_DTYPE_TYPE_SIZE(array);
 258
 259   switch(type_size)
 260     {
 261     case GFC_DTYPE_LOGICAL_1:
 262     case GFC_DTYPE_INTEGER_1:
 263     case GFC_DTYPE_DERIVED_1:
 264       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
 265                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
 266       return;
 267
 268     case GFC_DTYPE_LOGICAL_2:
 269     case GFC_DTYPE_INTEGER_2:
 270       pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 271                (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 272       return;
 273
 274     case GFC_DTYPE_LOGICAL_4:
 275     case GFC_DTYPE_INTEGER_4:
 276       pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 277                (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 278       return;
 279
 280     case GFC_DTYPE_LOGICAL_8:
 281     case GFC_DTYPE_INTEGER_8:
 282       pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 283                (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 284       return;
 285
 286 #ifdef HAVE_GFC_INTEGER_16
 287     case GFC_DTYPE_LOGICAL_16:
 288     case GFC_DTYPE_INTEGER_16:
 289       pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 290                 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 291       return;
 292 #endif
 293
 294     case GFC_DTYPE_REAL_4:
 295       pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
 296                (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
 297       return;
 298
 299     case GFC_DTYPE_REAL_8:
 300       pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
 301                (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
 302       return;
 303
 304 #ifdef HAVE_GFC_REAL_10
 305     case GFC_DTYPE_REAL_10:
 306       pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
 307                 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
 308       return;
 309 #endif
 310
 311 #ifdef HAVE_GFC_REAL_16
 312     case GFC_DTYPE_REAL_16:
 313       pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
 314                 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
 315       return;
 316 #endif
 317
 318     case GFC_DTYPE_COMPLEX_4:
 319       pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
 320                (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
 321       return;
 322
 323     case GFC_DTYPE_COMPLEX_8:
 324       pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
 325                (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
 326       return;
 327
 328 #ifdef HAVE_GFC_COMPLEX_10
 329     case GFC_DTYPE_COMPLEX_10:
 330       pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
 331                 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
 332       return;
 333 #endif
 334
 335 #ifdef HAVE_GFC_COMPLEX_16
 336     case GFC_DTYPE_COMPLEX_16:
 337       pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
 338                 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
 339       return;
 340 #endif
 341
 342       /* For derived types, let's check the actual alignment of the
 343          data pointers.  If they are aligned, we can safely call
 344          the unpack functions.  */
 345
 346     case GFC_DTYPE_DERIVED_2:
 347       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data)
 348           || (vector && GFC_UNALIGNED_2(vector->data)))
 349         break;
 350       else
 351         {
 352           pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
 353                    (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
 354           return;
 355         }
 356
 357     case GFC_DTYPE_DERIVED_4:
 358       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data)
 359           || (vector && GFC_UNALIGNED_4(vector->data)))
 360         break;
 361       else
 362         {
 363           pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
 364                    (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
 365           return;
 366         }
 367
 368     case GFC_DTYPE_DERIVED_8:
 369       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data)
 370           || (vector && GFC_UNALIGNED_8(vector->data)))
 371         break;
 372       else
 373         {
 374           pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
 375                    (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
 376           return;
 377         }
 378
 379 #ifdef HAVE_GFC_INTEGER_16
 380     case GFC_DTYPE_DERIVED_16:
 381       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)
 382           || (vector && GFC_UNALIGNED_16(vector->data)))
 383         break;
 384       else
 385         {
 386           pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 387                    (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
 388           return;
 389         }
 390 #endif
 391
 392     }
 393
 394   size = GFC_DESCRIPTOR_SIZE (array);
 395   pack_internal (ret, array, mask, vector, size);
 396 }
 397
 398
 399 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 400                        const gfc_array_l1 *, const gfc_array_char *,
 401                        GFC_INTEGER_4, GFC_INTEGER_4);
 402 export_proto(pack_char);
 403
 404 void
 405 pack_char (gfc_array_char *ret,
 406            GFC_INTEGER_4 ret_length __attribute__((unused)),
 407            const gfc_array_char *array, const gfc_array_l1 *mask,
 408            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 409            GFC_INTEGER_4 vector_length __attribute__((unused)))
 410 {
 411   pack_internal (ret, array, mask, vector, array_length);
 412 }
 413
 414
 415 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 416                         const gfc_array_l1 *, const gfc_array_char *,
 417                         GFC_INTEGER_4, GFC_INTEGER_4);
 418 export_proto(pack_char4);
 419
 420 void
 421 pack_char4 (gfc_array_char *ret,
 422             GFC_INTEGER_4 ret_length __attribute__((unused)),
 423             const gfc_array_char *array, const gfc_array_l1 *mask,
 424             const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 425             GFC_INTEGER_4 vector_length __attribute__((unused)))
 426 {
 427   pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
 428 }
 429
 430
 431 static void
 432 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
 433                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
 434                  index_type size)
 435 {
 436   /* r.* indicates the return array.  */
 437   index_type rstride0;
 438   char *rptr;
 439   /* s.* indicates the source array.  */
 440   index_type sstride[GFC_MAX_DIMENSIONS];
 441   index_type sstride0;
 442   const char *sptr;
 443
 444   index_type count[GFC_MAX_DIMENSIONS];
 445   index_type extent[GFC_MAX_DIMENSIONS];
 446   index_type n;
 447   index_type dim;
 448   index_type ssize;
 449   index_type nelem;
 450   index_type total;
 451
 452   dim = GFC_DESCRIPTOR_RANK (array);
 453   ssize = 1;
 454   for (n = 0; n < dim; n++)
 455     {
 456       count[n] = 0;
 457       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 458       if (extent[n] < 0)
 459         extent[n] = 0;
 460
 461       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 462       ssize *= extent[n];
 463     }
 464   if (sstride[0] == 0)
 465     sstride[0] = size;
 466
 467   sstride0 = sstride[0];
 468
 469   if (ssize != 0)
 470     sptr = array->data;
 471   else
 472     sptr = NULL;
 473
 474   if (ret->data == NULL)
 475     {
 476       /* Allocate the memory for the result.  */
 477
 478       if (vector != NULL)
 479         {
 480           /* The return array will have as many elements as there are
 481              in vector.  */
 482           total = GFC_DESCRIPTOR_EXTENT(vector,0);
 483           if (total <= 0)
 484             {
 485               total = 0;
 486               vector = NULL;
 487             }
 488         }
 489       else
 490         {
 491           if (*mask)
 492             {
 493               /* The result array will have as many elements as the input
 494                  array.  */
 495               total = extent[0];
 496               for (n = 1; n < dim; n++)
 497                 total *= extent[n];
 498             }
 499           else
 500             /* The result array will be empty.  */
 501             total = 0;
 502         }
 503
 504       /* Setup the array descriptor.  */
 505       GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
 506
 507       ret->offset = 0;
 508
 509       if (total == 0)
 510         {
 511           ret->data = internal_malloc_size (1);
 512           return;
 513         }
 514       else
 515         ret->data = internal_malloc_size (size * total);
 516     }
 517
 518   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
 519   if (rstride0 == 0)
 520     rstride0 = size;
 521   rptr = ret->data;
 522
 523   /* The remaining possibilities are now:
 524        If MASK is .TRUE., we have to copy the source array into the
 525      result array. We then have to fill it up with elements from VECTOR.
 526        If MASK is .FALSE., we have to copy VECTOR into the result
 527      array. If VECTOR were not present we would have already returned.  */
 528
 529   if (*mask && ssize != 0)
 530     {
 531       while (sptr)
 532         {
 533           /* Add this element.  */
 534           memcpy (rptr, sptr, size);
 535           rptr += rstride0;
 536
 537           /* Advance to the next element.  */
 538           sptr += sstride0;
 539           count[0]++;
 540           n = 0;
 541           while (count[n] == extent[n])
 542             {
 543               /* When we get to the end of a dimension, reset it and
 544                  increment the next dimension.  */
 545               count[n] = 0;
 546               /* We could precalculate these products, but this is a
 547                  less frequently used path so probably not worth it.  */
 548               sptr -= sstride[n] * extent[n];
 549               n++;
 550               if (n >= dim)
 551                 {
 552                   /* Break out of the loop.  */
 553                   sptr = NULL;
 554                   break;
 555                 }
 556               else
 557                 {
 558                   count[n]++;
 559                   sptr += sstride[n];
 560                 }
 561             }
 562         }
 563     }
 564
 565   /* Add any remaining elements from VECTOR.  */
 566   if (vector)
 567     {
 568       n = GFC_DESCRIPTOR_EXTENT(vector,0);
 569       nelem = ((rptr - ret->data) / rstride0);
 570       if (n > nelem)
 571         {
 572           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 573           if (sstride0 == 0)
 574             sstride0 = size;
 575
 576           sptr = vector->data + sstride0 * nelem;
 577           n -= nelem;
 578           while (n--)
 579             {
 580               memcpy (rptr, sptr, size);
 581               rptr += rstride0;
 582               sptr += sstride0;
 583             }
 584         }
 585     }
 586 }
 587
 588 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
 589                     const GFC_LOGICAL_4 *, const gfc_array_char *);
 590 export_proto(pack_s);
 591
 592 void
 593 pack_s (gfc_array_char *ret, const gfc_array_char *array,
 594         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
 595 {
 596   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 597 }
 598
 599
 600 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
 601                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
 602                          const gfc_array_char *, GFC_INTEGER_4,
 603                          GFC_INTEGER_4);
 604 export_proto(pack_s_char);
 605
 606 void
 607 pack_s_char (gfc_array_char *ret,
 608              GFC_INTEGER_4 ret_length __attribute__((unused)),
 609              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 610              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 611              GFC_INTEGER_4 vector_length __attribute__((unused)))
 612 {
 613   pack_s_internal (ret, array, mask, vector, array_length);
 614 }
 615
 616
 617 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
 618                           const gfc_array_char *array, const GFC_LOGICAL_4 *,
 619                           const gfc_array_char *, GFC_INTEGER_4,
 620                           GFC_INTEGER_4);
 621 export_proto(pack_s_char4);
 622
 623 void
 624 pack_s_char4 (gfc_array_char *ret,
 625               GFC_INTEGER_4 ret_length __attribute__((unused)),
 626               const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 627               const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 628               GFC_INTEGER_4 vector_length __attribute__((unused)))
 629 {
 630   pack_s_internal (ret, array, mask, vector,
 631                    array_length * sizeof (gfc_char4_t));
 632 }