libgfortran/generated/unpack_r4.c

   1 /* Specific implementation of the UNPACK intrinsic
   2    Copyright 2008, 2009, 2012 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_4)
  34
  35 void
  36 unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector,
  37                  const gfc_array_l1 *mask, const GFC_REAL_4 *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_4 * restrict rptr;
  44   /* v.* indicates the vector array.  */
  45   index_type vstride0;
  46   GFC_REAL_4 *vptr;
  47   /* Value for field, this is constant.  */
  48   const GFC_REAL_4 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 = xmalloc (rs * sizeof (GFC_REAL_4));
 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_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector,
 179                  const gfc_array_l1 *mask, const gfc_array_r4 *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_4 * restrict rptr;
 186   /* v.* indicates the vector array.  */
 187   index_type vstride0;
 188   GFC_REAL_4 *vptr;
 189   /* f.* indicates the field array.  */
 190   index_type fstride[GFC_MAX_DIMENSIONS];
 191   index_type fstride0;
 192   const GFC_REAL_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 = xmalloc (rs * sizeof (GFC_REAL_4));
 248     }
 249   else
 250     {
 251       dim = GFC_DESCRIPTOR_RANK (ret);
 252       for (n = 0; n < dim; n++)
 253         {
 254           count[n] = 0;
 255           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 256           empty = empty || extent[n] <= 0;
 257           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
 258           fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
 259           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 260         }
 261       if (rstride[0] == 0)
 262         rstride[0] = 1;
 263     }
 264
 265   if (empty)
 266     return;
 267
 268   if (fstride[0] == 0)
 269     fstride[0] = 1;
 270   if (mstride[0] == 0)
 271     mstride[0] = 1;
 272
 273   vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
 274   if (vstride0 == 0)
 275     vstride0 = 1;
 276   rstride0 = rstride[0];
 277   fstride0 = fstride[0];
 278   mstride0 = mstride[0];
 279   rptr = ret->base_addr;
 280   fptr = field->base_addr;
 281   vptr = vector->base_addr;
 282
 283   while (rptr)
 284     {
 285       if (*mptr)
 286         {
 287           /* From vector.  */
 288           *rptr = *vptr;
 289           vptr += vstride0;
 290         }
 291       else
 292         {
 293           /* From field.  */
 294           *rptr = *fptr;
 295         }
 296       /* Advance to the next element.  */
 297       rptr += rstride0;
 298       fptr += fstride0;
 299       mptr += mstride0;
 300       count[0]++;
 301       n = 0;
 302       while (count[n] == extent[n])
 303         {
 304           /* When we get to the end of a dimension, reset it and increment
 305              the next dimension.  */
 306           count[n] = 0;
 307           /* We could precalculate these products, but this is a less
 308              frequently used path so probably not worth it.  */
 309           rptr -= rstride[n] * extent[n];
 310           fptr -= fstride[n] * extent[n];
 311           mptr -= mstride[n] * extent[n];
 312           n++;
 313           if (n >= dim)
 314             {
 315               /* Break out of the loop.  */
 316               rptr = NULL;
 317               break;
 318             }
 319           else
 320             {
 321               count[n]++;
 322               rptr += rstride[n];
 323               fptr += fstride[n];
 324               mptr += mstride[n];
 325             }
 326         }
 327     }
 328 }
 329
 330 #endif
 331