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   index_type type_size;
 200   index_type size;
 201
 202   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 203   size = GFC_DESCRIPTOR_SIZE (vector);
 204
 205   switch(type_size)
 206     {
 207     case GFC_DTYPE_LOGICAL_1:
 208     case GFC_DTYPE_INTEGER_1:
 209     case GFC_DTYPE_DERIVED_1:
 210       unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 211                   mask, (gfc_array_i1 *) field);
 212       return;
 213
 214     case GFC_DTYPE_LOGICAL_2:
 215     case GFC_DTYPE_INTEGER_2:
 216       unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 217                   mask, (gfc_array_i2 *) field);
 218       return;
 219
 220     case GFC_DTYPE_LOGICAL_4:
 221     case GFC_DTYPE_INTEGER_4:
 222       unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 223                   mask, (gfc_array_i4 *) field);
 224       return;
 225
 226     case GFC_DTYPE_LOGICAL_8:
 227     case GFC_DTYPE_INTEGER_8:
 228       unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 229                   mask, (gfc_array_i8 *) field);
 230       return;
 231
 232 #ifdef HAVE_GFC_INTEGER_16
 233     case GFC_DTYPE_LOGICAL_16:
 234     case GFC_DTYPE_INTEGER_16:
 235       unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 236                    mask, (gfc_array_i16 *) field);
 237       return;
 238 #endif
 239     case GFC_DTYPE_REAL_4:
 240       unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 241                   mask, (gfc_array_r4 *) field);
 242       return;
 243
 244     case GFC_DTYPE_REAL_8:
 245       unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
 246                   mask, (gfc_array_r8 *) field);
 247       return;
 248
 249 #ifdef HAVE_GFC_REAL_10
 250     case GFC_DTYPE_REAL_10:
 251       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 252                    mask, (gfc_array_r10 *) field);
 253           return;
 254 #endif
 255
 256 #ifdef HAVE_GFC_REAL_16
 257     case GFC_DTYPE_REAL_16:
 258       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 259                    mask, (gfc_array_r16 *) field);
 260       return;
 261 #endif
 262
 263     case GFC_DTYPE_COMPLEX_4:
 264       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 265                   mask, (gfc_array_c4 *) field);
 266       return;
 267
 268     case GFC_DTYPE_COMPLEX_8:
 269       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 270                   mask, (gfc_array_c8 *) field);
 271       return;
 272
 273 #ifdef HAVE_GFC_COMPLEX_10
 274     case GFC_DTYPE_COMPLEX_10:
 275       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 276                    mask, (gfc_array_c10 *) field);
 277       return;
 278 #endif
 279
 280 #ifdef HAVE_GFC_COMPLEX_16
 281     case GFC_DTYPE_COMPLEX_16:
 282       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 283                    mask, (gfc_array_c16 *) field);
 284       return;
 285 #endif
 286
 287     case GFC_DTYPE_DERIVED_2:
 288       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 289           || GFC_UNALIGNED_2(field->data))
 290         break;
 291       else
 292         {
 293           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 294                       mask, (gfc_array_i2 *) field);
 295           return;
 296         }
 297
 298     case GFC_DTYPE_DERIVED_4:
 299       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 300           || GFC_UNALIGNED_4(field->data))
 301         break;
 302       else
 303         {
 304           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 305                       mask, (gfc_array_i4 *) field);
 306           return;
 307         }
 308
 309     case GFC_DTYPE_DERIVED_8:
 310       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 311           || GFC_UNALIGNED_8(field->data))
 312         break;
 313       else
 314         {
 315           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 316                       mask, (gfc_array_i8 *) field);
 317           return;
 318         }
 319
 320 #ifdef HAVE_GFC_INTEGER_16
 321     case GFC_DTYPE_DERIVED_16:
 322       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 323           || GFC_UNALIGNED_16(field->data))
 324         break;
 325       else
 326         {
 327           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 328                        mask, (gfc_array_i16 *) field);
 329           return;
 330         }
 331 #endif
 332     }
 333
 334   unpack_internal (ret, vector, mask, field, size,
 335                    GFC_DESCRIPTOR_SIZE (field));
 336 }
 337
 338 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 339                           const gfc_array_char *, const gfc_array_l1 *,
 340                           const gfc_array_char *, GFC_INTEGER_4,
 341                           GFC_INTEGER_4);
 342 export_proto(unpack1_char);
 343
 344 void
 345 unpack1_char (gfc_array_char *ret,
 346               GFC_INTEGER_4 ret_length __attribute__((unused)),
 347               const gfc_array_char *vector, const gfc_array_l1 *mask,
 348               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 349               GFC_INTEGER_4 field_length)
 350 {
 351   unpack_internal (ret, vector, mask, field, vector_length, field_length);
 352 }
 353
 354 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 355                      const gfc_array_l1 *, char *);
 356 export_proto(unpack0);
 357
 358 void
 359 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 360          const gfc_array_l1 *mask, char *field)
 361 {
 362   gfc_array_char tmp;
 363
 364   index_type type_size;
 365   index_type size;
 366
 367   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 368   size = GFC_DESCRIPTOR_SIZE (vector);
 369
 370   switch(type_size)
 371     {
 372     case GFC_DTYPE_LOGICAL_1:
 373     case GFC_DTYPE_INTEGER_1:
 374     case GFC_DTYPE_DERIVED_1:
 375       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 376                   mask, (GFC_INTEGER_1 *) field);
 377       return;
 378
 379     case GFC_DTYPE_LOGICAL_2:
 380     case GFC_DTYPE_INTEGER_2:
 381       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 382                   mask, (GFC_INTEGER_2 *) field);
 383       return;
 384
 385     case GFC_DTYPE_LOGICAL_4:
 386     case GFC_DTYPE_INTEGER_4:
 387       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 388                   mask, (GFC_INTEGER_4 *) field);
 389       return;
 390
 391     case GFC_DTYPE_LOGICAL_8:
 392     case GFC_DTYPE_INTEGER_8:
 393       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 394                   mask, (GFC_INTEGER_8 *) field);
 395       return;
 396
 397 #ifdef HAVE_GFC_INTEGER_16
 398     case GFC_DTYPE_LOGICAL_16:
 399     case GFC_DTYPE_INTEGER_16:
 400       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 401                    mask, (GFC_INTEGER_16 *) field);
 402       return;
 403 #endif
 404     case GFC_DTYPE_REAL_4:
 405       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 406                   mask, (GFC_REAL_4 *) field);
 407       return;
 408
 409     case GFC_DTYPE_REAL_8:
 410       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 411                   mask, (GFC_REAL_8  *) field);
 412       return;
 413
 414 #ifdef HAVE_GFC_REAL_10
 415     case GFC_DTYPE_REAL_10:
 416       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 417                    mask, (GFC_REAL_10 *) field);
 418       return;
 419 #endif
 420
 421 #ifdef HAVE_GFC_REAL_16
 422     case GFC_DTYPE_REAL_16:
 423       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 424                    mask, (GFC_REAL_16 *) field);
 425       return;
 426 #endif
 427
 428     case GFC_DTYPE_COMPLEX_4:
 429       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 430                   mask, (GFC_COMPLEX_4 *) field);
 431       return;
 432
 433     case GFC_DTYPE_COMPLEX_8:
 434       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 435                   mask, (GFC_COMPLEX_8 *) field);
 436       return;
 437
 438 #ifdef HAVE_GFC_COMPLEX_10
 439     case GFC_DTYPE_COMPLEX_10:
 440       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 441                    mask, (GFC_COMPLEX_10 *) field);
 442       return;
 443 #endif
 444
 445 #ifdef HAVE_GFC_COMPLEX_16
 446     case GFC_DTYPE_COMPLEX_16:
 447       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 448                    mask, (GFC_COMPLEX_16 *) field);
 449       return;
 450 #endif
 451     case GFC_DTYPE_DERIVED_2:
 452       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 453           || GFC_UNALIGNED_2(field))
 454         break;
 455       else
 456         {
 457           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 458                       mask, (GFC_INTEGER_2 *) field);
 459           return;
 460         }
 461
 462     case GFC_DTYPE_DERIVED_4:
 463       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 464           || GFC_UNALIGNED_4(field))
 465         break;
 466       else
 467         {
 468           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 469                       mask, (GFC_INTEGER_4 *) field);
 470           return;
 471         }
 472
 473     case GFC_DTYPE_DERIVED_8:
 474       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 475           || GFC_UNALIGNED_8(field))
 476         break;
 477       else
 478         {
 479           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 480                       mask, (GFC_INTEGER_8 *) field);
 481           return;
 482         }
 483 #ifdef HAVE_GFC_INTEGER_16
 484     case GFC_DTYPE_DERIVED_16:
 485       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 486           || GFC_UNALIGNED_16(field))
 487         break;
 488       else
 489         {
 490           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 491                        mask, (GFC_INTEGER_16 *) field);
 492           return;
 493         }
 494 #endif
 495     }
 496
 497   memset (&tmp, 0, sizeof (tmp));
 498   tmp.dtype = 0;
 499   tmp.data = field;
 500   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
 501 }
 502
 503 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 504                           const gfc_array_char *, const gfc_array_l1 *,
 505                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 506 export_proto(unpack0_char);
 507
 508 void
 509 unpack0_char (gfc_array_char *ret,
 510               GFC_INTEGER_4 ret_length __attribute__((unused)),
 511               const gfc_array_char *vector, const gfc_array_l1 *mask,
 512               char *field, GFC_INTEGER_4 vector_length,
 513               GFC_INTEGER_4 field_length __attribute__((unused)))
 514 {
 515   gfc_array_char tmp;
 516
 517   memset (&tmp, 0, sizeof (tmp));
 518   tmp.dtype = 0;
 519   tmp.data = field;
 520   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
 521 }