libgfortran/intrinsics/pack_generic.c

   1 /* Generic implementation of the PACK intrinsic
   2    Copyright (C) 2002, 2004, 2005 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 fucntion.
  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_l4 *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_4 *mptr;
  93
  94   index_type count[GFC_MAX_DIMENSIONS];
  95   index_type extent[GFC_MAX_DIMENSIONS];
  96   index_type n;
  97   index_type dim;
  98   index_type nelem;
  99
 100   dim = GFC_DESCRIPTOR_RANK (array);
 101   for (n = 0; n < dim; n++)
 102     {
 103       count[n] = 0;
 104       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 105       sstride[n] = array->dim[n].stride * size;
 106       mstride[n] = mask->dim[n].stride;
 107     }
 108   if (sstride[0] == 0)
 109     sstride[0] = size;
 110   if (mstride[0] == 0)
 111     mstride[0] = 1;
 112
 113   sptr = array->data;
 114   mptr = mask->data;
 115
 116   /* Use the same loop for both logical types. */
 117   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 118     {
 119       if (GFC_DESCRIPTOR_SIZE (mask) != 8)
 120         runtime_error ("Funny sized logical array");
 121       for (n = 0; n < dim; n++)
 122         mstride[n] <<= 1;
 123       mptr = GFOR_POINTER_L8_TO_L4 (mptr);
 124     }
 125
 126   if (ret->data == NULL)
 127     {
 128       /* Allocate the memory for the result.  */
 129       int total;
 130
 131       if (vector != NULL)
 132         {
 133           /* The return array will have as many
 134              elements as there are in VECTOR.  */
 135           total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 136         }
 137       else
 138         {
 139           /* We have to count the true elements in MASK.  */
 140
 141           /* TODO: We could speed up pack easily in the case of only
 142              few .TRUE. entries in MASK, by keeping track of where we
 143              would be in the source array during the initial traversal
 144              of MASK, and caching the pointers to those elements. Then,
 145              supposed the number of elements is small enough, we would
 146              only have to traverse the list, and copy those elements
 147              into the result array. In the case of datatypes which fit
 148              in one of the integer types we could also cache the
 149              value instead of a pointer to it.
 150              This approach might be bad from the point of view of
 151              cache behavior in the case where our cache is not big
 152              enough to hold all elements that have to be copied.  */
 153
 154           const GFC_LOGICAL_4 *m = mptr;
 155
 156           total = 0;
 157
 158           while (m)
 159             {
 160               /* Test this element.  */
 161               if (*m)
 162                 total++;
 163
 164               /* Advance to the next element.  */
 165               m += mstride[0];
 166               count[0]++;
 167               n = 0;
 168               while (count[n] == extent[n])
 169                 {
 170                   /* When we get to the end of a dimension, reset it
 171                      and increment the next dimension.  */
 172                   count[n] = 0;
 173                   /* We could precalculate this product, but this is a
 174                      less frequently used path so proabably not worth
 175                      it.  */
 176                   m -= mstride[n] * extent[n];
 177                   n++;
 178                   if (n >= dim)
 179                     {
 180                       /* Break out of the loop.  */
 181                       m = NULL;
 182                       break;
 183                     }
 184                   else
 185                     {
 186                       count[n]++;
 187                       m += mstride[n];
 188                     }
 189                 }
 190             }
 191         }
 192
 193       /* Setup the array descriptor.  */
 194       ret->dim[0].lbound = 0;
 195       ret->dim[0].ubound = total - 1;
 196       ret->dim[0].stride = 1;
 197
 198       ret->data = internal_malloc_size (size * total);
 199       ret->offset = 0;
 200
 201       if (total == 0)
 202         /* In this case, nothing remains to be done.  */
 203         return;
 204     }
 205
 206   rstride0 = ret->dim[0].stride * size;
 207   if (rstride0 == 0)
 208     rstride0 = size;
 209   sstride0 = sstride[0];
 210   mstride0 = mstride[0];
 211   rptr = ret->data;
 212
 213   while (sptr)
 214     {
 215       /* Test this element.  */
 216       if (*mptr)
 217         {
 218           /* Add it.  */
 219           memcpy (rptr, sptr, size);
 220           rptr += rstride0;
 221         }
 222       /* Advance to the next element.  */
 223       sptr += sstride0;
 224       mptr += mstride0;
 225       count[0]++;
 226       n = 0;
 227       while (count[n] == extent[n])
 228         {
 229           /* When we get to the end of a dimension, reset it and increment
 230              the next dimension.  */
 231           count[n] = 0;
 232           /* We could precalculate these products, but this is a less
 233              frequently used path so proabably not worth it.  */
 234           sptr -= sstride[n] * extent[n];
 235           mptr -= mstride[n] * extent[n];
 236           n++;
 237           if (n >= dim)
 238             {
 239               /* Break out of the loop.  */
 240               sptr = NULL;
 241               break;
 242             }
 243           else
 244             {
 245               count[n]++;
 246               sptr += sstride[n];
 247               mptr += mstride[n];
 248             }
 249         }
 250     }
 251
 252   /* Add any remaining elements from VECTOR.  */
 253   if (vector)
 254     {
 255       n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 256       nelem = ((rptr - ret->data) / rstride0);
 257       if (n > nelem)
 258         {
 259           sstride0 = vector->dim[0].stride * size;
 260           if (sstride0 == 0)
 261             sstride0 = size;
 262
 263           sptr = vector->data + sstride0 * nelem;
 264           n -= nelem;
 265           while (n--)
 266             {
 267               memcpy (rptr, sptr, size);
 268               rptr += rstride0;
 269               sptr += sstride0;
 270             }
 271         }
 272     }
 273 }
 274
 275 extern void pack (gfc_array_char *, const gfc_array_char *,
 276                   const gfc_array_l4 *, const gfc_array_char *);
 277 export_proto(pack);
 278
 279 void
 280 pack (gfc_array_char *ret, const gfc_array_char *array,
 281       const gfc_array_l4 *mask, const gfc_array_char *vector)
 282 {
 283   pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 284 }
 285
 286 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
 287                        const gfc_array_l4 *, const gfc_array_char *,
 288                        GFC_INTEGER_4, GFC_INTEGER_4);
 289 export_proto(pack_char);
 290
 291 void
 292 pack_char (gfc_array_char *ret,
 293            GFC_INTEGER_4 ret_length __attribute__((unused)),
 294            const gfc_array_char *array, const gfc_array_l4 *mask,
 295            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 296            GFC_INTEGER_4 vector_length __attribute__((unused)))
 297 {
 298   pack_internal (ret, array, mask, vector, array_length);
 299 }
 300
 301 static void
 302 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
 303                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
 304                  index_type size)
 305 {
 306   /* r.* indicates the return array.  */
 307   index_type rstride0;
 308   char *rptr;
 309   /* s.* indicates the source array.  */
 310   index_type sstride[GFC_MAX_DIMENSIONS];
 311   index_type sstride0;
 312   const char *sptr;
 313
 314   index_type count[GFC_MAX_DIMENSIONS];
 315   index_type extent[GFC_MAX_DIMENSIONS];
 316   index_type n;
 317   index_type dim;
 318   index_type nelem;
 319
 320   dim = GFC_DESCRIPTOR_RANK (array);
 321   for (n = 0; n < dim; n++)
 322     {
 323       count[n] = 0;
 324       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 325       sstride[n] = array->dim[n].stride * size;
 326     }
 327   if (sstride[0] == 0)
 328     sstride[0] = size;
 329
 330   sstride0 = sstride[0];
 331   sptr = array->data;
 332
 333   if (ret->data == NULL)
 334     {
 335       /* Allocate the memory for the result.  */
 336       int total;
 337
 338       if (vector != NULL)
 339         {
 340           /* The return array will have as many elements as there are
 341              in vector.  */
 342           total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 343         }
 344       else
 345         {
 346           if (*mask)
 347             {
 348               /* The result array will have as many elements as the input
 349                  array.  */
 350               total = extent[0];
 351               for (n = 1; n < dim; n++)
 352                 total *= extent[n];
 353             }
 354           else
 355             {
 356               /* The result array will be empty.  */
 357               ret->dim[0].lbound = 0;
 358               ret->dim[0].ubound = -1;
 359               ret->dim[0].stride = 1;
 360               ret->data = internal_malloc_size (0);
 361               ret->offset = 0;
 362
 363               return;
 364             }
 365         }
 366
 367       /* Setup the array descriptor.  */
 368       ret->dim[0].lbound = 0;
 369       ret->dim[0].ubound = total - 1;
 370       ret->dim[0].stride = 1;
 371
 372       ret->data = internal_malloc_size (size * total);
 373       ret->offset = 0;
 374     }
 375
 376   rstride0 = ret->dim[0].stride * size;
 377   if (rstride0 == 0)
 378     rstride0 = size;
 379   rptr = ret->data;
 380
 381   /* The remaining possibilities are now:
 382        If MASK is .TRUE., we have to copy the source array into the
 383      result array. We then have to fill it up with elements from VECTOR.
 384        If MASK is .FALSE., we have to copy VECTOR into the result
 385      array. If VECTOR were not present we would have already returned.  */
 386
 387   if (*mask)
 388     {
 389       while (sptr)
 390         {
 391           /* Add this element.  */
 392           memcpy (rptr, sptr, size);
 393           rptr += rstride0;
 394
 395           /* Advance to the next element.  */
 396           sptr += sstride0;
 397           count[0]++;
 398           n = 0;
 399           while (count[n] == extent[n])
 400             {
 401               /* When we get to the end of a dimension, reset it and
 402                  increment the next dimension.  */
 403               count[n] = 0;
 404               /* We could precalculate these products, but this is a
 405                  less frequently used path so proabably not worth it.  */
 406               sptr -= sstride[n] * extent[n];
 407               n++;
 408               if (n >= dim)
 409                 {
 410                   /* Break out of the loop.  */
 411                   sptr = NULL;
 412                   break;
 413                 }
 414               else
 415                 {
 416                   count[n]++;
 417                   sptr += sstride[n];
 418                 }
 419             }
 420         }
 421     }
 422
 423   /* Add any remaining elements from VECTOR.  */
 424   if (vector)
 425     {
 426       n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
 427       nelem = ((rptr - ret->data) / rstride0);
 428       if (n > nelem)
 429         {
 430           sstride0 = vector->dim[0].stride * size;
 431           if (sstride0 == 0)
 432             sstride0 = size;
 433
 434           sptr = vector->data + sstride0 * nelem;
 435           n -= nelem;
 436           while (n--)
 437             {
 438               memcpy (rptr, sptr, size);
 439               rptr += rstride0;
 440               sptr += sstride0;
 441             }
 442         }
 443     }
 444 }
 445
 446 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
 447                     const GFC_LOGICAL_4 *, const gfc_array_char *);
 448 export_proto(pack_s);
 449
 450 void
 451 pack_s (gfc_array_char *ret, const gfc_array_char *array,
 452         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
 453 {
 454   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
 455 }
 456
 457 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
 458                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
 459                          const gfc_array_char *, GFC_INTEGER_4,
 460                          GFC_INTEGER_4);
 461 export_proto(pack_s_char);
 462
 463 void
 464 pack_s_char (gfc_array_char *ret,
 465              GFC_INTEGER_4 ret_length __attribute__((unused)),
 466              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
 467              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
 468              GFC_INTEGER_4 vector_length __attribute__((unused)))
 469 {
 470   pack_s_internal (ret, array, mask, vector, array_length);
 471 }