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