libgfortran/generated/unpack_c4.c

   1 /* Specific implementation of the UNPACK intrinsic
   2    Copyright 2008 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 95 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 2 of the License, or (at your option) any later version.
  12
  13 In addition to the permissions in the GNU General Public License, the
  14 Free Software Foundation gives you unlimited permission to link the
  15 compiled version of this file into combinations with other programs,
  16 and to distribute those combinations without any restriction coming
  17 from the use of this file.  (The General Public License restrictions
  18 do apply in other respects; for example, they cover modification of
  19 the file, and distribution when not linked into a combine
  20 executable.)
  21
  22 Ligbfortran is distributed in the hope that it will be useful,
  23 but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 GNU General Public License for more details.
  26
  27 You should have received a copy of the GNU General Public
  28 License along with libgfortran; see the file COPYING.  If not,
  29 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 Boston, MA 02110-1301, USA.  */
  31
  32 #include "libgfortran.h"
  33 #include <stdlib.h>
  34 #include <assert.h>
  35 #include <string.h>
  36
  37
  38 #if defined (HAVE_GFC_COMPLEX_4)
  39
  40 void
  41 unpack0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector,
  42                  const gfc_array_l1 *mask, const GFC_COMPLEX_4 *fptr)
  43 {
  44   /* r.* indicates the return array.  */
  45   index_type rstride[GFC_MAX_DIMENSIONS];
  46   index_type rstride0;
  47   index_type rs;
  48   GFC_COMPLEX_4 * restrict rptr;
  49   /* v.* indicates the vector array.  */
  50   index_type vstride0;
  51   GFC_COMPLEX_4 *vptr;
  52   /* Value for field, this is constant.  */
  53   const GFC_COMPLEX_4 fval = *fptr;
  54   /* m.* indicates the mask array.  */
  55   index_type mstride[GFC_MAX_DIMENSIONS];
  56   index_type mstride0;
  57   const GFC_LOGICAL_1 *mptr;
  58
  59   index_type count[GFC_MAX_DIMENSIONS];
  60   index_type extent[GFC_MAX_DIMENSIONS];
  61   index_type n;
  62   index_type dim;
  63
  64   int empty;
  65   int mask_kind;
  66
  67   empty = 0;
  68
  69   mptr = mask->data;
  70
  71   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  72      and using shifting to address size and endian issues.  */
  73
  74   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  75
  76   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  77 #ifdef HAVE_GFC_LOGICAL_16
  78       || mask_kind == 16
  79 #endif
  80       )
  81     {
  82       /*  Do not convert a NULL pointer as we use test for NULL below.  */
  83       if (mptr)
  84         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  85     }
  86   else
  87     runtime_error ("Funny sized logical array");
  88
  89   if (ret->data == NULL)
  90     {
  91       /* The front end has signalled that we need to populate the
  92          return array descriptor.  */
  93       dim = GFC_DESCRIPTOR_RANK (mask);
  94       rs = 1;
  95       for (n = 0; n < dim; n++)
  96         {
  97           count[n] = 0;
  98           ret->dim[n].stride = rs;
  99           ret->dim[n].lbound = 0;
 100           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
 101           extent[n] = ret->dim[n].ubound + 1;
 102           empty = empty || extent[n] <= 0;
 103           rstride[n] = ret->dim[n].stride;
 104           mstride[n] = mask->dim[n].stride * mask_kind;
 105           rs *= extent[n];
 106         }
 107       ret->offset = 0;
 108       ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_4));
 109     }
 110   else
 111     {
 112       dim = GFC_DESCRIPTOR_RANK (ret);
 113       for (n = 0; n < dim; n++)
 114         {
 115           count[n] = 0;
 116           extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 117           empty = empty || extent[n] <= 0;
 118           rstride[n] = ret->dim[n].stride;
 119           mstride[n] = mask->dim[n].stride * mask_kind;
 120         }
 121       if (rstride[0] == 0)
 122         rstride[0] = 1;
 123     }
 124
 125   if (empty)
 126     return;
 127
 128   if (mstride[0] == 0)
 129     mstride[0] = 1;
 130
 131   vstride0 = vector->dim[0].stride;
 132   if (vstride0 == 0)
 133     vstride0 = 1;
 134   rstride0 = rstride[0];
 135   mstride0 = mstride[0];
 136   rptr = ret->data;
 137   vptr = vector->data;
 138
 139   while (rptr)
 140     {
 141       if (*mptr)
 142         {
 143           /* From vector.  */
 144           *rptr = *vptr;
 145           vptr += vstride0;
 146         }
 147       else
 148         {
 149           /* From field.  */
 150           *rptr = fval;
 151         }
 152       /* Advance to the next element.  */
 153       rptr += rstride0;
 154       mptr += mstride0;
 155       count[0]++;
 156       n = 0;
 157       while (count[n] == extent[n])
 158         {
 159           /* When we get to the end of a dimension, reset it and increment
 160              the next dimension.  */
 161           count[n] = 0;
 162           /* We could precalculate these products, but this is a less
 163              frequently used path so probably not worth it.  */
 164           rptr -= rstride[n] * extent[n];
 165           mptr -= mstride[n] * extent[n];
 166           n++;
 167           if (n >= dim)
 168             {
 169               /* Break out of the loop.  */
 170               rptr = NULL;
 171               break;
 172             }
 173           else
 174             {
 175               count[n]++;
 176               rptr += rstride[n];
 177               mptr += mstride[n];
 178             }
 179         }
 180     }
 181 }
 182
 183 void
 184 unpack1_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector,
 185                  const gfc_array_l1 *mask, const gfc_array_c4 *field)
 186 {
 187   /* r.* indicates the return array.  */
 188   index_type rstride[GFC_MAX_DIMENSIONS];
 189   index_type rstride0;
 190   index_type rs;
 191   GFC_COMPLEX_4 * restrict rptr;
 192   /* v.* indicates the vector array.  */
 193   index_type vstride0;
 194   GFC_COMPLEX_4 *vptr;
 195   /* f.* indicates the field array.  */
 196   index_type fstride[GFC_MAX_DIMENSIONS];
 197   index_type fstride0;
 198   const GFC_COMPLEX_4 *fptr;
 199   /* m.* indicates the mask array.  */
 200   index_type mstride[GFC_MAX_DIMENSIONS];
 201   index_type mstride0;
 202   const GFC_LOGICAL_1 *mptr;
 203
 204   index_type count[GFC_MAX_DIMENSIONS];
 205   index_type extent[GFC_MAX_DIMENSIONS];
 206   index_type n;
 207   index_type dim;
 208
 209   int empty;
 210   int mask_kind;
 211
 212   empty = 0;
 213
 214   mptr = mask->data;
 215
 216   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
 217      and using shifting to address size and endian issues.  */
 218
 219   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 220
 221   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 222 #ifdef HAVE_GFC_LOGICAL_16
 223       || mask_kind == 16
 224 #endif
 225       )
 226     {
 227       /*  Do not convert a NULL pointer as we use test for NULL below.  */
 228       if (mptr)
 229         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 230     }
 231   else
 232     runtime_error ("Funny sized logical array");
 233
 234   if (ret->data == NULL)
 235     {
 236       /* The front end has signalled that we need to populate the
 237          return array descriptor.  */
 238       dim = GFC_DESCRIPTOR_RANK (mask);
 239       rs = 1;
 240       for (n = 0; n < dim; n++)
 241         {
 242           count[n] = 0;
 243           ret->dim[n].stride = rs;
 244           ret->dim[n].lbound = 0;
 245           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
 246           extent[n] = ret->dim[n].ubound + 1;
 247           empty = empty || extent[n] <= 0;
 248           rstride[n] = ret->dim[n].stride;
 249           fstride[n] = field->dim[n].stride;
 250           mstride[n] = mask->dim[n].stride * mask_kind;
 251           rs *= extent[n];
 252         }
 253       ret->offset = 0;
 254       ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_4));
 255     }
 256   else
 257     {
 258       dim = GFC_DESCRIPTOR_RANK (ret);
 259       for (n = 0; n < dim; n++)
 260         {
 261           count[n] = 0;
 262           extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 263           empty = empty || extent[n] <= 0;
 264           rstride[n] = ret->dim[n].stride;
 265           fstride[n] = field->dim[n].stride;
 266           mstride[n] = mask->dim[n].stride * mask_kind;
 267         }
 268       if (rstride[0] == 0)
 269         rstride[0] = 1;
 270     }
 271
 272   if (empty)
 273     return;
 274
 275   if (fstride[0] == 0)
 276     fstride[0] = 1;
 277   if (mstride[0] == 0)
 278     mstride[0] = 1;
 279
 280   vstride0 = vector->dim[0].stride;
 281   if (vstride0 == 0)
 282     vstride0 = 1;
 283   rstride0 = rstride[0];
 284   fstride0 = fstride[0];
 285   mstride0 = mstride[0];
 286   rptr = ret->data;
 287   fptr = field->data;
 288   vptr = vector->data;
 289
 290   while (rptr)
 291     {
 292       if (*mptr)
 293         {
 294           /* From vector.  */
 295           *rptr = *vptr;
 296           vptr += vstride0;
 297         }
 298       else
 299         {
 300           /* From field.  */
 301           *rptr = *fptr;
 302         }
 303       /* Advance to the next element.  */
 304       rptr += rstride0;
 305       fptr += fstride0;
 306       mptr += mstride0;
 307       count[0]++;
 308       n = 0;
 309       while (count[n] == extent[n])
 310         {
 311           /* When we get to the end of a dimension, reset it and increment
 312              the next dimension.  */
 313           count[n] = 0;
 314           /* We could precalculate these products, but this is a less
 315              frequently used path so probably not worth it.  */
 316           rptr -= rstride[n] * extent[n];
 317           fptr -= fstride[n] * extent[n];
 318           mptr -= mstride[n] * extent[n];
 319           n++;
 320           if (n >= dim)
 321             {
 322               /* Break out of the loop.  */
 323               rptr = NULL;
 324               break;
 325             }
 326           else
 327             {
 328               count[n]++;
 329               rptr += rstride[n];
 330               fptr += fstride[n];
 331               mptr += mstride[n];
 332             }
 333         }
 334     }
 335 }
 336
 337 #endif
 338