libgfortran/generated/unpack_c4.c

   1 /* Specific implementation of the UNPACK intrinsic
   2    Copyright (C) 2008-2018 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 <string.h>
  29
  30
  31 #if defined (HAVE_GFC_COMPLEX_4)
  32
  33 void
  34 unpack0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector,
  35                  const gfc_array_l1 *mask, const GFC_COMPLEX_4 *fptr)
  36 {
  37   /* r.* indicates the return array.  */
  38   index_type rstride[GFC_MAX_DIMENSIONS];
  39   index_type rstride0;
  40   index_type rs;
  41   GFC_COMPLEX_4 * restrict rptr;
  42   /* v.* indicates the vector array.  */
  43   index_type vstride0;
  44   GFC_COMPLEX_4 *vptr;
  45   /* Value for field, this is constant.  */
  46   const GFC_COMPLEX_4 fval = *fptr;
  47   /* m.* indicates the mask array.  */
  48   index_type mstride[GFC_MAX_DIMENSIONS];
  49   index_type mstride0;
  50   const GFC_LOGICAL_1 *mptr;
  51
  52   index_type count[GFC_MAX_DIMENSIONS];
  53   index_type extent[GFC_MAX_DIMENSIONS];
  54   index_type n;
  55   index_type dim;
  56
  57   int empty;
  58   int mask_kind;
  59
  60   empty = 0;
  61
  62   mptr = mask->base_addr;
  63
  64   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  65      and using shifting to address size and endian issues.  */
  66
  67   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  68
  69   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  70 #ifdef HAVE_GFC_LOGICAL_16
  71       || mask_kind == 16
  72 #endif
  73       )
  74     {
  75       /*  Do not convert a NULL pointer as we use test for NULL below.  */
  76       if (mptr)
  77         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  78     }
  79   else
  80     runtime_error ("Funny sized logical array");
  81
  82   if (ret->base_addr == NULL)
  83     {
  84       /* The front end has signalled that we need to populate the
  85          return array descriptor.  */
  86       dim = GFC_DESCRIPTOR_RANK (mask);
  87       rs = 1;
  88       for (n = 0; n < dim; n++)
  89         {
  90           count[n] = 0;
  91           GFC_DIMENSION_SET(ret->dim[n], 0,
  92                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
  93           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
  94           empty = empty || extent[n] <= 0;
  95           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
  96           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
  97           rs *= extent[n];
  98         }
  99       ret->offset = 0;
 100       ret->base_addr = xmallocarray (rs, sizeof (GFC_COMPLEX_4));
 101     }
 102   else
 103     {
 104       dim = GFC_DESCRIPTOR_RANK (ret);
 105       /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 106       rstride[0] = 1;
 107       for (n = 0; n < dim; n++)
 108         {
 109           count[n] = 0;
 110           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 111           empty = empty || extent[n] <= 0;
 112           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 113           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 114         }
 115       if (rstride[0] == 0)
 116         rstride[0] = 1;
 117     }
 118
 119   if (empty)
 120     return;
 121
 122   if (mstride[0] == 0)
 123     mstride[0] = 1;
 124
 125   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 126   if (vstride0 == 0)
 127     vstride0 = 1;
 128   rstride0 = rstride[0];
 129   mstride0 = mstride[0];
 130   rptr = ret->base_addr;
 131   vptr = vector->base_addr;
 132
 133   while (rptr)
 134     {
 135       if (*mptr)
 136         {
 137           /* From vector.  */
 138           *rptr = *vptr;
 139           vptr += vstride0;
 140         }
 141       else
 142         {
 143           /* From field.  */
 144           *rptr = fval;
 145         }
 146       /* Advance to the next element.  */
 147       rptr += rstride0;
 148       mptr += mstride0;
 149       count[0]++;
 150       n = 0;
 151       while (count[n] == extent[n])
 152         {
 153           /* When we get to the end of a dimension, reset it and increment
 154              the next dimension.  */
 155           count[n] = 0;
 156           /* We could precalculate these products, but this is a less
 157              frequently used path so probably not worth it.  */
 158           rptr -= rstride[n] * extent[n];
 159           mptr -= mstride[n] * extent[n];
 160           n++;
 161           if (n >= dim)
 162             {
 163               /* Break out of the loop.  */
 164               rptr = NULL;
 165               break;
 166             }
 167           else
 168             {
 169               count[n]++;
 170               rptr += rstride[n];
 171               mptr += mstride[n];
 172             }
 173         }
 174     }
 175 }
 176
 177 void
 178 unpack1_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector,
 179                  const gfc_array_l1 *mask, const gfc_array_c4 *field)
 180 {
 181   /* r.* indicates the return array.  */
 182   index_type rstride[GFC_MAX_DIMENSIONS];
 183   index_type rstride0;
 184   index_type rs;
 185   GFC_COMPLEX_4 * restrict rptr;
 186   /* v.* indicates the vector array.  */
 187   index_type vstride0;
 188   GFC_COMPLEX_4 *vptr;
 189   /* f.* indicates the field array.  */
 190   index_type fstride[GFC_MAX_DIMENSIONS];
 191   index_type fstride0;
 192   const GFC_COMPLEX_4 *fptr;
 193   /* m.* indicates the mask array.  */
 194   index_type mstride[GFC_MAX_DIMENSIONS];
 195   index_type mstride0;
 196   const GFC_LOGICAL_1 *mptr;
 197
 198   index_type count[GFC_MAX_DIMENSIONS];
 199   index_type extent[GFC_MAX_DIMENSIONS];
 200   index_type n;
 201   index_type dim;
 202
 203   int empty;
 204   int mask_kind;
 205
 206   empty = 0;
 207
 208   mptr = mask->base_addr;
 209
 210   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 211      and using shifting to address size and endian issues.  */
 212
 213   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 214
 215   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 216 #ifdef HAVE_GFC_LOGICAL_16
 217       || mask_kind == 16
 218 #endif
 219       )
 220     {
 221       /*  Do not convert a NULL pointer as we use test for NULL below.  */
 222       if (mptr)
 223         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 224     }
 225   else
 226     runtime_error ("Funny sized logical array");
 227
 228   if (ret->base_addr == NULL)
 229     {
 230       /* The front end has signalled that we need to populate the
 231          return array descriptor.  */
 232       dim = GFC_DESCRIPTOR_RANK (mask);
 233       rs = 1;
 234       for (n = 0; n < dim; n++)
 235         {
 236           count[n] = 0;
 237           GFC_DIMENSION_SET(ret->dim[n], 0,
 238                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 239           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 240           empty = empty || extent[n] <= 0;
 241           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 242           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 243           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 244           rs *= extent[n];
 245         }
 246       ret->offset = 0;
 247       ret->base_addr = xmallocarray (rs, sizeof (GFC_COMPLEX_4));
 248     }
 249   else
 250     {
 251       dim = GFC_DESCRIPTOR_RANK (ret);
 252       /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 253       rstride[0] = 1;
 254       for (n = 0; n < dim; n++)
 255         {
 256           count[n] = 0;
 257           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 258           empty = empty || extent[n] <= 0;
 259           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 260           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 261           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 262         }
 263       if (rstride[0] == 0)
 264         rstride[0] = 1;
 265     }
 266
 267   if (empty)
 268     return;
 269
 270   if (fstride[0] == 0)
 271     fstride[0] = 1;
 272   if (mstride[0] == 0)
 273     mstride[0] = 1;
 274
 275   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 276   if (vstride0 == 0)
 277     vstride0 = 1;
 278   rstride0 = rstride[0];
 279   fstride0 = fstride[0];
 280   mstride0 = mstride[0];
 281   rptr = ret->base_addr;
 282   fptr = field->base_addr;
 283   vptr = vector->base_addr;
 284
 285   while (rptr)
 286     {
 287       if (*mptr)
 288         {
 289           /* From vector.  */
 290           *rptr = *vptr;
 291           vptr += vstride0;
 292         }
 293       else
 294         {
 295           /* From field.  */
 296           *rptr = *fptr;
 297         }
 298       /* Advance to the next element.  */
 299       rptr += rstride0;
 300       fptr += fstride0;
 301       mptr += mstride0;
 302       count[0]++;
 303       n = 0;
 304       while (count[n] == extent[n])
 305         {
 306           /* When we get to the end of a dimension, reset it and increment
 307              the next dimension.  */
 308           count[n] = 0;
 309           /* We could precalculate these products, but this is a less
 310              frequently used path so probably not worth it.  */
 311           rptr -= rstride[n] * extent[n];
 312           fptr -= fstride[n] * extent[n];
 313           mptr -= mstride[n] * extent[n];
 314           n++;
 315           if (n >= dim)
 316             {
 317               /* Break out of the loop.  */
 318               rptr = NULL;
 319               break;
 320             }
 321           else
 322             {
 323               count[n]++;
 324               rptr += rstride[n];
 325               fptr += fstride[n];
 326               mptr += mstride[n];
 327             }
 328         }
 329     }
 330 }
 331
 332 #endif
 333