libgfortran/intrinsics/pack_generic.c

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