libgfortran/intrinsics/pack_generic.c

   1 /* Generic implementation of the PACK intrinsic
   2    Copyright (C) 2002, 2004, 2005, 2006 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 "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35 #include "libgfortran.h"
  36
  37 /* PACK is specified as follows:
  38
  39    13.14.80 PACK (ARRAY, MASK, [VECTOR])
  40
  41    Description: Pack an array into an array of rank one under the
  42    control of a mask.
  43
  44    Class: Transformational function.
  45
  46    Arguments:
  47       ARRAY   may be of any type. It shall not be scalar.
  48       MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
  49       VECTOR  (optional) shall be of the same type and type parameters
  50               as ARRAY. VECTOR shall have at least as many elements as
  51               there are true elements in MASK. If MASK is a scalar
  52               with the value true, VECTOR shall have at least as many
  53               elements as there are in ARRAY.
  54
  55    Result Characteristics: The result is an array of rank one with the
  56    same type and type parameters as ARRAY. If VECTOR is present, the
  57    result size is that of VECTOR; otherwise, the result size is the
  58    number /t/ of true elements in MASK unless MASK is scalar with the
  59    value true, in which case the result size is the size of ARRAY.
  60
  61    Result Value: Element /i/ of the result is the element of ARRAY
  62    that corresponds to the /i/th true element of MASK, taking elements
  63    in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
  64    present and has size /n/ > /t/, element /i/ of the result has the
  65    value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
  66
  67    Examples: The nonzero elements of an array M with the value
  68    | 0 0 0 |
  69    | 9 0 0 | may be "gathered" by the function PACK. The result of
  70    | 0 0 7 |
  71    PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
  72    VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
  73
  74 There are two variants of the PACK intrinsic: one, where MASK is
  75 array valued, and the other one where MASK is scalar.  */
  76
  77 static void
  78 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
  79                const gfc_array_l1 *mask, const gfc_array_char *vector,
  80                index_type size)
  81 {
  82   /* r.* indicates the return array.  */
  83   index_type rstride0;
  84   char *rptr;
  85   /* s.* indicates the source array.  */
  86   index_type sstride[GFC_MAX_DIMENSIONS];
  87   index_type sstride0;
  88   const char *sptr;
  89   /* m.* indicates the mask array.  */
  90   index_type mstride[GFC_MAX_DIMENSIONS];
  91   index_type mstride0;
  92   const GFC_LOGICAL_1 *mptr;
  93
  94   index_type count[GFC_MAX_DIMENSIONS];
  95   index_type extent[GFC_MAX_DIMENSIONS];
  96   int zero_sized;
  97   index_type n;
  98   index_type dim;
  99   index_type nelem;
 100   index_type total;
 101   int mask_kind;
 102
 103   dim = GFC_DESCRIPTOR_RANK (array);
 104
 105   sptr = array->data;
 106   mptr = mask->data;
 107
 108   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 109      and using shifting to address size and endian issues.  */
 110
 111   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 112
 113   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 114 #ifdef HAVE_GFC_LOGICAL_16
 115       || mask_kind == 16
 116 #endif
 117       )
 118     {
 119       /*  Don't convert a NULL pointer as we use test for NULL below.  */
 120       if (mptr)
 121         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 122     }
 123   else
 124     runtime_error ("Funny sized logical array");
 125
 126   zero_sized = 0;
 127   for (n = 0; n < dim; n++)
 128     {
 129       count[n] = 0;
 130       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 131       if (extent[n] <= 0)
 132        zero_sized = 1;
 133       sstride[n] = array->dim[n].stride * size;
 134       mstride[n] = mask->dim[n].stride * mask_kind;
 135     }
 136   if (sstride[0] == 0)
 137     sstride[0] = size;
 138   if (mstride[0] == 0)
 139     mstride[0] = mask_kind;
 140
 141   if (ret->data == NULL || compile_options.bounds_check)
 142     {
 143       /* Count the elements, either for allocating memory or
 144          for bounds checking.  */
 145
 146       if (vector != NULL)
 147         {
 148           /* The return array will have as many
 149              elements as there are in VECTOR.  */
 150           total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 151         }
 152       else
 153         {
 154           /* We have to count the true elements in MASK.  */
 155
 156           /* TODO: We could speed up pack easily in the case of only
 157              few .TRUE. entries in MASK, by keeping track of where we
 158              would be in the source array during the initial traversal
 159              of MASK, and caching the pointers to those elements. Then,
 160              supposed the number of elements is small enough, we would
 161              only have to traverse the list, and copy those elements
 162              into the result array. In the case of datatypes which fit
 163              in one of the integer types we could also cache the
 164              value instead of a pointer to it.
 165              This approach might be bad from the point of view of
 166              cache behavior in the case where our cache is not big
 167              enough to hold all elements that have to be copied.  */
 168
 169           const GFC_LOGICAL_1 *m = mptr;
 170
 171           total = 0;
 172           if (zero_sized)
 173             m = NULL;
 174
 175           while (m)
 176             {
 177               /* Test this element.  */
 178               if (*m)
 179                 total++;
 180
 181               /* Advance to the next element.  */
 182               m += mstride[0];
 183               count[0]++;
 184               n = 0;
 185               while (count[n] == extent[n])
 186                 {
 187                   /* When we get to the end of a dimension, reset it
 188                      and increment the next dimension.  */
 189                   count[n] = 0;
 190                   /* We could precalculate this product, but this is a
 191                      less frequently used path so probably not worth
 192                      it.  */
 193                   m -= mstride[n] * extent[n];
 194                   n++;
 195                   if (n >= dim)
 196                     {
 197                       /* Break out of the loop.  */
 198                       m = NULL;
 199                       break;
 200                     }
 201                   else
 202                     {
 203                       count[n]++;
 204                       m += mstride[n];
 205                     }
 206                 }
 207             }
 208         }
 209
 210       if (ret->data == NULL)
 211         {
 212           /* Setup the array descriptor.  */
 213           ret->dim[0].lbound = 0;
 214           ret->dim[0].ubound = total - 1;
 215           ret->dim[0].stride = 1;
 216
 217           ret->offset = 0;
 218           if (total == 0)
 219             {
 220               /* In this case, nothing remains to be done.  */
 221               ret->data = internal_malloc_size (1);
 222               return;
 223             }
 224           else
 225             ret->data = internal_malloc_size (size * total);
 226         }
 227       else
 228         {
 229           /* We come here because of range checking.  */
 230           index_type ret_extent;
 231
 232           ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
 233           if (total != ret_extent)
 234             runtime_error ("Incorrect extent in return value of PACK intrinsic;"
 235                            " is %ld, should be %ld", (long int) total,
 236                            (long int) ret_extent);
 237         }
 238     }
 239
 240   rstride0 = ret->dim[0].stride * size;
 241   if (rstride0 == 0)
 242     rstride0 = size;
 243   sstride0 = sstride[0];
 244   mstride0 = mstride[0];
 245   rptr = ret->data;
 246
 247   while (sptr && mptr)
 248     {
 249       /* Test this element.  */
 250       if (*mptr)
 251         {
 252           /* Add it.  */
 253           memcpy (rptr, sptr, size);
 254           rptr += rstride0;
 255         }
 256       /* Advance to the next element.  */
 257       sptr += sstride0;
 258       mptr += mstride0;
 259       count[0]++;
 260       n = 0;
 261       while (count[n] == extent[n])
 262         {
 263           /* When we get to the end of a dimension, reset it and increment
 264              the next dimension.  */
 265           count[n] = 0;
 266           /* We could precalculate these products, but this is a less
 267              frequently used path so probably not worth it.  */
 268           sptr -= sstride[n] * extent[n];
 269           mptr -= mstride[n] * extent[n];
 270           n++;
 271           if (n >= dim)
 272             {
 273               /* Break out of the loop.  */
 274               sptr = NULL;
 275               break;
 276             }
 277           else
 278             {
 279               count[n]++;
 280               sptr += sstride[n];
 281               mptr += mstride[n];
 282             }
 283         }
 284     }
 285
 286   /* Add any remaining elements from VECTOR.  */
 287   if (vector)
 288     {
 289       n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 290       nelem = ((rptr - ret->data) / rstride0);
 291       if (n > nelem)
 292         {
 293           sstride0 = vector->dim[0].stride * size;
 294           if (sstride0 == 0)
 295             sstride0 = size;
 296
 297           sptr = vector->data + sstride0 * nelem;
 298           n -= nelem;
 299           while (n--)
 300             {
 301               memcpy (rptr, sptr, size);
 302               rptr += rstride0;
 303               sptr += sstride0;
 304             }
 305         }
 306     }
 307 }
 308
 309 extern void pack (gfc_array_char *, const gfc_array_char *,
 310                   const gfc_array_l4 *, const gfc_array_char *);
 311 export_proto(pack);
 312
 313 void
 314 pack (gfc_array_char *ret, const gfc_array_char *array,
 315       const gfc_array_l4 *mask, const gfc_array_char *vector)
 316 {
 317   pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 318 }
 319
 320 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 321                        const gfc_array_l4 *, const gfc_array_char *,
 322                        GFC_INTEGER_4, GFC_INTEGER_4);
 323 export_proto(pack_char);
 324
 325 void
 326 pack_char (gfc_array_char *ret,
 327            GFC_INTEGER_4 ret_length __attribute__((unused)),
 328            const gfc_array_char *array, const gfc_array_l4 *mask,
 329            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 330            GFC_INTEGER_4 vector_length __attribute__((unused)))
 331 {
 332   pack_internal (ret, array, mask, vector, array_length);
 333 }
 334
 335 static void
 336 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
 337                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
 338                  index_type size)
 339 {
 340   /* r.* indicates the return array.  */
 341   index_type rstride0;
 342   char *rptr;
 343   /* s.* indicates the source array.  */
 344   index_type sstride[GFC_MAX_DIMENSIONS];
 345   index_type sstride0;
 346   const char *sptr;
 347
 348   index_type count[GFC_MAX_DIMENSIONS];
 349   index_type extent[GFC_MAX_DIMENSIONS];
 350   index_type n;
 351   index_type dim;
 352   index_type ssize;
 353   index_type nelem;
 354
 355   dim = GFC_DESCRIPTOR_RANK (array);
 356   ssize = 1;
 357   for (n = 0; n < dim; n++)
 358     {
 359       count[n] = 0;
 360       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 361       sstride[n] = array->dim[n].stride * size;
 362       ssize *= extent[n];
 363     }
 364   if (sstride[0] == 0)
 365     sstride[0] = size;
 366
 367   sstride0 = sstride[0];
 368   sptr = array->data;
 369
 370   if (ret->data == NULL)
 371     {
 372       /* Allocate the memory for the result.  */
 373       int total;
 374
 375       if (vector != NULL)
 376         {
 377           /* The return array will have as many elements as there are
 378              in vector.  */
 379           total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 380         }
 381       else
 382         {
 383           if (*mask)
 384             {
 385               /* The result array will have as many elements as the input
 386                  array.  */
 387               total = extent[0];
 388               for (n = 1; n < dim; n++)
 389                 total *= extent[n];
 390             }
 391           else
 392             /* The result array will be empty.  */
 393             total = 0;
 394         }
 395
 396       /* Setup the array descriptor.  */
 397       ret->dim[0].lbound = 0;
 398       ret->dim[0].ubound = total - 1;
 399       ret->dim[0].stride = 1;
 400       ret->offset = 0;
 401
 402       if (total == 0)
 403         {
 404           ret->data = internal_malloc_size (1);
 405           return;
 406         }
 407       else
 408         ret->data = internal_malloc_size (size * total);
 409     }
 410
 411   rstride0 = ret->dim[0].stride * size;
 412   if (rstride0 == 0)
 413     rstride0 = size;
 414   rptr = ret->data;
 415
 416   /* The remaining possibilities are now:
 417        If MASK is .TRUE., we have to copy the source array into the
 418      result array. We then have to fill it up with elements from VECTOR.
 419        If MASK is .FALSE., we have to copy VECTOR into the result
 420      array. If VECTOR were not present we would have already returned.  */
 421
 422   if (*mask && ssize != 0)
 423     {
 424       while (sptr)
 425         {
 426           /* Add this element.  */
 427           memcpy (rptr, sptr, size);
 428           rptr += rstride0;
 429
 430           /* Advance to the next element.  */
 431           sptr += sstride0;
 432           count[0]++;
 433           n = 0;
 434           while (count[n] == extent[n])
 435             {
 436               /* When we get to the end of a dimension, reset it and
 437                  increment the next dimension.  */
 438               count[n] = 0;
 439               /* We could precalculate these products, but this is a
 440                  less frequently used path so probably not worth it.  */
 441               sptr -= sstride[n] * extent[n];
 442               n++;
 443               if (n >= dim)
 444                 {
 445                   /* Break out of the loop.  */
 446                   sptr = NULL;
 447                   break;
 448                 }
 449               else
 450                 {
 451                   count[n]++;
 452                   sptr += sstride[n];
 453                 }
 454             }
 455         }
 456     }
 457
 458   /* Add any remaining elements from VECTOR.  */
 459   if (vector)
 460     {
 461       n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 462       nelem = ((rptr - ret->data) / rstride0);
 463       if (n > nelem)
 464         {
 465           sstride0 = vector->dim[0].stride * size;
 466           if (sstride0 == 0)
 467             sstride0 = size;
 468
 469           sptr = vector->data + sstride0 * nelem;
 470           n -= nelem;
 471           while (n--)
 472             {
 473               memcpy (rptr, sptr, size);
 474               rptr += rstride0;
 475               sptr += sstride0;
 476             }
 477         }
 478     }
 479 }
 480
 481 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
 482                     const GFC_LOGICAL_4 *, const gfc_array_char *);
 483 export_proto(pack_s);
 484
 485 void
 486 pack_s (gfc_array_char *ret, const gfc_array_char *array,
 487         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
 488 {
 489   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 490 }
 491
 492 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
 493                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
 494                          const gfc_array_char *, GFC_INTEGER_4,
 495                          GFC_INTEGER_4);
 496 export_proto(pack_s_char);
 497
 498 void
 499 pack_s_char (gfc_array_char *ret,
 500              GFC_INTEGER_4 ret_length __attribute__((unused)),
 501              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 502              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 503              GFC_INTEGER_4 vector_length __attribute__((unused)))
 504 {
 505   pack_s_internal (ret, array, mask, vector, array_length);
 506 }