gcc/fortran/simplify.c

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