gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "arith.h"
  27 #include "intrinsic.h"
  28 #include "target-memory.h"
  29
  30 gfc_expr gfc_bad_expr;
  31
  32
  33 /* Note that 'simplification' is not just transforming expressions.
  34    For functions that are not simplified at compile time, range
  35    checking is done if possible.
  36
  37    The return convention is that each simplification function returns:
  38
  39      A new expression node corresponding to the simplified arguments.
  40      The original arguments are destroyed by the caller, and must not
  41      be a part of the new expression.
  42
  43      NULL pointer indicating that no simplification was possible and
  44      the original expression should remain intact.  If the
  45      simplification function sets the type and/or the function name
  46      via the pointer gfc_simple_expression, then this type is
  47      retained.
  48
  49      An expression pointer to gfc_bad_expr (a static placeholder)
  50      indicating that some error has prevented simplification.  For
  51      example, sqrt(-1.0).  The error is generated within the function
  52      and should be propagated upwards
  53
  54    By the time a simplification function gets control, it has been
  55    decided that the function call is really supposed to be the
  56    intrinsic.  No type checking is strictly necessary, since only
  57    valid types will be passed on.  On the other hand, a simplification
  58    subroutine may have to look at the type of an argument as part of
  59    its processing.
  60
  61    Array arguments are never passed to these subroutines.
  62
  63    The functions in this file don't have much comment with them, but
  64    everything is reasonably straight-forward.  The Standard, chapter 13
  65    is the best comment you'll find for this file anyway.  */
  66
  67 /* Range checks an expression node.  If all goes well, returns the
  68    node, otherwise returns &gfc_bad_expr and frees the node.  */
  69
  70 static gfc_expr *
  71 range_check (gfc_expr *result, const char *name)
  72 {
  73   switch (gfc_range_check (result))
  74     {
  75       case ARITH_OK:
  76         return result;
  77
  78       case ARITH_OVERFLOW:
  79         gfc_error ("Result of %s overflows its kind at %L", name,
  80                    &result->where);
  81         break;
  82
  83       case ARITH_UNDERFLOW:
  84         gfc_error ("Result of %s underflows its kind at %L", name,
  85                    &result->where);
  86         break;
  87
  88       case ARITH_NAN:
  89         gfc_error ("Result of %s is NaN at %L", name, &result->where);
  90         break;
  91
  92       default:
  93         gfc_error ("Result of %s gives range error for its kind at %L", name,
  94                    &result->where);
  95         break;
  96     }
  97
  98   gfc_free_expr (result);
  99   return &gfc_bad_expr;
 100 }
 101
 102
 103 /* A helper function that gets an optional and possibly missing
 104    kind parameter.  Returns the kind, -1 if something went wrong.  */
 105
 106 static int
 107 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 108 {
 109   int kind;
 110
 111   if (k == NULL)
 112     return default_kind;
 113
 114   if (k->expr_type != EXPR_CONSTANT)
 115     {
 116       gfc_error ("KIND parameter of %s at %L must be an initialization "
 117                  "expression", name, &k->where);
 118
 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           break;
2365
2366         case BT_REAL:
2367           if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
2368               * sign > 0)
2369             mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2370                       GFC_RND_MODE);
2371           break;
2372
2373         case BT_CHARACTER:
2374 #define LENGTH(x) ((x)->expr->value.character.length)
2375 #define STRING(x) ((x)->expr->value.character.string)
2376           if (LENGTH(extremum) < LENGTH(arg))
2377             {
2378               char * tmp = STRING(extremum);
2379
2380               STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2381               memcpy (STRING(extremum), tmp, LENGTH(extremum));
2382               memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2383                       LENGTH(arg) - LENGTH(extremum));
2384               STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
2385               LENGTH(extremum) = LENGTH(arg);
2386               gfc_free (tmp);
2387             }
2388
2389           if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2390             {
2391               gfc_free (STRING(extremum));
2392               STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2393               memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2394               memset (&STRING(extremum)[LENGTH(arg)], ' ',
2395                       LENGTH(extremum) - LENGTH(arg));
2396               STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
2397             }
2398 #undef LENGTH
2399 #undef STRING
2400           break;
2401
2402
2403         default:
2404           gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2405         }
2406
2407       /* Delete the extra constant argument.  */
2408       if (last == NULL)
2409         expr->value.function.actual = arg->next;
2410       else
2411         last->next = arg->next;
2412
2413       arg->next = NULL;
2414       gfc_free_actual_arglist (arg);
2415       arg = last;
2416     }
2417
2418   /* If there is one value left, replace the function call with the
2419      expression.  */
2420   if (expr->value.function.actual->next != NULL)
2421     return NULL;
2422
2423   /* Convert to the correct type and kind.  */
2424   if (expr->ts.type != BT_UNKNOWN)
2425     return gfc_convert_constant (expr->value.function.actual->expr,
2426         expr->ts.type, expr->ts.kind);
2427
2428   if (specific->ts.type != BT_UNKNOWN)
2429     return gfc_convert_constant (expr->value.function.actual->expr,
2430         specific->ts.type, specific->ts.kind);
2431
2432   return gfc_copy_expr (expr->value.function.actual->expr);
2433 }
2434
2435
2436 gfc_expr *
2437 gfc_simplify_min (gfc_expr *e)
2438 {
2439   return simplify_min_max (e, -1);
2440 }
2441
2442
2443 gfc_expr *
2444 gfc_simplify_max (gfc_expr *e)
2445 {
2446   return simplify_min_max (e, 1);
2447 }
2448
2449
2450 gfc_expr *
2451 gfc_simplify_maxexponent (gfc_expr *x)
2452 {
2453   gfc_expr *result;
2454   int i;
2455
2456   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2457
2458   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2459   result->where = x->where;
2460
2461   return result;
2462 }
2463
2464
2465 gfc_expr *
2466 gfc_simplify_minexponent (gfc_expr *x)
2467 {
2468   gfc_expr *result;
2469   int i;
2470
2471   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2472
2473   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2474   result->where = x->where;
2475
2476   return result;
2477 }
2478
2479
2480 gfc_expr *
2481 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2482 {
2483   gfc_expr *result;
2484   mpfr_t quot, iquot, term;
2485   int kind;
2486
2487   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2488     return NULL;
2489
2490   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2491   result = gfc_constant_result (a->ts.type, kind, &a->where);
2492
2493   switch (a->ts.type)
2494     {
2495     case BT_INTEGER:
2496       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2497         {
2498           /* Result is processor-dependent.  */
2499           gfc_error ("Second argument MOD at %L is zero", &a->where);
2500           gfc_free_expr (result);
2501           return &gfc_bad_expr;
2502         }
2503       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2504       break;
2505
2506     case BT_REAL:
2507       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2508         {
2509           /* Result is processor-dependent.  */
2510           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2511           gfc_free_expr (result);
2512           return &gfc_bad_expr;
2513         }
2514
2515       gfc_set_model_kind (kind);
2516       mpfr_init (quot);
2517       mpfr_init (iquot);
2518       mpfr_init (term);
2519
2520       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2521       mpfr_trunc (iquot, quot);
2522       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2523       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2524
2525       mpfr_clear (quot);
2526       mpfr_clear (iquot);
2527       mpfr_clear (term);
2528       break;
2529
2530     default:
2531       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2532     }
2533
2534   return range_check (result, "MOD");
2535 }
2536
2537
2538 gfc_expr *
2539 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2540 {
2541   gfc_expr *result;
2542   mpfr_t quot, iquot, term;
2543   int kind;
2544
2545   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2546     return NULL;
2547
2548   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2549   result = gfc_constant_result (a->ts.type, kind, &a->where);
2550
2551   switch (a->ts.type)
2552     {
2553     case BT_INTEGER:
2554       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2555         {
2556           /* Result is processor-dependent. This processor just opts
2557              to not handle it at all.  */
2558           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2559           gfc_free_expr (result);
2560           return &gfc_bad_expr;
2561         }
2562       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2563
2564       break;
2565
2566     case BT_REAL:
2567       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2568         {
2569           /* Result is processor-dependent.  */
2570           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2571           gfc_free_expr (result);
2572           return &gfc_bad_expr;
2573         }
2574
2575       gfc_set_model_kind (kind);
2576       mpfr_init (quot);
2577       mpfr_init (iquot);
2578       mpfr_init (term);
2579
2580       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2581       mpfr_floor (iquot, quot);
2582       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2583       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2584
2585       mpfr_clear (quot);
2586       mpfr_clear (iquot);
2587       mpfr_clear (term);
2588       break;
2589
2590     default:
2591       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2592     }
2593
2594   return range_check (result, "MODULO");
2595 }
2596
2597
2598 /* Exists for the sole purpose of consistency with other intrinsics.  */
2599 gfc_expr *
2600 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
2601                      gfc_expr *fp ATTRIBUTE_UNUSED,
2602                      gfc_expr *l  ATTRIBUTE_UNUSED,
2603                      gfc_expr *to ATTRIBUTE_UNUSED,
2604                      gfc_expr *tp ATTRIBUTE_UNUSED)
2605 {
2606   return NULL;
2607 }
2608
2609
2610 gfc_expr *
2611 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2612 {
2613   gfc_expr *result;
2614   mpfr_t tmp;
2615   int sgn;
2616
2617   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2618     return NULL;
2619
2620   if (mpfr_sgn (s->value.real) == 0)
2621     {
2622       gfc_error ("Second argument of NEAREST at %L shall not be zero",
2623                  &s->where);
2624       return &gfc_bad_expr;
2625     }
2626
2627   gfc_set_model_kind (x->ts.kind);
2628   result = gfc_copy_expr (x);
2629
2630   sgn = mpfr_sgn (s->value.real);
2631   mpfr_init (tmp);
2632   mpfr_set_inf (tmp, sgn);
2633   mpfr_nexttoward (result->value.real, tmp);
2634   mpfr_clear (tmp);
2635
2636   return range_check (result, "NEAREST");
2637 }
2638
2639
2640 static gfc_expr *
2641 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2642 {
2643   gfc_expr *itrunc, *result;
2644   int kind;
2645
2646   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2647   if (kind == -1)
2648     return &gfc_bad_expr;
2649
2650   if (e->expr_type != EXPR_CONSTANT)
2651     return NULL;
2652
2653   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2654
2655   itrunc = gfc_copy_expr (e);
2656
2657   mpfr_round (itrunc->value.real, e->value.real);
2658
2659   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2660
2661   gfc_free_expr (itrunc);
2662
2663   return range_check (result, name);
2664 }
2665
2666
2667 gfc_expr *
2668 gfc_simplify_new_line (gfc_expr *e)
2669 {
2670   gfc_expr *result;
2671
2672   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2673   result->value.character.string = gfc_getmem (2);
2674   result->value.character.length = 1;
2675   result->value.character.string[0] = '\n';
2676   result->value.character.string[1] = '\0';     /* For debugger */
2677   return result;
2678 }
2679
2680
2681 gfc_expr *
2682 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2683 {
2684   return simplify_nint ("NINT", e, k);
2685 }
2686
2687
2688 gfc_expr *
2689 gfc_simplify_idnint (gfc_expr *e)
2690 {
2691   return simplify_nint ("IDNINT", e, NULL);
2692 }
2693
2694
2695 gfc_expr *
2696 gfc_simplify_not (gfc_expr *e)
2697 {
2698   gfc_expr *result;
2699
2700   if (e->expr_type != EXPR_CONSTANT)
2701     return NULL;
2702
2703   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2704
2705   mpz_com (result->value.integer, e->value.integer);
2706
2707   return range_check (result, "NOT");
2708 }
2709
2710
2711 gfc_expr *
2712 gfc_simplify_null (gfc_expr *mold)
2713 {
2714   gfc_expr *result;
2715
2716   if (mold == NULL)
2717     {
2718       result = gfc_get_expr ();
2719       result->ts.type = BT_UNKNOWN;
2720     }
2721   else
2722     result = gfc_copy_expr (mold);
2723   result->expr_type = EXPR_NULL;
2724
2725   return result;
2726 }
2727
2728
2729 gfc_expr *
2730 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2731 {
2732   gfc_expr *result;
2733   int kind;
2734
2735   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2736     return NULL;
2737
2738   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2739   if (x->ts.type == BT_INTEGER)
2740     {
2741       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2742       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2743     }
2744   else /* BT_LOGICAL */
2745     {
2746       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2747       result->value.logical = x->value.logical || y->value.logical;
2748     }
2749
2750   return range_check (result, "OR");
2751 }
2752
2753
2754 gfc_expr *
2755 gfc_simplify_precision (gfc_expr *e)
2756 {
2757   gfc_expr *result;
2758   int i;
2759
2760   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2761
2762   result = gfc_int_expr (gfc_real_kinds[i].precision);
2763   result->where = e->where;
2764
2765   return result;
2766 }
2767
2768
2769 gfc_expr *
2770 gfc_simplify_radix (gfc_expr *e)
2771 {
2772   gfc_expr *result;
2773   int i;
2774
2775   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2776   switch (e->ts.type)
2777     {
2778     case BT_INTEGER:
2779       i = gfc_integer_kinds[i].radix;
2780       break;
2781
2782     case BT_REAL:
2783       i = gfc_real_kinds[i].radix;
2784       break;
2785
2786     default:
2787       gcc_unreachable ();
2788     }
2789
2790   result = gfc_int_expr (i);
2791   result->where = e->where;
2792
2793   return result;
2794 }
2795
2796
2797 gfc_expr *
2798 gfc_simplify_range (gfc_expr *e)
2799 {
2800   gfc_expr *result;
2801   int i;
2802   long j;
2803
2804   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2805
2806   switch (e->ts.type)
2807     {
2808     case BT_INTEGER:
2809       j = gfc_integer_kinds[i].range;
2810       break;
2811
2812     case BT_REAL:
2813     case BT_COMPLEX:
2814       j = gfc_real_kinds[i].range;
2815       break;
2816
2817     default:
2818       gcc_unreachable ();
2819     }
2820
2821   result = gfc_int_expr (j);
2822   result->where = e->where;
2823
2824   return result;
2825 }
2826
2827
2828 gfc_expr *
2829 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2830 {
2831   gfc_expr *result;
2832   int kind;
2833
2834   if (e->ts.type == BT_COMPLEX)
2835     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2836   else
2837     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2838
2839   if (kind == -1)
2840     return &gfc_bad_expr;
2841
2842   if (e->expr_type != EXPR_CONSTANT)
2843     return NULL;
2844
2845   switch (e->ts.type)
2846     {
2847     case BT_INTEGER:
2848       result = gfc_int2real (e, kind);
2849       break;
2850
2851     case BT_REAL:
2852       result = gfc_real2real (e, kind);
2853       break;
2854
2855     case BT_COMPLEX:
2856       result = gfc_complex2real (e, kind);
2857       break;
2858
2859     default:
2860       gfc_internal_error ("bad type in REAL");
2861       /* Not reached */
2862     }
2863
2864   return range_check (result, "REAL");
2865 }
2866
2867
2868 gfc_expr *
2869 gfc_simplify_realpart (gfc_expr *e)
2870 {
2871   gfc_expr *result;
2872
2873   if (e->expr_type != EXPR_CONSTANT)
2874     return NULL;
2875
2876   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2877   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2878
2879   return range_check (result, "REALPART");
2880 }
2881
2882 gfc_expr *
2883 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
2884 {
2885   gfc_expr *result;
2886   int i, j, len, ncop, nlen;
2887   mpz_t ncopies;
2888   bool have_length = false;
2889
2890   /* If NCOPIES isn't a constant, there's nothing we can do.  */
2891   if (n->expr_type != EXPR_CONSTANT)
2892     return NULL;
2893
2894   /* If NCOPIES is negative, it's an error.  */
2895   if (mpz_sgn (n->value.integer) < 0)
2896     {
2897       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2898                  &n->where);
2899       return &gfc_bad_expr;
2900     }
2901
2902   /* If we don't know the character length, we can do no more.  */
2903   if (e->ts.cl && e->ts.cl->length
2904         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2905     {
2906       len = mpz_get_si (e->ts.cl->length->value.integer);
2907       have_length = true;
2908     }
2909   else if (e->expr_type == EXPR_CONSTANT
2910              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
2911     {
2912       len = e->value.character.length;
2913     }
2914   else
2915     return NULL;
2916
2917   /* If the source length is 0, any value of NCOPIES is valid
2918      and everything behaves as if NCOPIES == 0.  */
2919   mpz_init (ncopies);
2920   if (len == 0)
2921     mpz_set_ui (ncopies, 0);
2922   else
2923     mpz_set (ncopies, n->value.integer);
2924
2925   /* Check that NCOPIES isn't too large.  */
2926   if (len)
2927     {
2928       mpz_t max, mlen;
2929       int i;
2930
2931       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
2932       mpz_init (max);
2933       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2934
2935       if (have_length)
2936         {
2937           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
2938                       e->ts.cl->length->value.integer);
2939         }
2940       else
2941         {
2942           mpz_init_set_si (mlen, len);
2943           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
2944           mpz_clear (mlen);
2945         }
2946
2947       /* The check itself.  */
2948       if (mpz_cmp (ncopies, max) > 0)
2949         {
2950           mpz_clear (max);
2951           mpz_clear (ncopies);
2952           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2953                      &n->where);
2954           return &gfc_bad_expr;
2955         }
2956
2957       mpz_clear (max);
2958     }
2959   mpz_clear (ncopies);
2960
2961   /* For further simplification, we need the character string to be
2962      constant.  */
2963   if (e->expr_type != EXPR_CONSTANT)
2964     return NULL;
2965
2966   if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
2967     {
2968       const char *res = gfc_extract_int (n, &ncop);
2969       gcc_assert (res == NULL);
2970     }
2971   else
2972     ncop = 0;
2973
2974   len = e->value.character.length;
2975   nlen = ncop * len;
2976
2977   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2978
2979   if (ncop == 0)
2980     {
2981       result->value.character.string = gfc_getmem (1);
2982       result->value.character.length = 0;
2983       result->value.character.string[0] = '\0';
2984       return result;
2985     }
2986
2987   result->value.character.length = nlen;
2988   result->value.character.string = gfc_getmem (nlen + 1);
2989
2990   for (i = 0; i < ncop; i++)
2991     for (j = 0; j < len; j++)
2992       result->value.character.string[j + i * len]
2993       = e->value.character.string[j];
2994
2995   result->value.character.string[nlen] = '\0';  /* For debugger */
2996   return result;
2997 }
2998
2999
3000 /* This one is a bear, but mainly has to do with shuffling elements.  */
3001
3002 gfc_expr *
3003 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3004                       gfc_expr *pad, gfc_expr *order_exp)
3005 {
3006   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3007   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3008   gfc_constructor *head, *tail;
3009   mpz_t index, size;
3010   unsigned long j;
3011   size_t nsource;
3012   gfc_expr *e;
3013
3014   /* Unpack the shape array.  */
3015   if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
3016     return NULL;
3017
3018   if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
3019     return NULL;
3020
3021   if (pad != NULL
3022       && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
3023     return NULL;
3024
3025   if (order_exp != NULL
3026       && (order_exp->expr_type != EXPR_ARRAY
3027           || !gfc_is_constant_expr (order_exp)))
3028     return NULL;
3029
3030   mpz_init (index);
3031   rank = 0;
3032   head = tail = NULL;
3033
3034   for (;;)
3035     {
3036       e = gfc_get_array_element (shape_exp, rank);
3037       if (e == NULL)
3038         break;
3039
3040       if (gfc_extract_int (e, &shape[rank]) != NULL)
3041         {
3042           gfc_error ("Integer too large in shape specification at %L",
3043                      &e->where);
3044           gfc_free_expr (e);
3045           goto bad_reshape;
3046         }
3047
3048       gfc_free_expr (e);
3049
3050       if (rank >= GFC_MAX_DIMENSIONS)
3051         {
3052           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3053                      "at %L", &e->where);
3054
3055           goto bad_reshape;
3056         }
3057
3058       if (shape[rank] < 0)
3059         {
3060           gfc_error ("Shape specification at %L cannot be negative",
3061                      &e->where);
3062           goto bad_reshape;
3063         }
3064
3065       rank++;
3066     }
3067
3068   if (rank == 0)
3069     {
3070       gfc_error ("Shape specification at %L cannot be the null array",
3071                  &shape_exp->where);
3072       goto bad_reshape;
3073     }
3074
3075   /* Now unpack the order array if present.  */
3076   if (order_exp == NULL)
3077     {
3078       for (i = 0; i < rank; i++)
3079         order[i] = i;
3080     }
3081   else
3082     {
3083       for (i = 0; i < rank; i++)
3084         x[i] = 0;
3085
3086       for (i = 0; i < rank; i++)
3087         {
3088           e = gfc_get_array_element (order_exp, i);
3089           if (e == NULL)
3090             {
3091               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3092                          "size as SHAPE parameter", &order_exp->where);
3093               goto bad_reshape;
3094             }
3095
3096           if (gfc_extract_int (e, &order[i]) != NULL)
3097             {
3098               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3099                          &e->where);
3100               gfc_free_expr (e);
3101               goto bad_reshape;
3102             }
3103
3104           gfc_free_expr (e);
3105
3106           if (order[i] < 1 || order[i] > rank)
3107             {
3108               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3109                          &e->where);
3110               goto bad_reshape;
3111             }
3112
3113           order[i]--;
3114
3115           if (x[order[i]])
3116             {
3117               gfc_error ("Invalid permutation in ORDER parameter at %L",
3118                          &e->where);
3119               goto bad_reshape;
3120             }
3121
3122           x[order[i]] = 1;
3123         }
3124     }
3125
3126   /* Count the elements in the source and padding arrays.  */
3127
3128   npad = 0;
3129   if (pad != NULL)
3130     {
3131       gfc_array_size (pad, &size);
3132       npad = mpz_get_ui (size);
3133       mpz_clear (size);
3134     }
3135
3136   gfc_array_size (source, &size);
3137   nsource = mpz_get_ui (size);
3138   mpz_clear (size);
3139
3140   /* If it weren't for that pesky permutation we could just loop
3141      through the source and round out any shortage with pad elements.
3142      But no, someone just had to have the compiler do something the
3143      user should be doing.  */
3144
3145   for (i = 0; i < rank; i++)
3146     x[i] = 0;
3147
3148   for (;;)
3149     {
3150       /* Figure out which element to extract.  */
3151       mpz_set_ui (index, 0);
3152
3153       for (i = rank - 1; i >= 0; i--)
3154         {
3155           mpz_add_ui (index, index, x[order[i]]);
3156           if (i != 0)
3157             mpz_mul_ui (index, index, shape[order[i - 1]]);
3158         }
3159
3160       if (mpz_cmp_ui (index, INT_MAX) > 0)
3161         gfc_internal_error ("Reshaped array too large at %L", &e->where);
3162
3163       j = mpz_get_ui (index);
3164
3165       if (j < nsource)
3166         e = gfc_get_array_element (source, j);
3167       else
3168         {
3169           j = j - nsource;
3170
3171           if (npad == 0)
3172             {
3173               gfc_error ("PAD parameter required for short SOURCE parameter "
3174                          "at %L", &source->where);
3175               goto bad_reshape;
3176             }
3177
3178           j = j % npad;
3179           e = gfc_get_array_element (pad, j);
3180         }
3181
3182       if (head == NULL)
3183         head = tail = gfc_get_constructor ();
3184       else
3185         {
3186           tail->next = gfc_get_constructor ();
3187           tail = tail->next;
3188         }
3189
3190       if (e == NULL)
3191         goto bad_reshape;
3192
3193       tail->where = e->where;
3194       tail->expr = e;
3195
3196       /* Calculate the next element.  */
3197       i = 0;
3198
3199 inc:
3200       if (++x[i] < shape[i])
3201         continue;
3202       x[i++] = 0;
3203       if (i < rank)
3204         goto inc;
3205
3206       break;
3207     }
3208
3209   mpz_clear (index);
3210
3211   e = gfc_get_expr ();
3212   e->where = source->where;
3213   e->expr_type = EXPR_ARRAY;
3214   e->value.constructor = head;
3215   e->shape = gfc_get_shape (rank);
3216
3217   for (i = 0; i < rank; i++)
3218     mpz_init_set_ui (e->shape[i], shape[i]);
3219
3220   e->ts = source->ts;
3221   e->rank = rank;
3222
3223   return e;
3224
3225 bad_reshape:
3226   gfc_free_constructor (head);
3227   mpz_clear (index);
3228   return &gfc_bad_expr;
3229 }
3230
3231
3232 gfc_expr *
3233 gfc_simplify_rrspacing (gfc_expr *x)
3234 {
3235   gfc_expr *result;
3236   int i;
3237   long int e, p;
3238
3239   if (x->expr_type != EXPR_CONSTANT)
3240     return NULL;
3241
3242   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3243
3244   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3245
3246   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3247
3248   /* Special case x = -0 and 0.  */
3249   if (mpfr_sgn (result->value.real) == 0)
3250     {
3251       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3252       return result;
3253     }
3254
3255   /* | x * 2**(-e) | * 2**p.  */
3256   e = - (long int) mpfr_get_exp (x->value.real);
3257   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3258
3259   p = (long int) gfc_real_kinds[i].digits;
3260   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3261
3262   return range_check (result, "RRSPACING");
3263 }
3264
3265
3266 gfc_expr *
3267 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3268 {
3269   int k, neg_flag, power, exp_range;
3270   mpfr_t scale, radix;
3271   gfc_expr *result;
3272
3273   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3274     return NULL;
3275
3276   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3277
3278   if (mpfr_sgn (x->value.real) == 0)
3279     {
3280       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3281       return result;
3282     }
3283
3284   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3285
3286   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3287
3288   /* This check filters out values of i that would overflow an int.  */
3289   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3290       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3291     {
3292       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3293       return &gfc_bad_expr;
3294     }
3295
3296   /* Compute scale = radix ** power.  */
3297   power = mpz_get_si (i->value.integer);
3298
3299   if (power >= 0)
3300     neg_flag = 0;
3301   else
3302     {
3303       neg_flag = 1;
3304       power = -power;
3305     }
3306
3307   gfc_set_model_kind (x->ts.kind);
3308   mpfr_init (scale);
3309   mpfr_init (radix);
3310   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3311   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3312
3313   if (neg_flag)
3314     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3315   else
3316     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3317
3318   mpfr_clear (scale);
3319   mpfr_clear (radix);
3320
3321   return range_check (result, "SCALE");
3322 }
3323
3324
3325 gfc_expr *
3326 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
3327 {
3328   gfc_expr *result;
3329   int back;
3330   size_t i;
3331   size_t indx, len, lenc;
3332
3333   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3334     return NULL;
3335
3336   if (b != NULL && b->value.logical != 0)
3337     back = 1;
3338   else
3339     back = 0;
3340
3341   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3342                                 &e->where);
3343
3344   len = e->value.character.length;
3345   lenc = c->value.character.length;
3346
3347   if (len == 0 || lenc == 0)
3348     {
3349       indx = 0;
3350     }
3351   else
3352     {
3353       if (back == 0)
3354         {
3355           indx = strcspn (e->value.character.string, c->value.character.string)
3356                + 1;
3357           if (indx > len)
3358             indx = 0;
3359         }
3360       else
3361         {
3362           i = 0;
3363           for (indx = len; indx > 0; indx--)
3364             {
3365               for (i = 0; i < lenc; i++)
3366                 {
3367                   if (c->value.character.string[i]
3368                       == e->value.character.string[indx - 1])
3369                     break;
3370                 }
3371               if (i < lenc)
3372                 break;
3373             }
3374         }
3375     }
3376   mpz_set_ui (result->value.integer, indx);
3377   return range_check (result, "SCAN");
3378 }
3379
3380
3381 gfc_expr *
3382 gfc_simplify_selected_int_kind (gfc_expr *e)
3383 {
3384   int i, kind, range;
3385   gfc_expr *result;
3386
3387   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3388     return NULL;
3389
3390   kind = INT_MAX;
3391
3392   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3393     if (gfc_integer_kinds[i].range >= range
3394         && gfc_integer_kinds[i].kind < kind)
3395       kind = gfc_integer_kinds[i].kind;
3396
3397   if (kind == INT_MAX)
3398     kind = -1;
3399
3400   result = gfc_int_expr (kind);
3401   result->where = e->where;
3402
3403   return result;
3404 }
3405
3406
3407 gfc_expr *
3408 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3409 {
3410   int range, precision, i, kind, found_precision, found_range;
3411   gfc_expr *result;
3412
3413   if (p == NULL)
3414     precision = 0;
3415   else
3416     {
3417       if (p->expr_type != EXPR_CONSTANT
3418           || gfc_extract_int (p, &precision) != NULL)
3419         return NULL;
3420     }
3421
3422   if (q == NULL)
3423     range = 0;
3424   else
3425     {
3426       if (q->expr_type != EXPR_CONSTANT
3427           || gfc_extract_int (q, &range) != NULL)
3428         return NULL;
3429     }
3430
3431   kind = INT_MAX;
3432   found_precision = 0;
3433   found_range = 0;
3434
3435   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3436     {
3437       if (gfc_real_kinds[i].precision >= precision)
3438         found_precision = 1;
3439
3440       if (gfc_real_kinds[i].range >= range)
3441         found_range = 1;
3442
3443       if (gfc_real_kinds[i].precision >= precision
3444           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3445         kind = gfc_real_kinds[i].kind;
3446     }
3447
3448   if (kind == INT_MAX)
3449     {
3450       kind = 0;
3451
3452       if (!found_precision)
3453         kind = -1;
3454       if (!found_range)
3455         kind -= 2;
3456     }
3457
3458   result = gfc_int_expr (kind);
3459   result->where = (p != NULL) ? p->where : q->where;
3460
3461   return result;
3462 }
3463
3464
3465 gfc_expr *
3466 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3467 {
3468   gfc_expr *result;
3469   mpfr_t exp, absv, log2, pow2, frac;
3470   unsigned long exp2;
3471
3472   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3473     return NULL;
3474
3475   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3476
3477   gfc_set_model_kind (x->ts.kind);
3478
3479   if (mpfr_sgn (x->value.real) == 0)
3480     {
3481       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3482       return result;
3483     }
3484
3485   mpfr_init (absv);
3486   mpfr_init (log2);
3487   mpfr_init (exp);
3488   mpfr_init (pow2);
3489   mpfr_init (frac);
3490
3491   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3492   mpfr_log2 (log2, absv, GFC_RND_MODE);
3493
3494   mpfr_trunc (log2, log2);
3495   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3496
3497   /* Old exponent value, and fraction.  */
3498   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3499
3500   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3501
3502   /* New exponent.  */
3503   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3504   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3505
3506   mpfr_clear (absv);
3507   mpfr_clear (log2);
3508   mpfr_clear (pow2);
3509   mpfr_clear (frac);
3510
3511   return range_check (result, "SET_EXPONENT");
3512 }
3513
3514
3515 gfc_expr *
3516 gfc_simplify_shape (gfc_expr *source)
3517 {
3518   mpz_t shape[GFC_MAX_DIMENSIONS];
3519   gfc_expr *result, *e, *f;
3520   gfc_array_ref *ar;
3521   int n;
3522   try t;
3523
3524   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3525     return NULL;
3526
3527   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3528                                   &source->where);
3529
3530   ar = gfc_find_array_ref (source);
3531
3532   t = gfc_array_ref_shape (ar, shape);
3533
3534   for (n = 0; n < source->rank; n++)
3535     {
3536       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3537                                &source->where);
3538
3539       if (t == SUCCESS)
3540         {
3541           mpz_set (e->value.integer, shape[n]);
3542           mpz_clear (shape[n]);
3543         }
3544       else
3545         {
3546           mpz_set_ui (e->value.integer, n + 1);
3547
3548           f = gfc_simplify_size (source, e);
3549           gfc_free_expr (e);
3550           if (f == NULL)
3551             {
3552               gfc_free_expr (result);
3553               return NULL;
3554             }
3555           else
3556             {
3557               e = f;
3558             }
3559         }
3560
3561       gfc_append_constructor (result, e);
3562     }
3563
3564   return result;
3565 }
3566
3567
3568 gfc_expr *
3569 gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
3570 {
3571   mpz_t size;
3572   gfc_expr *result;
3573   int d;
3574
3575   if (dim == NULL)
3576     {
3577       if (gfc_array_size (array, &size) == FAILURE)
3578         return NULL;
3579     }
3580   else
3581     {
3582       if (dim->expr_type != EXPR_CONSTANT)
3583         return NULL;
3584
3585       d = mpz_get_ui (dim->value.integer) - 1;
3586       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3587         return NULL;
3588     }
3589
3590   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3591                                 &array->where);
3592
3593   mpz_set (result->value.integer, size);
3594
3595   return result;
3596 }
3597
3598
3599 gfc_expr *
3600 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3601 {
3602   gfc_expr *result;
3603
3604   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3605     return NULL;
3606
3607   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3608
3609   switch (x->ts.type)
3610     {
3611     case BT_INTEGER:
3612       mpz_abs (result->value.integer, x->value.integer);
3613       if (mpz_sgn (y->value.integer) < 0)
3614         mpz_neg (result->value.integer, result->value.integer);
3615
3616       break;
3617
3618     case BT_REAL:
3619       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3620          it.  */
3621       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3622       if (mpfr_sgn (y->value.real) < 0)
3623         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3624
3625       break;
3626
3627     default:
3628       gfc_internal_error ("Bad type in gfc_simplify_sign");
3629     }
3630
3631   return result;
3632 }
3633
3634
3635 gfc_expr *
3636 gfc_simplify_sin (gfc_expr *x)
3637 {
3638   gfc_expr *result;
3639   mpfr_t xp, xq;
3640
3641   if (x->expr_type != EXPR_CONSTANT)
3642     return NULL;
3643
3644   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3645
3646   switch (x->ts.type)
3647     {
3648     case BT_REAL:
3649       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3650       break;
3651
3652     case BT_COMPLEX:
3653       gfc_set_model (x->value.real);
3654       mpfr_init (xp);
3655       mpfr_init (xq);
3656
3657       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3658       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3659       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3660
3661       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3662       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3663       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3664
3665       mpfr_clear (xp);
3666       mpfr_clear (xq);
3667       break;
3668
3669     default:
3670       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3671     }
3672
3673   return range_check (result, "SIN");
3674 }
3675
3676
3677 gfc_expr *
3678 gfc_simplify_sinh (gfc_expr *x)
3679 {
3680   gfc_expr *result;
3681
3682   if (x->expr_type != EXPR_CONSTANT)
3683     return NULL;
3684
3685   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3686
3687   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3688
3689   return range_check (result, "SINH");
3690 }
3691
3692
3693 /* The argument is always a double precision real that is converted to
3694    single precision.  TODO: Rounding!  */
3695
3696 gfc_expr *
3697 gfc_simplify_sngl (gfc_expr *a)
3698 {
3699   gfc_expr *result;
3700
3701   if (a->expr_type != EXPR_CONSTANT)
3702     return NULL;
3703
3704   result = gfc_real2real (a, gfc_default_real_kind);
3705   return range_check (result, "SNGL");
3706 }
3707
3708
3709 gfc_expr *
3710 gfc_simplify_spacing (gfc_expr *x)
3711 {
3712   gfc_expr *result;
3713   int i;
3714   long int en, ep;
3715
3716   if (x->expr_type != EXPR_CONSTANT)
3717     return NULL;
3718
3719   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3720
3721   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3722
3723   /* Special case x = 0 and -0.  */
3724   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3725   if (mpfr_sgn (result->value.real) == 0)
3726     {
3727       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3728       return result;
3729     }
3730
3731   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3732      are the radix, exponent of x, and precision.  This excludes the
3733      possibility of subnormal numbers.  Fortran 2003 states the result is
3734      b**max(e - p, emin - 1).  */
3735
3736   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3737   en = (long int) gfc_real_kinds[i].min_exponent - 1;
3738   en = en > ep ? en : ep;
3739
3740   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3741   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3742
3743   return range_check (result, "SPACING");
3744 }
3745
3746
3747 gfc_expr *
3748 gfc_simplify_sqrt (gfc_expr *e)
3749 {
3750   gfc_expr *result;
3751   mpfr_t ac, ad, s, t, w;
3752
3753   if (e->expr_type != EXPR_CONSTANT)
3754     return NULL;
3755
3756   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3757
3758   switch (e->ts.type)
3759     {
3760     case BT_REAL:
3761       if (mpfr_cmp_si (e->value.real, 0) < 0)
3762         goto negative_arg;
3763       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3764
3765       break;
3766
3767     case BT_COMPLEX:
3768       /* Formula taken from Numerical Recipes to avoid over- and
3769          underflow.  */
3770
3771       gfc_set_model (e->value.real);
3772       mpfr_init (ac);
3773       mpfr_init (ad);
3774       mpfr_init (s);
3775       mpfr_init (t);
3776       mpfr_init (w);
3777
3778       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3779           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3780         {
3781           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3782           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3783           break;
3784         }
3785
3786       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3787       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3788
3789       if (mpfr_cmp (ac, ad) >= 0)
3790         {
3791           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3792           mpfr_mul (t, t, t, GFC_RND_MODE);
3793           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3794           mpfr_sqrt (t, t, GFC_RND_MODE);
3795           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3796           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3797           mpfr_sqrt (t, t, GFC_RND_MODE);
3798           mpfr_sqrt (s, ac, GFC_RND_MODE);
3799           mpfr_mul (w, s, t, GFC_RND_MODE);
3800         }
3801       else
3802         {
3803           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3804           mpfr_mul (t, s, s, GFC_RND_MODE);
3805           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3806           mpfr_sqrt (t, t, GFC_RND_MODE);
3807           mpfr_abs (s, s, GFC_RND_MODE);
3808           mpfr_add (t, t, s, GFC_RND_MODE);
3809           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3810           mpfr_sqrt (t, t, GFC_RND_MODE);
3811           mpfr_sqrt (s, ad, GFC_RND_MODE);
3812           mpfr_mul (w, s, t, GFC_RND_MODE);
3813         }
3814
3815       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3816         {
3817           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3818           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3819           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3820         }
3821       else if (mpfr_cmp_ui (w, 0) != 0
3822                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3823                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3824         {
3825           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3826           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3827           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3828         }
3829       else if (mpfr_cmp_ui (w, 0) != 0
3830                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3831                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3832         {
3833           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3834           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3835           mpfr_neg (w, w, GFC_RND_MODE);
3836           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3837         }
3838       else
3839         gfc_internal_error ("invalid complex argument of SQRT at %L",
3840                             &e->where);
3841
3842       mpfr_clear (s);
3843       mpfr_clear (t);
3844       mpfr_clear (ac);
3845       mpfr_clear (ad);
3846       mpfr_clear (w);
3847
3848       break;
3849
3850     default:
3851       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3852     }
3853
3854   return range_check (result, "SQRT");
3855
3856 negative_arg:
3857   gfc_free_expr (result);
3858   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3859   return &gfc_bad_expr;
3860 }
3861
3862
3863 gfc_expr *
3864 gfc_simplify_tan (gfc_expr *x)
3865 {
3866   int i;
3867   gfc_expr *result;
3868
3869   if (x->expr_type != EXPR_CONSTANT)
3870     return NULL;
3871
3872   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3873
3874   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3875
3876   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3877
3878   return range_check (result, "TAN");
3879 }
3880
3881
3882 gfc_expr *
3883 gfc_simplify_tanh (gfc_expr *x)
3884 {
3885   gfc_expr *result;
3886
3887   if (x->expr_type != EXPR_CONSTANT)
3888     return NULL;
3889
3890   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3891
3892   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3893
3894   return range_check (result, "TANH");
3895
3896 }
3897
3898
3899 gfc_expr *
3900 gfc_simplify_tiny (gfc_expr *e)
3901 {
3902   gfc_expr *result;
3903   int i;
3904
3905   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3906
3907   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3908   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3909
3910   return result;
3911 }
3912
3913
3914 gfc_expr *
3915 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3916 {
3917   gfc_expr *result;
3918   gfc_expr *mold_element;
3919   size_t source_size;
3920   size_t result_size;
3921   size_t result_elt_size;
3922   size_t buffer_size;
3923   mpz_t tmp;
3924   unsigned char *buffer;
3925
3926   if (!gfc_is_constant_expr (source)
3927         || !gfc_is_constant_expr (size))
3928     return NULL;
3929
3930   /* Calculate the size of the source.  */
3931   if (source->expr_type == EXPR_ARRAY
3932       && gfc_array_size (source, &tmp) == FAILURE)
3933     gfc_internal_error ("Failure getting length of a constant array.");
3934
3935   source_size = gfc_target_expr_size (source);
3936
3937   /* Create an empty new expression with the appropriate characteristics.  */
3938   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
3939                                 &source->where);
3940   result->ts = mold->ts;
3941
3942   mold_element = mold->expr_type == EXPR_ARRAY
3943                  ? mold->value.constructor->expr
3944                  : mold;
3945
3946   /* Set result character length, if needed.  Note that this needs to be
3947      set even for array expressions, in order to pass this information into
3948      gfc_target_interpret_expr.  */
3949   if (result->ts.type == BT_CHARACTER)
3950     result->value.character.length = mold_element->value.character.length;
3951
3952   /* Set the number of elements in the result, and determine its size.  */
3953   result_elt_size = gfc_target_expr_size (mold_element);
3954   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
3955     {
3956       int result_length;
3957
3958       result->expr_type = EXPR_ARRAY;
3959       result->rank = 1;
3960
3961       if (size)
3962         result_length = (size_t)mpz_get_ui (size->value.integer);
3963       else
3964         {
3965           result_length = source_size / result_elt_size;
3966           if (result_length * result_elt_size < source_size)
3967             result_length += 1;
3968         }
3969
3970       result->shape = gfc_get_shape (1);
3971       mpz_init_set_ui (result->shape[0], result_length);
3972
3973       result_size = result_length * result_elt_size;
3974     }
3975   else
3976     {
3977       result->rank = 0;
3978       result_size = result_elt_size;
3979     }
3980
3981   /* Allocate the buffer to store the binary version of the source.  */
3982   buffer_size = MAX (source_size, result_size);
3983   buffer = (unsigned char*)alloca (buffer_size);
3984
3985   /* Now write source to the buffer.  */
3986   gfc_target_encode_expr (source, buffer, buffer_size);
3987
3988   /* And read the buffer back into the new expression.  */
3989   gfc_target_interpret_expr (buffer, buffer_size, result);
3990
3991   return result;
3992 }
3993
3994
3995 gfc_expr *
3996 gfc_simplify_trim (gfc_expr *e)
3997 {
3998   gfc_expr *result;
3999   int count, i, len, lentrim;
4000
4001   if (e->expr_type != EXPR_CONSTANT)
4002     return NULL;
4003
4004   len = e->value.character.length;
4005
4006   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4007
4008   for (count = 0, i = 1; i <= len; ++i)
4009     {
4010       if (e->value.character.string[len - i] == ' ')
4011         count++;
4012       else
4013         break;
4014     }
4015
4016   lentrim = len - count;
4017
4018   result->value.character.length = lentrim;
4019   result->value.character.string = gfc_getmem (lentrim + 1);
4020
4021   for (i = 0; i < lentrim; i++)
4022     result->value.character.string[i] = e->value.character.string[i];
4023
4024   result->value.character.string[lentrim] = '\0';       /* For debugger */
4025
4026   return result;
4027 }
4028
4029
4030 gfc_expr *
4031 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
4032 {
4033   return simplify_bound (array, dim, 1);
4034 }
4035
4036
4037 gfc_expr *
4038 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
4039 {
4040   gfc_expr *result;
4041   int back;
4042   size_t index, len, lenset;
4043   size_t i;
4044
4045   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4046     return NULL;
4047
4048   if (b != NULL && b->value.logical != 0)
4049     back = 1;
4050   else
4051     back = 0;
4052
4053   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4054                                 &s->where);
4055
4056   len = s->value.character.length;
4057   lenset = set->value.character.length;
4058
4059   if (len == 0)
4060     {
4061       mpz_set_ui (result->value.integer, 0);
4062       return result;
4063     }
4064
4065   if (back == 0)
4066     {
4067       if (lenset == 0)
4068         {
4069           mpz_set_ui (result->value.integer, 1);
4070           return result;
4071         }
4072
4073       index = strspn (s->value.character.string, set->value.character.string)
4074             + 1;
4075       if (index > len)
4076         index = 0;
4077
4078     }
4079   else
4080     {
4081       if (lenset == 0)
4082         {
4083           mpz_set_ui (result->value.integer, len);
4084           return result;
4085         }
4086       for (index = len; index > 0; index --)
4087         {
4088           for (i = 0; i < lenset; i++)
4089             {
4090               if (s->value.character.string[index - 1]
4091                   == set->value.character.string[i])
4092                 break;
4093             }
4094           if (i == lenset)
4095             break;
4096         }
4097     }
4098
4099   mpz_set_ui (result->value.integer, index);
4100   return result;
4101 }
4102
4103
4104 gfc_expr *
4105 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4106 {
4107   gfc_expr *result;
4108   int kind;
4109
4110   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4111     return NULL;
4112
4113   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4114   if (x->ts.type == BT_INTEGER)
4115     {
4116       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4117       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4118     }
4119   else /* BT_LOGICAL */
4120     {
4121       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4122       result->value.logical = (x->value.logical && !y->value.logical)
4123                               || (!x->value.logical && y->value.logical);
4124     }
4125
4126   return range_check (result, "XOR");
4127 }
4128
4129
4130 /****************** Constant simplification *****************/
4131
4132 /* Master function to convert one constant to another.  While this is
4133    used as a simplification function, it requires the destination type
4134    and kind information which is supplied by a special case in
4135    do_simplify().  */
4136
4137 gfc_expr *
4138 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4139 {
4140   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4141   gfc_constructor *head, *c, *tail = NULL;
4142
4143   switch (e->ts.type)
4144     {
4145     case BT_INTEGER:
4146       switch (type)
4147         {
4148         case BT_INTEGER:
4149           f = gfc_int2int;
4150           break;
4151         case BT_REAL:
4152           f = gfc_int2real;
4153           break;
4154         case BT_COMPLEX:
4155           f = gfc_int2complex;
4156           break;
4157         case BT_LOGICAL:
4158           f = gfc_int2log;
4159           break;
4160         default:
4161           goto oops;
4162         }
4163       break;
4164
4165     case BT_REAL:
4166       switch (type)
4167         {
4168         case BT_INTEGER:
4169           f = gfc_real2int;
4170           break;
4171         case BT_REAL:
4172           f = gfc_real2real;
4173           break;
4174         case BT_COMPLEX:
4175           f = gfc_real2complex;
4176           break;
4177         default:
4178           goto oops;
4179         }
4180       break;
4181
4182     case BT_COMPLEX:
4183       switch (type)
4184         {
4185         case BT_INTEGER:
4186           f = gfc_complex2int;
4187           break;
4188         case BT_REAL:
4189           f = gfc_complex2real;
4190           break;
4191         case BT_COMPLEX:
4192           f = gfc_complex2complex;
4193           break;
4194
4195         default:
4196           goto oops;
4197         }
4198       break;
4199
4200     case BT_LOGICAL:
4201       switch (type)
4202         {
4203         case BT_INTEGER:
4204           f = gfc_log2int;
4205           break;
4206         case BT_LOGICAL:
4207           f = gfc_log2log;
4208           break;
4209         default:
4210           goto oops;
4211         }
4212       break;
4213
4214     case BT_HOLLERITH:
4215       switch (type)
4216         {
4217         case BT_INTEGER:
4218           f = gfc_hollerith2int;
4219           break;
4220
4221         case BT_REAL:
4222           f = gfc_hollerith2real;
4223           break;
4224
4225         case BT_COMPLEX:
4226           f = gfc_hollerith2complex;
4227           break;
4228
4229         case BT_CHARACTER:
4230           f = gfc_hollerith2character;
4231           break;
4232
4233         case BT_LOGICAL:
4234           f = gfc_hollerith2logical;
4235           break;
4236
4237         default:
4238           goto oops;
4239         }
4240       break;
4241
4242     default:
4243     oops:
4244       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4245     }
4246
4247   result = NULL;
4248
4249   switch (e->expr_type)
4250     {
4251     case EXPR_CONSTANT:
4252       result = f (e, kind);
4253       if (result == NULL)
4254         return &gfc_bad_expr;
4255       break;
4256
4257     case EXPR_ARRAY:
4258       if (!gfc_is_constant_expr (e))
4259         break;
4260
4261       head = NULL;
4262
4263       for (c = e->value.constructor; c; c = c->next)
4264         {
4265           if (head == NULL)
4266             head = tail = gfc_get_constructor ();
4267           else
4268             {
4269               tail->next = gfc_get_constructor ();
4270               tail = tail->next;
4271             }
4272
4273           tail->where = c->where;
4274
4275           if (c->iterator == NULL)
4276             tail->expr = f (c->expr, kind);
4277           else
4278             {
4279               g = gfc_convert_constant (c->expr, type, kind);
4280               if (g == &gfc_bad_expr)
4281                 return g;
4282               tail->expr = g;
4283             }
4284
4285           if (tail->expr == NULL)
4286             {
4287               gfc_free_constructor (head);
4288               return NULL;
4289             }
4290         }
4291
4292       result = gfc_get_expr ();
4293       result->ts.type = type;
4294       result->ts.kind = kind;
4295       result->expr_type = EXPR_ARRAY;
4296       result->value.constructor = head;
4297       result->shape = gfc_copy_shape (e->shape, e->rank);
4298       result->where = e->where;
4299       result->rank = e->rank;
4300       break;
4301
4302     default:
4303       break;
4304     }
4305
4306   return result;
4307 }