libgfortran/m4/unpack.m4

   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 include(iparm.m4)dnl
  33
  34 `#if defined (HAVE_'rtype_name`)
  35
  36 void
  37 unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
  38                  const gfc_array_l1 *mask, const 'rtype_name` *fptr)
  39 {
  40   /* r.* indicates the return array.  */
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type rs;
  44   'rtype_name` * restrict rptr;
  45   /* v.* indicates the vector array.  */
  46   index_type vstride0;
  47   'rtype_name` *vptr;
  48   /* Value for field, this is constant.  */
  49   const 'rtype_name` fval = *fptr;
  50   /* m.* indicates the mask array.  */
  51   index_type mstride[GFC_MAX_DIMENSIONS];
  52   index_type mstride0;
  53   const GFC_LOGICAL_1 *mptr;
  54
  55   index_type count[GFC_MAX_DIMENSIONS];
  56   index_type extent[GFC_MAX_DIMENSIONS];
  57   index_type n;
  58   index_type dim;
  59
  60   int empty;
  61   int mask_kind;
  62
  63   empty = 0;
  64
  65   mptr = mask->data;
  66
  67   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  68      and using shifting to address size and endian issues.  */
  69
  70   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  71
  72   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  73 #ifdef HAVE_GFC_LOGICAL_16
  74       || mask_kind == 16
  75 #endif
  76       )
  77     {
  78       /*  Do not convert a NULL pointer as we use test for NULL below.  */
  79       if (mptr)
  80         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  81     }
  82   else
  83     runtime_error ("Funny sized logical array");
  84
  85   if (ret->data == 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           ret->dim[n].stride = rs;
  95           ret->dim[n].lbound = 0;
  96           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
  97           extent[n] = ret->dim[n].ubound + 1;
  98           empty = empty || extent[n] <= 0;
  99           rstride[n] = ret->dim[n].stride;
 100           mstride[n] = mask->dim[n].stride * mask_kind;
 101           rs *= extent[n];
 102         }
 103       ret->offset = 0;
 104       ret->data = internal_malloc_size (rs * sizeof ('rtype_name`));
 105     }
 106   else
 107     {
 108       dim = GFC_DESCRIPTOR_RANK (ret);
 109       for (n = 0; n < dim; n++)
 110         {
 111           count[n] = 0;
 112           extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 113           empty = empty || extent[n] <= 0;
 114           rstride[n] = ret->dim[n].stride;
 115           mstride[n] = mask->dim[n].stride * mask_kind;
 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 = vector->dim[0].stride;
 128   if (vstride0 == 0)
 129     vstride0 = 1;
 130   rstride0 = rstride[0];
 131   mstride0 = mstride[0];
 132   rptr = ret->data;
 133   vptr = vector->data;
 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_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
 181                  const gfc_array_l1 *mask, const 'rtype` *field)
 182 {
 183   /* r.* indicates the return array.  */
 184   index_type rstride[GFC_MAX_DIMENSIONS];
 185   index_type rstride0;
 186   index_type rs;
 187   'rtype_name` * restrict rptr;
 188   /* v.* indicates the vector array.  */
 189   index_type vstride0;
 190   'rtype_name` *vptr;
 191   /* f.* indicates the field array.  */
 192   index_type fstride[GFC_MAX_DIMENSIONS];
 193   index_type fstride0;
 194   const 'rtype_name` *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->data;
 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->data == 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           ret->dim[n].stride = rs;
 240           ret->dim[n].lbound = 0;
 241           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
 242           extent[n] = ret->dim[n].ubound + 1;
 243           empty = empty || extent[n] <= 0;
 244           rstride[n] = ret->dim[n].stride;
 245           fstride[n] = field->dim[n].stride;
 246           mstride[n] = mask->dim[n].stride * mask_kind;
 247           rs *= extent[n];
 248         }
 249       ret->offset = 0;
 250       ret->data = internal_malloc_size (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] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
 259           empty = empty || extent[n] <= 0;
 260           rstride[n] = ret->dim[n].stride;
 261           fstride[n] = field->dim[n].stride;
 262           mstride[n] = mask->dim[n].stride * mask_kind;
 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 = vector->dim[0].stride;
 277   if (vstride0 == 0)
 278     vstride0 = 1;
 279   rstride0 = rstride[0];
 280   fstride0 = fstride[0];
 281   mstride0 = mstride[0];
 282   rptr = ret->data;
 283   fptr = field->data;
 284   vptr = vector->data;
 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 '