gcc/fortran/target-memory.c

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