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