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