gcc/fortran/target-memory.c

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