libgfortran/intrinsics/unpack_generic.c

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