libgfortran/m4/unpack.m4

   1 `/* Specific implementation of the UNPACK intrinsic
   2    Copyright (C) 2008-2023 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 include(iparm.m4)dnl
  31
  32 `#if defined (HAVE_'rtype_name`)
  33
  34 void
  35 unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
  36                  const gfc_array_l1 *mask, const 'rtype_name` *fptr)
  37 {
  38   /* r.* indicates the return array.  */
  39   index_type rstride[GFC_MAX_DIMENSIONS];
  40   index_type rstride0;
  41   index_type rs;
  42   'rtype_name` * restrict rptr;
  43   /* v.* indicates the vector array.  */
  44   index_type vstride0;
  45   'rtype_name` *vptr;
  46   /* Value for field, this is constant.  */
  47   const 'rtype_name` fval = *fptr;
  48   /* m.* indicates the mask array.  */
  49   index_type mstride[GFC_MAX_DIMENSIONS];
  50   index_type mstride0;
  51   const GFC_LOGICAL_1 *mptr;
  52
  53   index_type count[GFC_MAX_DIMENSIONS];
  54   index_type extent[GFC_MAX_DIMENSIONS];
  55   index_type n;
  56   index_type dim;
  57
  58   int empty;
  59   int mask_kind;
  60
  61   empty = 0;
  62
  63   mptr = mask->base_addr;
  64
  65   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  66      and using shifting to address size and endian issues.  */
  67
  68   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  69
  70   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  71 #ifdef HAVE_GFC_LOGICAL_16
  72       || mask_kind == 16
  73 #endif
  74       )
  75     {
  76       /*  Do not convert a NULL pointer as we use test for NULL below.  */
  77       if (mptr)
  78         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  79     }
  80   else
  81     runtime_error ("Funny sized logical array");
  82
  83   /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
  84   rstride[0] = 1;
  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       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   /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
 230   rstride[0] = 1;
 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       for (n = 0; n < dim; n++)
 256         {
 257           count[n] = 0;
 258           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 259           empty = empty || extent[n] <= 0;
 260           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 261           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 262           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 263         }
 264       if (rstride[0] == 0)
 265         rstride[0] = 1;
 266     }
 267
 268   if (empty)
 269     return;
 270
 271   if (fstride[0] == 0)
 272     fstride[0] = 1;
 273   if (mstride[0] == 0)
 274     mstride[0] = 1;
 275
 276   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 277   if (vstride0 == 0)
 278     vstride0 = 1;
 279   rstride0 = rstride[0];
 280   fstride0 = fstride[0];
 281   mstride0 = mstride[0];
 282   rptr = ret->base_addr;
 283   fptr = field->base_addr;
 284   vptr = vector->base_addr;
 285
 286   while (rptr)
 287     {
 288       if (*mptr)
 289         {
 290           /* From vector.  */
 291           *rptr = *vptr;
 292           vptr += vstride0;
 293         }
 294       else
 295         {
 296           /* From field.  */
 297           *rptr = *fptr;
 298         }
 299       /* Advance to the next element.  */
 300       rptr += rstride0;
 301       fptr += fstride0;
 302       mptr += mstride0;
 303       count[0]++;
 304       n = 0;
 305       while (count[n] == extent[n])
 306         {
 307           /* When we get to the end of a dimension, reset it and increment
 308              the next dimension.  */
 309           count[n] = 0;
 310           /* We could precalculate these products, but this is a less
 311              frequently used path so probably not worth it.  */
 312           rptr -= rstride[n] * extent[n];
 313           fptr -= fstride[n] * extent[n];
 314           mptr -= mstride[n] * extent[n];
 315           n++;
 316           if (n >= dim)
 317             {
 318               /* Break out of the loop.  */
 319               rptr = NULL;
 320               break;
 321             }
 322           else
 323             {
 324               count[n]++;
 325               rptr += rstride[n];
 326               fptr += fstride[n];
 327               mptr += mstride[n];
 328             }
 329         }
 330     }
 331 }
 332
 333 #endif
 334 '