libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Ligbfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35
  36 static void
  37 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
  38                  const gfc_array_l1 *mask, const gfc_array_char *field,
  39                  index_type size, index_type fsize)
  40 {
  41   /* r.* indicates the return array.  */
  42   index_type rstride[GFC_MAX_DIMENSIONS];
  43   index_type rstride0;
  44   index_type rs;
  45   char *rptr;
  46   /* v.* indicates the vector array.  */
  47   index_type vstride0;
  48   char *vptr;
  49   /* f.* indicates the field array.  */
  50   index_type fstride[GFC_MAX_DIMENSIONS];
  51   index_type fstride0;
  52   const char *fptr;
  53   /* m.* indicates the mask array.  */
  54   index_type mstride[GFC_MAX_DIMENSIONS];
  55   index_type mstride0;
  56   const GFC_LOGICAL_1 *mptr;
  57
  58   index_type count[GFC_MAX_DIMENSIONS];
  59   index_type extent[GFC_MAX_DIMENSIONS];
  60   index_type n;
  61   index_type dim;
  62
  63   int empty;
  64   int mask_kind;
  65
  66   empty = 0;
  67
  68   mptr = mask->data;
  69
  70   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  71      and using shifting to address size and endian issues.  */
  72
  73   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  74
  75   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  76 #ifdef HAVE_GFC_LOGICAL_16
  77       || mask_kind == 16
  78 #endif
  79       )
  80     {
  81       /*  Don't convert a NULL pointer as we use test for NULL below.  */
  82       if (mptr)
  83         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
  84     }
  85   else
  86     runtime_error ("Funny sized logical array");
  87
  88   if (ret->data == NULL)
  89     {
  90       /* The front end has signalled that we need to populate the
  91          return array descriptor.  */
  92       dim = GFC_DESCRIPTOR_RANK (mask);
  93       rs = 1;
  94       for (n = 0; n < dim; n++)
  95         {
  96           count[n] = 0;
  97           ret->dim[n].stride = rs;
  98           ret->dim[n].lbound = 0;
  99           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
 100           extent[n] = ret->dim[n].ubound + 1;
 101           empty = empty || extent[n] <= 0;
 102           rstride[n] = ret->dim[n].stride * size;
 103           fstride[n] = field->dim[n].stride * fsize;
 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 * size);
 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 * size;
 119           fstride[n] = field->dim[n].stride * fsize;
 120           mstride[n] = mask->dim[n].stride * mask_kind;
 121         }
 122       if (rstride[0] == 0)
 123         rstride[0] = size;
 124     }
 125
 126   if (empty)
 127     return;
 128
 129   if (fstride[0] == 0)
 130     fstride[0] = fsize;
 131   if (mstride[0] == 0)
 132     mstride[0] = 1;
 133
 134   vstride0 = vector->dim[0].stride * size;
 135   if (vstride0 == 0)
 136     vstride0 = size;
 137   rstride0 = rstride[0];
 138   fstride0 = fstride[0];
 139   mstride0 = mstride[0];
 140   rptr = ret->data;
 141   fptr = field->data;
 142   vptr = vector->data;
 143
 144   while (rptr)
 145     {
 146       if (*mptr)
 147         {
 148           /* From vector.  */
 149           memcpy (rptr, vptr, size);
 150           vptr += vstride0;
 151         }
 152       else
 153         {
 154           /* From field.  */
 155           memcpy (rptr, fptr, size);
 156         }
 157       /* Advance to the next element.  */
 158       rptr += rstride0;
 159       fptr += fstride0;
 160       mptr += mstride0;
 161       count[0]++;
 162       n = 0;
 163       while (count[n] == extent[n])
 164         {
 165           /* When we get to the end of a dimension, reset it and increment
 166              the next dimension.  */
 167           count[n] = 0;
 168           /* We could precalculate these products, but this is a less
 169              frequently used path so probably not worth it.  */
 170           rptr -= rstride[n] * extent[n];
 171           fptr -= fstride[n] * extent[n];
 172           mptr -= mstride[n] * extent[n];
 173           n++;
 174           if (n >= dim)
 175             {
 176               /* Break out of the loop.  */
 177               rptr = NULL;
 178               break;
 179             }
 180           else
 181             {
 182               count[n]++;
 183               rptr += rstride[n];
 184               fptr += fstride[n];
 185               mptr += mstride[n];
 186             }
 187         }
 188     }
 189 }
 190
 191 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 192                      const gfc_array_l1 *, const gfc_array_char *);
 193 export_proto(unpack1);
 194
 195 void
 196 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 197          const gfc_array_l1 *mask, const gfc_array_char *field)
 198 {
 199   int type;
 200   index_type size;
 201
 202   type = GFC_DESCRIPTOR_TYPE (vector);
 203   size = GFC_DESCRIPTOR_SIZE (vector);
 204
 205   switch(type)
 206     {
 207     case GFC_DTYPE_INTEGER:
 208     case GFC_DTYPE_LOGICAL:
 209       switch(size)
 210         {
 211         case sizeof (GFC_INTEGER_1):
 212           unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 213                       mask, (gfc_array_i1 *) field);
 214           return;
 215
 216         case sizeof (GFC_INTEGER_2):
 217           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 218                       mask, (gfc_array_i2 *) field);
 219           return;
 220
 221         case sizeof (GFC_INTEGER_4):
 222           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 223                       mask, (gfc_array_i4 *) field);
 224           return;
 225
 226         case sizeof (GFC_INTEGER_8):
 227           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 228                       mask, (gfc_array_i8 *) field);
 229           return;
 230
 231 #ifdef HAVE_GFC_INTEGER_16
 232         case sizeof (GFC_INTEGER_16):
 233           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 234                        mask, (gfc_array_i16 *) field);
 235           return;
 236 #endif
 237         }
 238     case GFC_DTYPE_REAL:
 239       switch (size)
 240         {
 241         case sizeof (GFC_REAL_4):
 242           unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 243                       mask, (gfc_array_r4 *) field);
 244           return;
 245
 246         case sizeof (GFC_REAL_8):
 247           unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
 248                       mask, (gfc_array_r8 *) field);
 249           return;
 250
 251 #ifdef HAVE_GFC_REAL_10
 252         case sizeof (GFC_REAL_10):
 253           unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 254                       mask, (gfc_array_r10 *) field);
 255           return;
 256 #endif
 257
 258 #ifdef HAVE_GFC_REAL_16
 259         case sizeof (GFC_REAL_16):
 260           unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 261                       mask, (gfc_array_r16 *) field);
 262           return;
 263 #endif
 264         }
 265
 266     case GFC_DTYPE_COMPLEX:
 267       switch (size)
 268         {
 269         case sizeof (GFC_COMPLEX_4):
 270           unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 271                       mask, (gfc_array_c4 *) field);
 272           return;
 273
 274         case sizeof (GFC_COMPLEX_8):
 275           unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 276                       mask, (gfc_array_c8 *) field);
 277           return;
 278
 279 #ifdef HAVE_GFC_COMPLEX_10
 280         case sizeof (GFC_COMPLEX_10):
 281           unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 282                       mask, (gfc_array_c10 *) field);
 283           return;
 284 #endif
 285
 286 #ifdef HAVE_GFC_COMPLEX_16
 287         case sizeof (GFC_COMPLEX_16):
 288           unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 289                       mask, (gfc_array_c16 *) field);
 290           return;
 291 #endif
 292         }
 293
 294     }
 295   unpack_internal (ret, vector, mask, field, size,
 296                    GFC_DESCRIPTOR_SIZE (field));
 297 }
 298
 299 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 300                           const gfc_array_char *, const gfc_array_l1 *,
 301                           const gfc_array_char *, GFC_INTEGER_4,
 302                           GFC_INTEGER_4);
 303 export_proto(unpack1_char);
 304
 305 void
 306 unpack1_char (gfc_array_char *ret,
 307               GFC_INTEGER_4 ret_length __attribute__((unused)),
 308               const gfc_array_char *vector, const gfc_array_l1 *mask,
 309               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 310               GFC_INTEGER_4 field_length)
 311 {
 312   unpack_internal (ret, vector, mask, field, vector_length, field_length);
 313 }
 314
 315 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 316                      const gfc_array_l1 *, char *);
 317 export_proto(unpack0);
 318
 319 void
 320 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 321          const gfc_array_l1 *mask, char *field)
 322 {
 323   gfc_array_char tmp;
 324
 325   int type;
 326   index_type size;
 327
 328   type = GFC_DESCRIPTOR_TYPE (vector);
 329   size = GFC_DESCRIPTOR_SIZE (vector);
 330
 331   switch(type)
 332     {
 333     case GFC_DTYPE_INTEGER:
 334     case GFC_DTYPE_LOGICAL:
 335       switch(size)
 336         {
 337         case sizeof (GFC_INTEGER_1):
 338           unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 339                       mask, (GFC_INTEGER_1 *) field);
 340           return;
 341
 342         case sizeof (GFC_INTEGER_2):
 343           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 344                       mask, (GFC_INTEGER_2 *) field);
 345           return;
 346
 347         case sizeof (GFC_INTEGER_4):
 348           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 349                       mask, (GFC_INTEGER_4 *) field);
 350           return;
 351
 352         case sizeof (GFC_INTEGER_8):
 353           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 354                       mask, (GFC_INTEGER_8 *) field);
 355           return;
 356
 357 #ifdef HAVE_GFC_INTEGER_16
 358         case sizeof (GFC_INTEGER_16):
 359           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 360                       mask, (GFC_INTEGER_16 *) field);
 361           return;
 362 #endif
 363         }
 364
 365     case GFC_DTYPE_REAL:
 366       switch(size)
 367         {
 368         case sizeof (GFC_REAL_4):
 369           unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 370                       mask, (GFC_REAL_4 *) field);
 371           return;
 372
 373         case sizeof (GFC_REAL_8):
 374           unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 375                       mask, (GFC_REAL_8  *) field);
 376           return;
 377
 378 #ifdef HAVE_GFC_REAL_10
 379         case sizeof (GFC_REAL_10):
 380           unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 381                       mask, (GFC_REAL_10 *) field);
 382           return;
 383 #endif
 384
 385 #ifdef HAVE_GFC_REAL_16
 386         case sizeof (GFC_REAL_16):
 387           unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 388                       mask, (GFC_REAL_16 *) field);
 389           return;
 390 #endif
 391         }
 392
 393     case GFC_DTYPE_COMPLEX:
 394       switch(size)
 395         {
 396         case sizeof (GFC_COMPLEX_4):
 397           unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 398                       mask, (GFC_COMPLEX_4 *) field);
 399           return;
 400
 401         case sizeof (GFC_COMPLEX_8):
 402           unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 403                       mask, (GFC_COMPLEX_8 *) field);
 404           return;
 405
 406 #ifdef HAVE_GFC_COMPLEX_10
 407         case sizeof (GFC_COMPLEX_10):
 408           unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 409                       mask, (GFC_COMPLEX_10 *) field);
 410           return;
 411 #endif
 412
 413 #ifdef HAVE_GFC_COMPLEX_16
 414         case sizeof (GFC_COMPLEX_16):
 415           unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 416                       mask, (GFC_COMPLEX_16 *) field);
 417           return;
 418 #endif
 419         }
 420     }
 421   memset (&tmp, 0, sizeof (tmp));
 422   tmp.dtype = 0;
 423   tmp.data = field;
 424   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
 425 }
 426
 427 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 428                           const gfc_array_char *, const gfc_array_l1 *,
 429                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 430 export_proto(unpack0_char);
 431
 432 void
 433 unpack0_char (gfc_array_char *ret,
 434               GFC_INTEGER_4 ret_length __attribute__((unused)),
 435               const gfc_array_char *vector, const gfc_array_l1 *mask,
 436               char *field, GFC_INTEGER_4 vector_length,
 437               GFC_INTEGER_4 field_length __attribute__((unused)))
 438 {
 439   gfc_array_char tmp;
 440
 441   memset (&tmp, 0, sizeof (tmp));
 442   tmp.dtype = 0;
 443   tmp.data = field;
 444   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
 445 }