libgfortran/m4/unpack.m4

   1 `/* Specific implementation of the UNPACK intrinsic
   2    Copyright (C) 2008-2013 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
   4    unpack_generic.c by Paul Brook <paul@nowt.org>.
   5
   6 This file is part of the GNU Fortran runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Ligbfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <stdlib.h>
  29 #include <assert.h>
  30 #include <string.h>'
  31
  32 include(iparm.m4)dnl
  33
  34 `#if defined (HAVE_'rtype_name`)
  35
  36 void
  37 unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
  38                  const gfc_array_l1 *mask, const 'rtype_name` *fptr)
  39 {
  40   /* r.* indicates the return array.  */
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type rs;
  44   'rtype_name` * restrict rptr;
  45   /* v.* indicates the vector array.  */
  46   index_type vstride0;
  47   'rtype_name` *vptr;
  48   /* Value for field, this is constant.  */
  49   const 'rtype_name` fval = *fptr;
  50   /* m.* indicates the mask array.  */
  51   index_type mstride[GFC_MAX_DIMENSIONS];
  52   index_type mstride0;
  53   const GFC_LOGICAL_1 *mptr;
  54
  55   index_type count[GFC_MAX_DIMENSIONS];
  56   index_type extent[GFC_MAX_DIMENSIONS];
  57   index_type n;
  58   index_type dim;
  59
  60   int empty;
  61   int mask_kind;
  62
  63   empty = 0;
  64
  65   mptr = mask->base_addr;
  66
  67   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  68      and using shifting to address size and endian issues.  */
  69
  70   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  71
  72   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  73 #ifdef HAVE_GFC_LOGICAL_16
  74       || mask_kind == 16
  75 #endif
  76       )
  77     {
  78       /*  Do not convert a NULL pointer as we use test for NULL below.  */
  79       if (mptr)
  80         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  81     }
  82   else
  83     runtime_error ("Funny sized logical array");
  84
  85   if (ret->base_addr == NULL)
  86     {
  87       /* The front end has signalled that we need to populate the
  88          return array descriptor.  */
  89       dim = GFC_DESCRIPTOR_RANK (mask);
  90       rs = 1;
  91       for (n = 0; n < dim; n++)
  92         {
  93           count[n] = 0;
  94           GFC_DIMENSION_SET(ret->dim[n], 0,
  95                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
  96           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
  97           empty = empty || extent[n] <= 0;
  98           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
  99           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 100           rs *= extent[n];
 101         }
 102       ret->offset = 0;
 103       ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
 104     }
 105   else
 106     {
 107       dim = GFC_DESCRIPTOR_RANK (ret);
 108       for (n = 0; n < dim; n++)
 109         {
 110           count[n] = 0;
 111           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 112           empty = empty || extent[n] <= 0;
 113           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 114           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 115         }
 116       if (rstride[0] == 0)
 117         rstride[0] = 1;
 118     }
 119
 120   if (empty)
 121     return;
 122
 123   if (mstride[0] == 0)
 124     mstride[0] = 1;
 125
 126   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 127   if (vstride0 == 0)
 128     vstride0 = 1;
 129   rstride0 = rstride[0];
 130   mstride0 = mstride[0];
 131   rptr = ret->base_addr;
 132   vptr = vector->base_addr;
 133
 134   while (rptr)
 135     {
 136       if (*mptr)
 137         {
 138           /* From vector.  */
 139           *rptr = *vptr;
 140           vptr += vstride0;
 141         }
 142       else
 143         {
 144           /* From field.  */
 145           *rptr = fval;
 146         }
 147       /* Advance to the next element.  */
 148       rptr += rstride0;
 149       mptr += mstride0;
 150       count[0]++;
 151       n = 0;
 152       while (count[n] == extent[n])
 153         {
 154           /* When we get to the end of a dimension, reset it and increment
 155              the next dimension.  */
 156           count[n] = 0;
 157           /* We could precalculate these products, but this is a less
 158              frequently used path so probably not worth it.  */
 159           rptr -= rstride[n] * extent[n];
 160           mptr -= mstride[n] * extent[n];
 161           n++;
 162           if (n >= dim)
 163             {
 164               /* Break out of the loop.  */
 165               rptr = NULL;
 166               break;
 167             }
 168           else
 169             {
 170               count[n]++;
 171               rptr += rstride[n];
 172               mptr += mstride[n];
 173             }
 174         }
 175     }
 176 }
 177
 178 void
 179 unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
 180                  const gfc_array_l1 *mask, const 'rtype` *field)
 181 {
 182   /* r.* indicates the return array.  */
 183   index_type rstride[GFC_MAX_DIMENSIONS];
 184   index_type rstride0;
 185   index_type rs;
 186   'rtype_name` * restrict rptr;
 187   /* v.* indicates the vector array.  */
 188   index_type vstride0;
 189   'rtype_name` *vptr;
 190   /* f.* indicates the field array.  */
 191   index_type fstride[GFC_MAX_DIMENSIONS];
 192   index_type fstride0;
 193   const 'rtype_name` *fptr;
 194   /* m.* indicates the mask array.  */
 195   index_type mstride[GFC_MAX_DIMENSIONS];
 196   index_type mstride0;
 197   const GFC_LOGICAL_1 *mptr;
 198
 199   index_type count[GFC_MAX_DIMENSIONS];
 200   index_type extent[GFC_MAX_DIMENSIONS];
 201   index_type n;
 202   index_type dim;
 203
 204   int empty;
 205   int mask_kind;
 206
 207   empty = 0;
 208
 209   mptr = mask->base_addr;
 210
 211   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 212      and using shifting to address size and endian issues.  */
 213
 214   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 215
 216   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 217 #ifdef HAVE_GFC_LOGICAL_16
 218       || mask_kind == 16
 219 #endif
 220       )
 221     {
 222       /*  Do not convert a NULL pointer as we use test for NULL below.  */
 223       if (mptr)
 224         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 225     }
 226   else
 227     runtime_error ("Funny sized logical array");
 228
 229   if (ret->base_addr == NULL)
 230     {
 231       /* The front end has signalled that we need to populate the
 232          return array descriptor.  */
 233       dim = GFC_DESCRIPTOR_RANK (mask);
 234       rs = 1;
 235       for (n = 0; n < dim; n++)
 236         {
 237           count[n] = 0;
 238           GFC_DIMENSION_SET(ret->dim[n], 0,
 239                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 240           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 241           empty = empty || extent[n] <= 0;
 242           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 243           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 244           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 245           rs *= extent[n];
 246         }
 247       ret->offset = 0;
 248       ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
 249     }
 250   else
 251     {
 252       dim = GFC_DESCRIPTOR_RANK (ret);
 253       for (n = 0; n < dim; n++)
 254         {
 255           count[n] = 0;
 256           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 257           empty = empty || extent[n] <= 0;
 258           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 259           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 260           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 261         }
 262       if (rstride[0] == 0)
 263         rstride[0] = 1;
 264     }
 265
 266   if (empty)
 267     return;
 268
 269   if (fstride[0] == 0)
 270     fstride[0] = 1;
 271   if (mstride[0] == 0)
 272     mstride[0] = 1;
 273
 274   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 275   if (vstride0 == 0)
 276     vstride0 = 1;
 277   rstride0 = rstride[0];
 278   fstride0 = fstride[0];
 279   mstride0 = mstride[0];
 280   rptr = ret->base_addr;
 281   fptr = field->base_addr;
 282   vptr = vector->base_addr;
 283
 284   while (rptr)
 285     {
 286       if (*mptr)
 287         {
 288           /* From vector.  */
 289           *rptr = *vptr;
 290           vptr += vstride0;
 291         }
 292       else
 293         {
 294           /* From field.  */
 295           *rptr = *fptr;
 296         }
 297       /* Advance to the next element.  */
 298       rptr += rstride0;
 299       fptr += fstride0;
 300       mptr += mstride0;
 301       count[0]++;
 302       n = 0;
 303       while (count[n] == extent[n])
 304         {
 305           /* When we get to the end of a dimension, reset it and increment
 306              the next dimension.  */
 307           count[n] = 0;
 308           /* We could precalculate these products, but this is a less
 309              frequently used path so probably not worth it.  */
 310           rptr -= rstride[n] * extent[n];
 311           fptr -= fstride[n] * extent[n];
 312           mptr -= mstride[n] * extent[n];
 313           n++;
 314           if (n >= dim)
 315             {
 316               /* Break out of the loop.  */
 317               rptr = NULL;
 318               break;
 319             }
 320           else
 321             {
 322               count[n]++;
 323               rptr += rstride[n];
 324               fptr += fstride[n];
 325               mptr += mstride[n];
 326             }
 327         }
 328     }
 329 }
 330
 331 #endif
 332 '