gcc/fortran/simplify.c

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