libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 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 static void
  38 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
  39                  const gfc_array_l4 *mask, const gfc_array_char *field,
  40                  index_type size, index_type fsize)
  41 {
  42   /* r.* indicates the return array.  */
  43   index_type rstride[GFC_MAX_DIMENSIONS];
  44   index_type rstride0;
  45   index_type rs;
  46   char *rptr;
  47   /* v.* indicates the vector array.  */
  48   index_type vstride0;
  49   char *vptr;
  50   /* f.* indicates the field array.  */
  51   index_type fstride[GFC_MAX_DIMENSIONS];
  52   index_type fstride0;
  53   const char *fptr;
  54   /* m.* indicates the mask array.  */
  55   index_type mstride[GFC_MAX_DIMENSIONS];
  56   index_type mstride0;
  57   const GFC_LOGICAL_4 *mptr;
  58
  59   index_type count[GFC_MAX_DIMENSIONS];
  60   index_type extent[GFC_MAX_DIMENSIONS];
  61   index_type n;
  62   index_type dim;
  63
  64   if (ret->data == NULL)
  65     {
  66       /* The front end has signalled that we need to populate the
  67          return array descriptor.  */
  68       dim = GFC_DESCRIPTOR_RANK (mask);
  69       rs = 1;
  70       for (n = 0; n < dim; n++)
  71         {
  72           count[n] = 0;
  73           ret->dim[n].stride = rs;
  74           ret->dim[n].lbound = 0;
  75           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
  76           extent[n] = ret->dim[n].ubound + 1;
  77           rstride[n] = ret->dim[n].stride * size;
  78           fstride[n] = field->dim[n].stride * fsize;
  79           mstride[n] = mask->dim[n].stride;
  80           rs *= extent[n];
  81         }
  82       ret->offset = 0;
  83       ret->data = internal_malloc_size (rs * size);
  84     }
  85   else
  86     {
  87       dim = GFC_DESCRIPTOR_RANK (ret);
  88       for (n = 0; n < dim; n++)
  89         {
  90           count[n] = 0;
  91           extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
  92           rstride[n] = ret->dim[n].stride * size;
  93           fstride[n] = field->dim[n].stride * fsize;
  94           mstride[n] = mask->dim[n].stride;
  95         }
  96       if (rstride[0] == 0)
  97         rstride[0] = size;
  98     }
  99   if (fstride[0] == 0)
 100     fstride[0] = fsize;
 101   if (mstride[0] == 0)
 102     mstride[0] = 1;
 103
 104   vstride0 = vector->dim[0].stride * size;
 105   if (vstride0 == 0)
 106     vstride0 = size;
 107   rstride0 = rstride[0];
 108   fstride0 = fstride[0];
 109   mstride0 = mstride[0];
 110   rptr = ret->data;
 111   fptr = field->data;
 112   mptr = mask->data;
 113   vptr = vector->data;
 114
 115   /* Use the same loop for both logical types. */
 116   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 117     {
 118       if (GFC_DESCRIPTOR_SIZE (mask) != 8)
 119         runtime_error ("Funny sized logical array");
 120       for (n = 0; n < dim; n++)
 121         mstride[n] <<= 1;
 122       mstride0 <<= 1;
 123       mptr = GFOR_POINTER_L8_TO_L4 (mptr);
 124     }
 125
 126   while (rptr)
 127     {
 128       if (*mptr)
 129         {
 130           /* From vector.  */
 131           memcpy (rptr, vptr, size);
 132           vptr += vstride0;
 133         }
 134       else
 135         {
 136           /* From field.  */
 137           memcpy (rptr, fptr, size);
 138         }
 139       /* Advance to the next element.  */
 140       rptr += rstride0;
 141       fptr += fstride0;
 142       mptr += mstride0;
 143       count[0]++;
 144       n = 0;
 145       while (count[n] == extent[n])
 146         {
 147           /* When we get to the end of a dimension, reset it and increment
 148              the next dimension.  */
 149           count[n] = 0;
 150           /* We could precalculate these products, but this is a less
 151              frequently used path so probably not worth it.  */
 152           rptr -= rstride[n] * extent[n];
 153           fptr -= fstride[n] * extent[n];
 154           mptr -= mstride[n] * extent[n];
 155           n++;
 156           if (n >= dim)
 157             {
 158               /* Break out of the loop.  */
 159               rptr = NULL;
 160               break;
 161             }
 162           else
 163             {
 164               count[n]++;
 165               rptr += rstride[n];
 166               fptr += fstride[n];
 167               mptr += mstride[n];
 168             }
 169         }
 170     }
 171 }
 172
 173 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 174                      const gfc_array_l4 *, const gfc_array_char *);
 175 export_proto(unpack1);
 176
 177 void
 178 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 179          const gfc_array_l4 *mask, const gfc_array_char *field)
 180 {
 181   unpack_internal (ret, vector, mask, field,
 182                    GFC_DESCRIPTOR_SIZE (vector),
 183                    GFC_DESCRIPTOR_SIZE (field));
 184 }
 185
 186 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 187                           const gfc_array_char *, const gfc_array_l4 *,
 188                           const gfc_array_char *, GFC_INTEGER_4,
 189                           GFC_INTEGER_4);
 190 export_proto(unpack1_char);
 191
 192 void
 193 unpack1_char (gfc_array_char *ret,
 194               GFC_INTEGER_4 ret_length __attribute__((unused)),
 195               const gfc_array_char *vector, const gfc_array_l4 *mask,
 196               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 197               GFC_INTEGER_4 field_length)
 198 {
 199   unpack_internal (ret, vector, mask, field, vector_length, field_length);
 200 }
 201
 202 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 203                      const gfc_array_l4 *, char *);
 204 export_proto(unpack0);
 205
 206 void
 207 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 208          const gfc_array_l4 *mask, char *field)
 209 {
 210   gfc_array_char tmp;
 211
 212   tmp.dtype = 0;
 213   tmp.data = field;
 214   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
 215 }
 216
 217 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 218                           const gfc_array_char *, const gfc_array_l4 *,
 219                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 220 export_proto(unpack0_char);
 221
 222 void
 223 unpack0_char (gfc_array_char *ret,
 224               GFC_INTEGER_4 ret_length __attribute__((unused)),
 225               const gfc_array_char *vector, const gfc_array_l4 *mask,
 226               char *field, GFC_INTEGER_4 vector_length,
 227               GFC_INTEGER_4 field_length __attribute__((unused)))
 228 {
 229   gfc_array_char tmp;
 230
 231   tmp.dtype = 0;
 232   tmp.data = field;
 233   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
 234 }