gcc/fortran/target-memory.c

   1 /* Simulate storage of variables into target memory.
   2    Copyright (C) 2007-2019 Free Software Foundation, Inc.
   3    Contributed by Paul Thomas and Brooks Moses
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "coretypes.h"
  24 #include "tree.h"
  25 #include "gfortran.h"
  26 #include "trans.h"
  27 #include "fold-const.h"
  28 #include "stor-layout.h"
  29 #include "arith.h"
  30 #include "constructor.h"
  31 #include "trans-const.h"
  32 #include "trans-types.h"
  33 #include "target-memory.h"
  34
  35 /* --------------------------------------------------------------- */
  36 /* Calculate the size of an expression.  */
  37
  38
  39 static size_t
  40 size_integer (int kind)
  41 {
  42   return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind)));
  43 }
  44
  45
  46 static size_t
  47 size_float (int kind)
  48 {
  49   return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind)));
  50 }
  51
  52
  53 static size_t
  54 size_complex (int kind)
  55 {
  56   return 2 * size_float (kind);
  57 }
  58
  59
  60 static size_t
  61 size_logical (int kind)
  62 {
  63   return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind)));
  64 }
  65
  66
  67 static size_t
  68 size_character (gfc_charlen_t length, int kind)
  69 {
  70   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
  71   return length * gfc_character_kinds[i].bit_size / 8;
  72 }
  73
  74
  75 /* Return the size of a single element of the given expression.
  76    Equivalent to gfc_target_expr_size for scalars.  */
  77
  78 bool
  79 gfc_element_size (gfc_expr *e, size_t *siz)
  80 {
  81   tree type;
  82
  83   switch (e->ts.type)
  84     {
  85     case BT_INTEGER:
  86       *siz = size_integer (e->ts.kind);
  87       return true;
  88     case BT_REAL:
  89       *siz = size_float (e->ts.kind);
  90       return true;
  91     case BT_COMPLEX:
  92       *siz = size_complex (e->ts.kind);
  93       return true;
  94     case BT_LOGICAL:
  95       *siz = size_logical (e->ts.kind);
  96       return true;
  97     case BT_CHARACTER:
  98       if (e->expr_type == EXPR_CONSTANT)
  99         *siz = size_character (e->value.character.length, e->ts.kind);
 100       else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
 101                && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
 102                && e->ts.u.cl->length->ts.type == BT_INTEGER)
 103         {
 104           HOST_WIDE_INT length;
 105
 106           gfc_extract_hwi (e->ts.u.cl->length, &length);
 107           *siz = size_character (length, e->ts.kind);
 108         }
 109       else
 110         {
 111           *siz = 0;
 112           return false;
 113         }
 114       return true;
 115
 116     case BT_HOLLERITH:
 117       *siz = e->representation.length;
 118       return true;
 119     case BT_DERIVED:
 120     case BT_CLASS:
 121     case BT_VOID:
 122     case BT_ASSUMED:
 123     case BT_PROCEDURE:
 124       {
 125         /* Determine type size without clobbering the typespec for ISO C
 126            binding types.  */
 127         gfc_typespec ts;
 128         HOST_WIDE_INT size;
 129         ts = e->ts;
 130         type = gfc_typenode_for_spec (&ts);
 131         size = int_size_in_bytes (type);
 132         gcc_assert (size >= 0);
 133         *siz = size;
 134       }
 135       return true;
 136     default:
 137       gfc_internal_error ("Invalid expression in gfc_element_size.");
 138       *siz = 0;
 139       return false;
 140     }
 141   return true;
 142 }
 143
 144
 145 /* Return the size of an expression in its target representation.  */
 146
 147 bool
 148 gfc_target_expr_size (gfc_expr *e, size_t *size)
 149 {
 150   mpz_t tmp;
 151   size_t asz, el_size;
 152
 153   gcc_assert (e != NULL);
 154
 155   *size = 0;
 156   if (e->rank)
 157     {
 158       if (gfc_array_size (e, &tmp))
 159         asz = mpz_get_ui (tmp);
 160       else
 161         return false;
 162     }
 163   else
 164     asz = 1;
 165
 166   if (!gfc_element_size (e, &el_size))
 167     return false;
 168   *size = asz * el_size;
 169   return true;
 170 }
 171
 172
 173 /* The encode_* functions export a value into a buffer, and
 174    return the number of bytes of the buffer that have been
 175    used.  */
 176
 177 static unsigned HOST_WIDE_INT
 178 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
 179 {
 180   mpz_t array_size;
 181   int i;
 182   int ptr = 0;
 183
 184   gfc_constructor_base ctor = expr->value.constructor;
 185
 186   gfc_array_size (expr, &array_size);
 187   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
 188     {
 189       ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
 190                                      &buffer[ptr], buffer_size - ptr);
 191     }
 192
 193   mpz_clear (array_size);
 194   return ptr;
 195 }
 196
 197
 198 static int
 199 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
 200                 size_t buffer_size)
 201 {
 202   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
 203                              buffer, buffer_size);
 204 }
 205
 206
 207 static int
 208 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
 209 {
 210   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
 211                              buffer_size);
 212 }
 213
 214
 215 static int
 216 encode_complex (int kind, mpc_t cmplx,
 217                 unsigned char *buffer, size_t buffer_size)
 218 {
 219   int size;
 220   size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
 221   size += encode_float (kind, mpc_imagref (cmplx),
 222                         &buffer[size], buffer_size - size);
 223   return size;
 224 }
 225
 226
 227 static int
 228 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
 229 {
 230   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
 231                                             logical),
 232                              buffer, buffer_size);
 233 }
 234
 235
 236 size_t
 237 gfc_encode_character (int kind, size_t length, const gfc_char_t *string,
 238                       unsigned char *buffer, size_t buffer_size)
 239 {
 240   size_t elsize = size_character (1, kind);
 241   tree type = gfc_get_char_type (kind);
 242
 243   gcc_assert (buffer_size >= size_character (length, kind));
 244
 245   for (size_t i = 0; i < length; i++)
 246     native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
 247                         elsize);
 248
 249   return length;
 250 }
 251
 252
 253 static unsigned HOST_WIDE_INT
 254 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
 255 {
 256   gfc_constructor *c;
 257   gfc_component *cmp;
 258   int ptr;
 259   tree type;
 260   HOST_WIDE_INT size;
 261
 262   type = gfc_typenode_for_spec (&source->ts);
 263
 264   for (c = gfc_constructor_first (source->value.constructor),
 265        cmp = source->ts.u.derived->components;
 266        c;
 267        c = gfc_constructor_next (c), cmp = cmp->next)
 268     {
 269       gcc_assert (cmp);
 270       if (!c->expr)
 271         continue;
 272       ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 273             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 274
 275       if (c->expr->expr_type == EXPR_NULL)
 276         {
 277           size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl));
 278           gcc_assert (size >= 0);
 279           memset (&buffer[ptr], 0, size);
 280         }
 281       else
 282         gfc_target_encode_expr (c->expr, &buffer[ptr],
 283                                 buffer_size - ptr);
 284     }
 285
 286   size = int_size_in_bytes (type);
 287   gcc_assert (size >= 0);
 288   return size;
 289 }
 290
 291
 292 /* Write a constant expression in binary form to a buffer.  */
 293 unsigned HOST_WIDE_INT
 294 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 295                         size_t buffer_size)
 296 {
 297   if (source == NULL)
 298     return 0;
 299
 300   if (source->expr_type == EXPR_ARRAY)
 301     return encode_array (source, buffer, buffer_size);
 302
 303   gcc_assert (source->expr_type == EXPR_CONSTANT
 304               || source->expr_type == EXPR_STRUCTURE
 305               || source->expr_type == EXPR_SUBSTRING);
 306
 307   /* If we already have a target-memory representation, we use that rather
 308      than recreating one.  */
 309   if (source->representation.string)
 310     {
 311       memcpy (buffer, source->representation.string,
 312               source->representation.length);
 313       return source->representation.length;
 314     }
 315
 316   switch (source->ts.type)
 317     {
 318     case BT_INTEGER:
 319       return encode_integer (source->ts.kind, source->value.integer, buffer,
 320                              buffer_size);
 321     case BT_REAL:
 322       return encode_float (source->ts.kind, source->value.real, buffer,
 323                            buffer_size);
 324     case BT_COMPLEX:
 325       return encode_complex (source->ts.kind, source->value.complex,
 326                              buffer, buffer_size);
 327     case BT_LOGICAL:
 328       return encode_logical (source->ts.kind, source->value.logical, buffer,
 329                              buffer_size);
 330     case BT_CHARACTER:
 331       if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
 332         return gfc_encode_character (source->ts.kind,
 333                                      source->value.character.length,
 334                                      source->value.character.string,
 335                                      buffer, buffer_size);
 336       else
 337         {
 338           HOST_WIDE_INT start, end;
 339
 340           gcc_assert (source->expr_type == EXPR_SUBSTRING);
 341           gfc_extract_hwi (source->ref->u.ss.start, &start);
 342           gfc_extract_hwi (source->ref->u.ss.end, &end);
 343           return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
 344                                        &source->value.character.string[start-1],
 345                                        buffer, buffer_size);
 346         }
 347
 348     case BT_DERIVED:
 349       if (source->ts.u.derived->ts.f90_type == BT_VOID)
 350         {
 351           gfc_constructor *c;
 352           gcc_assert (source->expr_type == EXPR_STRUCTURE);
 353           c = gfc_constructor_first (source->value.constructor);
 354           gcc_assert (c->expr->expr_type == EXPR_CONSTANT
 355                       && c->expr->ts.type == BT_INTEGER);
 356           return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
 357                                  buffer, buffer_size);
 358         }
 359
 360       return encode_derived (source, buffer, buffer_size);
 361     default:
 362       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 363       return 0;
 364     }
 365 }
 366
 367
 368 static size_t
 369 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 370 {
 371   gfc_constructor_base base = NULL;
 372   size_t array_size = 1;
 373   size_t ptr = 0;
 374
 375   /* Calculate array size from its shape and rank.  */
 376   gcc_assert (result->rank > 0 && result->shape);
 377
 378   for (int i = 0; i < result->rank; i++)
 379     array_size *= mpz_get_ui (result->shape[i]);
 380
 381   /* Iterate over array elements, producing constructors.  */
 382   for (size_t i = 0; i < array_size; i++)
 383     {
 384       gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
 385                                            &result->where);
 386       e->ts = result->ts;
 387
 388       if (e->ts.type == BT_CHARACTER)
 389         e->value.character.length = result->value.character.length;
 390
 391       gfc_constructor_append_expr (&base, e, &result->where);
 392
 393       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
 394                                         true);
 395     }
 396
 397   result->value.constructor = base;
 398   return ptr;
 399 }
 400
 401
 402 int
 403 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 404                    mpz_t integer)
 405 {
 406   mpz_init (integer);
 407   gfc_conv_tree_to_mpz (integer,
 408                         native_interpret_expr (gfc_get_int_type (kind),
 409                                                buffer, buffer_size));
 410   return size_integer (kind);
 411 }
 412
 413
 414 int
 415 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 416                      mpfr_t real)
 417 {
 418   gfc_set_model_kind (kind);
 419   mpfr_init (real);
 420   gfc_conv_tree_to_mpfr (real,
 421                          native_interpret_expr (gfc_get_real_type (kind),
 422                                                 buffer, buffer_size));
 423
 424   return size_float (kind);
 425 }
 426
 427
 428 int
 429 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 430                        mpc_t complex)
 431 {
 432   int size;
 433   size = gfc_interpret_float (kind, &buffer[0], buffer_size,
 434                               mpc_realref (complex));
 435   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
 436                                mpc_imagref (complex));
 437   return size;
 438 }
 439
 440
 441 int
 442 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 443                    int *logical)
 444 {
 445   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 446                                   buffer_size);
 447   *logical = wi::to_wide (t) == 0 ? 0 : 1;
 448   return size_logical (kind);
 449 }
 450
 451
 452 size_t
 453 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
 454                          gfc_expr *result)
 455 {
 456   if (result->ts.u.cl && result->ts.u.cl->length)
 457     result->value.character.length =
 458       gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer);
 459
 460   gcc_assert (buffer_size >= size_character (result->value.character.length,
 461                                              result->ts.kind));
 462   result->value.character.string =
 463     gfc_get_wide_string (result->value.character.length + 1);
 464
 465   if (result->ts.kind == gfc_default_character_kind)
 466     for (size_t i = 0; i < (size_t) result->value.character.length; i++)
 467       result->value.character.string[i] = (gfc_char_t) buffer[i];
 468   else
 469     {
 470       mpz_t integer;
 471       size_t bytes = size_character (1, result->ts.kind);
 472       mpz_init (integer);
 473       gcc_assert (bytes <= sizeof (unsigned long));
 474
 475       for (size_t i = 0; i < (size_t) result->value.character.length; i++)
 476         {
 477           gfc_conv_tree_to_mpz (integer,
 478             native_interpret_expr (gfc_get_char_type (result->ts.kind),
 479                                    &buffer[bytes*i], buffer_size-bytes*i));
 480           result->value.character.string[i]
 481             = (gfc_char_t) mpz_get_ui (integer);
 482         }
 483
 484       mpz_clear (integer);
 485     }
 486
 487   result->value.character.string[result->value.character.length] = '\0';
 488
 489   return result->value.character.length;
 490 }
 491
 492
 493 int
 494 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 495 {
 496   gfc_component *cmp;
 497   int ptr;
 498   tree type;
 499
 500   /* The attributes of the derived type need to be bolted to the floor.  */
 501   result->expr_type = EXPR_STRUCTURE;
 502
 503   cmp = result->ts.u.derived->components;
 504
 505   if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
 506       && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
 507           || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
 508     {
 509       gfc_constructor *c;
 510       gfc_expr *e;
 511       /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
 512          sets this to BT_INTEGER.  */
 513       result->ts.type = BT_DERIVED;
 514       e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
 515       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
 516       c->n.component = cmp;
 517       gfc_target_interpret_expr (buffer, buffer_size, e, true);
 518       e->ts.is_iso_c = 1;
 519       return int_size_in_bytes (ptr_type_node);
 520     }
 521
 522   type = gfc_typenode_for_spec (&result->ts);
 523
 524   /* Run through the derived type components.  */
 525   for (;cmp; cmp = cmp->next)
 526     {
 527       gfc_constructor *c;
 528       gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
 529                                            &result->where);
 530       e->ts = cmp->ts;
 531
 532       /* Copy shape, if needed.  */
 533       if (cmp->as && cmp->as->rank)
 534         {
 535           int n;
 536
 537           e->expr_type = EXPR_ARRAY;
 538           e->rank = cmp->as->rank;
 539
 540           e->shape = gfc_get_shape (e->rank);
 541           for (n = 0; n < e->rank; n++)
 542              {
 543                mpz_init_set_ui (e->shape[n], 1);
 544                mpz_add (e->shape[n], e->shape[n],
 545                         cmp->as->upper[n]->value.integer);
 546                mpz_sub (e->shape[n], e->shape[n],
 547                         cmp->as->lower[n]->value.integer);
 548              }
 549         }
 550
 551       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
 552
 553       /* The constructor points to the component.  */
 554       c->n.component = cmp;
 555
 556       /* Calculate the offset, which consists of the FIELD_OFFSET in
 557          bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
 558          and additional bits of FIELD_BIT_OFFSET. The code assumes that all
 559          sizes of the components are multiples of BITS_PER_UNIT,
 560          i.e. there are, e.g., no bit fields.  */
 561
 562       gcc_assert (cmp->backend_decl);
 563       ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
 564       gcc_assert (ptr % 8 == 0);
 565       ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 566
 567       gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
 568       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
 569     }
 570
 571   return int_size_in_bytes (type);
 572 }
 573
 574
 575 /* Read a binary buffer to a constant expression.  */
 576 size_t
 577 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 578                            gfc_expr *result, bool convert_widechar)
 579 {
 580   if (result->expr_type == EXPR_ARRAY)
 581     return interpret_array (buffer, buffer_size, result);
 582
 583   switch (result->ts.type)
 584     {
 585     case BT_INTEGER:
 586       result->representation.length =
 587         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 588                                result->value.integer);
 589       break;
 590
 591     case BT_REAL:
 592       result->representation.length =
 593         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 594                              result->value.real);
 595       break;
 596
 597     case BT_COMPLEX:
 598       result->representation.length =
 599         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 600                                result->value.complex);
 601       break;
 602
 603     case BT_LOGICAL:
 604       result->representation.length =
 605         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 606                                &result->value.logical);
 607       break;
 608
 609     case BT_CHARACTER:
 610       result->representation.length =
 611         gfc_interpret_character (buffer, buffer_size, result);
 612       break;
 613
 614     case BT_CLASS:
 615       result->ts = CLASS_DATA (result)->ts;
 616       /* Fall through.  */
 617     case BT_DERIVED:
 618       result->representation.length =
 619         gfc_interpret_derived (buffer, buffer_size, result);
 620       gcc_assert (result->representation.length >= 0);
 621       break;
 622
 623     case BT_VOID:
 624       /* This deals with caf_tokens.  */
 625       result->representation.length =
 626         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 627                                result->value.integer);
 628       break;
 629
 630     default:
 631       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 632       break;
 633     }
 634
 635   if (result->ts.type == BT_CHARACTER && convert_widechar)
 636     result->representation.string
 637       = gfc_widechar_to_char (result->value.character.string,
 638                               result->value.character.length);
 639   else
 640     {
 641       result->representation.string =
 642         XCNEWVEC (char, result->representation.length + 1);
 643       memcpy (result->representation.string, buffer,
 644               result->representation.length);
 645       result->representation.string[result->representation.length] = '\0';
 646     }
 647
 648   return result->representation.length;
 649 }
 650
 651
 652 /* --------------------------------------------------------------- */
 653 /* Two functions used by trans-common.c to write overlapping
 654    equivalence initializers to a buffer.  This is added to the union
 655    and the original initializers freed.  */
 656
 657
 658 /* Writes the values of a constant expression to a char buffer. If another
 659    unequal initializer has already been written to the buffer, this is an
 660    error.  */
 661
 662 static size_t
 663 expr_to_char (gfc_expr *e, locus *loc,
 664               unsigned char *data, unsigned char *chk, size_t len)
 665 {
 666   int i;
 667   int ptr;
 668   gfc_constructor *c;
 669   gfc_component *cmp;
 670   unsigned char *buffer;
 671
 672   if (e == NULL)
 673     return 0;
 674
 675   /* Take a derived type, one component at a time, using the offsets from the backend
 676      declaration.  */
 677   if (e->ts.type == BT_DERIVED)
 678     {
 679       for (c = gfc_constructor_first (e->value.constructor),
 680            cmp = e->ts.u.derived->components;
 681            c; c = gfc_constructor_next (c), cmp = cmp->next)
 682         {
 683           gcc_assert (cmp && cmp->backend_decl);
 684           if (!c->expr)
 685             continue;
 686           ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 687             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 688           expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len);
 689         }
 690       return len;
 691     }
 692
 693   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
 694      to the target, in a buffer and check off the initialized part of the buffer.  */
 695   gfc_target_expr_size (e, &len);
 696   buffer = (unsigned char*)alloca (len);
 697   len = gfc_target_encode_expr (e, buffer, len);
 698
 699   for (i = 0; i < (int)len; i++)
 700     {
 701       if (chk[i] && (buffer[i] != data[i]))
 702         {
 703           if (loc)
 704             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 705                         "at %L", loc);
 706           else
 707             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 708                         "at %C");
 709           return 0;
 710         }
 711       chk[i] = 0xFF;
 712     }
 713
 714   memcpy (data, buffer, len);
 715   return len;
 716 }
 717
 718
 719 /* Writes the values from the equivalence initializers to a char* array
 720    that will be written to the constructor to make the initializer for
 721    the union declaration.  */
 722
 723 size_t
 724 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
 725                         unsigned char *data,
 726                         unsigned char *chk, size_t length)
 727 {
 728   size_t len = 0;
 729   gfc_constructor * c;
 730
 731   switch (e->expr_type)
 732     {
 733     case EXPR_CONSTANT:
 734     case EXPR_STRUCTURE:
 735       len = expr_to_char (e, loc, &data[0], &chk[0], length);
 736       break;
 737
 738     case EXPR_ARRAY:
 739       for (c = gfc_constructor_first (e->value.constructor);
 740            c; c = gfc_constructor_next (c))
 741         {
 742           size_t elt_size;
 743
 744           gfc_target_expr_size (c->expr, &elt_size);
 745
 746           if (mpz_cmp_si (c->offset, 0) != 0)
 747             len = elt_size * (size_t)mpz_get_si (c->offset);
 748
 749           len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len],
 750                                               &chk[len], length - len);
 751         }
 752       break;
 753
 754     default:
 755       return 0;
 756     }
 757
 758   return len;
 759 }
 760
 761
 762 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
 763    When successful, no BOZ or nothing to do, true is returned.  */
 764
 765 bool
 766 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
 767 {
 768   size_t buffer_size, boz_bit_size, ts_bit_size;
 769   int index;
 770   unsigned char *buffer;
 771
 772   if (expr->ts.type != BT_INTEGER)
 773     return true;
 774
 775   /* Don't convert BOZ to logical, character, derived etc.  */
 776   gcc_assert (ts->type == BT_REAL);
 777
 778   buffer_size = size_float (ts->kind);
 779   ts_bit_size = buffer_size * 8;
 780
 781   /* Convert BOZ to the smallest possible integer kind.  */
 782   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
 783
 784   gcc_assert (boz_bit_size <= ts_bit_size);
 785
 786   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 787     if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
 788       break;
 789
 790   expr->ts.kind = gfc_integer_kinds[index].kind;
 791   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
 792
 793   buffer = (unsigned char*)alloca (buffer_size);
 794   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
 795   mpz_clear (expr->value.integer);
 796
 797   mpfr_init (expr->value.real);
 798   gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
 799
 800   expr->ts.type = ts->type;
 801   expr->ts.kind = ts->kind;
 802
 803   return true;
 804 }