libgfortran/generated/unpack_r10.c

   1 /* Specific implementation of the UNPACK intrinsic
   2    Copyright (C) 2008-2021 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_REAL_10)
  32
  33 void
  34 unpack0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector,
  35                  const gfc_array_l1 *mask, const GFC_REAL_10 *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_REAL_10 * restrict rptr;
  42   /* v.* indicates the vector array.  */
  43   index_type vstride0;
  44   GFC_REAL_10 *vptr;
  45   /* Value for field, this is constant.  */
  46   const GFC_REAL_10 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   /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
  83   rstride[0] = 1;
  84   if (ret->base_addr == NULL)
  85     {
  86       /* The front end has signalled that we need to populate the
  87          return array descriptor.  */
  88       dim = GFC_DESCRIPTOR_RANK (mask);
  89       rs = 1;
  90       for (n = 0; n < dim; n++)
  91         {
  92           count[n] = 0;
  93           GFC_DIMENSION_SET(ret->dim[n], 0,
  94                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
  95           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
  96           empty = empty || extent[n] <= 0;
  97           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
  98           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
  99           rs *= extent[n];
 100         }
 101       ret->offset = 0;
 102       ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_10));
 103     }
 104   else
 105     {
 106       dim = GFC_DESCRIPTOR_RANK (ret);
 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_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector,
 179                  const gfc_array_l1 *mask, const gfc_array_r10 *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_REAL_10 * restrict rptr;
 186   /* v.* indicates the vector array.  */
 187   index_type vstride0;
 188   GFC_REAL_10 *vptr;
 189   /* f.* indicates the field array.  */
 190   index_type fstride[GFC_MAX_DIMENSIONS];
 191   index_type fstride0;
 192   const GFC_REAL_10 *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   /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 229   rstride[0] = 1;
 230   if (ret->base_addr == NULL)
 231     {
 232       /* The front end has signalled that we need to populate the
 233          return array descriptor.  */
 234       dim = GFC_DESCRIPTOR_RANK (mask);
 235       rs = 1;
 236       for (n = 0; n < dim; n++)
 237         {
 238           count[n] = 0;
 239           GFC_DIMENSION_SET(ret->dim[n], 0,
 240                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 241           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 242           empty = empty || extent[n] <= 0;
 243           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 244           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 245           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 246           rs *= extent[n];
 247         }
 248       ret->offset = 0;
 249       ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_10));
 250     }
 251   else
 252     {
 253       dim = GFC_DESCRIPTOR_RANK (ret);
 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