gcc/fortran/simplify.c

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