libgfortran/m4/unpack.m4

   1 `/* Specific implementation of the UNPACK intrinsic
   2    Copyright (C) 2008-2016 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 = xmallocarray (rs, sizeof ('rtype_name`));
 104     }
 105   else
 106     {
 107       dim = GFC_DESCRIPTOR_RANK (ret);
 108       /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 109       rstride[0] = 1;
 110       for (n = 0; n < dim; n++)
 111         {
 112           count[n] = 0;
 113           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 114           empty = empty || extent[n] <= 0;
 115           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 116           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 117         }
 118       if (rstride[0] == 0)
 119         rstride[0] = 1;
 120     }
 121
 122   if (empty)
 123     return;
 124
 125   if (mstride[0] == 0)
 126     mstride[0] = 1;
 127
 128   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 129   if (vstride0 == 0)
 130     vstride0 = 1;
 131   rstride0 = rstride[0];
 132   mstride0 = mstride[0];
 133   rptr = ret->base_addr;
 134   vptr = vector->base_addr;
 135
 136   while (rptr)
 137     {
 138       if (*mptr)
 139         {
 140           /* From vector.  */
 141           *rptr = *vptr;
 142           vptr += vstride0;
 143         }
 144       else
 145         {
 146           /* From field.  */
 147           *rptr = fval;
 148         }
 149       /* Advance to the next element.  */
 150       rptr += rstride0;
 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           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               mptr += mstride[n];
 175             }
 176         }
 177     }
 178 }
 179
 180 void
 181 unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
 182                  const gfc_array_l1 *mask, const 'rtype` *field)
 183 {
 184   /* r.* indicates the return array.  */
 185   index_type rstride[GFC_MAX_DIMENSIONS];
 186   index_type rstride0;
 187   index_type rs;
 188   'rtype_name` * restrict rptr;
 189   /* v.* indicates the vector array.  */
 190   index_type vstride0;
 191   'rtype_name` *vptr;
 192   /* f.* indicates the field array.  */
 193   index_type fstride[GFC_MAX_DIMENSIONS];
 194   index_type fstride0;
 195   const 'rtype_name` *fptr;
 196   /* m.* indicates the mask array.  */
 197   index_type mstride[GFC_MAX_DIMENSIONS];
 198   index_type mstride0;
 199   const GFC_LOGICAL_1 *mptr;
 200
 201   index_type count[GFC_MAX_DIMENSIONS];
 202   index_type extent[GFC_MAX_DIMENSIONS];
 203   index_type n;
 204   index_type dim;
 205
 206   int empty;
 207   int mask_kind;
 208
 209   empty = 0;
 210
 211   mptr = mask->base_addr;
 212
 213   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 214      and using shifting to address size and endian issues.  */
 215
 216   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 217
 218   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 219 #ifdef HAVE_GFC_LOGICAL_16
 220       || mask_kind == 16
 221 #endif
 222       )
 223     {
 224       /*  Do not convert a NULL pointer as we use test for NULL below.  */
 225       if (mptr)
 226         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 227     }
 228   else
 229     runtime_error ("Funny sized logical array");
 230
 231   if (ret->base_addr == NULL)
 232     {
 233       /* The front end has signalled that we need to populate the
 234          return array descriptor.  */
 235       dim = GFC_DESCRIPTOR_RANK (mask);
 236       rs = 1;
 237       for (n = 0; n < dim; n++)
 238         {
 239           count[n] = 0;
 240           GFC_DIMENSION_SET(ret->dim[n], 0,
 241                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 242           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 243           empty = empty || extent[n] <= 0;
 244           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 245           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 246           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 247           rs *= extent[n];
 248         }
 249       ret->offset = 0;
 250       ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`));
 251     }
 252   else
 253     {
 254       dim = GFC_DESCRIPTOR_RANK (ret);
 255       /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 256       rstride[0] = 1;
 257       for (n = 0; n < dim; n++)
 258         {
 259           count[n] = 0;
 260           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 261           empty = empty || extent[n] <= 0;
 262           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 263           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 264           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 265         }
 266       if (rstride[0] == 0)
 267         rstride[0] = 1;
 268     }
 269
 270   if (empty)
 271     return;
 272
 273   if (fstride[0] == 0)
 274     fstride[0] = 1;
 275   if (mstride[0] == 0)
 276     mstride[0] = 1;
 277
 278   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 279   if (vstride0 == 0)
 280     vstride0 = 1;
 281   rstride0 = rstride[0];
 282   fstride0 = fstride[0];
 283   mstride0 = mstride[0];
 284   rptr = ret->base_addr;
 285   fptr = field->base_addr;
 286   vptr = vector->base_addr;
 287
 288   while (rptr)
 289     {
 290       if (*mptr)
 291         {
 292           /* From vector.  */
 293           *rptr = *vptr;
 294           vptr += vstride0;
 295         }
 296       else
 297         {
 298           /* From field.  */
 299           *rptr = *fptr;
 300         }
 301       /* Advance to the next element.  */
 302       rptr += rstride0;
 303       fptr += fstride0;
 304       mptr += mstride0;
 305       count[0]++;
 306       n = 0;
 307       while (count[n] == extent[n])
 308         {
 309           /* When we get to the end of a dimension, reset it and increment
 310              the next dimension.  */
 311           count[n] = 0;
 312           /* We could precalculate these products, but this is a less
 313              frequently used path so probably not worth it.  */
 314           rptr -= rstride[n] * extent[n];
 315           fptr -= fstride[n] * extent[n];
 316           mptr -= mstride[n] * extent[n];
 317           n++;
 318           if (n >= dim)
 319             {
 320               /* Break out of the loop.  */
 321               rptr = NULL;
 322               break;
 323             }
 324           else
 325             {
 326               count[n]++;
 327               rptr += rstride[n];
 328               fptr += fstride[n];
 329               mptr += mstride[n];
 330             }
 331         }
 332     }
 333 }
 334
 335 #endif
 336 '