gcc/fortran/target-memory.c

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