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