gcc/fortran/target-memory.cc

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