gcc/fortran/target-memory.c

   1 /* Simulate storage of variables into target memory.
   2    Copyright (C) 2007, 2008, 2009
   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 "trans.h"
  30 #include "trans-const.h"
  31 #include "trans-types.h"
  32 #include "target-memory.h"
  33
  34 /* --------------------------------------------------------------- */
  35 /* Calculate the size of an expression.  */
  36
  37 static size_t
  38 size_array (gfc_expr *e)
  39 {
  40   mpz_t array_size;
  41   size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
  42
  43   gfc_array_size (e, &array_size);
  44   return (size_t)mpz_get_ui (array_size) * elt_size;
  45 }
  46
  47 static size_t
  48 size_integer (int kind)
  49 {
  50   return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
  51 }
  52
  53
  54 static size_t
  55 size_float (int kind)
  56 {
  57   return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
  58 }
  59
  60
  61 static size_t
  62 size_complex (int kind)
  63 {
  64   return 2 * size_float (kind);
  65 }
  66
  67
  68 static size_t
  69 size_logical (int kind)
  70 {
  71   return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
  72 }
  73
  74
  75 static size_t
  76 size_character (int length, int kind)
  77 {
  78   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
  79   return length * gfc_character_kinds[i].bit_size / 8;
  80 }
  81
  82
  83 size_t
  84 gfc_target_expr_size (gfc_expr *e)
  85 {
  86   tree type;
  87
  88   gcc_assert (e != NULL);
  89
  90   if (e->expr_type == EXPR_ARRAY)
  91     return size_array (e);
  92
  93   switch (e->ts.type)
  94     {
  95     case BT_INTEGER:
  96       return size_integer (e->ts.kind);
  97     case BT_REAL:
  98       return size_float (e->ts.kind);
  99     case BT_COMPLEX:
 100       return size_complex (e->ts.kind);
 101     case BT_LOGICAL:
 102       return size_logical (e->ts.kind);
 103     case BT_CHARACTER:
 104       if (e->expr_type == EXPR_SUBSTRING && e->ref)
 105         {
 106           int start, end;
 107
 108           gfc_extract_int (e->ref->u.ss.start, &start);
 109           gfc_extract_int (e->ref->u.ss.end, &end);
 110           return size_character (MAX(end - start + 1, 0), e->ts.kind);
 111         }
 112       else
 113         return size_character (e->value.character.length, e->ts.kind);
 114     case BT_HOLLERITH:
 115       return e->representation.length;
 116     case BT_DERIVED:
 117       type = gfc_typenode_for_spec (&e->ts);
 118       return int_size_in_bytes (type);
 119     default:
 120       gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
 121       return 0;
 122     }
 123 }
 124
 125
 126 /* The encode_* functions export a value into a buffer, and
 127    return the number of bytes of the buffer that have been
 128    used.  */
 129
 130 static int
 131 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
 132 {
 133   mpz_t array_size;
 134   int i;
 135   int ptr = 0;
 136
 137   gfc_array_size (expr, &array_size);
 138   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
 139     {
 140       ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
 141                                      &buffer[ptr], buffer_size - ptr);
 142     }
 143
 144   mpz_clear (array_size);
 145   return ptr;
 146 }
 147
 148
 149 static int
 150 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
 151                 size_t buffer_size)
 152 {
 153   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
 154                              buffer, buffer_size);
 155 }
 156
 157
 158 static int
 159 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
 160 {
 161   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
 162                              buffer_size);
 163 }
 164
 165
 166 static int
 167 encode_complex (int kind,
 168 #ifdef HAVE_mpc
 169                 mpc_t cmplx,
 170 #else
 171                 mpfr_t real, mpfr_t imaginary,
 172 #endif
 173                 unsigned char *buffer, size_t buffer_size)
 174 {
 175   int size;
 176   size = encode_float (kind,
 177 #ifdef HAVE_mpc
 178                        mpc_realref (cmplx),
 179 #else
 180                        real,
 181 #endif
 182                        &buffer[0], buffer_size);
 183   size += encode_float (kind,
 184 #ifdef HAVE_mpc
 185                         mpc_imagref (cmplx),
 186 #else
 187                         imaginary,
 188 #endif
 189                         &buffer[size], buffer_size - size);
 190   return size;
 191 }
 192
 193
 194 static int
 195 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
 196 {
 197   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
 198                                             logical),
 199                              buffer, buffer_size);
 200 }
 201
 202
 203 int
 204 gfc_encode_character (int kind, int length, const gfc_char_t *string,
 205                       unsigned char *buffer, size_t buffer_size)
 206 {
 207   size_t elsize = size_character (1, kind);
 208   tree type = gfc_get_char_type (kind);
 209   int i;
 210
 211   gcc_assert (buffer_size >= size_character (length, kind));
 212
 213   for (i = 0; i < length; i++)
 214     native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
 215                         elsize);
 216
 217   return length;
 218 }
 219
 220
 221 static int
 222 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
 223 {
 224   gfc_constructor *ctr;
 225   gfc_component *cmp;
 226   int ptr;
 227   tree type;
 228
 229   type = gfc_typenode_for_spec (&source->ts);
 230
 231   ctr = source->value.constructor;
 232   cmp = source->ts.derived->components;
 233   for (;ctr; ctr = ctr->next, cmp = cmp->next)
 234     {
 235       gcc_assert (cmp);
 236       if (!ctr->expr)
 237         continue;
 238       ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 239             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 240
 241       if (ctr->expr->expr_type == EXPR_NULL)
 242         memset (&buffer[ptr], 0,
 243                 int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
 244       else
 245         gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 246                                 buffer_size - ptr);
 247     }
 248
 249   return int_size_in_bytes (type);
 250 }
 251
 252
 253 /* Write a constant expression in binary form to a buffer.  */
 254 int
 255 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 256                         size_t buffer_size)
 257 {
 258   if (source == NULL)
 259     return 0;
 260
 261   if (source->expr_type == EXPR_ARRAY)
 262     return encode_array (source, buffer, buffer_size);
 263
 264   gcc_assert (source->expr_type == EXPR_CONSTANT
 265               || source->expr_type == EXPR_STRUCTURE
 266               || source->expr_type == EXPR_SUBSTRING);
 267
 268   /* If we already have a target-memory representation, we use that rather
 269      than recreating one.  */
 270   if (source->representation.string)
 271     {
 272       memcpy (buffer, source->representation.string,
 273               source->representation.length);
 274       return source->representation.length;
 275     }
 276
 277   switch (source->ts.type)
 278     {
 279     case BT_INTEGER:
 280       return encode_integer (source->ts.kind, source->value.integer, buffer,
 281                              buffer_size);
 282     case BT_REAL:
 283       return encode_float (source->ts.kind, source->value.real, buffer,
 284                            buffer_size);
 285     case BT_COMPLEX:
 286       return encode_complex (source->ts.kind,
 287 #ifdef HAVE_mpc
 288                              source->value.complex,
 289 #else
 290                              source->value.complex.r,
 291                              source->value.complex.i,
 292 #endif
 293                              buffer, buffer_size);
 294     case BT_LOGICAL:
 295       return encode_logical (source->ts.kind, source->value.logical, buffer,
 296                              buffer_size);
 297     case BT_CHARACTER:
 298       if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
 299         return gfc_encode_character (source->ts.kind,
 300                                      source->value.character.length,
 301                                      source->value.character.string,
 302                                      buffer, buffer_size);
 303       else
 304         {
 305           int start, end;
 306
 307           gcc_assert (source->expr_type == EXPR_SUBSTRING);
 308           gfc_extract_int (source->ref->u.ss.start, &start);
 309           gfc_extract_int (source->ref->u.ss.end, &end);
 310           return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
 311                                        &source->value.character.string[start-1],
 312                                        buffer, buffer_size);
 313         }
 314
 315     case BT_DERIVED:
 316       return encode_derived (source, buffer, buffer_size);
 317     default:
 318       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 319       return 0;
 320     }
 321 }
 322
 323
 324 static int
 325 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 326 {
 327   int array_size = 1;
 328   int i;
 329   int ptr = 0;
 330   gfc_constructor *head = NULL, *tail = NULL;
 331
 332   /* Calculate array size from its shape and rank.  */
 333   gcc_assert (result->rank > 0 && result->shape);
 334
 335   for (i = 0; i < result->rank; i++)
 336     array_size *= (int)mpz_get_ui (result->shape[i]);
 337
 338   /* Iterate over array elements, producing constructors.  */
 339   for (i = 0; i < array_size; i++)
 340     {
 341       if (head == NULL)
 342         head = tail = gfc_get_constructor ();
 343       else
 344         {
 345           tail->next = gfc_get_constructor ();
 346           tail = tail->next;
 347         }
 348
 349       tail->where = result->where;
 350       tail->expr = gfc_constant_result (result->ts.type,
 351                                           result->ts.kind, &result->where);
 352       tail->expr->ts = result->ts;
 353
 354       if (tail->expr->ts.type == BT_CHARACTER)
 355         tail->expr->value.character.length = result->value.character.length;
 356
 357       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 358                                         tail->expr);
 359     }
 360   result->value.constructor = head;
 361
 362   return ptr;
 363 }
 364
 365
 366 int
 367 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 368                    mpz_t integer)
 369 {
 370   mpz_init (integer);
 371   gfc_conv_tree_to_mpz (integer,
 372                         native_interpret_expr (gfc_get_int_type (kind),
 373                                                buffer, buffer_size));
 374   return size_integer (kind);
 375 }
 376
 377
 378 int
 379 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 380                      mpfr_t real)
 381 {
 382   gfc_set_model_kind (kind);
 383   mpfr_init (real);
 384   gfc_conv_tree_to_mpfr (real,
 385                          native_interpret_expr (gfc_get_real_type (kind),
 386                                                 buffer, buffer_size));
 387
 388   return size_float (kind);
 389 }
 390
 391
 392 int
 393 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 394 #ifdef HAVE_mpc
 395                        mpc_t complex
 396 #else
 397                        mpfr_t real, mpfr_t imaginary
 398 #endif
 399                        )
 400 {
 401   int size;
 402   size = gfc_interpret_float (kind, &buffer[0], buffer_size,
 403 #ifdef HAVE_mpc
 404                               mpc_realref (complex)
 405 #else
 406                               real
 407 #endif
 408                               );
 409   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
 410 #ifdef HAVE_mpc
 411                                mpc_imagref (complex)
 412 #else
 413                                imaginary
 414 #endif
 415                                );
 416   return size;
 417 }
 418
 419
 420 int
 421 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 422                    int *logical)
 423 {
 424   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 425                                   buffer_size);
 426   *logical = double_int_zero_p (tree_to_double_int (t))
 427              ? 0 : 1;
 428   return size_logical (kind);
 429 }
 430
 431
 432 int
 433 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
 434                          gfc_expr *result)
 435 {
 436   int i;
 437
 438   if (result->ts.cl && result->ts.cl->length)
 439     result->value.character.length =
 440       (int) mpz_get_ui (result->ts.cl->length->value.integer);
 441
 442   gcc_assert (buffer_size >= size_character (result->value.character.length,
 443                                              result->ts.kind));
 444   result->value.character.string =
 445     gfc_get_wide_string (result->value.character.length + 1);
 446
 447   if (result->ts.kind == gfc_default_character_kind)
 448     for (i = 0; i < result->value.character.length; i++)
 449       result->value.character.string[i] = (gfc_char_t) buffer[i];
 450   else
 451     {
 452       mpz_t integer;
 453       unsigned bytes = size_character (1, result->ts.kind);
 454       mpz_init (integer);
 455       gcc_assert (bytes <= sizeof (unsigned long));
 456
 457       for (i = 0; i < result->value.character.length; i++)
 458         {
 459           gfc_conv_tree_to_mpz (integer,
 460             native_interpret_expr (gfc_get_char_type (result->ts.kind),
 461                                    &buffer[bytes*i], buffer_size-bytes*i));
 462           result->value.character.string[i]
 463             = (gfc_char_t) mpz_get_ui (integer);
 464         }
 465
 466       mpz_clear (integer);
 467     }
 468
 469   result->value.character.string[result->value.character.length] = '\0';
 470
 471   return result->value.character.length;
 472 }
 473
 474
 475 int
 476 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 477 {
 478   gfc_component *cmp;
 479   gfc_constructor *head = NULL, *tail = NULL;
 480   int ptr;
 481   tree type;
 482
 483   /* The attributes of the derived type need to be bolted to the floor.  */
 484   result->expr_type = EXPR_STRUCTURE;
 485
 486   type = gfc_typenode_for_spec (&result->ts);
 487   cmp = result->ts.derived->components;
 488
 489   /* Run through the derived type components.  */
 490   for (;cmp; cmp = cmp->next)
 491     {
 492       if (head == NULL)
 493         head = tail = gfc_get_constructor ();
 494       else
 495         {
 496           tail->next = gfc_get_constructor ();
 497           tail = tail->next;
 498         }
 499
 500       /* The constructor points to the component.  */
 501       tail->n.component = cmp;
 502
 503       tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
 504                                         &result->where);
 505       tail->expr->ts = cmp->ts;
 506
 507       /* Copy shape, if needed.  */
 508       if (cmp->as && cmp->as->rank)
 509         {
 510           int n;
 511
 512           tail->expr->expr_type = EXPR_ARRAY;
 513           tail->expr->rank = cmp->as->rank;
 514
 515           tail->expr->shape = gfc_get_shape (tail->expr->rank);
 516           for (n = 0; n < tail->expr->rank; n++)
 517              {
 518                mpz_init_set_ui (tail->expr->shape[n], 1);
 519                mpz_add (tail->expr->shape[n], tail->expr->shape[n],
 520                         cmp->as->upper[n]->value.integer);
 521                mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
 522                         cmp->as->lower[n]->value.integer);
 523              }
 524         }
 525
 526       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 527       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 528                                  tail->expr);
 529
 530       result->value.constructor = head;
 531     }
 532
 533   return int_size_in_bytes (type);
 534 }
 535
 536
 537 /* Read a binary buffer to a constant expression.  */
 538 int
 539 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 540                            gfc_expr *result)
 541 {
 542   if (result->expr_type == EXPR_ARRAY)
 543     return interpret_array (buffer, buffer_size, result);
 544
 545   switch (result->ts.type)
 546     {
 547     case BT_INTEGER:
 548       result->representation.length =
 549         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 550                                result->value.integer);
 551       break;
 552
 553     case BT_REAL:
 554       result->representation.length =
 555         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 556                              result->value.real);
 557       break;
 558
 559     case BT_COMPLEX:
 560       result->representation.length =
 561         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 562 #ifdef HAVE_mpc
 563                                result->value.complex
 564 #else
 565                                result->value.complex.r,
 566                                result->value.complex.i
 567 #endif
 568                                );
 569       break;
 570
 571     case BT_LOGICAL:
 572       result->representation.length =
 573         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 574                                &result->value.logical);
 575       break;
 576
 577     case BT_CHARACTER:
 578       result->representation.length =
 579         gfc_interpret_character (buffer, buffer_size, result);
 580       break;
 581
 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)
 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         (char *) gfc_getmem (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 *ctr;
 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       ctr = e->value.constructor;
 636       cmp = e->ts.derived->components;
 637       for (;ctr; ctr = ctr->next, cmp = cmp->next)
 638         {
 639           gcc_assert (cmp && cmp->backend_decl);
 640           if (!ctr->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 (ctr->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 = e->value.constructor; c; c = c->next)
 692         {
 693           size_t elt_size = gfc_target_expr_size (c->expr);
 694
 695           if (c->n.offset)
 696             len = elt_size * (size_t)mpz_get_si (c->n.offset);
 697
 698           len = len + gfc_merge_initializers (ts, c->expr, &data[len],
 699                                               &chk[len], length - len);
 700         }
 701       break;
 702
 703     default:
 704       return 0;
 705     }
 706
 707   return len;
 708 }
 709
 710
 711 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
 712    When successful, no BOZ or nothing to do, true is returned.  */
 713
 714 bool
 715 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
 716 {
 717   size_t buffer_size, boz_bit_size, ts_bit_size;
 718   int index;
 719   unsigned char *buffer;
 720
 721   if (!expr->is_boz)
 722     return true;
 723
 724   gcc_assert (expr->expr_type == EXPR_CONSTANT
 725               && expr->ts.type == BT_INTEGER);
 726
 727   /* Don't convert BOZ to logical, character, derived etc.  */
 728   if (ts->type == BT_REAL)
 729     {
 730       buffer_size = size_float (ts->kind);
 731       ts_bit_size = buffer_size * 8;
 732     }
 733   else if (ts->type == BT_COMPLEX)
 734     {
 735       buffer_size = size_complex (ts->kind);
 736       ts_bit_size = buffer_size * 8 / 2;
 737     }
 738   else
 739     return true;
 740
 741   /* Convert BOZ to the smallest possible integer kind.  */
 742   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
 743
 744   if (boz_bit_size > ts_bit_size)
 745     {
 746       gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
 747                      &expr->where, (long) boz_bit_size, (long) ts_bit_size);
 748       return false;
 749     }
 750
 751   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 752     if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
 753       break;
 754
 755   expr->ts.kind = gfc_integer_kinds[index].kind;
 756   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
 757
 758   buffer = (unsigned char*)alloca (buffer_size);
 759   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
 760   mpz_clear (expr->value.integer);
 761
 762   if (ts->type == BT_REAL)
 763     {
 764       mpfr_init (expr->value.real);
 765       gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
 766     }
 767   else
 768     {
 769 #ifdef HAVE_mpc
 770       mpc_init2 (expr->value.complex, mpfr_get_default_prec());
 771 #else
 772       mpfr_init (expr->value.complex.r);
 773       mpfr_init (expr->value.complex.i);
 774 #endif
 775       gfc_interpret_complex (ts->kind, buffer, buffer_size,
 776 #ifdef HAVE_mpc
 777                              expr->value.complex
 778 #else
 779                              expr->value.complex.r, expr->value.complex.i
 780 #endif
 781                              );
 782     }
 783   expr->is_boz = 0;
 784   expr->ts.type = ts->type;
 785   expr->ts.kind = ts->kind;
 786
 787   return true;
 788 }