gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   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 "gfortran.h"
  26 #include "arith.h"
  27 #include "intrinsic.h"
  28 #include "target-memory.h"
  29
  30 gfc_expr gfc_bad_expr;
  31
  32
  33 /* Note that 'simplification' is not just transforming expressions.
  34    For functions that are not simplified at compile time, range
  35    checking is done if possible.
  36
  37    The return convention is that each simplification function returns:
  38
  39      A new expression node corresponding to the simplified arguments.
  40      The original arguments are destroyed by the caller, and must not
  41      be a part of the new expression.
  42
  43      NULL pointer indicating that no simplification was possible and
  44      the original expression should remain intact.  If the
  45      simplification function sets the type and/or the function name
  46      via the pointer gfc_simple_expression, then this type is
  47      retained.
  48
  49      An expression pointer to gfc_bad_expr (a static placeholder)
  50      indicating that some error has prevented simplification.  For
  51      example, sqrt(-1.0).  The error is generated within the function
  52      and should be propagated upwards
  53
  54    By the time a simplification function gets control, it has been
  55    decided that the function call is really supposed to be the
  56    intrinsic.  No type checking is strictly necessary, since only
  57    valid types will be passed on.  On the other hand, a simplification
  58    subroutine may have to look at the type of an argument as part of
  59    its processing.
  60
  61    Array arguments are never passed to these subroutines.
  62
  63    The functions in this file don't have much comment with them, but
  64    everything is reasonably straight-forward.  The Standard, chapter 13
  65    is the best comment you'll find for this file anyway.  */
  66
  67 /* Range checks an expression node.  If all goes well, returns the
  68    node, otherwise returns &gfc_bad_expr and frees the node.  */
  69
  70 static gfc_expr *
  71 range_check (gfc_expr *result, const char *name)
  72 {
  73   if (result == NULL)
  74     return &gfc_bad_expr;
  75
  76   switch (gfc_range_check (result))
  77     {
  78       case ARITH_OK:
  79         return result;
  80
  81       case ARITH_OVERFLOW:
  82         gfc_error ("Result of %s overflows its kind at %L", name,
  83                    &result->where);
  84         break;
  85
  86       case ARITH_UNDERFLOW:
  87         gfc_error ("Result of %s underflows its kind at %L", name,
  88                    &result->where);
  89         break;
  90
  91       case ARITH_NAN:
  92         gfc_error ("Result of %s is NaN at %L", name, &result->where);
  93         break;
  94
  95       default:
  96         gfc_error ("Result of %s gives range error for its kind at %L", name,
  97                    &result->where);
  98         break;
  99     }
 100
 101   gfc_free_expr (result);
 102   return &gfc_bad_expr;
 103 }
 104
 105
 106 /* A helper function that gets an optional and possibly missing
 107    kind parameter.  Returns the kind, -1 if something went wrong.  */
 108
 109 static int
 110 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 111 {
 112   int kind;
 113
 114   if (k == NULL)
 115     return default_kind;
 116
 117   if (k->expr_type != EXPR_CONSTANT)
 118     {
 119       gfc_error ("KIND parameter of %s at %L must be an initialization "
 120                  "expression", name, &k->where);
 121       return -1;
 122     }
 123
 124   if (gfc_extract_int (k, &kind) != NULL
 125       || gfc_validate_kind (type, kind, true) < 0)
 126     {
 127       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
 128       return -1;
 129     }
 130
 131   return kind;
 132 }
 133
 134
 135 /* Helper function to get an integer constant with a kind number given
 136    by an integer constant expression.  */
 137 static gfc_expr *
 138 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
 139 {
 140   gfc_expr *res = gfc_int_expr (i);
 141   res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
 142   if (res->ts.kind == -1)
 143     return NULL;
 144   else
 145     return res;
 146 }
 147
 148
 149 /* Converts an mpz_t signed variable into an unsigned one, assuming
 150    two's complement representations and a binary width of bitsize.
 151    The conversion is a no-op unless x is negative; otherwise, it can
 152    be accomplished by masking out the high bits.  */
 153
 154 static void
 155 convert_mpz_to_unsigned (mpz_t x, int bitsize)
 156 {
 157   mpz_t mask;
 158
 159   if (mpz_sgn (x) < 0)
 160     {
 161       /* Confirm that no bits above the signed range are unset.  */
 162       gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
 163
 164       mpz_init_set_ui (mask, 1);
 165       mpz_mul_2exp (mask, mask, bitsize);
 166       mpz_sub_ui (mask, mask, 1);
 167
 168       mpz_and (x, x, mask);
 169
 170       mpz_clear (mask);
 171     }
 172   else
 173     {
 174       /* Confirm that no bits above the signed range are set.  */
 175       gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
 176     }
 177 }
 178
 179
 180 /* Converts an mpz_t unsigned variable into a signed one, assuming
 181    two's complement representations and a binary width of bitsize.
 182    If the bitsize-1 bit is set, this is taken as a sign bit and
 183    the number is converted to the corresponding negative number.  */
 184
 185 static void
 186 convert_mpz_to_signed (mpz_t x, int bitsize)
 187 {
 188   mpz_t mask;
 189
 190   /* Confirm that no bits above the unsigned range are set.  */
 191   gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
 192
 193   if (mpz_tstbit (x, bitsize - 1) == 1)
 194     {
 195       mpz_init_set_ui (mask, 1);
 196       mpz_mul_2exp (mask, mask, bitsize);
 197       mpz_sub_ui (mask, mask, 1);
 198
 199       /* We negate the number by hand, zeroing the high bits, that is
 200          make it the corresponding positive number, and then have it
 201          negated by GMP, giving the correct representation of the
 202          negative number.  */
 203       mpz_com (x, x);
 204       mpz_add_ui (x, x, 1);
 205       mpz_and (x, x, mask);
 206
 207       mpz_neg (x, x);
 208
 209       mpz_clear (mask);
 210     }
 211 }
 212
 213
 214 /********************** Simplification functions *****************************/
 215
 216 gfc_expr *
 217 gfc_simplify_abs (gfc_expr *e)
 218 {
 219   gfc_expr *result;
 220
 221   if (e->expr_type != EXPR_CONSTANT)
 222     return NULL;
 223
 224   switch (e->ts.type)
 225     {
 226     case BT_INTEGER:
 227       result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
 228
 229       mpz_abs (result->value.integer, e->value.integer);
 230
 231       result = range_check (result, "IABS");
 232       break;
 233
 234     case BT_REAL:
 235       result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 236
 237       mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
 238
 239       result = range_check (result, "ABS");
 240       break;
 241
 242     case BT_COMPLEX:
 243       result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 244
 245       gfc_set_model_kind (e->ts.kind);
 246
 247       mpfr_hypot (result->value.real, e->value.complex.r,
 248                   e->value.complex.i, GFC_RND_MODE);
 249       result = range_check (result, "CABS");
 250       break;
 251
 252     default:
 253       gfc_internal_error ("gfc_simplify_abs(): Bad type");
 254     }
 255
 256   return result;
 257 }
 258
 259 /* We use the processor's collating sequence, because all
 260    systems that gfortran currently works on are ASCII.  */
 261
 262 gfc_expr *
 263 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
 264 {
 265   gfc_expr *result;
 266   int c, kind;
 267   const char *ch;
 268
 269   if (e->expr_type != EXPR_CONSTANT)
 270     return NULL;
 271
 272   kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
 273   if (kind == -1)
 274     return &gfc_bad_expr;
 275
 276   ch = gfc_extract_int (e, &c);
 277
 278   if (ch != NULL)
 279     gfc_internal_error ("gfc_simplify_achar: %s", ch);
 280
 281   if (gfc_option.warn_surprising && (c < 0 || c > 127))
 282     gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
 283                  &e->where);
 284
 285   result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
 286
 287   result->value.character.string = gfc_getmem (2);
 288
 289   result->value.character.length = 1;
 290   result->value.character.string[0] = c;
 291   result->value.character.string[1] = '\0';     /* For debugger */
 292   return result;
 293 }
 294
 295
 296 gfc_expr *
 297 gfc_simplify_acos (gfc_expr *x)
 298 {
 299   gfc_expr *result;
 300
 301   if (x->expr_type != EXPR_CONSTANT)
 302     return NULL;
 303
 304   if (mpfr_cmp_si (x->value.real, 1) > 0
 305       || mpfr_cmp_si (x->value.real, -1) < 0)
 306     {
 307       gfc_error ("Argument of ACOS at %L must be between -1 and 1",
 308                  &x->where);
 309       return &gfc_bad_expr;
 310     }
 311
 312   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 313
 314   mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 315
 316   return range_check (result, "ACOS");
 317 }
 318
 319 gfc_expr *
 320 gfc_simplify_acosh (gfc_expr *x)
 321 {
 322   gfc_expr *result;
 323
 324   if (x->expr_type != EXPR_CONSTANT)
 325     return NULL;
 326
 327   if (mpfr_cmp_si (x->value.real, 1) < 0)
 328     {
 329       gfc_error ("Argument of ACOSH at %L must not be less than 1",
 330                  &x->where);
 331       return &gfc_bad_expr;
 332     }
 333
 334   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 335
 336   mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
 337
 338   return range_check (result, "ACOSH");
 339 }
 340
 341 gfc_expr *
 342 gfc_simplify_adjustl (gfc_expr *e)
 343 {
 344   gfc_expr *result;
 345   int count, i, len;
 346   char ch;
 347
 348   if (e->expr_type != EXPR_CONSTANT)
 349     return NULL;
 350
 351   len = e->value.character.length;
 352
 353   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 354
 355   result->value.character.length = len;
 356   result->value.character.string = gfc_getmem (len + 1);
 357
 358   for (count = 0, i = 0; i < len; ++i)
 359     {
 360       ch = e->value.character.string[i];
 361       if (ch != ' ')
 362         break;
 363       ++count;
 364     }
 365
 366   for (i = 0; i < len - count; ++i)
 367     result->value.character.string[i] = e->value.character.string[count + i];
 368
 369   for (i = len - count; i < len; ++i)
 370     result->value.character.string[i] = ' ';
 371
 372   result->value.character.string[len] = '\0';   /* For debugger */
 373
 374   return result;
 375 }
 376
 377
 378 gfc_expr *
 379 gfc_simplify_adjustr (gfc_expr *e)
 380 {
 381   gfc_expr *result;
 382   int count, i, len;
 383   char ch;
 384
 385   if (e->expr_type != EXPR_CONSTANT)
 386     return NULL;
 387
 388   len = e->value.character.length;
 389
 390   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 391
 392   result->value.character.length = len;
 393   result->value.character.string = gfc_getmem (len + 1);
 394
 395   for (count = 0, i = len - 1; i >= 0; --i)
 396     {
 397       ch = e->value.character.string[i];
 398       if (ch != ' ')
 399         break;
 400       ++count;
 401     }
 402
 403   for (i = 0; i < count; ++i)
 404     result->value.character.string[i] = ' ';
 405
 406   for (i = count; i < len; ++i)
 407     result->value.character.string[i] = e->value.character.string[i - count];
 408
 409   result->value.character.string[len] = '\0';   /* For debugger */
 410
 411   return result;
 412 }
 413
 414
 415 gfc_expr *
 416 gfc_simplify_aimag (gfc_expr *e)
 417 {
 418   gfc_expr *result;
 419
 420   if (e->expr_type != EXPR_CONSTANT)
 421     return NULL;
 422
 423   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 424   mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
 425
 426   return range_check (result, "AIMAG");
 427 }
 428
 429
 430 gfc_expr *
 431 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 432 {
 433   gfc_expr *rtrunc, *result;
 434   int kind;
 435
 436   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
 437   if (kind == -1)
 438     return &gfc_bad_expr;
 439
 440   if (e->expr_type != EXPR_CONSTANT)
 441     return NULL;
 442
 443   rtrunc = gfc_copy_expr (e);
 444
 445   mpfr_trunc (rtrunc->value.real, e->value.real);
 446
 447   result = gfc_real2real (rtrunc, kind);
 448   gfc_free_expr (rtrunc);
 449
 450   return range_check (result, "AINT");
 451 }
 452
 453
 454 gfc_expr *
 455 gfc_simplify_dint (gfc_expr *e)
 456 {
 457   gfc_expr *rtrunc, *result;
 458
 459   if (e->expr_type != EXPR_CONSTANT)
 460     return NULL;
 461
 462   rtrunc = gfc_copy_expr (e);
 463
 464   mpfr_trunc (rtrunc->value.real, e->value.real);
 465
 466   result = gfc_real2real (rtrunc, gfc_default_double_kind);
 467   gfc_free_expr (rtrunc);
 468
 469   return range_check (result, "DINT");
 470 }
 471
 472
 473 gfc_expr *
 474 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
 475 {
 476   gfc_expr *result;
 477   int kind;
 478
 479   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
 480   if (kind == -1)
 481     return &gfc_bad_expr;
 482
 483   if (e->expr_type != EXPR_CONSTANT)
 484     return NULL;
 485
 486   result = gfc_constant_result (e->ts.type, kind, &e->where);
 487
 488   mpfr_round (result->value.real, e->value.real);
 489
 490   return range_check (result, "ANINT");
 491 }
 492
 493
 494 gfc_expr *
 495 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 496 {
 497   gfc_expr *result;
 498   int kind;
 499
 500   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 501     return NULL;
 502
 503   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
 504   if (x->ts.type == BT_INTEGER)
 505     {
 506       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
 507       mpz_and (result->value.integer, x->value.integer, y->value.integer);
 508     }
 509   else /* BT_LOGICAL */
 510     {
 511       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
 512       result->value.logical = x->value.logical && y->value.logical;
 513     }
 514
 515   return range_check (result, "AND");
 516 }
 517
 518
 519 gfc_expr *
 520 gfc_simplify_dnint (gfc_expr *e)
 521 {
 522   gfc_expr *result;
 523
 524   if (e->expr_type != EXPR_CONSTANT)
 525     return NULL;
 526
 527   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
 528
 529   mpfr_round (result->value.real, e->value.real);
 530
 531   return range_check (result, "DNINT");
 532 }
 533
 534
 535 gfc_expr *
 536 gfc_simplify_asin (gfc_expr *x)
 537 {
 538   gfc_expr *result;
 539
 540   if (x->expr_type != EXPR_CONSTANT)
 541     return NULL;
 542
 543   if (mpfr_cmp_si (x->value.real, 1) > 0
 544       || mpfr_cmp_si (x->value.real, -1) < 0)
 545     {
 546       gfc_error ("Argument of ASIN at %L must be between -1 and 1",
 547                  &x->where);
 548       return &gfc_bad_expr;
 549     }
 550
 551   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 552
 553   mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
 554
 555   return range_check (result, "ASIN");
 556 }
 557
 558
 559 gfc_expr *
 560 gfc_simplify_asinh (gfc_expr *x)
 561 {
 562   gfc_expr *result;
 563
 564   if (x->expr_type != EXPR_CONSTANT)
 565     return NULL;
 566
 567   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 568
 569   mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
 570
 571   return range_check (result, "ASINH");
 572 }
 573
 574
 575 gfc_expr *
 576 gfc_simplify_atan (gfc_expr *x)
 577 {
 578   gfc_expr *result;
 579
 580   if (x->expr_type != EXPR_CONSTANT)
 581     return NULL;
 582
 583   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 584
 585   mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
 586
 587   return range_check (result, "ATAN");
 588 }
 589
 590
 591 gfc_expr *
 592 gfc_simplify_atanh (gfc_expr *x)
 593 {
 594   gfc_expr *result;
 595
 596   if (x->expr_type != EXPR_CONSTANT)
 597     return NULL;
 598
 599   if (mpfr_cmp_si (x->value.real, 1) >= 0
 600       || mpfr_cmp_si (x->value.real, -1) <= 0)
 601     {
 602       gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
 603                  &x->where);
 604       return &gfc_bad_expr;
 605     }
 606
 607   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 608
 609   mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
 610
 611   return range_check (result, "ATANH");
 612 }
 613
 614
 615 gfc_expr *
 616 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
 617 {
 618   gfc_expr *result;
 619
 620   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 621     return NULL;
 622
 623   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 624
 625   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
 626     {
 627       gfc_error ("If first argument of ATAN2 %L is zero, then the "
 628                  "second argument must not be zero", &x->where);
 629       gfc_free_expr (result);
 630       return &gfc_bad_expr;
 631     }
 632
 633   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 634
 635   return range_check (result, "ATAN2");
 636 }
 637
 638
 639 gfc_expr *
 640 gfc_simplify_bit_size (gfc_expr *e)
 641 {
 642   gfc_expr *result;
 643   int i;
 644
 645   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 646   result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
 647   mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
 648
 649   return result;
 650 }
 651
 652
 653 gfc_expr *
 654 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
 655 {
 656   int b;
 657
 658   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
 659     return NULL;
 660
 661   if (gfc_extract_int (bit, &b) != NULL || b < 0)
 662     return gfc_logical_expr (0, &e->where);
 663
 664   return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
 665 }
 666
 667
 668 gfc_expr *
 669 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 670 {
 671   gfc_expr *ceil, *result;
 672   int kind;
 673
 674   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
 675   if (kind == -1)
 676     return &gfc_bad_expr;
 677
 678   if (e->expr_type != EXPR_CONSTANT)
 679     return NULL;
 680
 681   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
 682
 683   ceil = gfc_copy_expr (e);
 684
 685   mpfr_ceil (ceil->value.real, e->value.real);
 686   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
 687
 688   gfc_free_expr (ceil);
 689
 690   return range_check (result, "CEILING");
 691 }
 692
 693
 694 gfc_expr *
 695 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 696 {
 697   gfc_expr *result;
 698   int c, kind;
 699   const char *ch;
 700
 701   kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
 702   if (kind == -1)
 703     return &gfc_bad_expr;
 704
 705   if (e->expr_type != EXPR_CONSTANT)
 706     return NULL;
 707
 708   ch = gfc_extract_int (e, &c);
 709
 710   if (ch != NULL)
 711     gfc_internal_error ("gfc_simplify_char: %s", ch);
 712
 713   if (c < 0 || c > UCHAR_MAX)
 714     gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
 715                &e->where);
 716
 717   result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
 718
 719   result->value.character.length = 1;
 720   result->value.character.string = gfc_getmem (2);
 721
 722   result->value.character.string[0] = c;
 723   result->value.character.string[1] = '\0';     /* For debugger */
 724
 725   return result;
 726 }
 727
 728
 729 /* Common subroutine for simplifying CMPLX and DCMPLX.  */
 730
 731 static gfc_expr *
 732 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
 733 {
 734   gfc_expr *result;
 735
 736   result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
 737
 738   mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
 739
 740   switch (x->ts.type)
 741     {
 742     case BT_INTEGER:
 743       if (!x->is_boz)
 744         mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
 745       break;
 746
 747     case BT_REAL:
 748       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 749       break;
 750
 751     case BT_COMPLEX:
 752       mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
 753       mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
 754       break;
 755
 756     default:
 757       gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
 758     }
 759
 760   if (y != NULL)
 761     {
 762       switch (y->ts.type)
 763         {
 764         case BT_INTEGER:
 765           if (!y->is_boz)
 766             mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
 767           break;
 768
 769         case BT_REAL:
 770           mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 771           break;
 772
 773         default:
 774           gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
 775         }
 776     }
 777
 778   /* Handle BOZ.  */
 779   if (x->is_boz)
 780     {
 781       gfc_typespec ts;
 782       gfc_clear_ts (&ts);
 783       ts.kind = result->ts.kind;
 784       ts.type = BT_REAL;
 785       if (!gfc_convert_boz (x, &ts))
 786         return &gfc_bad_expr;
 787       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 788     }
 789
 790   if (y && y->is_boz)
 791     {
 792       gfc_typespec ts;
 793       gfc_clear_ts (&ts);
 794       ts.kind = result->ts.kind;
 795       ts.type = BT_REAL;
 796       if (!gfc_convert_boz (y, &ts))
 797         return &gfc_bad_expr;
 798       mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 799     }
 800
 801   return range_check (result, name);
 802 }
 803
 804
 805 gfc_expr *
 806 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
 807 {
 808   int kind;
 809
 810   if (x->expr_type != EXPR_CONSTANT
 811       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 812     return NULL;
 813
 814   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
 815   if (kind == -1)
 816     return &gfc_bad_expr;
 817
 818   return simplify_cmplx ("CMPLX", x, y, kind);
 819 }
 820
 821
 822 gfc_expr *
 823 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
 824 {
 825   int kind;
 826
 827   if (x->expr_type != EXPR_CONSTANT
 828       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 829     return NULL;
 830
 831   if (x->ts.type == BT_INTEGER)
 832     {
 833       if (y->ts.type == BT_INTEGER)
 834         kind = gfc_default_real_kind;
 835       else
 836         kind = y->ts.kind;
 837     }
 838   else
 839     {
 840       if (y->ts.type == BT_REAL)
 841         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 842       else
 843         kind = x->ts.kind;
 844     }
 845
 846   return simplify_cmplx ("COMPLEX", x, y, kind);
 847 }
 848
 849
 850 gfc_expr *
 851 gfc_simplify_conjg (gfc_expr *e)
 852 {
 853   gfc_expr *result;
 854
 855   if (e->expr_type != EXPR_CONSTANT)
 856     return NULL;
 857
 858   result = gfc_copy_expr (e);
 859   mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
 860
 861   return range_check (result, "CONJG");
 862 }
 863
 864
 865 gfc_expr *
 866 gfc_simplify_cos (gfc_expr *x)
 867 {
 868   gfc_expr *result;
 869   mpfr_t xp, xq;
 870
 871   if (x->expr_type != EXPR_CONSTANT)
 872     return NULL;
 873
 874   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 875
 876   switch (x->ts.type)
 877     {
 878     case BT_REAL:
 879       mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
 880       break;
 881     case BT_COMPLEX:
 882       gfc_set_model_kind (x->ts.kind);
 883       mpfr_init (xp);
 884       mpfr_init (xq);
 885
 886       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
 887       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
 888       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
 889
 890       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
 891       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
 892       mpfr_mul (xp, xp, xq, GFC_RND_MODE);
 893       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
 894
 895       mpfr_clear (xp);
 896       mpfr_clear (xq);
 897       break;
 898     default:
 899       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
 900     }
 901
 902   return range_check (result, "COS");
 903
 904 }
 905
 906
 907 gfc_expr *
 908 gfc_simplify_cosh (gfc_expr *x)
 909 {
 910   gfc_expr *result;
 911
 912   if (x->expr_type != EXPR_CONSTANT)
 913     return NULL;
 914
 915   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 916
 917   mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
 918
 919   return range_check (result, "COSH");
 920 }
 921
 922
 923 gfc_expr *
 924 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
 925 {
 926
 927   if (x->expr_type != EXPR_CONSTANT
 928       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 929     return NULL;
 930
 931   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
 932 }
 933
 934
 935 gfc_expr *
 936 gfc_simplify_dble (gfc_expr *e)
 937 {
 938   gfc_expr *result;
 939
 940   if (e->expr_type != EXPR_CONSTANT)
 941     return NULL;
 942
 943   switch (e->ts.type)
 944     {
 945     case BT_INTEGER:
 946       if (!e->is_boz)
 947         result = gfc_int2real (e, gfc_default_double_kind);
 948       break;
 949
 950     case BT_REAL:
 951       result = gfc_real2real (e, gfc_default_double_kind);
 952       break;
 953
 954     case BT_COMPLEX:
 955       result = gfc_complex2real (e, gfc_default_double_kind);
 956       break;
 957
 958     default:
 959       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
 960     }
 961
 962   if (e->ts.type == BT_INTEGER && e->is_boz)
 963     {
 964       gfc_typespec ts;
 965       gfc_clear_ts (&ts);
 966       ts.type = BT_REAL;
 967       ts.kind = gfc_default_double_kind;
 968       result = gfc_copy_expr (e);
 969       if (!gfc_convert_boz (result, &ts))
 970         return &gfc_bad_expr;
 971     }
 972
 973   return range_check (result, "DBLE");
 974 }
 975
 976
 977 gfc_expr *
 978 gfc_simplify_digits (gfc_expr *x)
 979 {
 980   int i, digits;
 981
 982   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
 983   switch (x->ts.type)
 984     {
 985     case BT_INTEGER:
 986       digits = gfc_integer_kinds[i].digits;
 987       break;
 988
 989     case BT_REAL:
 990     case BT_COMPLEX:
 991       digits = gfc_real_kinds[i].digits;
 992       break;
 993
 994     default:
 995       gcc_unreachable ();
 996     }
 997
 998   return gfc_int_expr (digits);
 999 }
1000
1001
1002 gfc_expr *
1003 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1004 {
1005   gfc_expr *result;
1006   int kind;
1007
1008   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1009     return NULL;
1010
1011   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1012   result = gfc_constant_result (x->ts.type, kind, &x->where);
1013
1014   switch (x->ts.type)
1015     {
1016     case BT_INTEGER:
1017       if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1018         mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1019       else
1020         mpz_set_ui (result->value.integer, 0);
1021
1022       break;
1023
1024     case BT_REAL:
1025       if (mpfr_cmp (x->value.real, y->value.real) > 0)
1026         mpfr_sub (result->value.real, x->value.real, y->value.real,
1027                   GFC_RND_MODE);
1028       else
1029         mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1030
1031       break;
1032
1033     default:
1034       gfc_internal_error ("gfc_simplify_dim(): Bad type");
1035     }
1036
1037   return range_check (result, "DIM");
1038 }
1039
1040
1041 gfc_expr *
1042 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1043 {
1044   gfc_expr *a1, *a2, *result;
1045
1046   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1047     return NULL;
1048
1049   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1050
1051   a1 = gfc_real2real (x, gfc_default_double_kind);
1052   a2 = gfc_real2real (y, gfc_default_double_kind);
1053
1054   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1055
1056   gfc_free_expr (a1);
1057   gfc_free_expr (a2);
1058
1059   return range_check (result, "DPROD");
1060 }
1061
1062
1063 gfc_expr *
1064 gfc_simplify_erf (gfc_expr *x)
1065 {
1066   gfc_expr *result;
1067
1068   if (x->expr_type != EXPR_CONSTANT)
1069     return NULL;
1070
1071   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1072
1073   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1074
1075   return range_check (result, "ERF");
1076 }
1077
1078
1079 gfc_expr *
1080 gfc_simplify_erfc (gfc_expr *x)
1081 {
1082   gfc_expr *result;
1083
1084   if (x->expr_type != EXPR_CONSTANT)
1085     return NULL;
1086
1087   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1088
1089   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1090
1091   return range_check (result, "ERFC");
1092 }
1093
1094
1095 gfc_expr *
1096 gfc_simplify_epsilon (gfc_expr *e)
1097 {
1098   gfc_expr *result;
1099   int i;
1100
1101   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1102
1103   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1104
1105   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1106
1107   return range_check (result, "EPSILON");
1108 }
1109
1110
1111 gfc_expr *
1112 gfc_simplify_exp (gfc_expr *x)
1113 {
1114   gfc_expr *result;
1115   mpfr_t xp, xq;
1116
1117   if (x->expr_type != EXPR_CONSTANT)
1118     return NULL;
1119
1120   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1121
1122   switch (x->ts.type)
1123     {
1124     case BT_REAL:
1125       mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1126       break;
1127
1128     case BT_COMPLEX:
1129       gfc_set_model_kind (x->ts.kind);
1130       mpfr_init (xp);
1131       mpfr_init (xq);
1132       mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1133       mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1134       mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1135       mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1136       mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1137       mpfr_clear (xp);
1138       mpfr_clear (xq);
1139       break;
1140
1141     default:
1142       gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1143     }
1144
1145   return range_check (result, "EXP");
1146 }
1147
1148 gfc_expr *
1149 gfc_simplify_exponent (gfc_expr *x)
1150 {
1151   int i;
1152   gfc_expr *result;
1153
1154   if (x->expr_type != EXPR_CONSTANT)
1155     return NULL;
1156
1157   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1158                                 &x->where);
1159
1160   gfc_set_model (x->value.real);
1161
1162   if (mpfr_sgn (x->value.real) == 0)
1163     {
1164       mpz_set_ui (result->value.integer, 0);
1165       return result;
1166     }
1167
1168   i = (int) mpfr_get_exp (x->value.real);
1169   mpz_set_si (result->value.integer, i);
1170
1171   return range_check (result, "EXPONENT");
1172 }
1173
1174
1175 gfc_expr *
1176 gfc_simplify_float (gfc_expr *a)
1177 {
1178   gfc_expr *result;
1179
1180   if (a->expr_type != EXPR_CONSTANT)
1181     return NULL;
1182
1183   if (a->is_boz)
1184     {
1185       gfc_typespec ts;
1186       gfc_clear_ts (&ts);
1187
1188       ts.type = BT_REAL;
1189       ts.kind = gfc_default_real_kind;
1190
1191       result = gfc_copy_expr (a);
1192       if (!gfc_convert_boz (result, &ts))
1193         return &gfc_bad_expr;
1194     }
1195   else
1196     result = gfc_int2real (a, gfc_default_real_kind);
1197   return range_check (result, "FLOAT");
1198 }
1199
1200
1201 gfc_expr *
1202 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1203 {
1204   gfc_expr *result;
1205   mpfr_t floor;
1206   int kind;
1207
1208   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1209   if (kind == -1)
1210     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1211
1212   if (e->expr_type != EXPR_CONSTANT)
1213     return NULL;
1214
1215   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1216
1217   gfc_set_model_kind (kind);
1218   mpfr_init (floor);
1219   mpfr_floor (floor, e->value.real);
1220
1221   gfc_mpfr_to_mpz (result->value.integer, floor);
1222
1223   mpfr_clear (floor);
1224
1225   return range_check (result, "FLOOR");
1226 }
1227
1228
1229 gfc_expr *
1230 gfc_simplify_fraction (gfc_expr *x)
1231 {
1232   gfc_expr *result;
1233   mpfr_t absv, exp, pow2;
1234
1235   if (x->expr_type != EXPR_CONSTANT)
1236     return NULL;
1237
1238   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1239
1240   gfc_set_model_kind (x->ts.kind);
1241
1242   if (mpfr_sgn (x->value.real) == 0)
1243     {
1244       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1245       return result;
1246     }
1247
1248   mpfr_init (exp);
1249   mpfr_init (absv);
1250   mpfr_init (pow2);
1251
1252   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1253   mpfr_log2 (exp, absv, GFC_RND_MODE);
1254
1255   mpfr_trunc (exp, exp);
1256   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1257
1258   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1259
1260   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1261
1262   mpfr_clear (exp);
1263   mpfr_clear (absv);
1264   mpfr_clear (pow2);
1265
1266   return range_check (result, "FRACTION");
1267 }
1268
1269
1270 gfc_expr *
1271 gfc_simplify_gamma (gfc_expr *x)
1272 {
1273   gfc_expr *result;
1274
1275   if (x->expr_type != EXPR_CONSTANT)
1276     return NULL;
1277
1278   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1279
1280   gfc_set_model_kind (x->ts.kind);
1281
1282   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1283
1284   return range_check (result, "GAMMA");
1285 }
1286
1287
1288 gfc_expr *
1289 gfc_simplify_huge (gfc_expr *e)
1290 {
1291   gfc_expr *result;
1292   int i;
1293
1294   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1295
1296   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1297
1298   switch (e->ts.type)
1299     {
1300     case BT_INTEGER:
1301       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1302       break;
1303
1304     case BT_REAL:
1305       mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1306       break;
1307
1308     default:
1309       gcc_unreachable ();
1310     }
1311
1312   return result;
1313 }
1314
1315
1316 gfc_expr *
1317 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1318 {
1319   gfc_expr *result;
1320
1321   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1322     return NULL;
1323
1324   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1325   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1326   return range_check (result, "HYPOT");
1327 }
1328
1329
1330 /* We use the processor's collating sequence, because all
1331    systems that gfortran currently works on are ASCII.  */
1332
1333 gfc_expr *
1334 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1335 {
1336   gfc_expr *result;
1337   int index;
1338
1339   if (e->expr_type != EXPR_CONSTANT)
1340     return NULL;
1341
1342   if (e->value.character.length != 1)
1343     {
1344       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1345       return &gfc_bad_expr;
1346     }
1347
1348   index = (unsigned char) e->value.character.string[0];
1349
1350   if (gfc_option.warn_surprising && index > 127)
1351     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1352                  &e->where);
1353
1354   if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1355     return &gfc_bad_expr;
1356
1357   result->where = e->where;
1358
1359   return range_check (result, "IACHAR");
1360 }
1361
1362
1363 gfc_expr *
1364 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1365 {
1366   gfc_expr *result;
1367
1368   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1369     return NULL;
1370
1371   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1372
1373   mpz_and (result->value.integer, x->value.integer, y->value.integer);
1374
1375   return range_check (result, "IAND");
1376 }
1377
1378
1379 gfc_expr *
1380 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1381 {
1382   gfc_expr *result;
1383   int k, pos;
1384
1385   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1386     return NULL;
1387
1388   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1389     {
1390       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1391       return &gfc_bad_expr;
1392     }
1393
1394   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1395
1396   if (pos >= gfc_integer_kinds[k].bit_size)
1397     {
1398       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1399                  &y->where);
1400       return &gfc_bad_expr;
1401     }
1402
1403   result = gfc_copy_expr (x);
1404
1405   convert_mpz_to_unsigned (result->value.integer,
1406                            gfc_integer_kinds[k].bit_size);
1407
1408   mpz_clrbit (result->value.integer, pos);
1409
1410   convert_mpz_to_signed (result->value.integer,
1411                          gfc_integer_kinds[k].bit_size);
1412
1413   return result;
1414 }
1415
1416
1417 gfc_expr *
1418 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1419 {
1420   gfc_expr *result;
1421   int pos, len;
1422   int i, k, bitsize;
1423   int *bits;
1424
1425   if (x->expr_type != EXPR_CONSTANT
1426       || y->expr_type != EXPR_CONSTANT
1427       || z->expr_type != EXPR_CONSTANT)
1428     return NULL;
1429
1430   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1431     {
1432       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1433       return &gfc_bad_expr;
1434     }
1435
1436   if (gfc_extract_int (z, &len) != NULL || len < 0)
1437     {
1438       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1439       return &gfc_bad_expr;
1440     }
1441
1442   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1443
1444   bitsize = gfc_integer_kinds[k].bit_size;
1445
1446   if (pos + len > bitsize)
1447     {
1448       gfc_error ("Sum of second and third arguments of IBITS exceeds "
1449                  "bit size at %L", &y->where);
1450       return &gfc_bad_expr;
1451     }
1452
1453   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1454   convert_mpz_to_unsigned (result->value.integer,
1455                            gfc_integer_kinds[k].bit_size);
1456
1457   bits = gfc_getmem (bitsize * sizeof (int));
1458
1459   for (i = 0; i < bitsize; i++)
1460     bits[i] = 0;
1461
1462   for (i = 0; i < len; i++)
1463     bits[i] = mpz_tstbit (x->value.integer, i + pos);
1464
1465   for (i = 0; i < bitsize; i++)
1466     {
1467       if (bits[i] == 0)
1468         mpz_clrbit (result->value.integer, i);
1469       else if (bits[i] == 1)
1470         mpz_setbit (result->value.integer, i);
1471       else
1472         gfc_internal_error ("IBITS: Bad bit");
1473     }
1474
1475   gfc_free (bits);
1476
1477   convert_mpz_to_signed (result->value.integer,
1478                          gfc_integer_kinds[k].bit_size);
1479
1480   return result;
1481 }
1482
1483
1484 gfc_expr *
1485 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1486 {
1487   gfc_expr *result;
1488   int k, pos;
1489
1490   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1491     return NULL;
1492
1493   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1494     {
1495       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1496       return &gfc_bad_expr;
1497     }
1498
1499   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1500
1501   if (pos >= gfc_integer_kinds[k].bit_size)
1502     {
1503       gfc_error ("Second argument of IBSET exceeds bit size at %L",
1504                  &y->where);
1505       return &gfc_bad_expr;
1506     }
1507
1508   result = gfc_copy_expr (x);
1509
1510   convert_mpz_to_unsigned (result->value.integer,
1511                            gfc_integer_kinds[k].bit_size);
1512
1513   mpz_setbit (result->value.integer, pos);
1514
1515   convert_mpz_to_signed (result->value.integer,
1516                          gfc_integer_kinds[k].bit_size);
1517
1518   return result;
1519 }
1520
1521
1522 gfc_expr *
1523 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1524 {
1525   gfc_expr *result;
1526   int index;
1527
1528   if (e->expr_type != EXPR_CONSTANT)
1529     return NULL;
1530
1531   if (e->value.character.length != 1)
1532     {
1533       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1534       return &gfc_bad_expr;
1535     }
1536
1537   index = (unsigned char) e->value.character.string[0];
1538
1539   if (index < 0 || index > UCHAR_MAX)
1540     gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1541
1542   if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1543     return &gfc_bad_expr;
1544
1545   result->where = e->where;
1546   return range_check (result, "ICHAR");
1547 }
1548
1549
1550 gfc_expr *
1551 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1552 {
1553   gfc_expr *result;
1554
1555   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1556     return NULL;
1557
1558   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1559
1560   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1561
1562   return range_check (result, "IEOR");
1563 }
1564
1565
1566 gfc_expr *
1567 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1568 {
1569   gfc_expr *result;
1570   int back, len, lensub;
1571   int i, j, k, count, index = 0, start;
1572
1573   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1574     return NULL;
1575
1576   if (b != NULL && b->value.logical != 0)
1577     back = 1;
1578   else
1579     back = 0;
1580
1581   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1582   if (k == -1)
1583     return &gfc_bad_expr;
1584
1585   result = gfc_constant_result (BT_INTEGER, k, &x->where);
1586
1587   len = x->value.character.length;
1588   lensub = y->value.character.length;
1589
1590   if (len < lensub)
1591     {
1592       mpz_set_si (result->value.integer, 0);
1593       return result;
1594     }
1595
1596   if (back == 0)
1597     {
1598       if (lensub == 0)
1599         {
1600           mpz_set_si (result->value.integer, 1);
1601           return result;
1602         }
1603       else if (lensub == 1)
1604         {
1605           for (i = 0; i < len; i++)
1606             {
1607               for (j = 0; j < lensub; j++)
1608                 {
1609                   if (y->value.character.string[j]
1610                       == x->value.character.string[i])
1611                     {
1612                       index = i + 1;
1613                       goto done;
1614                     }
1615                 }
1616             }
1617         }
1618       else
1619         {
1620           for (i = 0; i < len; i++)
1621             {
1622               for (j = 0; j < lensub; j++)
1623                 {
1624                   if (y->value.character.string[j]
1625                       == x->value.character.string[i])
1626                     {
1627                       start = i;
1628                       count = 0;
1629
1630                       for (k = 0; k < lensub; k++)
1631                         {
1632                           if (y->value.character.string[k]
1633                               == x->value.character.string[k + start])
1634                             count++;
1635                         }
1636
1637                       if (count == lensub)
1638                         {
1639                           index = start + 1;
1640                           goto done;
1641                         }
1642                     }
1643                 }
1644             }
1645         }
1646
1647     }
1648   else
1649     {
1650       if (lensub == 0)
1651         {
1652           mpz_set_si (result->value.integer, len + 1);
1653           return result;
1654         }
1655       else if (lensub == 1)
1656         {
1657           for (i = 0; i < len; i++)
1658             {
1659               for (j = 0; j < lensub; j++)
1660                 {
1661                   if (y->value.character.string[j]
1662                       == x->value.character.string[len - i])
1663                     {
1664                       index = len - i + 1;
1665                       goto done;
1666                     }
1667                 }
1668             }
1669         }
1670       else
1671         {
1672           for (i = 0; i < len; i++)
1673             {
1674               for (j = 0; j < lensub; j++)
1675                 {
1676                   if (y->value.character.string[j]
1677                       == x->value.character.string[len - i])
1678                     {
1679                       start = len - i;
1680                       if (start <= len - lensub)
1681                         {
1682                           count = 0;
1683                           for (k = 0; k < lensub; k++)
1684                             if (y->value.character.string[k]
1685                                 == x->value.character.string[k + start])
1686                               count++;
1687
1688                           if (count == lensub)
1689                             {
1690                               index = start + 1;
1691                               goto done;
1692                             }
1693                         }
1694                       else
1695                         {
1696                           continue;
1697                         }
1698                     }
1699                 }
1700             }
1701         }
1702     }
1703
1704 done:
1705   mpz_set_si (result->value.integer, index);
1706   return range_check (result, "INDEX");
1707 }
1708
1709
1710 gfc_expr *
1711 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1712 {
1713   gfc_expr *rpart, *rtrunc, *result;
1714   int kind;
1715
1716   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1717   if (kind == -1)
1718     return &gfc_bad_expr;
1719
1720   if (e->expr_type != EXPR_CONSTANT)
1721     return NULL;
1722
1723   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1724
1725   switch (e->ts.type)
1726     {
1727     case BT_INTEGER:
1728       mpz_set (result->value.integer, e->value.integer);
1729       break;
1730
1731     case BT_REAL:
1732       rtrunc = gfc_copy_expr (e);
1733       mpfr_trunc (rtrunc->value.real, e->value.real);
1734       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1735       gfc_free_expr (rtrunc);
1736       break;
1737
1738     case BT_COMPLEX:
1739       rpart = gfc_complex2real (e, kind);
1740       rtrunc = gfc_copy_expr (rpart);
1741       mpfr_trunc (rtrunc->value.real, rpart->value.real);
1742       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1743       gfc_free_expr (rpart);
1744       gfc_free_expr (rtrunc);
1745       break;
1746
1747     default:
1748       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1749       gfc_free_expr (result);
1750       return &gfc_bad_expr;
1751     }
1752
1753   return range_check (result, "INT");
1754 }
1755
1756
1757 static gfc_expr *
1758 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1759 {
1760   gfc_expr *rpart, *rtrunc, *result;
1761
1762   if (e->expr_type != EXPR_CONSTANT)
1763     return NULL;
1764
1765   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1766
1767   switch (e->ts.type)
1768     {
1769     case BT_INTEGER:
1770       mpz_set (result->value.integer, e->value.integer);
1771       break;
1772
1773     case BT_REAL:
1774       rtrunc = gfc_copy_expr (e);
1775       mpfr_trunc (rtrunc->value.real, e->value.real);
1776       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1777       gfc_free_expr (rtrunc);
1778       break;
1779
1780     case BT_COMPLEX:
1781       rpart = gfc_complex2real (e, kind);
1782       rtrunc = gfc_copy_expr (rpart);
1783       mpfr_trunc (rtrunc->value.real, rpart->value.real);
1784       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1785       gfc_free_expr (rpart);
1786       gfc_free_expr (rtrunc);
1787       break;
1788
1789     default:
1790       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1791       gfc_free_expr (result);
1792       return &gfc_bad_expr;
1793     }
1794
1795   return range_check (result, name);
1796 }
1797
1798
1799 gfc_expr *
1800 gfc_simplify_int2 (gfc_expr *e)
1801 {
1802   return gfc_simplify_intconv (e, 2, "INT2");
1803 }
1804
1805
1806 gfc_expr *
1807 gfc_simplify_int8 (gfc_expr *e)
1808 {
1809   return gfc_simplify_intconv (e, 8, "INT8");
1810 }
1811
1812
1813 gfc_expr *
1814 gfc_simplify_long (gfc_expr *e)
1815 {
1816   return gfc_simplify_intconv (e, 4, "LONG");
1817 }
1818
1819
1820 gfc_expr *
1821 gfc_simplify_ifix (gfc_expr *e)
1822 {
1823   gfc_expr *rtrunc, *result;
1824
1825   if (e->expr_type != EXPR_CONSTANT)
1826     return NULL;
1827
1828   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1829                                 &e->where);
1830
1831   rtrunc = gfc_copy_expr (e);
1832
1833   mpfr_trunc (rtrunc->value.real, e->value.real);
1834   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1835
1836   gfc_free_expr (rtrunc);
1837   return range_check (result, "IFIX");
1838 }
1839
1840
1841 gfc_expr *
1842 gfc_simplify_idint (gfc_expr *e)
1843 {
1844   gfc_expr *rtrunc, *result;
1845
1846   if (e->expr_type != EXPR_CONSTANT)
1847     return NULL;
1848
1849   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1850                                 &e->where);
1851
1852   rtrunc = gfc_copy_expr (e);
1853
1854   mpfr_trunc (rtrunc->value.real, e->value.real);
1855   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1856
1857   gfc_free_expr (rtrunc);
1858   return range_check (result, "IDINT");
1859 }
1860
1861
1862 gfc_expr *
1863 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1864 {
1865   gfc_expr *result;
1866
1867   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1868     return NULL;
1869
1870   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1871
1872   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1873   return range_check (result, "IOR");
1874 }
1875
1876
1877 gfc_expr *
1878 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1879 {
1880   gfc_expr *result;
1881   int shift, ashift, isize, k, *bits, i;
1882
1883   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1884     return NULL;
1885
1886   if (gfc_extract_int (s, &shift) != NULL)
1887     {
1888       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1889       return &gfc_bad_expr;
1890     }
1891
1892   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1893
1894   isize = gfc_integer_kinds[k].bit_size;
1895
1896   if (shift >= 0)
1897     ashift = shift;
1898   else
1899     ashift = -shift;
1900
1901   if (ashift > isize)
1902     {
1903       gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1904                  "at %L", &s->where);
1905       return &gfc_bad_expr;
1906     }
1907
1908   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1909
1910   if (shift == 0)
1911     {
1912       mpz_set (result->value.integer, e->value.integer);
1913       return range_check (result, "ISHFT");
1914     }
1915
1916   bits = gfc_getmem (isize * sizeof (int));
1917
1918   for (i = 0; i < isize; i++)
1919     bits[i] = mpz_tstbit (e->value.integer, i);
1920
1921   if (shift > 0)
1922     {
1923       for (i = 0; i < shift; i++)
1924         mpz_clrbit (result->value.integer, i);
1925
1926       for (i = 0; i < isize - shift; i++)
1927         {
1928           if (bits[i] == 0)
1929             mpz_clrbit (result->value.integer, i + shift);
1930           else
1931             mpz_setbit (result->value.integer, i + shift);
1932         }
1933     }
1934   else
1935     {
1936       for (i = isize - 1; i >= isize - ashift; i--)
1937         mpz_clrbit (result->value.integer, i);
1938
1939       for (i = isize - 1; i >= ashift; i--)
1940         {
1941           if (bits[i] == 0)
1942             mpz_clrbit (result->value.integer, i - ashift);
1943           else
1944             mpz_setbit (result->value.integer, i - ashift);
1945         }
1946     }
1947
1948   convert_mpz_to_signed (result->value.integer, isize);
1949
1950   gfc_free (bits);
1951   return result;
1952 }
1953
1954
1955 gfc_expr *
1956 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1957 {
1958   gfc_expr *result;
1959   int shift, ashift, isize, ssize, delta, k;
1960   int i, *bits;
1961
1962   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1963     return NULL;
1964
1965   if (gfc_extract_int (s, &shift) != NULL)
1966     {
1967       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1968       return &gfc_bad_expr;
1969     }
1970
1971   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1972   isize = gfc_integer_kinds[k].bit_size;
1973
1974   if (sz != NULL)
1975     {
1976       if (sz->expr_type != EXPR_CONSTANT)
1977         return NULL;
1978
1979       if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1980         {
1981           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1982           return &gfc_bad_expr;
1983         }
1984
1985       if (ssize > isize)
1986         {
1987           gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1988                      "BIT_SIZE of first argument at %L", &s->where);
1989           return &gfc_bad_expr;
1990         }
1991     }
1992   else
1993     ssize = isize;
1994
1995   if (shift >= 0)
1996     ashift = shift;
1997   else
1998     ashift = -shift;
1999
2000   if (ashift > ssize)
2001     {
2002       if (sz != NULL)
2003         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2004                    "third argument at %L", &s->where);
2005       else
2006         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2007                    "BIT_SIZE of first argument at %L", &s->where);
2008       return &gfc_bad_expr;
2009     }
2010
2011   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2012
2013   mpz_set (result->value.integer, e->value.integer);
2014
2015   if (shift == 0)
2016     return result;
2017
2018   convert_mpz_to_unsigned (result->value.integer, isize);
2019
2020   bits = gfc_getmem (ssize * sizeof (int));
2021
2022   for (i = 0; i < ssize; i++)
2023     bits[i] = mpz_tstbit (e->value.integer, i);
2024
2025   delta = ssize - ashift;
2026
2027   if (shift > 0)
2028     {
2029       for (i = 0; i < delta; i++)
2030         {
2031           if (bits[i] == 0)
2032             mpz_clrbit (result->value.integer, i + shift);
2033           else
2034             mpz_setbit (result->value.integer, i + shift);
2035         }
2036
2037       for (i = delta; i < ssize; i++)
2038         {
2039           if (bits[i] == 0)
2040             mpz_clrbit (result->value.integer, i - delta);
2041           else
2042             mpz_setbit (result->value.integer, i - delta);
2043         }
2044     }
2045   else
2046     {
2047       for (i = 0; i < ashift; i++)
2048         {
2049           if (bits[i] == 0)
2050             mpz_clrbit (result->value.integer, i + delta);
2051           else
2052             mpz_setbit (result->value.integer, i + delta);
2053         }
2054
2055       for (i = ashift; i < ssize; i++)
2056         {
2057           if (bits[i] == 0)
2058             mpz_clrbit (result->value.integer, i + shift);
2059           else
2060             mpz_setbit (result->value.integer, i + shift);
2061         }
2062     }
2063
2064   convert_mpz_to_signed (result->value.integer, isize);
2065
2066   gfc_free (bits);
2067   return result;
2068 }
2069
2070
2071 gfc_expr *
2072 gfc_simplify_kind (gfc_expr *e)
2073 {
2074
2075   if (e->ts.type == BT_DERIVED)
2076     {
2077       gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2078       return &gfc_bad_expr;
2079     }
2080
2081   return gfc_int_expr (e->ts.kind);
2082 }
2083
2084
2085 static gfc_expr *
2086 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2087                     gfc_array_spec *as)
2088 {
2089   gfc_expr *l, *u, *result;
2090   int k;
2091
2092   /* The last dimension of an assumed-size array is special.  */
2093   if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2094     {
2095       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2096         return gfc_copy_expr (as->lower[d-1]);
2097       else
2098         return NULL;
2099     }
2100
2101   /* Then, we need to know the extent of the given dimension.  */
2102   l = as->lower[d-1];
2103   u = as->upper[d-1];
2104
2105   if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2106     return NULL;
2107
2108   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2109                 gfc_default_integer_kind);
2110   if (k == -1)
2111     return &gfc_bad_expr;
2112
2113   result = gfc_constant_result (BT_INTEGER, k, &array->where);
2114
2115   if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2116     {
2117       /* Zero extent.  */
2118       if (upper)
2119         mpz_set_si (result->value.integer, 0);
2120       else
2121         mpz_set_si (result->value.integer, 1);
2122     }
2123   else
2124     {
2125       /* Nonzero extent.  */
2126       if (upper)
2127         mpz_set (result->value.integer, u->value.integer);
2128       else
2129         mpz_set (result->value.integer, l->value.integer);
2130     }
2131
2132   return range_check (result, upper ? "UBOUND" : "LBOUND");
2133 }
2134
2135
2136 static gfc_expr *
2137 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2138 {
2139   gfc_ref *ref;
2140   gfc_array_spec *as;
2141   int d;
2142
2143   if (array->expr_type != EXPR_VARIABLE)
2144     return NULL;
2145
2146   /* Follow any component references.  */
2147   as = array->symtree->n.sym->as;
2148   for (ref = array->ref; ref; ref = ref->next)
2149     {
2150       switch (ref->type)
2151         {
2152         case REF_ARRAY:
2153           switch (ref->u.ar.type)
2154             {
2155             case AR_ELEMENT:
2156               as = NULL;
2157               continue;
2158
2159             case AR_FULL:
2160               /* We're done because 'as' has already been set in the
2161                  previous iteration.  */
2162               goto done;
2163
2164             case AR_SECTION:
2165             case AR_UNKNOWN:
2166               return NULL;
2167             }
2168
2169           gcc_unreachable ();
2170
2171         case REF_COMPONENT:
2172           as = ref->u.c.component->as;
2173           continue;
2174
2175         case REF_SUBSTRING:
2176           continue;
2177         }
2178     }
2179
2180   gcc_unreachable ();
2181
2182  done:
2183
2184   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2185     return NULL;
2186
2187   if (dim == NULL)
2188     {
2189       /* Multi-dimensional bounds.  */
2190       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2191       gfc_expr *e;
2192       gfc_constructor *head, *tail;
2193       int k;
2194
2195       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
2196       if (upper && as->type == AS_ASSUMED_SIZE)
2197         {
2198           /* An error message will be emitted in
2199              check_assumed_size_reference (resolve.c).  */
2200           return &gfc_bad_expr;
2201         }
2202
2203       /* Simplify the bounds for each dimension.  */
2204       for (d = 0; d < array->rank; d++)
2205         {
2206           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2207           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2208             {
2209               int j;
2210
2211               for (j = 0; j < d; j++)
2212                 gfc_free_expr (bounds[j]);
2213               return bounds[d];
2214             }
2215         }
2216
2217       /* Allocate the result expression.  */
2218       e = gfc_get_expr ();
2219       e->where = array->where;
2220       e->expr_type = EXPR_ARRAY;
2221       e->ts.type = BT_INTEGER;
2222       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2223                     gfc_default_integer_kind);
2224       if (k == -1)
2225         return &gfc_bad_expr;
2226       e->ts.kind = k;
2227
2228       /* The result is a rank 1 array; its size is the rank of the first
2229          argument to {L,U}BOUND.  */
2230       e->rank = 1;
2231       e->shape = gfc_get_shape (1);
2232       mpz_init_set_ui (e->shape[0], array->rank);
2233
2234       /* Create the constructor for this array.  */
2235       head = tail = NULL;
2236       for (d = 0; d < array->rank; d++)
2237         {
2238           /* Get a new constructor element.  */
2239           if (head == NULL)
2240             head = tail = gfc_get_constructor ();
2241           else
2242             {
2243               tail->next = gfc_get_constructor ();
2244               tail = tail->next;
2245             }
2246
2247           tail->where = e->where;
2248           tail->expr = bounds[d];
2249         }
2250       e->value.constructor = head;
2251
2252       return e;
2253     }
2254   else
2255     {
2256       /* A DIM argument is specified.  */
2257       if (dim->expr_type != EXPR_CONSTANT)
2258         return NULL;
2259
2260       d = mpz_get_si (dim->value.integer);
2261
2262       if (d < 1 || d > as->rank
2263           || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2264         {
2265           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2266           return &gfc_bad_expr;
2267         }
2268
2269       return simplify_bound_dim (array, kind, d, upper, as);
2270     }
2271 }
2272
2273
2274 gfc_expr *
2275 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2276 {
2277   return simplify_bound (array, dim, kind, 0);
2278 }
2279
2280
2281 gfc_expr *
2282 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2283 {
2284   gfc_expr *result;
2285   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2286
2287   if (k == -1)
2288     return &gfc_bad_expr;
2289
2290   if (e->expr_type == EXPR_CONSTANT)
2291     {
2292       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2293       mpz_set_si (result->value.integer, e->value.character.length);
2294       return range_check (result, "LEN");
2295     }
2296
2297   if (e->ts.cl != NULL && e->ts.cl->length != NULL
2298       && e->ts.cl->length->expr_type == EXPR_CONSTANT
2299       && e->ts.cl->length->ts.type == BT_INTEGER)
2300     {
2301       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2302       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2303       return range_check (result, "LEN");
2304     }
2305
2306   return NULL;
2307 }
2308
2309
2310 gfc_expr *
2311 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2312 {
2313   gfc_expr *result;
2314   int count, len, lentrim, i;
2315   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2316
2317   if (k == -1)
2318     return &gfc_bad_expr;
2319
2320   if (e->expr_type != EXPR_CONSTANT)
2321     return NULL;
2322
2323   result = gfc_constant_result (BT_INTEGER, k, &e->where);
2324   len = e->value.character.length;
2325
2326   for (count = 0, i = 1; i <= len; i++)
2327     if (e->value.character.string[len - i] == ' ')
2328       count++;
2329     else
2330       break;
2331
2332   lentrim = len - count;
2333
2334   mpz_set_si (result->value.integer, lentrim);
2335   return range_check (result, "LEN_TRIM");
2336 }
2337
2338 gfc_expr *
2339 gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
2340 {
2341 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2342   gfc_expr *result;
2343   int sg;
2344
2345   if (x->expr_type != EXPR_CONSTANT)
2346     return NULL;
2347
2348   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2349
2350   gfc_set_model_kind (x->ts.kind);
2351
2352   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2353
2354   return range_check (result, "LGAMMA");
2355 #else
2356   return NULL;
2357 #endif
2358 }
2359
2360
2361 gfc_expr *
2362 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2363 {
2364   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2365     return NULL;
2366
2367   return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2368 }
2369
2370
2371 gfc_expr *
2372 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2373 {
2374   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2375     return NULL;
2376
2377   return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2378                            &a->where);
2379 }
2380
2381
2382 gfc_expr *
2383 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2384 {
2385   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2386     return NULL;
2387
2388   return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2389 }
2390
2391
2392 gfc_expr *
2393 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2394 {
2395   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2396     return NULL;
2397
2398   return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2399 }
2400
2401
2402 gfc_expr *
2403 gfc_simplify_log (gfc_expr *x)
2404 {
2405   gfc_expr *result;
2406   mpfr_t xr, xi;
2407
2408   if (x->expr_type != EXPR_CONSTANT)
2409     return NULL;
2410
2411   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2412
2413   gfc_set_model_kind (x->ts.kind);
2414
2415   switch (x->ts.type)
2416     {
2417     case BT_REAL:
2418       if (mpfr_sgn (x->value.real) <= 0)
2419         {
2420           gfc_error ("Argument of LOG at %L cannot be less than or equal "
2421                      "to zero", &x->where);
2422           gfc_free_expr (result);
2423           return &gfc_bad_expr;
2424         }
2425
2426       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2427       break;
2428
2429     case BT_COMPLEX:
2430       if ((mpfr_sgn (x->value.complex.r) == 0)
2431           && (mpfr_sgn (x->value.complex.i) == 0))
2432         {
2433           gfc_error ("Complex argument of LOG at %L cannot be zero",
2434                      &x->where);
2435           gfc_free_expr (result);
2436           return &gfc_bad_expr;
2437         }
2438
2439       mpfr_init (xr);
2440       mpfr_init (xi);
2441
2442       mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2443                   x->value.complex.r, GFC_RND_MODE);
2444
2445       mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2446       mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2447       mpfr_add (xr, xr, xi, GFC_RND_MODE);
2448       mpfr_sqrt (xr, xr, GFC_RND_MODE);
2449       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2450
2451       mpfr_clear (xr);
2452       mpfr_clear (xi);
2453
2454       break;
2455
2456     default:
2457       gfc_internal_error ("gfc_simplify_log: bad type");
2458     }
2459
2460   return range_check (result, "LOG");
2461 }
2462
2463
2464 gfc_expr *
2465 gfc_simplify_log10 (gfc_expr *x)
2466 {
2467   gfc_expr *result;
2468
2469   if (x->expr_type != EXPR_CONSTANT)
2470     return NULL;
2471
2472   gfc_set_model_kind (x->ts.kind);
2473
2474   if (mpfr_sgn (x->value.real) <= 0)
2475     {
2476       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2477                  "to zero", &x->where);
2478       return &gfc_bad_expr;
2479     }
2480
2481   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2482
2483   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2484
2485   return range_check (result, "LOG10");
2486 }
2487
2488
2489 gfc_expr *
2490 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2491 {
2492   gfc_expr *result;
2493   int kind;
2494
2495   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2496   if (kind < 0)
2497     return &gfc_bad_expr;
2498
2499   if (e->expr_type != EXPR_CONSTANT)
2500     return NULL;
2501
2502   result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2503
2504   result->value.logical = e->value.logical;
2505
2506   return result;
2507 }
2508
2509
2510 /* This function is special since MAX() can take any number of
2511    arguments.  The simplified expression is a rewritten version of the
2512    argument list containing at most one constant element.  Other
2513    constant elements are deleted.  Because the argument list has
2514    already been checked, this function always succeeds.  sign is 1 for
2515    MAX(), -1 for MIN().  */
2516
2517 static gfc_expr *
2518 simplify_min_max (gfc_expr *expr, int sign)
2519 {
2520   gfc_actual_arglist *arg, *last, *extremum;
2521   gfc_intrinsic_sym * specific;
2522
2523   last = NULL;
2524   extremum = NULL;
2525   specific = expr->value.function.isym;
2526
2527   arg = expr->value.function.actual;
2528
2529   for (; arg; last = arg, arg = arg->next)
2530     {
2531       if (arg->expr->expr_type != EXPR_CONSTANT)
2532         continue;
2533
2534       if (extremum == NULL)
2535         {
2536           extremum = arg;
2537           continue;
2538         }
2539
2540       switch (arg->expr->ts.type)
2541         {
2542         case BT_INTEGER:
2543           if (mpz_cmp (arg->expr->value.integer,
2544                        extremum->expr->value.integer) * sign > 0)
2545             mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2546           break;
2547
2548         case BT_REAL:
2549           /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
2550           if (sign > 0)
2551             mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2552                       arg->expr->value.real, GFC_RND_MODE);
2553           else
2554             mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2555                       arg->expr->value.real, GFC_RND_MODE);
2556           break;
2557
2558         case BT_CHARACTER:
2559 #define LENGTH(x) ((x)->expr->value.character.length)
2560 #define STRING(x) ((x)->expr->value.character.string)
2561           if (LENGTH(extremum) < LENGTH(arg))
2562             {
2563               char * tmp = STRING(extremum);
2564
2565               STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2566               memcpy (STRING(extremum), tmp, LENGTH(extremum));
2567               memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2568                       LENGTH(arg) - LENGTH(extremum));
2569               STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
2570               LENGTH(extremum) = LENGTH(arg);
2571               gfc_free (tmp);
2572             }
2573
2574           if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2575             {
2576               gfc_free (STRING(extremum));
2577               STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2578               memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2579               memset (&STRING(extremum)[LENGTH(arg)], ' ',
2580                       LENGTH(extremum) - LENGTH(arg));
2581               STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
2582             }
2583 #undef LENGTH
2584 #undef STRING
2585           break;
2586
2587
2588         default:
2589           gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2590         }
2591
2592       /* Delete the extra constant argument.  */
2593       if (last == NULL)
2594         expr->value.function.actual = arg->next;
2595       else
2596         last->next = arg->next;
2597
2598       arg->next = NULL;
2599       gfc_free_actual_arglist (arg);
2600       arg = last;
2601     }
2602
2603   /* If there is one value left, replace the function call with the
2604      expression.  */
2605   if (expr->value.function.actual->next != NULL)
2606     return NULL;
2607
2608   /* Convert to the correct type and kind.  */
2609   if (expr->ts.type != BT_UNKNOWN)
2610     return gfc_convert_constant (expr->value.function.actual->expr,
2611         expr->ts.type, expr->ts.kind);
2612
2613   if (specific->ts.type != BT_UNKNOWN)
2614     return gfc_convert_constant (expr->value.function.actual->expr,
2615         specific->ts.type, specific->ts.kind);
2616
2617   return gfc_copy_expr (expr->value.function.actual->expr);
2618 }
2619
2620
2621 gfc_expr *
2622 gfc_simplify_min (gfc_expr *e)
2623 {
2624   return simplify_min_max (e, -1);
2625 }
2626
2627
2628 gfc_expr *
2629 gfc_simplify_max (gfc_expr *e)
2630 {
2631   return simplify_min_max (e, 1);
2632 }
2633
2634
2635 gfc_expr *
2636 gfc_simplify_maxexponent (gfc_expr *x)
2637 {
2638   gfc_expr *result;
2639   int i;
2640
2641   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2642
2643   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2644   result->where = x->where;
2645
2646   return result;
2647 }
2648
2649
2650 gfc_expr *
2651 gfc_simplify_minexponent (gfc_expr *x)
2652 {
2653   gfc_expr *result;
2654   int i;
2655
2656   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2657
2658   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2659   result->where = x->where;
2660
2661   return result;
2662 }
2663
2664
2665 gfc_expr *
2666 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2667 {
2668   gfc_expr *result;
2669   mpfr_t quot, iquot, term;
2670   int kind;
2671
2672   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2673     return NULL;
2674
2675   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2676   result = gfc_constant_result (a->ts.type, kind, &a->where);
2677
2678   switch (a->ts.type)
2679     {
2680     case BT_INTEGER:
2681       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2682         {
2683           /* Result is processor-dependent.  */
2684           gfc_error ("Second argument MOD at %L is zero", &a->where);
2685           gfc_free_expr (result);
2686           return &gfc_bad_expr;
2687         }
2688       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2689       break;
2690
2691     case BT_REAL:
2692       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2693         {
2694           /* Result is processor-dependent.  */
2695           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2696           gfc_free_expr (result);
2697           return &gfc_bad_expr;
2698         }
2699
2700       gfc_set_model_kind (kind);
2701       mpfr_init (quot);
2702       mpfr_init (iquot);
2703       mpfr_init (term);
2704
2705       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2706       mpfr_trunc (iquot, quot);
2707       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2708       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2709
2710       mpfr_clear (quot);
2711       mpfr_clear (iquot);
2712       mpfr_clear (term);
2713       break;
2714
2715     default:
2716       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2717     }
2718
2719   return range_check (result, "MOD");
2720 }
2721
2722
2723 gfc_expr *
2724 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2725 {
2726   gfc_expr *result;
2727   mpfr_t quot, iquot, term;
2728   int kind;
2729
2730   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2731     return NULL;
2732
2733   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2734   result = gfc_constant_result (a->ts.type, kind, &a->where);
2735
2736   switch (a->ts.type)
2737     {
2738     case BT_INTEGER:
2739       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2740         {
2741           /* Result is processor-dependent. This processor just opts
2742              to not handle it at all.  */
2743           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2744           gfc_free_expr (result);
2745           return &gfc_bad_expr;
2746         }
2747       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2748
2749       break;
2750
2751     case BT_REAL:
2752       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2753         {
2754           /* Result is processor-dependent.  */
2755           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2756           gfc_free_expr (result);
2757           return &gfc_bad_expr;
2758         }
2759
2760       gfc_set_model_kind (kind);
2761       mpfr_init (quot);
2762       mpfr_init (iquot);
2763       mpfr_init (term);
2764
2765       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2766       mpfr_floor (iquot, quot);
2767       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2768       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2769
2770       mpfr_clear (quot);
2771       mpfr_clear (iquot);
2772       mpfr_clear (term);
2773       break;
2774
2775     default:
2776       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2777     }
2778
2779   return range_check (result, "MODULO");
2780 }
2781
2782
2783 /* Exists for the sole purpose of consistency with other intrinsics.  */
2784 gfc_expr *
2785 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
2786                      gfc_expr *fp ATTRIBUTE_UNUSED,
2787                      gfc_expr *l  ATTRIBUTE_UNUSED,
2788                      gfc_expr *to ATTRIBUTE_UNUSED,
2789                      gfc_expr *tp ATTRIBUTE_UNUSED)
2790 {
2791   return NULL;
2792 }
2793
2794
2795 gfc_expr *
2796 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2797 {
2798   gfc_expr *result;
2799   mp_exp_t emin, emax;
2800   int kind;
2801
2802   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2803     return NULL;
2804
2805   if (mpfr_sgn (s->value.real) == 0)
2806     {
2807       gfc_error ("Second argument of NEAREST at %L shall not be zero",
2808                  &s->where);
2809       return &gfc_bad_expr;
2810     }
2811
2812   gfc_set_model_kind (x->ts.kind);
2813   result = gfc_copy_expr (x);
2814
2815   /* Save current values of emin and emax.  */
2816   emin = mpfr_get_emin ();
2817   emax = mpfr_get_emax ();
2818
2819   /* Set emin and emax for the current model number.  */
2820   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2821   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2822                 mpfr_get_prec(result->value.real) + 1);
2823   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2824
2825   if (mpfr_sgn (s->value.real) > 0)
2826     {
2827       mpfr_nextabove (result->value.real);
2828       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2829     }
2830   else
2831     {
2832       mpfr_nextbelow (result->value.real);
2833       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2834     }
2835
2836   mpfr_set_emin (emin);
2837   mpfr_set_emax (emax);
2838
2839   /* Only NaN can occur. Do not use range check as it gives an
2840      error for denormal numbers.  */
2841   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2842     {
2843       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2844       return &gfc_bad_expr;
2845     }
2846
2847   return result;
2848 }
2849
2850
2851 static gfc_expr *
2852 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2853 {
2854   gfc_expr *itrunc, *result;
2855   int kind;
2856
2857   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2858   if (kind == -1)
2859     return &gfc_bad_expr;
2860
2861   if (e->expr_type != EXPR_CONSTANT)
2862     return NULL;
2863
2864   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2865
2866   itrunc = gfc_copy_expr (e);
2867
2868   mpfr_round (itrunc->value.real, e->value.real);
2869
2870   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2871
2872   gfc_free_expr (itrunc);
2873
2874   return range_check (result, name);
2875 }
2876
2877
2878 gfc_expr *
2879 gfc_simplify_new_line (gfc_expr *e)
2880 {
2881   gfc_expr *result;
2882
2883   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2884   result->value.character.string = gfc_getmem (2);
2885   result->value.character.length = 1;
2886   result->value.character.string[0] = '\n';
2887   result->value.character.string[1] = '\0';     /* For debugger */
2888   return result;
2889 }
2890
2891
2892 gfc_expr *
2893 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2894 {
2895   return simplify_nint ("NINT", e, k);
2896 }
2897
2898
2899 gfc_expr *
2900 gfc_simplify_idnint (gfc_expr *e)
2901 {
2902   return simplify_nint ("IDNINT", e, NULL);
2903 }
2904
2905
2906 gfc_expr *
2907 gfc_simplify_not (gfc_expr *e)
2908 {
2909   gfc_expr *result;
2910
2911   if (e->expr_type != EXPR_CONSTANT)
2912     return NULL;
2913
2914   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2915
2916   mpz_com (result->value.integer, e->value.integer);
2917
2918   return range_check (result, "NOT");
2919 }
2920
2921
2922 gfc_expr *
2923 gfc_simplify_null (gfc_expr *mold)
2924 {
2925   gfc_expr *result;
2926
2927   if (mold == NULL)
2928     {
2929       result = gfc_get_expr ();
2930       result->ts.type = BT_UNKNOWN;
2931     }
2932   else
2933     result = gfc_copy_expr (mold);
2934   result->expr_type = EXPR_NULL;
2935
2936   return result;
2937 }
2938
2939
2940 gfc_expr *
2941 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2942 {
2943   gfc_expr *result;
2944   int kind;
2945
2946   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2947     return NULL;
2948
2949   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2950   if (x->ts.type == BT_INTEGER)
2951     {
2952       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2953       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2954     }
2955   else /* BT_LOGICAL */
2956     {
2957       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2958       result->value.logical = x->value.logical || y->value.logical;
2959     }
2960
2961   return range_check (result, "OR");
2962 }
2963
2964
2965 gfc_expr *
2966 gfc_simplify_precision (gfc_expr *e)
2967 {
2968   gfc_expr *result;
2969   int i;
2970
2971   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2972
2973   result = gfc_int_expr (gfc_real_kinds[i].precision);
2974   result->where = e->where;
2975
2976   return result;
2977 }
2978
2979
2980 gfc_expr *
2981 gfc_simplify_radix (gfc_expr *e)
2982 {
2983   gfc_expr *result;
2984   int i;
2985
2986   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2987   switch (e->ts.type)
2988     {
2989     case BT_INTEGER:
2990       i = gfc_integer_kinds[i].radix;
2991       break;
2992
2993     case BT_REAL:
2994       i = gfc_real_kinds[i].radix;
2995       break;
2996
2997     default:
2998       gcc_unreachable ();
2999     }
3000
3001   result = gfc_int_expr (i);
3002   result->where = e->where;
3003
3004   return result;
3005 }
3006
3007
3008 gfc_expr *
3009 gfc_simplify_range (gfc_expr *e)
3010 {
3011   gfc_expr *result;
3012   int i;
3013   long j;
3014
3015   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3016
3017   switch (e->ts.type)
3018     {
3019     case BT_INTEGER:
3020       j = gfc_integer_kinds[i].range;
3021       break;
3022
3023     case BT_REAL:
3024     case BT_COMPLEX:
3025       j = gfc_real_kinds[i].range;
3026       break;
3027
3028     default:
3029       gcc_unreachable ();
3030     }
3031
3032   result = gfc_int_expr (j);
3033   result->where = e->where;
3034
3035   return result;
3036 }
3037
3038
3039 gfc_expr *
3040 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3041 {
3042   gfc_expr *result;
3043   int kind;
3044
3045   if (e->ts.type == BT_COMPLEX)
3046     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3047   else
3048     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3049
3050   if (kind == -1)
3051     return &gfc_bad_expr;
3052
3053   if (e->expr_type != EXPR_CONSTANT)
3054     return NULL;
3055
3056   switch (e->ts.type)
3057     {
3058     case BT_INTEGER:
3059       if (!e->is_boz)
3060         result = gfc_int2real (e, kind);
3061       break;
3062
3063     case BT_REAL:
3064       result = gfc_real2real (e, kind);
3065       break;
3066
3067     case BT_COMPLEX:
3068       result = gfc_complex2real (e, kind);
3069       break;
3070
3071     default:
3072       gfc_internal_error ("bad type in REAL");
3073       /* Not reached */
3074     }
3075
3076   if (e->ts.type == BT_INTEGER && e->is_boz)
3077     {
3078       gfc_typespec ts;
3079       gfc_clear_ts (&ts);
3080       ts.type = BT_REAL;
3081       ts.kind = kind;
3082       result = gfc_copy_expr (e);
3083       if (!gfc_convert_boz (result, &ts))
3084         return &gfc_bad_expr;
3085     }
3086   return range_check (result, "REAL");
3087 }
3088
3089
3090 gfc_expr *
3091 gfc_simplify_realpart (gfc_expr *e)
3092 {
3093   gfc_expr *result;
3094
3095   if (e->expr_type != EXPR_CONSTANT)
3096     return NULL;
3097
3098   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3099   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3100
3101   return range_check (result, "REALPART");
3102 }
3103
3104 gfc_expr *
3105 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3106 {
3107   gfc_expr *result;
3108   int i, j, len, ncop, nlen;
3109   mpz_t ncopies;
3110   bool have_length = false;
3111
3112   /* If NCOPIES isn't a constant, there's nothing we can do.  */
3113   if (n->expr_type != EXPR_CONSTANT)
3114     return NULL;
3115
3116   /* If NCOPIES is negative, it's an error.  */
3117   if (mpz_sgn (n->value.integer) < 0)
3118     {
3119       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3120                  &n->where);
3121       return &gfc_bad_expr;
3122     }
3123
3124   /* If we don't know the character length, we can do no more.  */
3125   if (e->ts.cl && e->ts.cl->length
3126         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3127     {
3128       len = mpz_get_si (e->ts.cl->length->value.integer);
3129       have_length = true;
3130     }
3131   else if (e->expr_type == EXPR_CONSTANT
3132              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3133     {
3134       len = e->value.character.length;
3135     }
3136   else
3137     return NULL;
3138
3139   /* If the source length is 0, any value of NCOPIES is valid
3140      and everything behaves as if NCOPIES == 0.  */
3141   mpz_init (ncopies);
3142   if (len == 0)
3143     mpz_set_ui (ncopies, 0);
3144   else
3145     mpz_set (ncopies, n->value.integer);
3146
3147   /* Check that NCOPIES isn't too large.  */
3148   if (len)
3149     {
3150       mpz_t max, mlen;
3151       int i;
3152
3153       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
3154       mpz_init (max);
3155       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3156
3157       if (have_length)
3158         {
3159           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3160                       e->ts.cl->length->value.integer);
3161         }
3162       else
3163         {
3164           mpz_init_set_si (mlen, len);
3165           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3166           mpz_clear (mlen);
3167         }
3168
3169       /* The check itself.  */
3170       if (mpz_cmp (ncopies, max) > 0)
3171         {
3172           mpz_clear (max);
3173           mpz_clear (ncopies);
3174           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3175                      &n->where);
3176           return &gfc_bad_expr;
3177         }
3178
3179       mpz_clear (max);
3180     }
3181   mpz_clear (ncopies);
3182
3183   /* For further simplification, we need the character string to be
3184      constant.  */
3185   if (e->expr_type != EXPR_CONSTANT)
3186     return NULL;
3187
3188   if (len ||
3189       (e->ts.cl->length &&
3190        mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3191     {
3192       const char *res = gfc_extract_int (n, &ncop);
3193       gcc_assert (res == NULL);
3194     }
3195   else
3196     ncop = 0;
3197
3198   len = e->value.character.length;
3199   nlen = ncop * len;
3200
3201   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3202
3203   if (ncop == 0)
3204     {
3205       result->value.character.string = gfc_getmem (1);
3206       result->value.character.length = 0;
3207       result->value.character.string[0] = '\0';
3208       return result;
3209     }
3210
3211   result->value.character.length = nlen;
3212   result->value.character.string = gfc_getmem (nlen + 1);
3213
3214   for (i = 0; i < ncop; i++)
3215     for (j = 0; j < len; j++)
3216       result->value.character.string[j + i * len]
3217       = e->value.character.string[j];
3218
3219   result->value.character.string[nlen] = '\0';  /* For debugger */
3220   return result;
3221 }
3222
3223
3224 /* Test that the expression is an constant array.  */
3225
3226 static bool
3227 is_constant_array_expr (gfc_expr *e)
3228 {
3229   gfc_constructor *c;
3230
3231   if (e == NULL)
3232     return true;
3233
3234   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3235     return false;
3236
3237   if (e->value.constructor == NULL)
3238     return false;
3239
3240   for (c = e->value.constructor; c; c = c->next)
3241     if (c->expr->expr_type != EXPR_CONSTANT)
3242       return false;
3243
3244   return true;
3245 }
3246
3247
3248 /* This one is a bear, but mainly has to do with shuffling elements.  */
3249
3250 gfc_expr *
3251 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3252                       gfc_expr *pad, gfc_expr *order_exp)
3253 {
3254   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3255   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3256   gfc_constructor *head, *tail;
3257   mpz_t index, size;
3258   unsigned long j;
3259   size_t nsource;
3260   gfc_expr *e;
3261
3262   /* Check that argument expression types are OK.  */
3263   if (!is_constant_array_expr (source))
3264     return NULL;
3265
3266   if (!is_constant_array_expr (shape_exp))
3267     return NULL;
3268
3269   if (!is_constant_array_expr (pad))
3270     return NULL;
3271
3272   if (!is_constant_array_expr (order_exp))
3273     return NULL;
3274
3275   /* Proceed with simplification, unpacking the array.  */
3276
3277   mpz_init (index);
3278   rank = 0;
3279   head = tail = NULL;
3280
3281   for (;;)
3282     {
3283       e = gfc_get_array_element (shape_exp, rank);
3284       if (e == NULL)
3285         break;
3286
3287       if (gfc_extract_int (e, &shape[rank]) != NULL)
3288         {
3289           gfc_error ("Integer too large in shape specification at %L",
3290                      &e->where);
3291           gfc_free_expr (e);
3292           goto bad_reshape;
3293         }
3294
3295       gfc_free_expr (e);
3296
3297       if (rank >= GFC_MAX_DIMENSIONS)
3298         {
3299           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3300                      "at %L", &e->where);
3301
3302           goto bad_reshape;
3303         }
3304
3305       if (shape[rank] < 0)
3306         {
3307           gfc_error ("Shape specification at %L cannot be negative",
3308                      &e->where);
3309           goto bad_reshape;
3310         }
3311
3312       rank++;
3313     }
3314
3315   if (rank == 0)
3316     {
3317       gfc_error ("Shape specification at %L cannot be the null array",
3318                  &shape_exp->where);
3319       goto bad_reshape;
3320     }
3321
3322   /* Now unpack the order array if present.  */
3323   if (order_exp == NULL)
3324     {
3325       for (i = 0; i < rank; i++)
3326         order[i] = i;
3327     }
3328   else
3329     {
3330       for (i = 0; i < rank; i++)
3331         x[i] = 0;
3332
3333       for (i = 0; i < rank; i++)
3334         {
3335           e = gfc_get_array_element (order_exp, i);
3336           if (e == NULL)
3337             {
3338               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3339                          "size as SHAPE parameter", &order_exp->where);
3340               goto bad_reshape;
3341             }
3342
3343           if (gfc_extract_int (e, &order[i]) != NULL)
3344             {
3345               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3346                          &e->where);
3347               gfc_free_expr (e);
3348               goto bad_reshape;
3349             }
3350
3351           gfc_free_expr (e);
3352
3353           if (order[i] < 1 || order[i] > rank)
3354             {
3355               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3356                          &e->where);
3357               goto bad_reshape;
3358             }
3359
3360           order[i]--;
3361
3362           if (x[order[i]])
3363             {
3364               gfc_error ("Invalid permutation in ORDER parameter at %L",
3365                          &e->where);
3366               goto bad_reshape;
3367             }
3368
3369           x[order[i]] = 1;
3370         }
3371     }
3372
3373   /* Count the elements in the source and padding arrays.  */
3374
3375   npad = 0;
3376   if (pad != NULL)
3377     {
3378       gfc_array_size (pad, &size);
3379       npad = mpz_get_ui (size);
3380       mpz_clear (size);
3381     }
3382
3383   gfc_array_size (source, &size);
3384   nsource = mpz_get_ui (size);
3385   mpz_clear (size);
3386
3387   /* If it weren't for that pesky permutation we could just loop
3388      through the source and round out any shortage with pad elements.
3389      But no, someone just had to have the compiler do something the
3390      user should be doing.  */
3391
3392   for (i = 0; i < rank; i++)
3393     x[i] = 0;
3394
3395   for (;;)
3396     {
3397       /* Figure out which element to extract.  */
3398       mpz_set_ui (index, 0);
3399
3400       for (i = rank - 1; i >= 0; i--)
3401         {
3402           mpz_add_ui (index, index, x[order[i]]);
3403           if (i != 0)
3404             mpz_mul_ui (index, index, shape[order[i - 1]]);
3405         }
3406
3407       if (mpz_cmp_ui (index, INT_MAX) > 0)
3408         gfc_internal_error ("Reshaped array too large at %L", &e->where);
3409
3410       j = mpz_get_ui (index);
3411
3412       if (j < nsource)
3413         e = gfc_get_array_element (source, j);
3414       else
3415         {
3416           j = j - nsource;
3417
3418           if (npad == 0)
3419             {
3420               gfc_error ("PAD parameter required for short SOURCE parameter "
3421                          "at %L", &source->where);
3422               goto bad_reshape;
3423             }
3424
3425           j = j % npad;
3426           e = gfc_get_array_element (pad, j);
3427         }
3428
3429       if (head == NULL)
3430         head = tail = gfc_get_constructor ();
3431       else
3432         {
3433           tail->next = gfc_get_constructor ();
3434           tail = tail->next;
3435         }
3436
3437       if (e == NULL)
3438         goto bad_reshape;
3439
3440       tail->where = e->where;
3441       tail->expr = e;
3442
3443       /* Calculate the next element.  */
3444       i = 0;
3445
3446 inc:
3447       if (++x[i] < shape[i])
3448         continue;
3449       x[i++] = 0;
3450       if (i < rank)
3451         goto inc;
3452
3453       break;
3454     }
3455
3456   mpz_clear (index);
3457
3458   e = gfc_get_expr ();
3459   e->where = source->where;
3460   e->expr_type = EXPR_ARRAY;
3461   e->value.constructor = head;
3462   e->shape = gfc_get_shape (rank);
3463
3464   for (i = 0; i < rank; i++)
3465     mpz_init_set_ui (e->shape[i], shape[i]);
3466
3467   e->ts = source->ts;
3468   e->rank = rank;
3469
3470   return e;
3471
3472 bad_reshape:
3473   gfc_free_constructor (head);
3474   mpz_clear (index);
3475   return &gfc_bad_expr;
3476 }
3477
3478
3479 gfc_expr *
3480 gfc_simplify_rrspacing (gfc_expr *x)
3481 {
3482   gfc_expr *result;
3483   int i;
3484   long int e, p;
3485
3486   if (x->expr_type != EXPR_CONSTANT)
3487     return NULL;
3488
3489   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3490
3491   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3492
3493   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3494
3495   /* Special case x = -0 and 0.  */
3496   if (mpfr_sgn (result->value.real) == 0)
3497     {
3498       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3499       return result;
3500     }
3501
3502   /* | x * 2**(-e) | * 2**p.  */
3503   e = - (long int) mpfr_get_exp (x->value.real);
3504   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3505
3506   p = (long int) gfc_real_kinds[i].digits;
3507   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3508
3509   return range_check (result, "RRSPACING");
3510 }
3511
3512
3513 gfc_expr *
3514 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3515 {
3516   int k, neg_flag, power, exp_range;
3517   mpfr_t scale, radix;
3518   gfc_expr *result;
3519
3520   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3521     return NULL;
3522
3523   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3524
3525   if (mpfr_sgn (x->value.real) == 0)
3526     {
3527       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3528       return result;
3529     }
3530
3531   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3532
3533   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3534
3535   /* This check filters out values of i that would overflow an int.  */
3536   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3537       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3538     {
3539       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3540       return &gfc_bad_expr;
3541     }
3542
3543   /* Compute scale = radix ** power.  */
3544   power = mpz_get_si (i->value.integer);
3545
3546   if (power >= 0)
3547     neg_flag = 0;
3548   else
3549     {
3550       neg_flag = 1;
3551       power = -power;
3552     }
3553
3554   gfc_set_model_kind (x->ts.kind);
3555   mpfr_init (scale);
3556   mpfr_init (radix);
3557   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3558   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3559
3560   if (neg_flag)
3561     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3562   else
3563     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3564
3565   mpfr_clear (scale);
3566   mpfr_clear (radix);
3567
3568   return range_check (result, "SCALE");
3569 }
3570
3571
3572 gfc_expr *
3573 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3574 {
3575   gfc_expr *result;
3576   int back;
3577   size_t i;
3578   size_t indx, len, lenc;
3579   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3580
3581   if (k == -1)
3582     return &gfc_bad_expr;
3583
3584   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3585     return NULL;
3586
3587   if (b != NULL && b->value.logical != 0)
3588     back = 1;
3589   else
3590     back = 0;
3591
3592   result = gfc_constant_result (BT_INTEGER, k, &e->where);
3593
3594   len = e->value.character.length;
3595   lenc = c->value.character.length;
3596
3597   if (len == 0 || lenc == 0)
3598     {
3599       indx = 0;
3600     }
3601   else
3602     {
3603       if (back == 0)
3604         {
3605           indx = strcspn (e->value.character.string, c->value.character.string)
3606                + 1;
3607           if (indx > len)
3608             indx = 0;
3609         }
3610       else
3611         {
3612           i = 0;
3613           for (indx = len; indx > 0; indx--)
3614             {
3615               for (i = 0; i < lenc; i++)
3616                 {
3617                   if (c->value.character.string[i]
3618                       == e->value.character.string[indx - 1])
3619                     break;
3620                 }
3621               if (i < lenc)
3622                 break;
3623             }
3624         }
3625     }
3626   mpz_set_ui (result->value.integer, indx);
3627   return range_check (result, "SCAN");
3628 }
3629
3630
3631 gfc_expr *
3632 gfc_simplify_selected_char_kind (gfc_expr *e)
3633 {
3634   int kind;
3635   gfc_expr *result;
3636
3637   if (e->expr_type != EXPR_CONSTANT)
3638     return NULL;
3639
3640   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
3641       || gfc_compare_with_Cstring (e, "default", false) == 0)
3642     kind = 1;
3643   else
3644     kind = -1;
3645
3646   result = gfc_int_expr (kind);
3647   result->where = e->where;
3648
3649   return result;
3650 }
3651
3652
3653 gfc_expr *
3654 gfc_simplify_selected_int_kind (gfc_expr *e)
3655 {
3656   int i, kind, range;
3657   gfc_expr *result;
3658
3659   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3660     return NULL;
3661
3662   kind = INT_MAX;
3663
3664   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3665     if (gfc_integer_kinds[i].range >= range
3666         && gfc_integer_kinds[i].kind < kind)
3667       kind = gfc_integer_kinds[i].kind;
3668
3669   if (kind == INT_MAX)
3670     kind = -1;
3671
3672   result = gfc_int_expr (kind);
3673   result->where = e->where;
3674
3675   return result;
3676 }
3677
3678
3679 gfc_expr *
3680 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3681 {
3682   int range, precision, i, kind, found_precision, found_range;
3683   gfc_expr *result;
3684
3685   if (p == NULL)
3686     precision = 0;
3687   else
3688     {
3689       if (p->expr_type != EXPR_CONSTANT
3690           || gfc_extract_int (p, &precision) != NULL)
3691         return NULL;
3692     }
3693
3694   if (q == NULL)
3695     range = 0;
3696   else
3697     {
3698       if (q->expr_type != EXPR_CONSTANT
3699           || gfc_extract_int (q, &range) != NULL)
3700         return NULL;
3701     }
3702
3703   kind = INT_MAX;
3704   found_precision = 0;
3705   found_range = 0;
3706
3707   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3708     {
3709       if (gfc_real_kinds[i].precision >= precision)
3710         found_precision = 1;
3711
3712       if (gfc_real_kinds[i].range >= range)
3713         found_range = 1;
3714
3715       if (gfc_real_kinds[i].precision >= precision
3716           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3717         kind = gfc_real_kinds[i].kind;
3718     }
3719
3720   if (kind == INT_MAX)
3721     {
3722       kind = 0;
3723
3724       if (!found_precision)
3725         kind = -1;
3726       if (!found_range)
3727         kind -= 2;
3728     }
3729
3730   result = gfc_int_expr (kind);
3731   result->where = (p != NULL) ? p->where : q->where;
3732
3733   return result;
3734 }
3735
3736
3737 gfc_expr *
3738 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3739 {
3740   gfc_expr *result;
3741   mpfr_t exp, absv, log2, pow2, frac;
3742   unsigned long exp2;
3743
3744   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3745     return NULL;
3746
3747   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3748
3749   gfc_set_model_kind (x->ts.kind);
3750
3751   if (mpfr_sgn (x->value.real) == 0)
3752     {
3753       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3754       return result;
3755     }
3756
3757   mpfr_init (absv);
3758   mpfr_init (log2);
3759   mpfr_init (exp);
3760   mpfr_init (pow2);
3761   mpfr_init (frac);
3762
3763   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3764   mpfr_log2 (log2, absv, GFC_RND_MODE);
3765
3766   mpfr_trunc (log2, log2);
3767   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3768
3769   /* Old exponent value, and fraction.  */
3770   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3771
3772   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3773
3774   /* New exponent.  */
3775   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3776   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3777
3778   mpfr_clear (absv);
3779   mpfr_clear (log2);
3780   mpfr_clear (pow2);
3781   mpfr_clear (frac);
3782
3783   return range_check (result, "SET_EXPONENT");
3784 }
3785
3786
3787 gfc_expr *
3788 gfc_simplify_shape (gfc_expr *source)
3789 {
3790   mpz_t shape[GFC_MAX_DIMENSIONS];
3791   gfc_expr *result, *e, *f;
3792   gfc_array_ref *ar;
3793   int n;
3794   try t;
3795
3796   if (source->rank == 0)
3797     return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3798                                   &source->where);
3799
3800   if (source->expr_type != EXPR_VARIABLE)
3801     return NULL;
3802
3803   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3804                                   &source->where);
3805
3806   ar = gfc_find_array_ref (source);
3807
3808   t = gfc_array_ref_shape (ar, shape);
3809
3810   for (n = 0; n < source->rank; n++)
3811     {
3812       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3813                                &source->where);
3814
3815       if (t == SUCCESS)
3816         {
3817           mpz_set (e->value.integer, shape[n]);
3818           mpz_clear (shape[n]);
3819         }
3820       else
3821         {
3822           mpz_set_ui (e->value.integer, n + 1);
3823
3824           f = gfc_simplify_size (source, e, NULL);
3825           gfc_free_expr (e);
3826           if (f == NULL)
3827             {
3828               gfc_free_expr (result);
3829               return NULL;
3830             }
3831           else
3832             {
3833               e = f;
3834             }
3835         }
3836
3837       gfc_append_constructor (result, e);
3838     }
3839
3840   return result;
3841 }
3842
3843
3844 gfc_expr *
3845 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3846 {
3847   mpz_t size;
3848   gfc_expr *result;
3849   int d;
3850   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
3851
3852   if (k == -1)
3853     return &gfc_bad_expr;
3854
3855   if (dim == NULL)
3856     {
3857       if (gfc_array_size (array, &size) == FAILURE)
3858         return NULL;
3859     }
3860   else
3861     {
3862       if (dim->expr_type != EXPR_CONSTANT)
3863         return NULL;
3864
3865       d = mpz_get_ui (dim->value.integer) - 1;
3866       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3867         return NULL;
3868     }
3869
3870   result = gfc_constant_result (BT_INTEGER, k, &array->where);
3871   mpz_set (result->value.integer, size);
3872   return result;
3873 }
3874
3875
3876 gfc_expr *
3877 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3878 {
3879   gfc_expr *result;
3880
3881   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3882     return NULL;
3883
3884   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3885
3886   switch (x->ts.type)
3887     {
3888     case BT_INTEGER:
3889       mpz_abs (result->value.integer, x->value.integer);
3890       if (mpz_sgn (y->value.integer) < 0)
3891         mpz_neg (result->value.integer, result->value.integer);
3892
3893       break;
3894
3895     case BT_REAL:
3896       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3897          it.  */
3898       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3899       if (mpfr_sgn (y->value.real) < 0)
3900         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3901
3902       break;
3903
3904     default:
3905       gfc_internal_error ("Bad type in gfc_simplify_sign");
3906     }
3907
3908   return result;
3909 }
3910
3911
3912 gfc_expr *
3913 gfc_simplify_sin (gfc_expr *x)
3914 {
3915   gfc_expr *result;
3916   mpfr_t xp, xq;
3917
3918   if (x->expr_type != EXPR_CONSTANT)
3919     return NULL;
3920
3921   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3922
3923   switch (x->ts.type)
3924     {
3925     case BT_REAL:
3926       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3927       break;
3928
3929     case BT_COMPLEX:
3930       gfc_set_model (x->value.real);
3931       mpfr_init (xp);
3932       mpfr_init (xq);
3933
3934       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3935       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3936       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3937
3938       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3939       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3940       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3941
3942       mpfr_clear (xp);
3943       mpfr_clear (xq);
3944       break;
3945
3946     default:
3947       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3948     }
3949
3950   return range_check (result, "SIN");
3951 }
3952
3953
3954 gfc_expr *
3955 gfc_simplify_sinh (gfc_expr *x)
3956 {
3957   gfc_expr *result;
3958
3959   if (x->expr_type != EXPR_CONSTANT)
3960     return NULL;
3961
3962   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3963
3964   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3965
3966   return range_check (result, "SINH");
3967 }
3968
3969
3970 /* The argument is always a double precision real that is converted to
3971    single precision.  TODO: Rounding!  */
3972
3973 gfc_expr *
3974 gfc_simplify_sngl (gfc_expr *a)
3975 {
3976   gfc_expr *result;
3977
3978   if (a->expr_type != EXPR_CONSTANT)
3979     return NULL;
3980
3981   result = gfc_real2real (a, gfc_default_real_kind);
3982   return range_check (result, "SNGL");
3983 }
3984
3985
3986 gfc_expr *
3987 gfc_simplify_spacing (gfc_expr *x)
3988 {
3989   gfc_expr *result;
3990   int i;
3991   long int en, ep;
3992
3993   if (x->expr_type != EXPR_CONSTANT)
3994     return NULL;
3995
3996   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3997
3998   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3999
4000   /* Special case x = 0 and -0.  */
4001   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4002   if (mpfr_sgn (result->value.real) == 0)
4003     {
4004       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4005       return result;
4006     }
4007
4008   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4009      are the radix, exponent of x, and precision.  This excludes the
4010      possibility of subnormal numbers.  Fortran 2003 states the result is
4011      b**max(e - p, emin - 1).  */
4012
4013   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4014   en = (long int) gfc_real_kinds[i].min_exponent - 1;
4015   en = en > ep ? en : ep;
4016
4017   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4018   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4019
4020   return range_check (result, "SPACING");
4021 }
4022
4023
4024 gfc_expr *
4025 gfc_simplify_sqrt (gfc_expr *e)
4026 {
4027   gfc_expr *result;
4028   mpfr_t ac, ad, s, t, w;
4029
4030   if (e->expr_type != EXPR_CONSTANT)
4031     return NULL;
4032
4033   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4034
4035   switch (e->ts.type)
4036     {
4037     case BT_REAL:
4038       if (mpfr_cmp_si (e->value.real, 0) < 0)
4039         goto negative_arg;
4040       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4041
4042       break;
4043
4044     case BT_COMPLEX:
4045       /* Formula taken from Numerical Recipes to avoid over- and
4046          underflow.  */
4047
4048       gfc_set_model (e->value.real);
4049       mpfr_init (ac);
4050       mpfr_init (ad);
4051       mpfr_init (s);
4052       mpfr_init (t);
4053       mpfr_init (w);
4054
4055       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4056           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4057         {
4058           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4059           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4060           break;
4061         }
4062
4063       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4064       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4065
4066       if (mpfr_cmp (ac, ad) >= 0)
4067         {
4068           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4069           mpfr_mul (t, t, t, GFC_RND_MODE);
4070           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4071           mpfr_sqrt (t, t, GFC_RND_MODE);
4072           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4073           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4074           mpfr_sqrt (t, t, GFC_RND_MODE);
4075           mpfr_sqrt (s, ac, GFC_RND_MODE);
4076           mpfr_mul (w, s, t, GFC_RND_MODE);
4077         }
4078       else
4079         {
4080           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4081           mpfr_mul (t, s, s, GFC_RND_MODE);
4082           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4083           mpfr_sqrt (t, t, GFC_RND_MODE);
4084           mpfr_abs (s, s, GFC_RND_MODE);
4085           mpfr_add (t, t, s, GFC_RND_MODE);
4086           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4087           mpfr_sqrt (t, t, GFC_RND_MODE);
4088           mpfr_sqrt (s, ad, GFC_RND_MODE);
4089           mpfr_mul (w, s, t, GFC_RND_MODE);
4090         }
4091
4092       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4093         {
4094           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4095           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4096           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4097         }
4098       else if (mpfr_cmp_ui (w, 0) != 0
4099                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4100                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4101         {
4102           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4103           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4104           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4105         }
4106       else if (mpfr_cmp_ui (w, 0) != 0
4107                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4108                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4109         {
4110           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4111           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4112           mpfr_neg (w, w, GFC_RND_MODE);
4113           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4114         }
4115       else
4116         gfc_internal_error ("invalid complex argument of SQRT at %L",
4117                             &e->where);
4118
4119       mpfr_clear (s);
4120       mpfr_clear (t);
4121       mpfr_clear (ac);
4122       mpfr_clear (ad);
4123       mpfr_clear (w);
4124
4125       break;
4126
4127     default:
4128       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4129     }
4130
4131   return range_check (result, "SQRT");
4132
4133 negative_arg:
4134   gfc_free_expr (result);
4135   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4136   return &gfc_bad_expr;
4137 }
4138
4139
4140 gfc_expr *
4141 gfc_simplify_tan (gfc_expr *x)
4142 {
4143   int i;
4144   gfc_expr *result;
4145
4146   if (x->expr_type != EXPR_CONSTANT)
4147     return NULL;
4148
4149   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4150
4151   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4152
4153   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4154
4155   return range_check (result, "TAN");
4156 }
4157
4158
4159 gfc_expr *
4160 gfc_simplify_tanh (gfc_expr *x)
4161 {
4162   gfc_expr *result;
4163
4164   if (x->expr_type != EXPR_CONSTANT)
4165     return NULL;
4166
4167   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4168
4169   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4170
4171   return range_check (result, "TANH");
4172
4173 }
4174
4175
4176 gfc_expr *
4177 gfc_simplify_tiny (gfc_expr *e)
4178 {
4179   gfc_expr *result;
4180   int i;
4181
4182   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4183
4184   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4185   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4186
4187   return result;
4188 }
4189
4190
4191 gfc_expr *
4192 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4193 {
4194   gfc_expr *result;
4195   gfc_expr *mold_element;
4196   size_t source_size;
4197   size_t result_size;
4198   size_t result_elt_size;
4199   size_t buffer_size;
4200   mpz_t tmp;
4201   unsigned char *buffer;
4202
4203   if (!gfc_is_constant_expr (source)
4204         || (gfc_init_expr && !gfc_is_constant_expr (mold))
4205         || !gfc_is_constant_expr (size))
4206     return NULL;
4207
4208   if (source->expr_type == EXPR_FUNCTION)
4209     return NULL;
4210
4211   /* Calculate the size of the source.  */
4212   if (source->expr_type == EXPR_ARRAY
4213       && gfc_array_size (source, &tmp) == FAILURE)
4214     gfc_internal_error ("Failure getting length of a constant array.");
4215
4216   source_size = gfc_target_expr_size (source);
4217
4218   /* Create an empty new expression with the appropriate characteristics.  */
4219   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4220                                 &source->where);
4221   result->ts = mold->ts;
4222
4223   mold_element = mold->expr_type == EXPR_ARRAY
4224                  ? mold->value.constructor->expr
4225                  : mold;
4226
4227   /* Set result character length, if needed.  Note that this needs to be
4228      set even for array expressions, in order to pass this information into
4229      gfc_target_interpret_expr.  */
4230   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4231     result->value.character.length = mold_element->value.character.length;
4232
4233   /* Set the number of elements in the result, and determine its size.  */
4234   result_elt_size = gfc_target_expr_size (mold_element);
4235   if (result_elt_size == 0)
4236     {
4237       gfc_free_expr (result);
4238       return NULL;
4239     }
4240
4241   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4242     {
4243       int result_length;
4244
4245       result->expr_type = EXPR_ARRAY;
4246       result->rank = 1;
4247
4248       if (size)
4249         result_length = (size_t)mpz_get_ui (size->value.integer);
4250       else
4251         {
4252           result_length = source_size / result_elt_size;
4253           if (result_length * result_elt_size < source_size)
4254             result_length += 1;
4255         }
4256
4257       result->shape = gfc_get_shape (1);
4258       mpz_init_set_ui (result->shape[0], result_length);
4259
4260       result_size = result_length * result_elt_size;
4261     }
4262   else
4263     {
4264       result->rank = 0;
4265       result_size = result_elt_size;
4266     }
4267
4268   if (gfc_option.warn_surprising && source_size < result_size)
4269     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4270                 "source size %ld < result size %ld", &source->where,
4271                 (long) source_size, (long) result_size);
4272
4273   /* Allocate the buffer to store the binary version of the source.  */
4274   buffer_size = MAX (source_size, result_size);
4275   buffer = (unsigned char*)alloca (buffer_size);
4276
4277   /* Now write source to the buffer.  */
4278   gfc_target_encode_expr (source, buffer, buffer_size);
4279
4280   /* And read the buffer back into the new expression.  */
4281   gfc_target_interpret_expr (buffer, buffer_size, result);
4282
4283   return result;
4284 }
4285
4286
4287 gfc_expr *
4288 gfc_simplify_trim (gfc_expr *e)
4289 {
4290   gfc_expr *result;
4291   int count, i, len, lentrim;
4292
4293   if (e->expr_type != EXPR_CONSTANT)
4294     return NULL;
4295
4296   len = e->value.character.length;
4297
4298   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4299
4300   for (count = 0, i = 1; i <= len; ++i)
4301     {
4302       if (e->value.character.string[len - i] == ' ')
4303         count++;
4304       else
4305         break;
4306     }
4307
4308   lentrim = len - count;
4309
4310   result->value.character.length = lentrim;
4311   result->value.character.string = gfc_getmem (lentrim + 1);
4312
4313   for (i = 0; i < lentrim; i++)
4314     result->value.character.string[i] = e->value.character.string[i];
4315
4316   result->value.character.string[lentrim] = '\0';       /* For debugger */
4317
4318   return result;
4319 }
4320
4321
4322 gfc_expr *
4323 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4324 {
4325   return simplify_bound (array, dim, kind, 1);
4326 }
4327
4328
4329 gfc_expr *
4330 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4331 {
4332   gfc_expr *result;
4333   int back;
4334   size_t index, len, lenset;
4335   size_t i;
4336   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4337
4338   if (k == -1)
4339     return &gfc_bad_expr;
4340
4341   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4342     return NULL;
4343
4344   if (b != NULL && b->value.logical != 0)
4345     back = 1;
4346   else
4347     back = 0;
4348
4349   result = gfc_constant_result (BT_INTEGER, k, &s->where);
4350
4351   len = s->value.character.length;
4352   lenset = set->value.character.length;
4353
4354   if (len == 0)
4355     {
4356       mpz_set_ui (result->value.integer, 0);
4357       return result;
4358     }
4359
4360   if (back == 0)
4361     {
4362       if (lenset == 0)
4363         {
4364           mpz_set_ui (result->value.integer, 1);
4365           return result;
4366         }
4367
4368       index = strspn (s->value.character.string, set->value.character.string)
4369             + 1;
4370       if (index > len)
4371         index = 0;
4372
4373     }
4374   else
4375     {
4376       if (lenset == 0)
4377         {
4378           mpz_set_ui (result->value.integer, len);
4379           return result;
4380         }
4381       for (index = len; index > 0; index --)
4382         {
4383           for (i = 0; i < lenset; i++)
4384             {
4385               if (s->value.character.string[index - 1]
4386                   == set->value.character.string[i])
4387                 break;
4388             }
4389           if (i == lenset)
4390             break;
4391         }
4392     }
4393
4394   mpz_set_ui (result->value.integer, index);
4395   return result;
4396 }
4397
4398
4399 gfc_expr *
4400 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4401 {
4402   gfc_expr *result;
4403   int kind;
4404
4405   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4406     return NULL;
4407
4408   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4409   if (x->ts.type == BT_INTEGER)
4410     {
4411       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4412       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4413     }
4414   else /* BT_LOGICAL */
4415     {
4416       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4417       result->value.logical = (x->value.logical && !y->value.logical)
4418                               || (!x->value.logical && y->value.logical);
4419     }
4420
4421   return range_check (result, "XOR");
4422 }
4423
4424
4425 /****************** Constant simplification *****************/
4426
4427 /* Master function to convert one constant to another.  While this is
4428    used as a simplification function, it requires the destination type
4429    and kind information which is supplied by a special case in
4430    do_simplify().  */
4431
4432 gfc_expr *
4433 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4434 {
4435   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4436   gfc_constructor *head, *c, *tail = NULL;
4437
4438   switch (e->ts.type)
4439     {
4440     case BT_INTEGER:
4441       switch (type)
4442         {
4443         case BT_INTEGER:
4444           f = gfc_int2int;
4445           break;
4446         case BT_REAL:
4447           f = gfc_int2real;
4448           break;
4449         case BT_COMPLEX:
4450           f = gfc_int2complex;
4451           break;
4452         case BT_LOGICAL:
4453           f = gfc_int2log;
4454           break;
4455         default:
4456           goto oops;
4457         }
4458       break;
4459
4460     case BT_REAL:
4461       switch (type)
4462         {
4463         case BT_INTEGER:
4464           f = gfc_real2int;
4465           break;
4466         case BT_REAL:
4467           f = gfc_real2real;
4468           break;
4469         case BT_COMPLEX:
4470           f = gfc_real2complex;
4471           break;
4472         default:
4473           goto oops;
4474         }
4475       break;
4476
4477     case BT_COMPLEX:
4478       switch (type)
4479         {
4480         case BT_INTEGER:
4481           f = gfc_complex2int;
4482           break;
4483         case BT_REAL:
4484           f = gfc_complex2real;
4485           break;
4486         case BT_COMPLEX:
4487           f = gfc_complex2complex;
4488           break;
4489
4490         default:
4491           goto oops;
4492         }
4493       break;
4494
4495     case BT_LOGICAL:
4496       switch (type)
4497         {
4498         case BT_INTEGER:
4499           f = gfc_log2int;
4500           break;
4501         case BT_LOGICAL:
4502           f = gfc_log2log;
4503           break;
4504         default:
4505           goto oops;
4506         }
4507       break;
4508
4509     case BT_HOLLERITH:
4510       switch (type)
4511         {
4512         case BT_INTEGER:
4513           f = gfc_hollerith2int;
4514           break;
4515
4516         case BT_REAL:
4517           f = gfc_hollerith2real;
4518           break;
4519
4520         case BT_COMPLEX:
4521           f = gfc_hollerith2complex;
4522           break;
4523
4524         case BT_CHARACTER:
4525           f = gfc_hollerith2character;
4526           break;
4527
4528         case BT_LOGICAL:
4529           f = gfc_hollerith2logical;
4530           break;
4531
4532         default:
4533           goto oops;
4534         }
4535       break;
4536
4537     default:
4538     oops:
4539       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4540     }
4541
4542   result = NULL;
4543
4544   switch (e->expr_type)
4545     {
4546     case EXPR_CONSTANT:
4547       result = f (e, kind);
4548       if (result == NULL)
4549         return &gfc_bad_expr;
4550       break;
4551
4552     case EXPR_ARRAY:
4553       if (!gfc_is_constant_expr (e))
4554         break;
4555
4556       head = NULL;
4557
4558       for (c = e->value.constructor; c; c = c->next)
4559         {
4560           if (head == NULL)
4561             head = tail = gfc_get_constructor ();
4562           else
4563             {
4564               tail->next = gfc_get_constructor ();
4565               tail = tail->next;
4566             }
4567
4568           tail->where = c->where;
4569
4570           if (c->iterator == NULL)
4571             tail->expr = f (c->expr, kind);
4572           else
4573             {
4574               g = gfc_convert_constant (c->expr, type, kind);
4575               if (g == &gfc_bad_expr)
4576                 return g;
4577               tail->expr = g;
4578             }
4579
4580           if (tail->expr == NULL)
4581             {
4582               gfc_free_constructor (head);
4583               return NULL;
4584             }
4585         }
4586
4587       result = gfc_get_expr ();
4588       result->ts.type = type;
4589       result->ts.kind = kind;
4590       result->expr_type = EXPR_ARRAY;
4591       result->value.constructor = head;
4592       result->shape = gfc_copy_shape (e->shape, e->rank);
4593       result->where = e->where;
4594       result->rank = e->rank;
4595       break;
4596
4597     default:
4598       break;
4599     }
4600
4601   return result;
4602 }