gcc/fortran/target-memory.c

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