gcc/fortran/simplify.c

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