libgfortran/generated/unpack_c10.c

   1 /* Specific implementation of the UNPACK intrinsic
   2    Copyright 2008, 2009 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 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_COMPLEX_10)
  34
  35 void
  36 unpack0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector,
  37                  const gfc_array_l1 *mask, const GFC_COMPLEX_10 *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_COMPLEX_10 * restrict rptr;
  44   /* v.* indicates the vector array.  */
  45   index_type vstride0;
  46   GFC_COMPLEX_10 *vptr;
  47   /* Value for field, this is constant.  */
  48   const GFC_COMPLEX_10 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->data;
  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->data == 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           ret->dim[n].stride = rs;
  94           ret->dim[n].lbound = 0;
  95           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
  96           extent[n] = ret->dim[n].ubound + 1;
  97           empty = empty || extent[n] <= 0;
  98           rstride[n] = ret->dim[n].stride;
  99           mstride[n] = mask->dim[n].stride * mask_kind;
 100           rs *= extent[n];
 101         }
 102       ret->offset = 0;
 103       ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10));
 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] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 112           empty = empty || extent[n] <= 0;
 113           rstride[n] = ret->dim[n].stride;
 114           mstride[n] = mask->dim[n].stride * mask_kind;
 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 = vector->dim[0].stride;
 127   if (vstride0 == 0)
 128     vstride0 = 1;
 129   rstride0 = rstride[0];
 130   mstride0 = mstride[0];
 131   rptr = ret->data;
 132   vptr = vector->data;
 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_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector,
 180                  const gfc_array_l1 *mask, const gfc_array_c10 *field)
 181 {
 182   /* r.* indicates the return array.  */
 183   index_type rstride[GFC_MAX_DIMENSIONS];
 184   index_type rstride0;
 185   index_type rs;
 186   GFC_COMPLEX_10 * restrict rptr;
 187   /* v.* indicates the vector array.  */
 188   index_type vstride0;
 189   GFC_COMPLEX_10 *vptr;
 190   /* f.* indicates the field array.  */
 191   index_type fstride[GFC_MAX_DIMENSIONS];
 192   index_type fstride0;
 193   const GFC_COMPLEX_10 *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->data;
 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   if (ret->data == NULL)
 230     {
 231       /* The front end has signalled that we need to populate the
 232          return array descriptor.  */
 233       dim = GFC_DESCRIPTOR_RANK (mask);
 234       rs = 1;
 235       for (n = 0; n < dim; n++)
 236         {
 237           count[n] = 0;
 238           ret->dim[n].stride = rs;
 239           ret->dim[n].lbound = 0;
 240           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
 241           extent[n] = ret->dim[n].ubound + 1;
 242           empty = empty || extent[n] <= 0;
 243           rstride[n] = ret->dim[n].stride;
 244           fstride[n] = field->dim[n].stride;
 245           mstride[n] = mask->dim[n].stride * mask_kind;
 246           rs *= extent[n];
 247         }
 248       ret->offset = 0;
 249       ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_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] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 258           empty = empty || extent[n] <= 0;
 259           rstride[n] = ret->dim[n].stride;
 260           fstride[n] = field->dim[n].stride;
 261           mstride[n] = mask->dim[n].stride * mask_kind;
 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 = vector->dim[0].stride;
 276   if (vstride0 == 0)
 277     vstride0 = 1;
 278   rstride0 = rstride[0];
 279   fstride0 = fstride[0];
 280   mstride0 = mstride[0];
 281   rptr = ret->data;
 282   fptr = field->data;
 283   vptr = vector->data;
 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