libgfortran/generated/unpack_r8.c

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