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