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   if (e->expr_type != EXPR_CONSTANT)
2645     return NULL;
2646
2647   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2648
2649   result->value.character.string = gfc_getmem (2);
2650
2651   result->value.character.length = 1;
2652   result->value.character.string[0] = '\n';
2653   result->value.character.string[1] = '\0';     /* For debugger */
2654   return result;
2655 }
2656
2657
2658 gfc_expr *
2659 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2660 {
2661   return simplify_nint ("NINT", e, k);
2662 }
2663
2664
2665 gfc_expr *
2666 gfc_simplify_idnint (gfc_expr *e)
2667 {
2668   return simplify_nint ("IDNINT", e, NULL);
2669 }
2670
2671
2672 gfc_expr *
2673 gfc_simplify_not (gfc_expr *e)
2674 {
2675   gfc_expr *result;
2676
2677   if (e->expr_type != EXPR_CONSTANT)
2678     return NULL;
2679
2680   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2681
2682   mpz_com (result->value.integer, e->value.integer);
2683
2684   return range_check (result, "NOT");
2685 }
2686
2687
2688 gfc_expr *
2689 gfc_simplify_null (gfc_expr *mold)
2690 {
2691   gfc_expr *result;
2692
2693   if (mold == NULL)
2694     {
2695       result = gfc_get_expr ();
2696       result->ts.type = BT_UNKNOWN;
2697     }
2698   else
2699     result = gfc_copy_expr (mold);
2700   result->expr_type = EXPR_NULL;
2701
2702   return result;
2703 }
2704
2705
2706 gfc_expr *
2707 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2708 {
2709   gfc_expr *result;
2710   int kind;
2711
2712   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2713     return NULL;
2714
2715   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2716   if (x->ts.type == BT_INTEGER)
2717     {
2718       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2719       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2720     }
2721   else /* BT_LOGICAL */
2722     {
2723       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2724       result->value.logical = x->value.logical || y->value.logical;
2725     }
2726
2727   return range_check (result, "OR");
2728 }
2729
2730
2731 gfc_expr *
2732 gfc_simplify_precision (gfc_expr *e)
2733 {
2734   gfc_expr *result;
2735   int i;
2736
2737   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2738
2739   result = gfc_int_expr (gfc_real_kinds[i].precision);
2740   result->where = e->where;
2741
2742   return result;
2743 }
2744
2745
2746 gfc_expr *
2747 gfc_simplify_radix (gfc_expr *e)
2748 {
2749   gfc_expr *result;
2750   int i;
2751
2752   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2753   switch (e->ts.type)
2754     {
2755     case BT_INTEGER:
2756       i = gfc_integer_kinds[i].radix;
2757       break;
2758
2759     case BT_REAL:
2760       i = gfc_real_kinds[i].radix;
2761       break;
2762
2763     default:
2764       gcc_unreachable ();
2765     }
2766
2767   result = gfc_int_expr (i);
2768   result->where = e->where;
2769
2770   return result;
2771 }
2772
2773
2774 gfc_expr *
2775 gfc_simplify_range (gfc_expr *e)
2776 {
2777   gfc_expr *result;
2778   int i;
2779   long j;
2780
2781   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2782
2783   switch (e->ts.type)
2784     {
2785     case BT_INTEGER:
2786       j = gfc_integer_kinds[i].range;
2787       break;
2788
2789     case BT_REAL:
2790     case BT_COMPLEX:
2791       j = gfc_real_kinds[i].range;
2792       break;
2793
2794     default:
2795       gcc_unreachable ();
2796     }
2797
2798   result = gfc_int_expr (j);
2799   result->where = e->where;
2800
2801   return result;
2802 }
2803
2804
2805 gfc_expr *
2806 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2807 {
2808   gfc_expr *result;
2809   int kind;
2810
2811   if (e->ts.type == BT_COMPLEX)
2812     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2813   else
2814     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2815
2816   if (kind == -1)
2817     return &gfc_bad_expr;
2818
2819   if (e->expr_type != EXPR_CONSTANT)
2820     return NULL;
2821
2822   switch (e->ts.type)
2823     {
2824     case BT_INTEGER:
2825       result = gfc_int2real (e, kind);
2826       break;
2827
2828     case BT_REAL:
2829       result = gfc_real2real (e, kind);
2830       break;
2831
2832     case BT_COMPLEX:
2833       result = gfc_complex2real (e, kind);
2834       break;
2835
2836     default:
2837       gfc_internal_error ("bad type in REAL");
2838       /* Not reached */
2839     }
2840
2841   return range_check (result, "REAL");
2842 }
2843
2844
2845 gfc_expr *
2846 gfc_simplify_realpart (gfc_expr *e)
2847 {
2848   gfc_expr *result;
2849
2850   if (e->expr_type != EXPR_CONSTANT)
2851     return NULL;
2852
2853   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2854   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2855
2856   return range_check (result, "REALPART");
2857 }
2858
2859 gfc_expr *
2860 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
2861 {
2862   gfc_expr *result;
2863   int i, j, len, ncop, nlen;
2864   mpz_t ncopies;
2865
2866   /* If NCOPIES isn't a constant, there's nothing we can do.  */
2867   if (n->expr_type != EXPR_CONSTANT)
2868     return NULL;
2869
2870   /* If NCOPIES is negative, it's an error.  */
2871   if (mpz_sgn (n->value.integer) < 0)
2872     {
2873       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2874                  &n->where);
2875       return &gfc_bad_expr;
2876     }
2877
2878   /* If we don't know the character length, we can do no more.  */
2879   if (e->ts.cl == NULL || e->ts.cl->length == NULL
2880       || e->ts.cl->length->expr_type != EXPR_CONSTANT)
2881     return NULL;
2882
2883   /* If the source length is 0, any value of NCOPIES is valid
2884      and everything behaves as if NCOPIES == 0.  */
2885   mpz_init (ncopies);
2886   if (mpz_sgn (e->ts.cl->length->value.integer) == 0)
2887     mpz_set_ui (ncopies, 0);
2888   else
2889     mpz_set (ncopies, n->value.integer);
2890
2891   /* Check that NCOPIES isn't too large.  */
2892   if (mpz_sgn (e->ts.cl->length->value.integer) != 0)
2893     {
2894       mpz_t max;
2895       int i;
2896
2897       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
2898       mpz_init (max);
2899       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2900       mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
2901                   e->ts.cl->length->value.integer);
2902
2903       /* The check itself.  */
2904       if (mpz_cmp (ncopies, max) > 0)
2905         {
2906           mpz_clear (max);
2907           mpz_clear (ncopies);
2908           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2909                      &n->where);
2910           return &gfc_bad_expr;
2911         }
2912
2913       mpz_clear (max);
2914     }
2915   mpz_clear (ncopies);
2916
2917   /* For further simplification, we need the character string to be
2918      constant.  */
2919   if (e->expr_type != EXPR_CONSTANT)
2920     return NULL;
2921
2922   if (mpz_sgn (e->ts.cl->length->value.integer) != 0)
2923     {
2924       const char *res = gfc_extract_int (n, &ncop);
2925       gcc_assert (res == NULL);
2926     }
2927   else
2928     ncop = 0;
2929
2930   len = e->value.character.length;
2931   nlen = ncop * len;
2932
2933   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2934
2935   if (ncop == 0)
2936     {
2937       result->value.character.string = gfc_getmem (1);
2938       result->value.character.length = 0;
2939       result->value.character.string[0] = '\0';
2940       return result;
2941     }
2942
2943   result->value.character.length = nlen;
2944   result->value.character.string = gfc_getmem (nlen + 1);
2945
2946   for (i = 0; i < ncop; i++)
2947     for (j = 0; j < len; j++)
2948       result->value.character.string[j + i * len]
2949       = e->value.character.string[j];
2950
2951   result->value.character.string[nlen] = '\0';  /* For debugger */
2952   return result;
2953 }
2954
2955
2956 /* This one is a bear, but mainly has to do with shuffling elements.  */
2957
2958 gfc_expr *
2959 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
2960                       gfc_expr *pad, gfc_expr *order_exp)
2961 {
2962   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2963   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2964   gfc_constructor *head, *tail;
2965   mpz_t index, size;
2966   unsigned long j;
2967   size_t nsource;
2968   gfc_expr *e;
2969
2970   /* Unpack the shape array.  */
2971   if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2972     return NULL;
2973
2974   if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2975     return NULL;
2976
2977   if (pad != NULL
2978       && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
2979     return NULL;
2980
2981   if (order_exp != NULL
2982       && (order_exp->expr_type != EXPR_ARRAY
2983           || !gfc_is_constant_expr (order_exp)))
2984     return NULL;
2985
2986   mpz_init (index);
2987   rank = 0;
2988   head = tail = NULL;
2989
2990   for (;;)
2991     {
2992       e = gfc_get_array_element (shape_exp, rank);
2993       if (e == NULL)
2994         break;
2995
2996       if (gfc_extract_int (e, &shape[rank]) != NULL)
2997         {
2998           gfc_error ("Integer too large in shape specification at %L",
2999                      &e->where);
3000           gfc_free_expr (e);
3001           goto bad_reshape;
3002         }
3003
3004       gfc_free_expr (e);
3005
3006       if (rank >= GFC_MAX_DIMENSIONS)
3007         {
3008           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3009                      "at %L", &e->where);
3010
3011           goto bad_reshape;
3012         }
3013
3014       if (shape[rank] < 0)
3015         {
3016           gfc_error ("Shape specification at %L cannot be negative",
3017                      &e->where);
3018           goto bad_reshape;
3019         }
3020
3021       rank++;
3022     }
3023
3024   if (rank == 0)
3025     {
3026       gfc_error ("Shape specification at %L cannot be the null array",
3027                  &shape_exp->where);
3028       goto bad_reshape;
3029     }
3030
3031   /* Now unpack the order array if present.  */
3032   if (order_exp == NULL)
3033     {
3034       for (i = 0; i < rank; i++)
3035         order[i] = i;
3036     }
3037   else
3038     {
3039       for (i = 0; i < rank; i++)
3040         x[i] = 0;
3041
3042       for (i = 0; i < rank; i++)
3043         {
3044           e = gfc_get_array_element (order_exp, i);
3045           if (e == NULL)
3046             {
3047               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3048                          "size as SHAPE parameter", &order_exp->where);
3049               goto bad_reshape;
3050             }
3051
3052           if (gfc_extract_int (e, &order[i]) != NULL)
3053             {
3054               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3055                          &e->where);
3056               gfc_free_expr (e);
3057               goto bad_reshape;
3058             }
3059
3060           gfc_free_expr (e);
3061
3062           if (order[i] < 1 || order[i] > rank)
3063             {
3064               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3065                          &e->where);
3066               goto bad_reshape;
3067             }
3068
3069           order[i]--;
3070
3071           if (x[order[i]])
3072             {
3073               gfc_error ("Invalid permutation in ORDER parameter at %L",
3074                          &e->where);
3075               goto bad_reshape;
3076             }
3077
3078           x[order[i]] = 1;
3079         }
3080     }
3081
3082   /* Count the elements in the source and padding arrays.  */
3083
3084   npad = 0;
3085   if (pad != NULL)
3086     {
3087       gfc_array_size (pad, &size);
3088       npad = mpz_get_ui (size);
3089       mpz_clear (size);
3090     }
3091
3092   gfc_array_size (source, &size);
3093   nsource = mpz_get_ui (size);
3094   mpz_clear (size);
3095
3096   /* If it weren't for that pesky permutation we could just loop
3097      through the source and round out any shortage with pad elements.
3098      But no, someone just had to have the compiler do something the
3099      user should be doing.  */
3100
3101   for (i = 0; i < rank; i++)
3102     x[i] = 0;
3103
3104   for (;;)
3105     {
3106       /* Figure out which element to extract.  */
3107       mpz_set_ui (index, 0);
3108
3109       for (i = rank - 1; i >= 0; i--)
3110         {
3111           mpz_add_ui (index, index, x[order[i]]);
3112           if (i != 0)
3113             mpz_mul_ui (index, index, shape[order[i - 1]]);
3114         }
3115
3116       if (mpz_cmp_ui (index, INT_MAX) > 0)
3117         gfc_internal_error ("Reshaped array too large at %L", &e->where);
3118
3119       j = mpz_get_ui (index);
3120
3121       if (j < nsource)
3122         e = gfc_get_array_element (source, j);
3123       else
3124         {
3125           j = j - nsource;
3126
3127           if (npad == 0)
3128             {
3129               gfc_error ("PAD parameter required for short SOURCE parameter "
3130                          "at %L", &source->where);
3131               goto bad_reshape;
3132             }
3133
3134           j = j % npad;
3135           e = gfc_get_array_element (pad, j);
3136         }
3137
3138       if (head == NULL)
3139         head = tail = gfc_get_constructor ();
3140       else
3141         {
3142           tail->next = gfc_get_constructor ();
3143           tail = tail->next;
3144         }
3145
3146       if (e == NULL)
3147         goto bad_reshape;
3148
3149       tail->where = e->where;
3150       tail->expr = e;
3151
3152       /* Calculate the next element.  */
3153       i = 0;
3154
3155 inc:
3156       if (++x[i] < shape[i])
3157         continue;
3158       x[i++] = 0;
3159       if (i < rank)
3160         goto inc;
3161
3162       break;
3163     }
3164
3165   mpz_clear (index);
3166
3167   e = gfc_get_expr ();
3168   e->where = source->where;
3169   e->expr_type = EXPR_ARRAY;
3170   e->value.constructor = head;
3171   e->shape = gfc_get_shape (rank);
3172
3173   for (i = 0; i < rank; i++)
3174     mpz_init_set_ui (e->shape[i], shape[i]);
3175
3176   e->ts = source->ts;
3177   e->rank = rank;
3178
3179   return e;
3180
3181 bad_reshape:
3182   gfc_free_constructor (head);
3183   mpz_clear (index);
3184   return &gfc_bad_expr;
3185 }
3186
3187
3188 gfc_expr *
3189 gfc_simplify_rrspacing (gfc_expr *x)
3190 {
3191   gfc_expr *result;
3192   int i;
3193   long int e, p;
3194
3195   if (x->expr_type != EXPR_CONSTANT)
3196     return NULL;
3197
3198   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3199
3200   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3201
3202   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3203
3204   /* Special case x = -0 and 0.  */
3205   if (mpfr_sgn (result->value.real) == 0)
3206     {
3207       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3208       return result;
3209     }
3210
3211   /* | x * 2**(-e) | * 2**p.  */
3212   e = - (long int) mpfr_get_exp (x->value.real);
3213   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3214
3215   p = (long int) gfc_real_kinds[i].digits;
3216   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3217
3218   return range_check (result, "RRSPACING");
3219 }
3220
3221
3222 gfc_expr *
3223 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3224 {
3225   int k, neg_flag, power, exp_range;
3226   mpfr_t scale, radix;
3227   gfc_expr *result;
3228
3229   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3230     return NULL;
3231
3232   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3233
3234   if (mpfr_sgn (x->value.real) == 0)
3235     {
3236       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3237       return result;
3238     }
3239
3240   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3241
3242   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3243
3244   /* This check filters out values of i that would overflow an int.  */
3245   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3246       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3247     {
3248       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3249       return &gfc_bad_expr;
3250     }
3251
3252   /* Compute scale = radix ** power.  */
3253   power = mpz_get_si (i->value.integer);
3254
3255   if (power >= 0)
3256     neg_flag = 0;
3257   else
3258     {
3259       neg_flag = 1;
3260       power = -power;
3261     }
3262
3263   gfc_set_model_kind (x->ts.kind);
3264   mpfr_init (scale);
3265   mpfr_init (radix);
3266   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3267   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3268
3269   if (neg_flag)
3270     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3271   else
3272     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3273
3274   mpfr_clear (scale);
3275   mpfr_clear (radix);
3276
3277   return range_check (result, "SCALE");
3278 }
3279
3280
3281 gfc_expr *
3282 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
3283 {
3284   gfc_expr *result;
3285   int back;
3286   size_t i;
3287   size_t indx, len, lenc;
3288
3289   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3290     return NULL;
3291
3292   if (b != NULL && b->value.logical != 0)
3293     back = 1;
3294   else
3295     back = 0;
3296
3297   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3298                                 &e->where);
3299
3300   len = e->value.character.length;
3301   lenc = c->value.character.length;
3302
3303   if (len == 0 || lenc == 0)
3304     {
3305       indx = 0;
3306     }
3307   else
3308     {
3309       if (back == 0)
3310         {
3311           indx = strcspn (e->value.character.string, c->value.character.string)
3312                + 1;
3313           if (indx > len)
3314             indx = 0;
3315         }
3316       else
3317         {
3318           i = 0;
3319           for (indx = len; indx > 0; indx--)
3320             {
3321               for (i = 0; i < lenc; i++)
3322                 {
3323                   if (c->value.character.string[i]
3324                       == e->value.character.string[indx - 1])
3325                     break;
3326                 }
3327               if (i < lenc)
3328                 break;
3329             }
3330         }
3331     }
3332   mpz_set_ui (result->value.integer, indx);
3333   return range_check (result, "SCAN");
3334 }
3335
3336
3337 gfc_expr *
3338 gfc_simplify_selected_int_kind (gfc_expr *e)
3339 {
3340   int i, kind, range;
3341   gfc_expr *result;
3342
3343   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3344     return NULL;
3345
3346   kind = INT_MAX;
3347
3348   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3349     if (gfc_integer_kinds[i].range >= range
3350         && gfc_integer_kinds[i].kind < kind)
3351       kind = gfc_integer_kinds[i].kind;
3352
3353   if (kind == INT_MAX)
3354     kind = -1;
3355
3356   result = gfc_int_expr (kind);
3357   result->where = e->where;
3358
3359   return result;
3360 }
3361
3362
3363 gfc_expr *
3364 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3365 {
3366   int range, precision, i, kind, found_precision, found_range;
3367   gfc_expr *result;
3368
3369   if (p == NULL)
3370     precision = 0;
3371   else
3372     {
3373       if (p->expr_type != EXPR_CONSTANT
3374           || gfc_extract_int (p, &precision) != NULL)
3375         return NULL;
3376     }
3377
3378   if (q == NULL)
3379     range = 0;
3380   else
3381     {
3382       if (q->expr_type != EXPR_CONSTANT
3383           || gfc_extract_int (q, &range) != NULL)
3384         return NULL;
3385     }
3386
3387   kind = INT_MAX;
3388   found_precision = 0;
3389   found_range = 0;
3390
3391   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3392     {
3393       if (gfc_real_kinds[i].precision >= precision)
3394         found_precision = 1;
3395
3396       if (gfc_real_kinds[i].range >= range)
3397         found_range = 1;
3398
3399       if (gfc_real_kinds[i].precision >= precision
3400           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3401         kind = gfc_real_kinds[i].kind;
3402     }
3403
3404   if (kind == INT_MAX)
3405     {
3406       kind = 0;
3407
3408       if (!found_precision)
3409         kind = -1;
3410       if (!found_range)
3411         kind -= 2;
3412     }
3413
3414   result = gfc_int_expr (kind);
3415   result->where = (p != NULL) ? p->where : q->where;
3416
3417   return result;
3418 }
3419
3420
3421 gfc_expr *
3422 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3423 {
3424   gfc_expr *result;
3425   mpfr_t exp, absv, log2, pow2, frac;
3426   unsigned long exp2;
3427
3428   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3429     return NULL;
3430
3431   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3432
3433   gfc_set_model_kind (x->ts.kind);
3434
3435   if (mpfr_sgn (x->value.real) == 0)
3436     {
3437       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3438       return result;
3439     }
3440
3441   mpfr_init (absv);
3442   mpfr_init (log2);
3443   mpfr_init (exp);
3444   mpfr_init (pow2);
3445   mpfr_init (frac);
3446
3447   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3448   mpfr_log2 (log2, absv, GFC_RND_MODE);
3449
3450   mpfr_trunc (log2, log2);
3451   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3452
3453   /* Old exponent value, and fraction.  */
3454   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3455
3456   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3457
3458   /* New exponent.  */
3459   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3460   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3461
3462   mpfr_clear (absv);
3463   mpfr_clear (log2);
3464   mpfr_clear (pow2);
3465   mpfr_clear (frac);
3466
3467   return range_check (result, "SET_EXPONENT");
3468 }
3469
3470
3471 gfc_expr *
3472 gfc_simplify_shape (gfc_expr *source)
3473 {
3474   mpz_t shape[GFC_MAX_DIMENSIONS];
3475   gfc_expr *result, *e, *f;
3476   gfc_array_ref *ar;
3477   int n;
3478   try t;
3479
3480   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3481     return NULL;
3482
3483   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3484                                   &source->where);
3485
3486   ar = gfc_find_array_ref (source);
3487
3488   t = gfc_array_ref_shape (ar, shape);
3489
3490   for (n = 0; n < source->rank; n++)
3491     {
3492       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3493                                &source->where);
3494
3495       if (t == SUCCESS)
3496         {
3497           mpz_set (e->value.integer, shape[n]);
3498           mpz_clear (shape[n]);
3499         }
3500       else
3501         {
3502           mpz_set_ui (e->value.integer, n + 1);
3503
3504           f = gfc_simplify_size (source, e);
3505           gfc_free_expr (e);
3506           if (f == NULL)
3507             {
3508               gfc_free_expr (result);
3509               return NULL;
3510             }
3511           else
3512             {
3513               e = f;
3514             }
3515         }
3516
3517       gfc_append_constructor (result, e);
3518     }
3519
3520   return result;
3521 }
3522
3523
3524 gfc_expr *
3525 gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
3526 {
3527   mpz_t size;
3528   gfc_expr *result;
3529   int d;
3530
3531   if (dim == NULL)
3532     {
3533       if (gfc_array_size (array, &size) == FAILURE)
3534         return NULL;
3535     }
3536   else
3537     {
3538       if (dim->expr_type != EXPR_CONSTANT)
3539         return NULL;
3540
3541       d = mpz_get_ui (dim->value.integer) - 1;
3542       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3543         return NULL;
3544     }
3545
3546   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3547                                 &array->where);
3548
3549   mpz_set (result->value.integer, size);
3550
3551   return result;
3552 }
3553
3554
3555 gfc_expr *
3556 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3557 {
3558   gfc_expr *result;
3559
3560   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3561     return NULL;
3562
3563   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3564
3565   switch (x->ts.type)
3566     {
3567     case BT_INTEGER:
3568       mpz_abs (result->value.integer, x->value.integer);
3569       if (mpz_sgn (y->value.integer) < 0)
3570         mpz_neg (result->value.integer, result->value.integer);
3571
3572       break;
3573
3574     case BT_REAL:
3575       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3576          it.  */
3577       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3578       if (mpfr_sgn (y->value.real) < 0)
3579         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3580
3581       break;
3582
3583     default:
3584       gfc_internal_error ("Bad type in gfc_simplify_sign");
3585     }
3586
3587   return result;
3588 }
3589
3590
3591 gfc_expr *
3592 gfc_simplify_sin (gfc_expr *x)
3593 {
3594   gfc_expr *result;
3595   mpfr_t xp, xq;
3596
3597   if (x->expr_type != EXPR_CONSTANT)
3598     return NULL;
3599
3600   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3601
3602   switch (x->ts.type)
3603     {
3604     case BT_REAL:
3605       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3606       break;
3607
3608     case BT_COMPLEX:
3609       gfc_set_model (x->value.real);
3610       mpfr_init (xp);
3611       mpfr_init (xq);
3612
3613       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3614       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3615       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3616
3617       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3618       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3619       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3620
3621       mpfr_clear (xp);
3622       mpfr_clear (xq);
3623       break;
3624
3625     default:
3626       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3627     }
3628
3629   return range_check (result, "SIN");
3630 }
3631
3632
3633 gfc_expr *
3634 gfc_simplify_sinh (gfc_expr *x)
3635 {
3636   gfc_expr *result;
3637
3638   if (x->expr_type != EXPR_CONSTANT)
3639     return NULL;
3640
3641   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3642
3643   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3644
3645   return range_check (result, "SINH");
3646 }
3647
3648
3649 /* The argument is always a double precision real that is converted to
3650    single precision.  TODO: Rounding!  */
3651
3652 gfc_expr *
3653 gfc_simplify_sngl (gfc_expr *a)
3654 {
3655   gfc_expr *result;
3656
3657   if (a->expr_type != EXPR_CONSTANT)
3658     return NULL;
3659
3660   result = gfc_real2real (a, gfc_default_real_kind);
3661   return range_check (result, "SNGL");
3662 }
3663
3664
3665 gfc_expr *
3666 gfc_simplify_spacing (gfc_expr *x)
3667 {
3668   gfc_expr *result;
3669   int i;
3670   long int en, ep;
3671
3672   if (x->expr_type != EXPR_CONSTANT)
3673     return NULL;
3674
3675   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3676
3677   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3678
3679   /* Special case x = 0 and -0.  */
3680   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3681   if (mpfr_sgn (result->value.real) == 0)
3682     {
3683       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3684       return result;
3685     }
3686
3687   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3688      are the radix, exponent of x, and precision.  This excludes the
3689      possibility of subnormal numbers.  Fortran 2003 states the result is
3690      b**max(e - p, emin - 1).  */
3691
3692   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3693   en = (long int) gfc_real_kinds[i].min_exponent - 1;
3694   en = en > ep ? en : ep;
3695
3696   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3697   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3698
3699   return range_check (result, "SPACING");
3700 }
3701
3702
3703 gfc_expr *
3704 gfc_simplify_sqrt (gfc_expr *e)
3705 {
3706   gfc_expr *result;
3707   mpfr_t ac, ad, s, t, w;
3708
3709   if (e->expr_type != EXPR_CONSTANT)
3710     return NULL;
3711
3712   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3713
3714   switch (e->ts.type)
3715     {
3716     case BT_REAL:
3717       if (mpfr_cmp_si (e->value.real, 0) < 0)
3718         goto negative_arg;
3719       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3720
3721       break;
3722
3723     case BT_COMPLEX:
3724       /* Formula taken from Numerical Recipes to avoid over- and
3725          underflow.  */
3726
3727       gfc_set_model (e->value.real);
3728       mpfr_init (ac);
3729       mpfr_init (ad);
3730       mpfr_init (s);
3731       mpfr_init (t);
3732       mpfr_init (w);
3733
3734       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3735           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3736         {
3737           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3738           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3739           break;
3740         }
3741
3742       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3743       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3744
3745       if (mpfr_cmp (ac, ad) >= 0)
3746         {
3747           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3748           mpfr_mul (t, t, t, GFC_RND_MODE);
3749           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3750           mpfr_sqrt (t, t, GFC_RND_MODE);
3751           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3752           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3753           mpfr_sqrt (t, t, GFC_RND_MODE);
3754           mpfr_sqrt (s, ac, GFC_RND_MODE);
3755           mpfr_mul (w, s, t, GFC_RND_MODE);
3756         }
3757       else
3758         {
3759           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3760           mpfr_mul (t, s, s, GFC_RND_MODE);
3761           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3762           mpfr_sqrt (t, t, GFC_RND_MODE);
3763           mpfr_abs (s, s, GFC_RND_MODE);
3764           mpfr_add (t, t, s, GFC_RND_MODE);
3765           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3766           mpfr_sqrt (t, t, GFC_RND_MODE);
3767           mpfr_sqrt (s, ad, GFC_RND_MODE);
3768           mpfr_mul (w, s, t, GFC_RND_MODE);
3769         }
3770
3771       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3772         {
3773           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3774           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3775           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3776         }
3777       else if (mpfr_cmp_ui (w, 0) != 0
3778                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3779                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3780         {
3781           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3782           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3783           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3784         }
3785       else if (mpfr_cmp_ui (w, 0) != 0
3786                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3787                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3788         {
3789           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3790           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3791           mpfr_neg (w, w, GFC_RND_MODE);
3792           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3793         }
3794       else
3795         gfc_internal_error ("invalid complex argument of SQRT at %L",
3796                             &e->where);
3797
3798       mpfr_clear (s);
3799       mpfr_clear (t);
3800       mpfr_clear (ac);
3801       mpfr_clear (ad);
3802       mpfr_clear (w);
3803
3804       break;
3805
3806     default:
3807       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3808     }
3809
3810   return range_check (result, "SQRT");
3811
3812 negative_arg:
3813   gfc_free_expr (result);
3814   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3815   return &gfc_bad_expr;
3816 }
3817
3818
3819 gfc_expr *
3820 gfc_simplify_tan (gfc_expr *x)
3821 {
3822   int i;
3823   gfc_expr *result;
3824
3825   if (x->expr_type != EXPR_CONSTANT)
3826     return NULL;
3827
3828   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3829
3830   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3831
3832   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3833
3834   return range_check (result, "TAN");
3835 }
3836
3837
3838 gfc_expr *
3839 gfc_simplify_tanh (gfc_expr *x)
3840 {
3841   gfc_expr *result;
3842
3843   if (x->expr_type != EXPR_CONSTANT)
3844     return NULL;
3845
3846   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3847
3848   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3849
3850   return range_check (result, "TANH");
3851
3852 }
3853
3854
3855 gfc_expr *
3856 gfc_simplify_tiny (gfc_expr *e)
3857 {
3858   gfc_expr *result;
3859   int i;
3860
3861   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3862
3863   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3864   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3865
3866   return result;
3867 }
3868
3869
3870 gfc_expr *
3871 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3872 {
3873   /* Reference mold and size to suppress warning.  */
3874   if (gfc_init_expr && (mold || size))
3875     gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
3876                &source->where);
3877
3878   return NULL;
3879 }
3880
3881
3882 gfc_expr *
3883 gfc_simplify_trim (gfc_expr *e)
3884 {
3885   gfc_expr *result;
3886   int count, i, len, lentrim;
3887
3888   if (e->expr_type != EXPR_CONSTANT)
3889     return NULL;
3890
3891   len = e->value.character.length;
3892
3893   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3894
3895   for (count = 0, i = 1; i <= len; ++i)
3896     {
3897       if (e->value.character.string[len - i] == ' ')
3898         count++;
3899       else
3900         break;
3901     }
3902
3903   lentrim = len - count;
3904
3905   result->value.character.length = lentrim;
3906   result->value.character.string = gfc_getmem (lentrim + 1);
3907
3908   for (i = 0; i < lentrim; i++)
3909     result->value.character.string[i] = e->value.character.string[i];
3910
3911   result->value.character.string[lentrim] = '\0';       /* For debugger */
3912
3913   return result;
3914 }
3915
3916
3917 gfc_expr *
3918 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
3919 {
3920   return simplify_bound (array, dim, 1);
3921 }
3922
3923
3924 gfc_expr *
3925 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
3926 {
3927   gfc_expr *result;
3928   int back;
3929   size_t index, len, lenset;
3930   size_t i;
3931
3932   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3933     return NULL;
3934
3935   if (b != NULL && b->value.logical != 0)
3936     back = 1;
3937   else
3938     back = 0;
3939
3940   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3941                                 &s->where);
3942
3943   len = s->value.character.length;
3944   lenset = set->value.character.length;
3945
3946   if (len == 0)
3947     {
3948       mpz_set_ui (result->value.integer, 0);
3949       return result;
3950     }
3951
3952   if (back == 0)
3953     {
3954       if (lenset == 0)
3955         {
3956           mpz_set_ui (result->value.integer, 1);
3957           return result;
3958         }
3959
3960       index = strspn (s->value.character.string, set->value.character.string)
3961             + 1;
3962       if (index > len)
3963         index = 0;
3964
3965     }
3966   else
3967     {
3968       if (lenset == 0)
3969         {
3970           mpz_set_ui (result->value.integer, len);
3971           return result;
3972         }
3973       for (index = len; index > 0; index --)
3974         {
3975           for (i = 0; i < lenset; i++)
3976             {
3977               if (s->value.character.string[index - 1]
3978                   == set->value.character.string[i])
3979                 break;
3980             }
3981           if (i == lenset)
3982             break;
3983         }
3984     }
3985
3986   mpz_set_ui (result->value.integer, index);
3987   return result;
3988 }
3989
3990
3991 gfc_expr *
3992 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
3993 {
3994   gfc_expr *result;
3995   int kind;
3996
3997   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3998     return NULL;
3999
4000   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4001   if (x->ts.type == BT_INTEGER)
4002     {
4003       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4004       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4005     }
4006   else /* BT_LOGICAL */
4007     {
4008       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4009       result->value.logical = (x->value.logical && !y->value.logical)
4010                               || (!x->value.logical && y->value.logical);
4011     }
4012
4013   return range_check (result, "XOR");
4014 }
4015
4016
4017 /****************** Constant simplification *****************/
4018
4019 /* Master function to convert one constant to another.  While this is
4020    used as a simplification function, it requires the destination type
4021    and kind information which is supplied by a special case in
4022    do_simplify().  */
4023
4024 gfc_expr *
4025 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4026 {
4027   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4028   gfc_constructor *head, *c, *tail = NULL;
4029
4030   switch (e->ts.type)
4031     {
4032     case BT_INTEGER:
4033       switch (type)
4034         {
4035         case BT_INTEGER:
4036           f = gfc_int2int;
4037           break;
4038         case BT_REAL:
4039           f = gfc_int2real;
4040           break;
4041         case BT_COMPLEX:
4042           f = gfc_int2complex;
4043           break;
4044         case BT_LOGICAL:
4045           f = gfc_int2log;
4046           break;
4047         default:
4048           goto oops;
4049         }
4050       break;
4051
4052     case BT_REAL:
4053       switch (type)
4054         {
4055         case BT_INTEGER:
4056           f = gfc_real2int;
4057           break;
4058         case BT_REAL:
4059           f = gfc_real2real;
4060           break;
4061         case BT_COMPLEX:
4062           f = gfc_real2complex;
4063           break;
4064         default:
4065           goto oops;
4066         }
4067       break;
4068
4069     case BT_COMPLEX:
4070       switch (type)
4071         {
4072         case BT_INTEGER:
4073           f = gfc_complex2int;
4074           break;
4075         case BT_REAL:
4076           f = gfc_complex2real;
4077           break;
4078         case BT_COMPLEX:
4079           f = gfc_complex2complex;
4080           break;
4081
4082         default:
4083           goto oops;
4084         }
4085       break;
4086
4087     case BT_LOGICAL:
4088       switch (type)
4089         {
4090         case BT_INTEGER:
4091           f = gfc_log2int;
4092           break;
4093         case BT_LOGICAL:
4094           f = gfc_log2log;
4095           break;
4096         default:
4097           goto oops;
4098         }
4099       break;
4100
4101     case BT_HOLLERITH:
4102       switch (type)
4103         {
4104         case BT_INTEGER:
4105           f = gfc_hollerith2int;
4106           break;
4107
4108         case BT_REAL:
4109           f = gfc_hollerith2real;
4110           break;
4111
4112         case BT_COMPLEX:
4113           f = gfc_hollerith2complex;
4114           break;
4115
4116         case BT_CHARACTER:
4117           f = gfc_hollerith2character;
4118           break;
4119
4120         case BT_LOGICAL:
4121           f = gfc_hollerith2logical;
4122           break;
4123
4124         default:
4125           goto oops;
4126         }
4127       break;
4128
4129     default:
4130     oops:
4131       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4132     }
4133
4134   result = NULL;
4135
4136   switch (e->expr_type)
4137     {
4138     case EXPR_CONSTANT:
4139       result = f (e, kind);
4140       if (result == NULL)
4141         return &gfc_bad_expr;
4142       break;
4143
4144     case EXPR_ARRAY:
4145       if (!gfc_is_constant_expr (e))
4146         break;
4147
4148       head = NULL;
4149
4150       for (c = e->value.constructor; c; c = c->next)
4151         {
4152           if (head == NULL)
4153             head = tail = gfc_get_constructor ();
4154           else
4155             {
4156               tail->next = gfc_get_constructor ();
4157               tail = tail->next;
4158             }
4159
4160           tail->where = c->where;
4161
4162           if (c->iterator == NULL)
4163             tail->expr = f (c->expr, kind);
4164           else
4165             {
4166               g = gfc_convert_constant (c->expr, type, kind);
4167               if (g == &gfc_bad_expr)
4168                 return g;
4169               tail->expr = g;
4170             }
4171
4172           if (tail->expr == NULL)
4173             {
4174               gfc_free_constructor (head);
4175               return NULL;
4176             }
4177         }
4178
4179       result = gfc_get_expr ();
4180       result->ts.type = type;
4181       result->ts.kind = kind;
4182       result->expr_type = EXPR_ARRAY;
4183       result->value.constructor = head;
4184       result->shape = gfc_copy_shape (e->shape, e->rank);
4185       result->where = e->where;
4186       result->rank = e->rank;
4187       break;
4188
4189     default:
4190       break;
4191     }
4192
4193   return result;
4194 }