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