gcc/fortran/simplify.c

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