gcc/fortran/simplify.c

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