gcc/fortran/target-memory.cc

   1 /* Simulate storage of variables into target memory.
   2    Copyright (C) 2007-2023 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                  bool convert_widechar)
 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                                         convert_widechar);
 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
 420   tree source = native_interpret_expr (gfc_get_real_type (kind), buffer,
 421                                        buffer_size);
 422   if (!source)
 423     return 0;
 424
 425   mpfr_init (real);
 426   gfc_conv_tree_to_mpfr (real, source);
 427   return size_float (kind);
 428 }
 429
 430
 431 int
 432 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 433                        mpc_t complex)
 434 {
 435   int size;
 436   size = gfc_interpret_float (kind, &buffer[0], buffer_size,
 437                               mpc_realref (complex));
 438   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
 439                                mpc_imagref (complex));
 440   return size;
 441 }
 442
 443
 444 int
 445 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 446                    int *logical)
 447 {
 448   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 449                                   buffer_size);
 450   *logical = wi::to_wide (t) == 0 ? 0 : 1;
 451   return size_logical (kind);
 452 }
 453
 454
 455 size_t
 456 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
 457                          gfc_expr *result)
 458 {
 459   if (result->ts.u.cl && result->ts.u.cl->length)
 460     result->value.character.length =
 461       gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer);
 462
 463   gcc_assert (buffer_size >= size_character (result->value.character.length,
 464                                              result->ts.kind));
 465   result->value.character.string =
 466     gfc_get_wide_string (result->value.character.length + 1);
 467
 468   if (result->ts.kind == gfc_default_character_kind)
 469     for (size_t i = 0; i < (size_t) result->value.character.length; i++)
 470       result->value.character.string[i] = (gfc_char_t) buffer[i];
 471   else
 472     {
 473       mpz_t integer;
 474       size_t bytes = size_character (1, result->ts.kind);
 475       mpz_init (integer);
 476       gcc_assert (bytes <= sizeof (unsigned long));
 477
 478       for (size_t i = 0; i < (size_t) result->value.character.length; i++)
 479         {
 480           gfc_conv_tree_to_mpz (integer,
 481             native_interpret_expr (gfc_get_char_type (result->ts.kind),
 482                                    &buffer[bytes*i], buffer_size-bytes*i));
 483           result->value.character.string[i]
 484             = (gfc_char_t) mpz_get_ui (integer);
 485         }
 486
 487       mpz_clear (integer);
 488     }
 489
 490   result->value.character.string[result->value.character.length] = '\0';
 491
 492   return size_character (result->value.character.length, result->ts.kind);
 493 }
 494
 495
 496 int
 497 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 498 {
 499   gfc_component *cmp;
 500   int ptr;
 501   tree type;
 502
 503   /* The attributes of the derived type need to be bolted to the floor.  */
 504   result->expr_type = EXPR_STRUCTURE;
 505
 506   cmp = result->ts.u.derived->components;
 507
 508   if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
 509       && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
 510           || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
 511     {
 512       gfc_constructor *c;
 513       gfc_expr *e;
 514       /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
 515          sets this to BT_INTEGER.  */
 516       result->ts.type = BT_DERIVED;
 517       e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
 518       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
 519       c->n.component = cmp;
 520       gfc_target_interpret_expr (buffer, buffer_size, e, true);
 521       e->ts.is_iso_c = 1;
 522       return int_size_in_bytes (ptr_type_node);
 523     }
 524
 525   type = gfc_typenode_for_spec (&result->ts);
 526
 527   /* Run through the derived type components.  */
 528   for (;cmp; cmp = cmp->next)
 529     {
 530       gfc_constructor *c;
 531       gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
 532                                            &result->where);
 533       e->ts = cmp->ts;
 534
 535       /* Copy shape, if needed.  */
 536       if (cmp->as && cmp->as->rank)
 537         {
 538           int n;
 539
 540           if (cmp->as->type != AS_EXPLICIT)
 541             return 0;
 542
 543           e->expr_type = EXPR_ARRAY;
 544           e->rank = cmp->as->rank;
 545
 546           e->shape = gfc_get_shape (e->rank);
 547           for (n = 0; n < e->rank; n++)
 548              {
 549                mpz_init_set_ui (e->shape[n], 1);
 550                mpz_add (e->shape[n], e->shape[n],
 551                         cmp->as->upper[n]->value.integer);
 552                mpz_sub (e->shape[n], e->shape[n],
 553                         cmp->as->lower[n]->value.integer);
 554              }
 555         }
 556
 557       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
 558
 559       /* The constructor points to the component.  */
 560       c->n.component = cmp;
 561
 562       /* Calculate the offset, which consists of the FIELD_OFFSET in
 563          bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
 564          and additional bits of FIELD_BIT_OFFSET. The code assumes that all
 565          sizes of the components are multiples of BITS_PER_UNIT,
 566          i.e. there are, e.g., no bit fields.  */
 567
 568       gcc_assert (cmp->backend_decl);
 569       ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
 570       gcc_assert (ptr % 8 == 0);
 571       ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 572
 573       gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
 574       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
 575     }
 576
 577   return int_size_in_bytes (type);
 578 }
 579
 580
 581 /* Read a binary buffer to a constant expression.  */
 582 size_t
 583 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 584                            gfc_expr *result, bool convert_widechar)
 585 {
 586   if (result->expr_type == EXPR_ARRAY)
 587     return interpret_array (buffer, buffer_size, result, convert_widechar);
 588
 589   switch (result->ts.type)
 590     {
 591     case BT_INTEGER:
 592       result->representation.length =
 593         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 594                                result->value.integer);
 595       break;
 596
 597     case BT_REAL:
 598       result->representation.length =
 599         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 600                              result->value.real);
 601       break;
 602
 603     case BT_COMPLEX:
 604       result->representation.length =
 605         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 606                                result->value.complex);
 607       break;
 608
 609     case BT_LOGICAL:
 610       result->representation.length =
 611         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 612                                &result->value.logical);
 613       break;
 614
 615     case BT_CHARACTER:
 616       result->representation.length =
 617         gfc_interpret_character (buffer, buffer_size, result);
 618       break;
 619
 620     case BT_CLASS:
 621       result->ts = CLASS_DATA (result)->ts;
 622       /* Fall through.  */
 623     case BT_DERIVED:
 624       result->representation.length =
 625         gfc_interpret_derived (buffer, buffer_size, result);
 626       gcc_assert (result->representation.length >= 0);
 627       break;
 628
 629     case BT_VOID:
 630       /* This deals with caf_tokens.  */
 631       result->representation.length =
 632         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 633                                result->value.integer);
 634       break;
 635
 636     default:
 637       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 638       break;
 639     }
 640
 641   if (result->ts.type == BT_CHARACTER && convert_widechar)
 642     result->representation.string
 643       = gfc_widechar_to_char (result->value.character.string,
 644                               result->value.character.length);
 645   else
 646     {
 647       result->representation.string =
 648         XCNEWVEC (char, result->representation.length + 1);
 649       memcpy (result->representation.string, buffer,
 650               result->representation.length);
 651       result->representation.string[result->representation.length] = '\0';
 652     }
 653
 654   return result->representation.length;
 655 }
 656
 657
 658 /* --------------------------------------------------------------- */
 659 /* Two functions used by trans-common.cc to write overlapping
 660    equivalence initializers to a buffer.  This is added to the union
 661    and the original initializers freed.  */
 662
 663
 664 /* Writes the values of a constant expression to a char buffer. If another
 665    unequal initializer has already been written to the buffer, this is an
 666    error.  */
 667
 668 static size_t
 669 expr_to_char (gfc_expr *e, locus *loc,
 670               unsigned char *data, unsigned char *chk, size_t len)
 671 {
 672   int i;
 673   int ptr;
 674   gfc_constructor *c;
 675   gfc_component *cmp;
 676   unsigned char *buffer;
 677
 678   if (e == NULL)
 679     return 0;
 680
 681   /* Take a derived type, one component at a time, using the offsets from the backend
 682      declaration.  */
 683   if (e->ts.type == BT_DERIVED)
 684     {
 685       for (c = gfc_constructor_first (e->value.constructor),
 686            cmp = e->ts.u.derived->components;
 687            c; c = gfc_constructor_next (c), cmp = cmp->next)
 688         {
 689           gcc_assert (cmp && cmp->backend_decl);
 690           if (!c->expr)
 691             continue;
 692           ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 693             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 694           expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len);
 695         }
 696       return len;
 697     }
 698
 699   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
 700      to the target, in a buffer and check off the initialized part of the buffer.  */
 701   gfc_target_expr_size (e, &len);
 702   buffer = (unsigned char*)alloca (len);
 703   len = gfc_target_encode_expr (e, buffer, len);
 704
 705   for (i = 0; i < (int)len; i++)
 706     {
 707       if (chk[i] && (buffer[i] != data[i]))
 708         {
 709           if (loc)
 710             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 711                         "at %L", loc);
 712           else
 713             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 714                         "at %C");
 715           return 0;
 716         }
 717       chk[i] = 0xFF;
 718     }
 719
 720   memcpy (data, buffer, len);
 721   return len;
 722 }
 723
 724
 725 /* Writes the values from the equivalence initializers to a char* array
 726    that will be written to the constructor to make the initializer for
 727    the union declaration.  */
 728
 729 size_t
 730 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
 731                         unsigned char *data,
 732                         unsigned char *chk, size_t length)
 733 {
 734   size_t len = 0;
 735   gfc_constructor * c;
 736
 737   switch (e->expr_type)
 738     {
 739     case EXPR_CONSTANT:
 740     case EXPR_STRUCTURE:
 741       len = expr_to_char (e, loc, &data[0], &chk[0], length);
 742       break;
 743
 744     case EXPR_ARRAY:
 745       for (c = gfc_constructor_first (e->value.constructor);
 746            c; c = gfc_constructor_next (c))
 747         {
 748           size_t elt_size;
 749
 750           gfc_target_expr_size (c->expr, &elt_size);
 751
 752           if (mpz_cmp_si (c->offset, 0) != 0)
 753             len = elt_size * (size_t)mpz_get_si (c->offset);
 754
 755           len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len],
 756                                               &chk[len], length - len);
 757         }
 758       break;
 759
 760     default:
 761       return 0;
 762     }
 763
 764   return len;
 765 }
 766
 767
 768 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
 769    When successful, no BOZ or nothing to do, true is returned.  */
 770
 771 bool
 772 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
 773 {
 774   size_t buffer_size, boz_bit_size, ts_bit_size;
 775   int index;
 776   unsigned char *buffer;
 777
 778   if (expr->ts.type != BT_INTEGER)
 779     return true;
 780
 781   /* Don't convert BOZ to logical, character, derived etc.  */
 782   gcc_assert (ts->type == BT_REAL);
 783
 784   buffer_size = size_float (ts->kind);
 785   ts_bit_size = buffer_size * 8;
 786
 787   /* Convert BOZ to the smallest possible integer kind.  */
 788   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
 789
 790   gcc_assert (boz_bit_size <= ts_bit_size);
 791
 792   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 793     if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
 794       break;
 795
 796   expr->ts.kind = gfc_integer_kinds[index].kind;
 797   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
 798
 799   buffer = (unsigned char*)alloca (buffer_size);
 800   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
 801   mpz_clear (expr->value.integer);
 802
 803   mpfr_init (expr->value.real);
 804   gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
 805
 806   expr->ts.type = ts->type;
 807   expr->ts.kind = ts->kind;
 808
 809   return true;
 810 }