gcc/fortran/simplify.c

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