gcc/fortran/simplify.c

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