gcc/fortran/simplify.c

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