gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   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_get_wide_string (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   gfc_char_t 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_get_wide_string (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   gfc_char_t 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_get_wide_string (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       return range_check (result, "AND");
 509     }
 510   else /* BT_LOGICAL */
 511     {
 512       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
 513       result->value.logical = x->value.logical && y->value.logical;
 514       return result;
 515     }
 516
 517 }
 518
 519
 520 gfc_expr *
 521 gfc_simplify_dnint (gfc_expr *e)
 522 {
 523   gfc_expr *result;
 524
 525   if (e->expr_type != EXPR_CONSTANT)
 526     return NULL;
 527
 528   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
 529
 530   mpfr_round (result->value.real, e->value.real);
 531
 532   return range_check (result, "DNINT");
 533 }
 534
 535
 536 gfc_expr *
 537 gfc_simplify_asin (gfc_expr *x)
 538 {
 539   gfc_expr *result;
 540
 541   if (x->expr_type != EXPR_CONSTANT)
 542     return NULL;
 543
 544   if (mpfr_cmp_si (x->value.real, 1) > 0
 545       || mpfr_cmp_si (x->value.real, -1) < 0)
 546     {
 547       gfc_error ("Argument of ASIN at %L must be between -1 and 1",
 548                  &x->where);
 549       return &gfc_bad_expr;
 550     }
 551
 552   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 553
 554   mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
 555
 556   return range_check (result, "ASIN");
 557 }
 558
 559
 560 gfc_expr *
 561 gfc_simplify_asinh (gfc_expr *x)
 562 {
 563   gfc_expr *result;
 564
 565   if (x->expr_type != EXPR_CONSTANT)
 566     return NULL;
 567
 568   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 569
 570   mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
 571
 572   return range_check (result, "ASINH");
 573 }
 574
 575
 576 gfc_expr *
 577 gfc_simplify_atan (gfc_expr *x)
 578 {
 579   gfc_expr *result;
 580
 581   if (x->expr_type != EXPR_CONSTANT)
 582     return NULL;
 583
 584   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 585
 586   mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
 587
 588   return range_check (result, "ATAN");
 589 }
 590
 591
 592 gfc_expr *
 593 gfc_simplify_atanh (gfc_expr *x)
 594 {
 595   gfc_expr *result;
 596
 597   if (x->expr_type != EXPR_CONSTANT)
 598     return NULL;
 599
 600   if (mpfr_cmp_si (x->value.real, 1) >= 0
 601       || mpfr_cmp_si (x->value.real, -1) <= 0)
 602     {
 603       gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
 604                  &x->where);
 605       return &gfc_bad_expr;
 606     }
 607
 608   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 609
 610   mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
 611
 612   return range_check (result, "ATANH");
 613 }
 614
 615
 616 gfc_expr *
 617 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
 618 {
 619   gfc_expr *result;
 620
 621   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 622     return NULL;
 623
 624   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 625
 626   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
 627     {
 628       gfc_error ("If first argument of ATAN2 %L is zero, then the "
 629                  "second argument must not be zero", &x->where);
 630       gfc_free_expr (result);
 631       return &gfc_bad_expr;
 632     }
 633
 634   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 635
 636   return range_check (result, "ATAN2");
 637 }
 638
 639
 640 gfc_expr *
 641 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
 642 {
 643 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 644   gfc_expr *result;
 645
 646   if (x->expr_type != EXPR_CONSTANT)
 647     return NULL;
 648
 649   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 650   gfc_set_model_kind (x->ts.kind);
 651   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
 652
 653   return range_check (result, "BESSEL_J0");
 654 #else
 655   return NULL;
 656 #endif
 657 }
 658
 659
 660 gfc_expr *
 661 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
 662 {
 663 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 664   gfc_expr *result;
 665
 666   if (x->expr_type != EXPR_CONSTANT)
 667     return NULL;
 668
 669   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 670   gfc_set_model_kind (x->ts.kind);
 671   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
 672
 673   return range_check (result, "BESSEL_J1");
 674 #else
 675   return NULL;
 676 #endif
 677 }
 678
 679
 680 gfc_expr *
 681 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
 682                         gfc_expr *x ATTRIBUTE_UNUSED)
 683 {
 684 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 685   gfc_expr *result;
 686   long n;
 687
 688   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
 689     return NULL;
 690
 691   n = mpz_get_si (order->value.integer);
 692   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 693   gfc_set_model_kind (x->ts.kind);
 694   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
 695
 696   return range_check (result, "BESSEL_JN");
 697 #else
 698   return NULL;
 699 #endif
 700 }
 701
 702
 703 gfc_expr *
 704 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
 705 {
 706 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 707   gfc_expr *result;
 708
 709   if (x->expr_type != EXPR_CONSTANT)
 710     return NULL;
 711
 712   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 713   gfc_set_model_kind (x->ts.kind);
 714   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
 715
 716   return range_check (result, "BESSEL_Y0");
 717 #else
 718   return NULL;
 719 #endif
 720 }
 721
 722
 723 gfc_expr *
 724 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
 725 {
 726 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 727   gfc_expr *result;
 728
 729   if (x->expr_type != EXPR_CONSTANT)
 730     return NULL;
 731
 732   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 733   gfc_set_model_kind (x->ts.kind);
 734   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
 735
 736   return range_check (result, "BESSEL_Y1");
 737 #else
 738   return NULL;
 739 #endif
 740 }
 741
 742
 743 gfc_expr *
 744 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
 745                         gfc_expr *x ATTRIBUTE_UNUSED)
 746 {
 747 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
 748   gfc_expr *result;
 749   long n;
 750
 751   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
 752     return NULL;
 753
 754   n = mpz_get_si (order->value.integer);
 755   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 756   gfc_set_model_kind (x->ts.kind);
 757   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
 758
 759   return range_check (result, "BESSEL_YN");
 760 #else
 761   return NULL;
 762 #endif
 763 }
 764
 765
 766 gfc_expr *
 767 gfc_simplify_bit_size (gfc_expr *e)
 768 {
 769   gfc_expr *result;
 770   int i;
 771
 772   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 773   result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
 774   mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
 775
 776   return result;
 777 }
 778
 779
 780 gfc_expr *
 781 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
 782 {
 783   int b;
 784
 785   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
 786     return NULL;
 787
 788   if (gfc_extract_int (bit, &b) != NULL || b < 0)
 789     return gfc_logical_expr (0, &e->where);
 790
 791   return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
 792 }
 793
 794
 795 gfc_expr *
 796 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 797 {
 798   gfc_expr *ceil, *result;
 799   int kind;
 800
 801   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
 802   if (kind == -1)
 803     return &gfc_bad_expr;
 804
 805   if (e->expr_type != EXPR_CONSTANT)
 806     return NULL;
 807
 808   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
 809
 810   ceil = gfc_copy_expr (e);
 811
 812   mpfr_ceil (ceil->value.real, e->value.real);
 813   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
 814
 815   gfc_free_expr (ceil);
 816
 817   return range_check (result, "CEILING");
 818 }
 819
 820
 821 gfc_expr *
 822 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 823 {
 824   gfc_expr *result;
 825   int c, kind;
 826   const char *ch;
 827
 828   kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
 829   if (kind == -1)
 830     return &gfc_bad_expr;
 831
 832   if (e->expr_type != EXPR_CONSTANT)
 833     return NULL;
 834
 835   ch = gfc_extract_int (e, &c);
 836
 837   if (ch != NULL)
 838     gfc_internal_error ("gfc_simplify_char: %s", ch);
 839
 840   if (c < 0 || c > UCHAR_MAX)
 841     gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
 842                &e->where);
 843
 844   result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
 845
 846   result->value.character.length = 1;
 847   result->value.character.string = gfc_get_wide_string (2);
 848
 849   result->value.character.string[0] = c;
 850   result->value.character.string[1] = '\0';     /* For debugger */
 851
 852   return result;
 853 }
 854
 855
 856 /* Common subroutine for simplifying CMPLX and DCMPLX.  */
 857
 858 static gfc_expr *
 859 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
 860 {
 861   gfc_expr *result;
 862
 863   result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
 864
 865   mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
 866
 867   switch (x->ts.type)
 868     {
 869     case BT_INTEGER:
 870       if (!x->is_boz)
 871         mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
 872       break;
 873
 874     case BT_REAL:
 875       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 876       break;
 877
 878     case BT_COMPLEX:
 879       mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
 880       mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
 881       break;
 882
 883     default:
 884       gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
 885     }
 886
 887   if (y != NULL)
 888     {
 889       switch (y->ts.type)
 890         {
 891         case BT_INTEGER:
 892           if (!y->is_boz)
 893             mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
 894           break;
 895
 896         case BT_REAL:
 897           mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 898           break;
 899
 900         default:
 901           gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
 902         }
 903     }
 904
 905   /* Handle BOZ.  */
 906   if (x->is_boz)
 907     {
 908       gfc_typespec ts;
 909       gfc_clear_ts (&ts);
 910       ts.kind = result->ts.kind;
 911       ts.type = BT_REAL;
 912       if (!gfc_convert_boz (x, &ts))
 913         return &gfc_bad_expr;
 914       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 915     }
 916
 917   if (y && y->is_boz)
 918     {
 919       gfc_typespec ts;
 920       gfc_clear_ts (&ts);
 921       ts.kind = result->ts.kind;
 922       ts.type = BT_REAL;
 923       if (!gfc_convert_boz (y, &ts))
 924         return &gfc_bad_expr;
 925       mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 926     }
 927
 928   return range_check (result, name);
 929 }
 930
 931
 932 /* Function called when we won't simplify an expression like CMPLX (or
 933    COMPLEX or DCMPLX) but still want to convert BOZ arguments.  */
 934
 935 static gfc_expr *
 936 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
 937 {
 938   if (x->is_boz)
 939     {
 940       gfc_typespec ts;
 941       gfc_clear_ts (&ts);
 942       ts.type = BT_REAL;
 943       ts.kind = kind;
 944       if (!gfc_convert_boz (x, &ts))
 945         return &gfc_bad_expr;
 946     }
 947
 948   if (y && y->is_boz)
 949     {
 950       gfc_typespec ts;
 951       gfc_clear_ts (&ts);
 952       ts.type = BT_REAL;
 953       ts.kind = kind;
 954       if (!gfc_convert_boz (y, &ts))
 955         return &gfc_bad_expr;
 956     }
 957
 958   return NULL;
 959 }
 960
 961
 962 gfc_expr *
 963 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
 964 {
 965   int kind;
 966
 967   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
 968   if (kind == -1)
 969     return &gfc_bad_expr;
 970
 971   if (x->expr_type != EXPR_CONSTANT
 972       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 973     return only_convert_cmplx_boz (x, y, kind);
 974
 975   return simplify_cmplx ("CMPLX", x, y, kind);
 976 }
 977
 978
 979 gfc_expr *
 980 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
 981 {
 982   int kind;
 983
 984   if (x->ts.type == BT_INTEGER)
 985     {
 986       if (y->ts.type == BT_INTEGER)
 987         kind = gfc_default_real_kind;
 988       else
 989         kind = y->ts.kind;
 990     }
 991   else
 992     {
 993       if (y->ts.type == BT_REAL)
 994         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 995       else
 996         kind = x->ts.kind;
 997     }
 998
 999   if (x->expr_type != EXPR_CONSTANT
1000       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1001     return only_convert_cmplx_boz (x, y, kind);
1002
1003   return simplify_cmplx ("COMPLEX", x, y, kind);
1004 }
1005
1006
1007 gfc_expr *
1008 gfc_simplify_conjg (gfc_expr *e)
1009 {
1010   gfc_expr *result;
1011
1012   if (e->expr_type != EXPR_CONSTANT)
1013     return NULL;
1014
1015   result = gfc_copy_expr (e);
1016   mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
1017
1018   return range_check (result, "CONJG");
1019 }
1020
1021
1022 gfc_expr *
1023 gfc_simplify_cos (gfc_expr *x)
1024 {
1025   gfc_expr *result;
1026   mpfr_t xp, xq;
1027
1028   if (x->expr_type != EXPR_CONSTANT)
1029     return NULL;
1030
1031   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1032
1033   switch (x->ts.type)
1034     {
1035     case BT_REAL:
1036       mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1037       break;
1038     case BT_COMPLEX:
1039       gfc_set_model_kind (x->ts.kind);
1040       mpfr_init (xp);
1041       mpfr_init (xq);
1042
1043       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
1044       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1045       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1046
1047       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
1048       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1049       mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1050       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1051
1052       mpfr_clear (xp);
1053       mpfr_clear (xq);
1054       break;
1055     default:
1056       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1057     }
1058
1059   return range_check (result, "COS");
1060
1061 }
1062
1063
1064 gfc_expr *
1065 gfc_simplify_cosh (gfc_expr *x)
1066 {
1067   gfc_expr *result;
1068
1069   if (x->expr_type != EXPR_CONSTANT)
1070     return NULL;
1071
1072   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1073
1074   mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1075
1076   return range_check (result, "COSH");
1077 }
1078
1079
1080 gfc_expr *
1081 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1082 {
1083
1084   if (x->expr_type != EXPR_CONSTANT
1085       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1086     return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1087
1088   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1089 }
1090
1091
1092 gfc_expr *
1093 gfc_simplify_dble (gfc_expr *e)
1094 {
1095   gfc_expr *result;
1096
1097   if (e->expr_type != EXPR_CONSTANT)
1098     return NULL;
1099
1100   switch (e->ts.type)
1101     {
1102     case BT_INTEGER:
1103       if (!e->is_boz)
1104         result = gfc_int2real (e, gfc_default_double_kind);
1105       break;
1106
1107     case BT_REAL:
1108       result = gfc_real2real (e, gfc_default_double_kind);
1109       break;
1110
1111     case BT_COMPLEX:
1112       result = gfc_complex2real (e, gfc_default_double_kind);
1113       break;
1114
1115     default:
1116       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1117     }
1118
1119   if (e->ts.type == BT_INTEGER && e->is_boz)
1120     {
1121       gfc_typespec ts;
1122       gfc_clear_ts (&ts);
1123       ts.type = BT_REAL;
1124       ts.kind = gfc_default_double_kind;
1125       result = gfc_copy_expr (e);
1126       if (!gfc_convert_boz (result, &ts))
1127         {
1128           gfc_free_expr (result);
1129           return &gfc_bad_expr;
1130         }
1131     }
1132
1133   return range_check (result, "DBLE");
1134 }
1135
1136
1137 gfc_expr *
1138 gfc_simplify_digits (gfc_expr *x)
1139 {
1140   int i, digits;
1141
1142   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1143   switch (x->ts.type)
1144     {
1145     case BT_INTEGER:
1146       digits = gfc_integer_kinds[i].digits;
1147       break;
1148
1149     case BT_REAL:
1150     case BT_COMPLEX:
1151       digits = gfc_real_kinds[i].digits;
1152       break;
1153
1154     default:
1155       gcc_unreachable ();
1156     }
1157
1158   return gfc_int_expr (digits);
1159 }
1160
1161
1162 gfc_expr *
1163 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1164 {
1165   gfc_expr *result;
1166   int kind;
1167
1168   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1169     return NULL;
1170
1171   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1172   result = gfc_constant_result (x->ts.type, kind, &x->where);
1173
1174   switch (x->ts.type)
1175     {
1176     case BT_INTEGER:
1177       if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1178         mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1179       else
1180         mpz_set_ui (result->value.integer, 0);
1181
1182       break;
1183
1184     case BT_REAL:
1185       if (mpfr_cmp (x->value.real, y->value.real) > 0)
1186         mpfr_sub (result->value.real, x->value.real, y->value.real,
1187                   GFC_RND_MODE);
1188       else
1189         mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1190
1191       break;
1192
1193     default:
1194       gfc_internal_error ("gfc_simplify_dim(): Bad type");
1195     }
1196
1197   return range_check (result, "DIM");
1198 }
1199
1200
1201 gfc_expr *
1202 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1203 {
1204   gfc_expr *a1, *a2, *result;
1205
1206   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1207     return NULL;
1208
1209   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1210
1211   a1 = gfc_real2real (x, gfc_default_double_kind);
1212   a2 = gfc_real2real (y, gfc_default_double_kind);
1213
1214   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1215
1216   gfc_free_expr (a1);
1217   gfc_free_expr (a2);
1218
1219   return range_check (result, "DPROD");
1220 }
1221
1222
1223 gfc_expr *
1224 gfc_simplify_erf (gfc_expr *x)
1225 {
1226   gfc_expr *result;
1227
1228   if (x->expr_type != EXPR_CONSTANT)
1229     return NULL;
1230
1231   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1232
1233   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1234
1235   return range_check (result, "ERF");
1236 }
1237
1238
1239 gfc_expr *
1240 gfc_simplify_erfc (gfc_expr *x)
1241 {
1242   gfc_expr *result;
1243
1244   if (x->expr_type != EXPR_CONSTANT)
1245     return NULL;
1246
1247   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1248
1249   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1250
1251   return range_check (result, "ERFC");
1252 }
1253
1254
1255 gfc_expr *
1256 gfc_simplify_epsilon (gfc_expr *e)
1257 {
1258   gfc_expr *result;
1259   int i;
1260
1261   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1262
1263   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1264
1265   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1266
1267   return range_check (result, "EPSILON");
1268 }
1269
1270
1271 gfc_expr *
1272 gfc_simplify_exp (gfc_expr *x)
1273 {
1274   gfc_expr *result;
1275   mpfr_t xp, xq;
1276
1277   if (x->expr_type != EXPR_CONSTANT)
1278     return NULL;
1279
1280   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1281
1282   switch (x->ts.type)
1283     {
1284     case BT_REAL:
1285       mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1286       break;
1287
1288     case BT_COMPLEX:
1289       gfc_set_model_kind (x->ts.kind);
1290       mpfr_init (xp);
1291       mpfr_init (xq);
1292       mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1293       mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1294       mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1295       mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1296       mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1297       mpfr_clear (xp);
1298       mpfr_clear (xq);
1299       break;
1300
1301     default:
1302       gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1303     }
1304
1305   return range_check (result, "EXP");
1306 }
1307
1308 gfc_expr *
1309 gfc_simplify_exponent (gfc_expr *x)
1310 {
1311   int i;
1312   gfc_expr *result;
1313
1314   if (x->expr_type != EXPR_CONSTANT)
1315     return NULL;
1316
1317   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1318                                 &x->where);
1319
1320   gfc_set_model (x->value.real);
1321
1322   if (mpfr_sgn (x->value.real) == 0)
1323     {
1324       mpz_set_ui (result->value.integer, 0);
1325       return result;
1326     }
1327
1328   i = (int) mpfr_get_exp (x->value.real);
1329   mpz_set_si (result->value.integer, i);
1330
1331   return range_check (result, "EXPONENT");
1332 }
1333
1334
1335 gfc_expr *
1336 gfc_simplify_float (gfc_expr *a)
1337 {
1338   gfc_expr *result;
1339
1340   if (a->expr_type != EXPR_CONSTANT)
1341     return NULL;
1342
1343   if (a->is_boz)
1344     {
1345       gfc_typespec ts;
1346       gfc_clear_ts (&ts);
1347
1348       ts.type = BT_REAL;
1349       ts.kind = gfc_default_real_kind;
1350
1351       result = gfc_copy_expr (a);
1352       if (!gfc_convert_boz (result, &ts))
1353         {
1354           gfc_free_expr (result);
1355           return &gfc_bad_expr;
1356         }
1357     }
1358   else
1359     result = gfc_int2real (a, gfc_default_real_kind);
1360   return range_check (result, "FLOAT");
1361 }
1362
1363
1364 gfc_expr *
1365 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1366 {
1367   gfc_expr *result;
1368   mpfr_t floor;
1369   int kind;
1370
1371   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1372   if (kind == -1)
1373     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1374
1375   if (e->expr_type != EXPR_CONSTANT)
1376     return NULL;
1377
1378   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1379
1380   gfc_set_model_kind (kind);
1381   mpfr_init (floor);
1382   mpfr_floor (floor, e->value.real);
1383
1384   gfc_mpfr_to_mpz (result->value.integer, floor);
1385
1386   mpfr_clear (floor);
1387
1388   return range_check (result, "FLOOR");
1389 }
1390
1391
1392 gfc_expr *
1393 gfc_simplify_fraction (gfc_expr *x)
1394 {
1395   gfc_expr *result;
1396   mpfr_t absv, exp, pow2;
1397
1398   if (x->expr_type != EXPR_CONSTANT)
1399     return NULL;
1400
1401   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1402
1403   gfc_set_model_kind (x->ts.kind);
1404
1405   if (mpfr_sgn (x->value.real) == 0)
1406     {
1407       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1408       return result;
1409     }
1410
1411   mpfr_init (exp);
1412   mpfr_init (absv);
1413   mpfr_init (pow2);
1414
1415   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1416   mpfr_log2 (exp, absv, GFC_RND_MODE);
1417
1418   mpfr_trunc (exp, exp);
1419   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1420
1421   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1422
1423   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1424
1425   mpfr_clear (exp);
1426   mpfr_clear (absv);
1427   mpfr_clear (pow2);
1428
1429   return range_check (result, "FRACTION");
1430 }
1431
1432
1433 gfc_expr *
1434 gfc_simplify_gamma (gfc_expr *x)
1435 {
1436   gfc_expr *result;
1437
1438   if (x->expr_type != EXPR_CONSTANT)
1439     return NULL;
1440
1441   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1442
1443   gfc_set_model_kind (x->ts.kind);
1444
1445   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1446
1447   return range_check (result, "GAMMA");
1448 }
1449
1450
1451 gfc_expr *
1452 gfc_simplify_huge (gfc_expr *e)
1453 {
1454   gfc_expr *result;
1455   int i;
1456
1457   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1458
1459   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1460
1461   switch (e->ts.type)
1462     {
1463     case BT_INTEGER:
1464       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1465       break;
1466
1467     case BT_REAL:
1468       mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1469       break;
1470
1471     default:
1472       gcc_unreachable ();
1473     }
1474
1475   return result;
1476 }
1477
1478
1479 gfc_expr *
1480 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1481 {
1482   gfc_expr *result;
1483
1484   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1485     return NULL;
1486
1487   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1488   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1489   return range_check (result, "HYPOT");
1490 }
1491
1492
1493 /* We use the processor's collating sequence, because all
1494    systems that gfortran currently works on are ASCII.  */
1495
1496 gfc_expr *
1497 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1498 {
1499   gfc_expr *result;
1500   gfc_char_t index;
1501
1502   if (e->expr_type != EXPR_CONSTANT)
1503     return NULL;
1504
1505   if (e->value.character.length != 1)
1506     {
1507       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1508       return &gfc_bad_expr;
1509     }
1510
1511   index = e->value.character.string[0];
1512
1513   if (gfc_option.warn_surprising && index > 127)
1514     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1515                  &e->where);
1516
1517   if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1518     return &gfc_bad_expr;
1519
1520   result->where = e->where;
1521
1522   return range_check (result, "IACHAR");
1523 }
1524
1525
1526 gfc_expr *
1527 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1528 {
1529   gfc_expr *result;
1530
1531   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1532     return NULL;
1533
1534   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1535
1536   mpz_and (result->value.integer, x->value.integer, y->value.integer);
1537
1538   return range_check (result, "IAND");
1539 }
1540
1541
1542 gfc_expr *
1543 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1544 {
1545   gfc_expr *result;
1546   int k, pos;
1547
1548   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1549     return NULL;
1550
1551   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1552     {
1553       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1554       return &gfc_bad_expr;
1555     }
1556
1557   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1558
1559   if (pos >= gfc_integer_kinds[k].bit_size)
1560     {
1561       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1562                  &y->where);
1563       return &gfc_bad_expr;
1564     }
1565
1566   result = gfc_copy_expr (x);
1567
1568   convert_mpz_to_unsigned (result->value.integer,
1569                            gfc_integer_kinds[k].bit_size);
1570
1571   mpz_clrbit (result->value.integer, pos);
1572
1573   convert_mpz_to_signed (result->value.integer,
1574                          gfc_integer_kinds[k].bit_size);
1575
1576   return result;
1577 }
1578
1579
1580 gfc_expr *
1581 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1582 {
1583   gfc_expr *result;
1584   int pos, len;
1585   int i, k, bitsize;
1586   int *bits;
1587
1588   if (x->expr_type != EXPR_CONSTANT
1589       || y->expr_type != EXPR_CONSTANT
1590       || z->expr_type != EXPR_CONSTANT)
1591     return NULL;
1592
1593   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1594     {
1595       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1596       return &gfc_bad_expr;
1597     }
1598
1599   if (gfc_extract_int (z, &len) != NULL || len < 0)
1600     {
1601       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1602       return &gfc_bad_expr;
1603     }
1604
1605   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1606
1607   bitsize = gfc_integer_kinds[k].bit_size;
1608
1609   if (pos + len > bitsize)
1610     {
1611       gfc_error ("Sum of second and third arguments of IBITS exceeds "
1612                  "bit size at %L", &y->where);
1613       return &gfc_bad_expr;
1614     }
1615
1616   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1617   convert_mpz_to_unsigned (result->value.integer,
1618                            gfc_integer_kinds[k].bit_size);
1619
1620   bits = gfc_getmem (bitsize * sizeof (int));
1621
1622   for (i = 0; i < bitsize; i++)
1623     bits[i] = 0;
1624
1625   for (i = 0; i < len; i++)
1626     bits[i] = mpz_tstbit (x->value.integer, i + pos);
1627
1628   for (i = 0; i < bitsize; i++)
1629     {
1630       if (bits[i] == 0)
1631         mpz_clrbit (result->value.integer, i);
1632       else if (bits[i] == 1)
1633         mpz_setbit (result->value.integer, i);
1634       else
1635         gfc_internal_error ("IBITS: Bad bit");
1636     }
1637
1638   gfc_free (bits);
1639
1640   convert_mpz_to_signed (result->value.integer,
1641                          gfc_integer_kinds[k].bit_size);
1642
1643   return result;
1644 }
1645
1646
1647 gfc_expr *
1648 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1649 {
1650   gfc_expr *result;
1651   int k, pos;
1652
1653   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1654     return NULL;
1655
1656   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1657     {
1658       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1659       return &gfc_bad_expr;
1660     }
1661
1662   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1663
1664   if (pos >= gfc_integer_kinds[k].bit_size)
1665     {
1666       gfc_error ("Second argument of IBSET exceeds bit size at %L",
1667                  &y->where);
1668       return &gfc_bad_expr;
1669     }
1670
1671   result = gfc_copy_expr (x);
1672
1673   convert_mpz_to_unsigned (result->value.integer,
1674                            gfc_integer_kinds[k].bit_size);
1675
1676   mpz_setbit (result->value.integer, pos);
1677
1678   convert_mpz_to_signed (result->value.integer,
1679                          gfc_integer_kinds[k].bit_size);
1680
1681   return result;
1682 }
1683
1684
1685 gfc_expr *
1686 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1687 {
1688   gfc_expr *result;
1689   gfc_char_t index;
1690
1691   if (e->expr_type != EXPR_CONSTANT)
1692     return NULL;
1693
1694   if (e->value.character.length != 1)
1695     {
1696       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1697       return &gfc_bad_expr;
1698     }
1699
1700   index = e->value.character.string[0];
1701   if (index > UCHAR_MAX)
1702     gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1703
1704   if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1705     return &gfc_bad_expr;
1706
1707   result->where = e->where;
1708   return range_check (result, "ICHAR");
1709 }
1710
1711
1712 gfc_expr *
1713 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1714 {
1715   gfc_expr *result;
1716
1717   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1718     return NULL;
1719
1720   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1721
1722   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1723
1724   return range_check (result, "IEOR");
1725 }
1726
1727
1728 gfc_expr *
1729 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1730 {
1731   gfc_expr *result;
1732   int back, len, lensub;
1733   int i, j, k, count, index = 0, start;
1734
1735   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
1736       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
1737     return NULL;
1738
1739   if (b != NULL && b->value.logical != 0)
1740     back = 1;
1741   else
1742     back = 0;
1743
1744   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1745   if (k == -1)
1746     return &gfc_bad_expr;
1747
1748   result = gfc_constant_result (BT_INTEGER, k, &x->where);
1749
1750   len = x->value.character.length;
1751   lensub = y->value.character.length;
1752
1753   if (len < lensub)
1754     {
1755       mpz_set_si (result->value.integer, 0);
1756       return result;
1757     }
1758
1759   if (back == 0)
1760     {
1761       if (lensub == 0)
1762         {
1763           mpz_set_si (result->value.integer, 1);
1764           return result;
1765         }
1766       else if (lensub == 1)
1767         {
1768           for (i = 0; i < len; i++)
1769             {
1770               for (j = 0; j < lensub; j++)
1771                 {
1772                   if (y->value.character.string[j]
1773                       == x->value.character.string[i])
1774                     {
1775                       index = i + 1;
1776                       goto done;
1777                     }
1778                 }
1779             }
1780         }
1781       else
1782         {
1783           for (i = 0; i < len; i++)
1784             {
1785               for (j = 0; j < lensub; j++)
1786                 {
1787                   if (y->value.character.string[j]
1788                       == x->value.character.string[i])
1789                     {
1790                       start = i;
1791                       count = 0;
1792
1793                       for (k = 0; k < lensub; k++)
1794                         {
1795                           if (y->value.character.string[k]
1796                               == x->value.character.string[k + start])
1797                             count++;
1798                         }
1799
1800                       if (count == lensub)
1801                         {
1802                           index = start + 1;
1803                           goto done;
1804                         }
1805                     }
1806                 }
1807             }
1808         }
1809
1810     }
1811   else
1812     {
1813       if (lensub == 0)
1814         {
1815           mpz_set_si (result->value.integer, len + 1);
1816           return result;
1817         }
1818       else if (lensub == 1)
1819         {
1820           for (i = 0; i < len; i++)
1821             {
1822               for (j = 0; j < lensub; j++)
1823                 {
1824                   if (y->value.character.string[j]
1825                       == x->value.character.string[len - i])
1826                     {
1827                       index = len - i + 1;
1828                       goto done;
1829                     }
1830                 }
1831             }
1832         }
1833       else
1834         {
1835           for (i = 0; i < len; i++)
1836             {
1837               for (j = 0; j < lensub; j++)
1838                 {
1839                   if (y->value.character.string[j]
1840                       == x->value.character.string[len - i])
1841                     {
1842                       start = len - i;
1843                       if (start <= len - lensub)
1844                         {
1845                           count = 0;
1846                           for (k = 0; k < lensub; k++)
1847                             if (y->value.character.string[k]
1848                                 == x->value.character.string[k + start])
1849                               count++;
1850
1851                           if (count == lensub)
1852                             {
1853                               index = start + 1;
1854                               goto done;
1855                             }
1856                         }
1857                       else
1858                         {
1859                           continue;
1860                         }
1861                     }
1862                 }
1863             }
1864         }
1865     }
1866
1867 done:
1868   mpz_set_si (result->value.integer, index);
1869   return range_check (result, "INDEX");
1870 }
1871
1872
1873 gfc_expr *
1874 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1875 {
1876   gfc_expr *result = NULL;
1877   int kind;
1878
1879   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1880   if (kind == -1)
1881     return &gfc_bad_expr;
1882
1883   if (e->expr_type != EXPR_CONSTANT)
1884     return NULL;
1885
1886   switch (e->ts.type)
1887     {
1888     case BT_INTEGER:
1889       result = gfc_int2int (e, kind);
1890       break;
1891
1892     case BT_REAL:
1893       result = gfc_real2int (e, kind);
1894       break;
1895
1896     case BT_COMPLEX:
1897       result = gfc_complex2int (e, kind);
1898       break;
1899
1900     default:
1901       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1902       return &gfc_bad_expr;
1903     }
1904
1905   return range_check (result, "INT");
1906 }
1907
1908
1909 static gfc_expr *
1910 simplify_intconv (gfc_expr *e, int kind, const char *name)
1911 {
1912   gfc_expr *result = NULL;
1913
1914   if (e->expr_type != EXPR_CONSTANT)
1915     return NULL;
1916
1917   switch (e->ts.type)
1918     {
1919     case BT_INTEGER:
1920       result = gfc_int2int (e, kind);
1921       break;
1922
1923     case BT_REAL:
1924       result = gfc_real2int (e, kind);
1925       break;
1926
1927     case BT_COMPLEX:
1928       result = gfc_complex2int (e, kind);
1929       break;
1930
1931     default:
1932       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1933       return &gfc_bad_expr;
1934     }
1935
1936   return range_check (result, name);
1937 }
1938
1939
1940 gfc_expr *
1941 gfc_simplify_int2 (gfc_expr *e)
1942 {
1943   return simplify_intconv (e, 2, "INT2");
1944 }
1945
1946
1947 gfc_expr *
1948 gfc_simplify_int8 (gfc_expr *e)
1949 {
1950   return simplify_intconv (e, 8, "INT8");
1951 }
1952
1953
1954 gfc_expr *
1955 gfc_simplify_long (gfc_expr *e)
1956 {
1957   return simplify_intconv (e, 4, "LONG");
1958 }
1959
1960
1961 gfc_expr *
1962 gfc_simplify_ifix (gfc_expr *e)
1963 {
1964   gfc_expr *rtrunc, *result;
1965
1966   if (e->expr_type != EXPR_CONSTANT)
1967     return NULL;
1968
1969   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1970                                 &e->where);
1971
1972   rtrunc = gfc_copy_expr (e);
1973
1974   mpfr_trunc (rtrunc->value.real, e->value.real);
1975   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1976
1977   gfc_free_expr (rtrunc);
1978   return range_check (result, "IFIX");
1979 }
1980
1981
1982 gfc_expr *
1983 gfc_simplify_idint (gfc_expr *e)
1984 {
1985   gfc_expr *rtrunc, *result;
1986
1987   if (e->expr_type != EXPR_CONSTANT)
1988     return NULL;
1989
1990   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1991                                 &e->where);
1992
1993   rtrunc = gfc_copy_expr (e);
1994
1995   mpfr_trunc (rtrunc->value.real, e->value.real);
1996   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1997
1998   gfc_free_expr (rtrunc);
1999   return range_check (result, "IDINT");
2000 }
2001
2002
2003 gfc_expr *
2004 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2005 {
2006   gfc_expr *result;
2007
2008   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2009     return NULL;
2010
2011   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
2012
2013   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2014   return range_check (result, "IOR");
2015 }
2016
2017
2018 gfc_expr *
2019 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2020 {
2021   gfc_expr *result;
2022   int shift, ashift, isize, k, *bits, i;
2023
2024   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2025     return NULL;
2026
2027   if (gfc_extract_int (s, &shift) != NULL)
2028     {
2029       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2030       return &gfc_bad_expr;
2031     }
2032
2033   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2034
2035   isize = gfc_integer_kinds[k].bit_size;
2036
2037   if (shift >= 0)
2038     ashift = shift;
2039   else
2040     ashift = -shift;
2041
2042   if (ashift > isize)
2043     {
2044       gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2045                  "at %L", &s->where);
2046       return &gfc_bad_expr;
2047     }
2048
2049   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2050
2051   if (shift == 0)
2052     {
2053       mpz_set (result->value.integer, e->value.integer);
2054       return range_check (result, "ISHFT");
2055     }
2056
2057   bits = gfc_getmem (isize * sizeof (int));
2058
2059   for (i = 0; i < isize; i++)
2060     bits[i] = mpz_tstbit (e->value.integer, i);
2061
2062   if (shift > 0)
2063     {
2064       for (i = 0; i < shift; i++)
2065         mpz_clrbit (result->value.integer, i);
2066
2067       for (i = 0; i < isize - shift; i++)
2068         {
2069           if (bits[i] == 0)
2070             mpz_clrbit (result->value.integer, i + shift);
2071           else
2072             mpz_setbit (result->value.integer, i + shift);
2073         }
2074     }
2075   else
2076     {
2077       for (i = isize - 1; i >= isize - ashift; i--)
2078         mpz_clrbit (result->value.integer, i);
2079
2080       for (i = isize - 1; i >= ashift; i--)
2081         {
2082           if (bits[i] == 0)
2083             mpz_clrbit (result->value.integer, i - ashift);
2084           else
2085             mpz_setbit (result->value.integer, i - ashift);
2086         }
2087     }
2088
2089   convert_mpz_to_signed (result->value.integer, isize);
2090
2091   gfc_free (bits);
2092   return result;
2093 }
2094
2095
2096 gfc_expr *
2097 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2098 {
2099   gfc_expr *result;
2100   int shift, ashift, isize, ssize, delta, k;
2101   int i, *bits;
2102
2103   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2104     return NULL;
2105
2106   if (gfc_extract_int (s, &shift) != NULL)
2107     {
2108       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2109       return &gfc_bad_expr;
2110     }
2111
2112   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2113   isize = gfc_integer_kinds[k].bit_size;
2114
2115   if (sz != NULL)
2116     {
2117       if (sz->expr_type != EXPR_CONSTANT)
2118         return NULL;
2119
2120       if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2121         {
2122           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2123           return &gfc_bad_expr;
2124         }
2125
2126       if (ssize > isize)
2127         {
2128           gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2129                      "BIT_SIZE of first argument at %L", &s->where);
2130           return &gfc_bad_expr;
2131         }
2132     }
2133   else
2134     ssize = isize;
2135
2136   if (shift >= 0)
2137     ashift = shift;
2138   else
2139     ashift = -shift;
2140
2141   if (ashift > ssize)
2142     {
2143       if (sz != NULL)
2144         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2145                    "third argument at %L", &s->where);
2146       else
2147         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2148                    "BIT_SIZE of first argument at %L", &s->where);
2149       return &gfc_bad_expr;
2150     }
2151
2152   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2153
2154   mpz_set (result->value.integer, e->value.integer);
2155
2156   if (shift == 0)
2157     return result;
2158
2159   convert_mpz_to_unsigned (result->value.integer, isize);
2160
2161   bits = gfc_getmem (ssize * sizeof (int));
2162
2163   for (i = 0; i < ssize; i++)
2164     bits[i] = mpz_tstbit (e->value.integer, i);
2165
2166   delta = ssize - ashift;
2167
2168   if (shift > 0)
2169     {
2170       for (i = 0; i < delta; i++)
2171         {
2172           if (bits[i] == 0)
2173             mpz_clrbit (result->value.integer, i + shift);
2174           else
2175             mpz_setbit (result->value.integer, i + shift);
2176         }
2177
2178       for (i = delta; i < ssize; i++)
2179         {
2180           if (bits[i] == 0)
2181             mpz_clrbit (result->value.integer, i - delta);
2182           else
2183             mpz_setbit (result->value.integer, i - delta);
2184         }
2185     }
2186   else
2187     {
2188       for (i = 0; i < ashift; i++)
2189         {
2190           if (bits[i] == 0)
2191             mpz_clrbit (result->value.integer, i + delta);
2192           else
2193             mpz_setbit (result->value.integer, i + delta);
2194         }
2195
2196       for (i = ashift; i < ssize; i++)
2197         {
2198           if (bits[i] == 0)
2199             mpz_clrbit (result->value.integer, i + shift);
2200           else
2201             mpz_setbit (result->value.integer, i + shift);
2202         }
2203     }
2204
2205   convert_mpz_to_signed (result->value.integer, isize);
2206
2207   gfc_free (bits);
2208   return result;
2209 }
2210
2211
2212 gfc_expr *
2213 gfc_simplify_kind (gfc_expr *e)
2214 {
2215
2216   if (e->ts.type == BT_DERIVED)
2217     {
2218       gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2219       return &gfc_bad_expr;
2220     }
2221
2222   return gfc_int_expr (e->ts.kind);
2223 }
2224
2225
2226 static gfc_expr *
2227 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2228                     gfc_array_spec *as)
2229 {
2230   gfc_expr *l, *u, *result;
2231   int k;
2232
2233   /* The last dimension of an assumed-size array is special.  */
2234   if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2235     {
2236       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2237         return gfc_copy_expr (as->lower[d-1]);
2238       else
2239         return NULL;
2240     }
2241
2242   /* Then, we need to know the extent of the given dimension.  */
2243   l = as->lower[d-1];
2244   u = as->upper[d-1];
2245
2246   if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2247     return NULL;
2248
2249   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2250                 gfc_default_integer_kind);
2251   if (k == -1)
2252     return &gfc_bad_expr;
2253
2254   result = gfc_constant_result (BT_INTEGER, k, &array->where);
2255
2256   if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2257     {
2258       /* Zero extent.  */
2259       if (upper)
2260         mpz_set_si (result->value.integer, 0);
2261       else
2262         mpz_set_si (result->value.integer, 1);
2263     }
2264   else
2265     {
2266       /* Nonzero extent.  */
2267       if (upper)
2268         mpz_set (result->value.integer, u->value.integer);
2269       else
2270         mpz_set (result->value.integer, l->value.integer);
2271     }
2272
2273   return range_check (result, upper ? "UBOUND" : "LBOUND");
2274 }
2275
2276
2277 static gfc_expr *
2278 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2279 {
2280   gfc_ref *ref;
2281   gfc_array_spec *as;
2282   int d;
2283
2284   if (array->expr_type != EXPR_VARIABLE)
2285     return NULL;
2286
2287   /* Follow any component references.  */
2288   as = array->symtree->n.sym->as;
2289   for (ref = array->ref; ref; ref = ref->next)
2290     {
2291       switch (ref->type)
2292         {
2293         case REF_ARRAY:
2294           switch (ref->u.ar.type)
2295             {
2296             case AR_ELEMENT:
2297               as = NULL;
2298               continue;
2299
2300             case AR_FULL:
2301               /* We're done because 'as' has already been set in the
2302                  previous iteration.  */
2303               goto done;
2304
2305             case AR_SECTION:
2306             case AR_UNKNOWN:
2307               return NULL;
2308             }
2309
2310           gcc_unreachable ();
2311
2312         case REF_COMPONENT:
2313           as = ref->u.c.component->as;
2314           continue;
2315
2316         case REF_SUBSTRING:
2317           continue;
2318         }
2319     }
2320
2321   gcc_unreachable ();
2322
2323  done:
2324
2325   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2326     return NULL;
2327
2328   if (dim == NULL)
2329     {
2330       /* Multi-dimensional bounds.  */
2331       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2332       gfc_expr *e;
2333       gfc_constructor *head, *tail;
2334       int k;
2335
2336       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
2337       if (upper && as->type == AS_ASSUMED_SIZE)
2338         {
2339           /* An error message will be emitted in
2340              check_assumed_size_reference (resolve.c).  */
2341           return &gfc_bad_expr;
2342         }
2343
2344       /* Simplify the bounds for each dimension.  */
2345       for (d = 0; d < array->rank; d++)
2346         {
2347           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2348           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2349             {
2350               int j;
2351
2352               for (j = 0; j < d; j++)
2353                 gfc_free_expr (bounds[j]);
2354               return bounds[d];
2355             }
2356         }
2357
2358       /* Allocate the result expression.  */
2359       e = gfc_get_expr ();
2360       e->where = array->where;
2361       e->expr_type = EXPR_ARRAY;
2362       e->ts.type = BT_INTEGER;
2363       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2364                     gfc_default_integer_kind);
2365       if (k == -1)
2366         {
2367           gfc_free_expr (e);
2368           return &gfc_bad_expr;
2369         }
2370       e->ts.kind = k;
2371
2372       /* The result is a rank 1 array; its size is the rank of the first
2373          argument to {L,U}BOUND.  */
2374       e->rank = 1;
2375       e->shape = gfc_get_shape (1);
2376       mpz_init_set_ui (e->shape[0], array->rank);
2377
2378       /* Create the constructor for this array.  */
2379       head = tail = NULL;
2380       for (d = 0; d < array->rank; d++)
2381         {
2382           /* Get a new constructor element.  */
2383           if (head == NULL)
2384             head = tail = gfc_get_constructor ();
2385           else
2386             {
2387               tail->next = gfc_get_constructor ();
2388               tail = tail->next;
2389             }
2390
2391           tail->where = e->where;
2392           tail->expr = bounds[d];
2393         }
2394       e->value.constructor = head;
2395
2396       return e;
2397     }
2398   else
2399     {
2400       /* A DIM argument is specified.  */
2401       if (dim->expr_type != EXPR_CONSTANT)
2402         return NULL;
2403
2404       d = mpz_get_si (dim->value.integer);
2405
2406       if (d < 1 || d > as->rank
2407           || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2408         {
2409           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2410           return &gfc_bad_expr;
2411         }
2412
2413       return simplify_bound_dim (array, kind, d, upper, as);
2414     }
2415 }
2416
2417
2418 gfc_expr *
2419 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2420 {
2421   return simplify_bound (array, dim, kind, 0);
2422 }
2423
2424
2425 gfc_expr *
2426 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2427 {
2428   gfc_expr *result;
2429   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2430
2431   if (k == -1)
2432     return &gfc_bad_expr;
2433
2434   if (e->expr_type == EXPR_CONSTANT)
2435     {
2436       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2437       mpz_set_si (result->value.integer, e->value.character.length);
2438       return range_check (result, "LEN");
2439     }
2440
2441   if (e->ts.cl != NULL && e->ts.cl->length != NULL
2442       && e->ts.cl->length->expr_type == EXPR_CONSTANT
2443       && e->ts.cl->length->ts.type == BT_INTEGER)
2444     {
2445       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2446       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2447       return range_check (result, "LEN");
2448     }
2449
2450   return NULL;
2451 }
2452
2453
2454 gfc_expr *
2455 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2456 {
2457   gfc_expr *result;
2458   int count, len, lentrim, i;
2459   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2460
2461   if (k == -1)
2462     return &gfc_bad_expr;
2463
2464   if (e->expr_type != EXPR_CONSTANT)
2465     return NULL;
2466
2467   result = gfc_constant_result (BT_INTEGER, k, &e->where);
2468   len = e->value.character.length;
2469
2470   for (count = 0, i = 1; i <= len; i++)
2471     if (e->value.character.string[len - i] == ' ')
2472       count++;
2473     else
2474       break;
2475
2476   lentrim = len - count;
2477
2478   mpz_set_si (result->value.integer, lentrim);
2479   return range_check (result, "LEN_TRIM");
2480 }
2481
2482 gfc_expr *
2483 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
2484 {
2485 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2486   gfc_expr *result;
2487   int sg;
2488
2489   if (x->expr_type != EXPR_CONSTANT)
2490     return NULL;
2491
2492   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2493
2494   gfc_set_model_kind (x->ts.kind);
2495
2496   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2497
2498   return range_check (result, "LGAMMA");
2499 #else
2500   return NULL;
2501 #endif
2502 }
2503
2504
2505 gfc_expr *
2506 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2507 {
2508   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2509     return NULL;
2510
2511   return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2512 }
2513
2514
2515 gfc_expr *
2516 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2517 {
2518   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2519     return NULL;
2520
2521   return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2522                            &a->where);
2523 }
2524
2525
2526 gfc_expr *
2527 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2528 {
2529   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2530     return NULL;
2531
2532   return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2533 }
2534
2535
2536 gfc_expr *
2537 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2538 {
2539   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2540     return NULL;
2541
2542   return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2543 }
2544
2545
2546 gfc_expr *
2547 gfc_simplify_log (gfc_expr *x)
2548 {
2549   gfc_expr *result;
2550   mpfr_t xr, xi;
2551
2552   if (x->expr_type != EXPR_CONSTANT)
2553     return NULL;
2554
2555   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2556
2557   gfc_set_model_kind (x->ts.kind);
2558
2559   switch (x->ts.type)
2560     {
2561     case BT_REAL:
2562       if (mpfr_sgn (x->value.real) <= 0)
2563         {
2564           gfc_error ("Argument of LOG at %L cannot be less than or equal "
2565                      "to zero", &x->where);
2566           gfc_free_expr (result);
2567           return &gfc_bad_expr;
2568         }
2569
2570       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2571       break;
2572
2573     case BT_COMPLEX:
2574       if ((mpfr_sgn (x->value.complex.r) == 0)
2575           && (mpfr_sgn (x->value.complex.i) == 0))
2576         {
2577           gfc_error ("Complex argument of LOG at %L cannot be zero",
2578                      &x->where);
2579           gfc_free_expr (result);
2580           return &gfc_bad_expr;
2581         }
2582
2583       mpfr_init (xr);
2584       mpfr_init (xi);
2585
2586       mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2587                   x->value.complex.r, GFC_RND_MODE);
2588
2589       mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2590       mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2591       mpfr_add (xr, xr, xi, GFC_RND_MODE);
2592       mpfr_sqrt (xr, xr, GFC_RND_MODE);
2593       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2594
2595       mpfr_clear (xr);
2596       mpfr_clear (xi);
2597
2598       break;
2599
2600     default:
2601       gfc_internal_error ("gfc_simplify_log: bad type");
2602     }
2603
2604   return range_check (result, "LOG");
2605 }
2606
2607
2608 gfc_expr *
2609 gfc_simplify_log10 (gfc_expr *x)
2610 {
2611   gfc_expr *result;
2612
2613   if (x->expr_type != EXPR_CONSTANT)
2614     return NULL;
2615
2616   gfc_set_model_kind (x->ts.kind);
2617
2618   if (mpfr_sgn (x->value.real) <= 0)
2619     {
2620       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2621                  "to zero", &x->where);
2622       return &gfc_bad_expr;
2623     }
2624
2625   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2626
2627   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2628
2629   return range_check (result, "LOG10");
2630 }
2631
2632
2633 gfc_expr *
2634 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2635 {
2636   gfc_expr *result;
2637   int kind;
2638
2639   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2640   if (kind < 0)
2641     return &gfc_bad_expr;
2642
2643   if (e->expr_type != EXPR_CONSTANT)
2644     return NULL;
2645
2646   result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2647
2648   result->value.logical = e->value.logical;
2649
2650   return result;
2651 }
2652
2653
2654 /* This function is special since MAX() can take any number of
2655    arguments.  The simplified expression is a rewritten version of the
2656    argument list containing at most one constant element.  Other
2657    constant elements are deleted.  Because the argument list has
2658    already been checked, this function always succeeds.  sign is 1 for
2659    MAX(), -1 for MIN().  */
2660
2661 static gfc_expr *
2662 simplify_min_max (gfc_expr *expr, int sign)
2663 {
2664   gfc_actual_arglist *arg, *last, *extremum;
2665   gfc_intrinsic_sym * specific;
2666
2667   last = NULL;
2668   extremum = NULL;
2669   specific = expr->value.function.isym;
2670
2671   arg = expr->value.function.actual;
2672
2673   for (; arg; last = arg, arg = arg->next)
2674     {
2675       if (arg->expr->expr_type != EXPR_CONSTANT)
2676         continue;
2677
2678       if (extremum == NULL)
2679         {
2680           extremum = arg;
2681           continue;
2682         }
2683
2684       switch (arg->expr->ts.type)
2685         {
2686         case BT_INTEGER:
2687           if (mpz_cmp (arg->expr->value.integer,
2688                        extremum->expr->value.integer) * sign > 0)
2689             mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2690           break;
2691
2692         case BT_REAL:
2693           /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
2694           if (sign > 0)
2695             mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2696                       arg->expr->value.real, GFC_RND_MODE);
2697           else
2698             mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2699                       arg->expr->value.real, GFC_RND_MODE);
2700           break;
2701
2702         case BT_CHARACTER:
2703 #define LENGTH(x) ((x)->expr->value.character.length)
2704 #define STRING(x) ((x)->expr->value.character.string)
2705           if (LENGTH(extremum) < LENGTH(arg))
2706             {
2707               gfc_char_t *tmp = STRING(extremum);
2708
2709               STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2710               memcpy (STRING(extremum), tmp,
2711                       LENGTH(extremum) * sizeof (gfc_char_t));
2712               gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2713                                LENGTH(arg) - LENGTH(extremum));
2714               STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
2715               LENGTH(extremum) = LENGTH(arg);
2716               gfc_free (tmp);
2717             }
2718
2719           if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2720             {
2721               gfc_free (STRING(extremum));
2722               STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2723               memcpy (STRING(extremum), STRING(arg),
2724                       LENGTH(arg) * sizeof (gfc_char_t));
2725               gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2726                                LENGTH(extremum) - LENGTH(arg));
2727               STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
2728             }
2729 #undef LENGTH
2730 #undef STRING
2731           break;
2732
2733
2734         default:
2735           gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2736         }
2737
2738       /* Delete the extra constant argument.  */
2739       if (last == NULL)
2740         expr->value.function.actual = arg->next;
2741       else
2742         last->next = arg->next;
2743
2744       arg->next = NULL;
2745       gfc_free_actual_arglist (arg);
2746       arg = last;
2747     }
2748
2749   /* If there is one value left, replace the function call with the
2750      expression.  */
2751   if (expr->value.function.actual->next != NULL)
2752     return NULL;
2753
2754   /* Convert to the correct type and kind.  */
2755   if (expr->ts.type != BT_UNKNOWN)
2756     return gfc_convert_constant (expr->value.function.actual->expr,
2757         expr->ts.type, expr->ts.kind);
2758
2759   if (specific->ts.type != BT_UNKNOWN)
2760     return gfc_convert_constant (expr->value.function.actual->expr,
2761         specific->ts.type, specific->ts.kind);
2762
2763   return gfc_copy_expr (expr->value.function.actual->expr);
2764 }
2765
2766
2767 gfc_expr *
2768 gfc_simplify_min (gfc_expr *e)
2769 {
2770   return simplify_min_max (e, -1);
2771 }
2772
2773
2774 gfc_expr *
2775 gfc_simplify_max (gfc_expr *e)
2776 {
2777   return simplify_min_max (e, 1);
2778 }
2779
2780
2781 gfc_expr *
2782 gfc_simplify_maxexponent (gfc_expr *x)
2783 {
2784   gfc_expr *result;
2785   int i;
2786
2787   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2788
2789   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2790   result->where = x->where;
2791
2792   return result;
2793 }
2794
2795
2796 gfc_expr *
2797 gfc_simplify_minexponent (gfc_expr *x)
2798 {
2799   gfc_expr *result;
2800   int i;
2801
2802   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2803
2804   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2805   result->where = x->where;
2806
2807   return result;
2808 }
2809
2810
2811 gfc_expr *
2812 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2813 {
2814   gfc_expr *result;
2815   mpfr_t quot, iquot, term;
2816   int kind;
2817
2818   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2819     return NULL;
2820
2821   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2822   result = gfc_constant_result (a->ts.type, kind, &a->where);
2823
2824   switch (a->ts.type)
2825     {
2826     case BT_INTEGER:
2827       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2828         {
2829           /* Result is processor-dependent.  */
2830           gfc_error ("Second argument MOD at %L is zero", &a->where);
2831           gfc_free_expr (result);
2832           return &gfc_bad_expr;
2833         }
2834       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2835       break;
2836
2837     case BT_REAL:
2838       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2839         {
2840           /* Result is processor-dependent.  */
2841           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2842           gfc_free_expr (result);
2843           return &gfc_bad_expr;
2844         }
2845
2846       gfc_set_model_kind (kind);
2847       mpfr_init (quot);
2848       mpfr_init (iquot);
2849       mpfr_init (term);
2850
2851       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2852       mpfr_trunc (iquot, quot);
2853       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2854       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2855
2856       mpfr_clear (quot);
2857       mpfr_clear (iquot);
2858       mpfr_clear (term);
2859       break;
2860
2861     default:
2862       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2863     }
2864
2865   return range_check (result, "MOD");
2866 }
2867
2868
2869 gfc_expr *
2870 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2871 {
2872   gfc_expr *result;
2873   mpfr_t quot, iquot, term;
2874   int kind;
2875
2876   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2877     return NULL;
2878
2879   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2880   result = gfc_constant_result (a->ts.type, kind, &a->where);
2881
2882   switch (a->ts.type)
2883     {
2884     case BT_INTEGER:
2885       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2886         {
2887           /* Result is processor-dependent. This processor just opts
2888              to not handle it at all.  */
2889           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2890           gfc_free_expr (result);
2891           return &gfc_bad_expr;
2892         }
2893       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2894
2895       break;
2896
2897     case BT_REAL:
2898       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2899         {
2900           /* Result is processor-dependent.  */
2901           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2902           gfc_free_expr (result);
2903           return &gfc_bad_expr;
2904         }
2905
2906       gfc_set_model_kind (kind);
2907       mpfr_init (quot);
2908       mpfr_init (iquot);
2909       mpfr_init (term);
2910
2911       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2912       mpfr_floor (iquot, quot);
2913       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2914       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2915
2916       mpfr_clear (quot);
2917       mpfr_clear (iquot);
2918       mpfr_clear (term);
2919       break;
2920
2921     default:
2922       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2923     }
2924
2925   return range_check (result, "MODULO");
2926 }
2927
2928
2929 /* Exists for the sole purpose of consistency with other intrinsics.  */
2930 gfc_expr *
2931 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
2932                      gfc_expr *fp ATTRIBUTE_UNUSED,
2933                      gfc_expr *l  ATTRIBUTE_UNUSED,
2934                      gfc_expr *to ATTRIBUTE_UNUSED,
2935                      gfc_expr *tp ATTRIBUTE_UNUSED)
2936 {
2937   return NULL;
2938 }
2939
2940
2941 gfc_expr *
2942 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2943 {
2944   gfc_expr *result;
2945   mp_exp_t emin, emax;
2946   int kind;
2947
2948   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2949     return NULL;
2950
2951   if (mpfr_sgn (s->value.real) == 0)
2952     {
2953       gfc_error ("Second argument of NEAREST at %L shall not be zero",
2954                  &s->where);
2955       return &gfc_bad_expr;
2956     }
2957
2958   gfc_set_model_kind (x->ts.kind);
2959   result = gfc_copy_expr (x);
2960
2961   /* Save current values of emin and emax.  */
2962   emin = mpfr_get_emin ();
2963   emax = mpfr_get_emax ();
2964
2965   /* Set emin and emax for the current model number.  */
2966   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2967   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2968                 mpfr_get_prec(result->value.real) + 1);
2969   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2970
2971   if (mpfr_sgn (s->value.real) > 0)
2972     {
2973       mpfr_nextabove (result->value.real);
2974       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2975     }
2976   else
2977     {
2978       mpfr_nextbelow (result->value.real);
2979       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2980     }
2981
2982   mpfr_set_emin (emin);
2983   mpfr_set_emax (emax);
2984
2985   /* Only NaN can occur. Do not use range check as it gives an
2986      error for denormal numbers.  */
2987   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2988     {
2989       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2990       gfc_free_expr (result);
2991       return &gfc_bad_expr;
2992     }
2993
2994   return result;
2995 }
2996
2997
2998 static gfc_expr *
2999 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3000 {
3001   gfc_expr *itrunc, *result;
3002   int kind;
3003
3004   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3005   if (kind == -1)
3006     return &gfc_bad_expr;
3007
3008   if (e->expr_type != EXPR_CONSTANT)
3009     return NULL;
3010
3011   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
3012
3013   itrunc = gfc_copy_expr (e);
3014
3015   mpfr_round (itrunc->value.real, e->value.real);
3016
3017   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
3018
3019   gfc_free_expr (itrunc);
3020
3021   return range_check (result, name);
3022 }
3023
3024
3025 gfc_expr *
3026 gfc_simplify_new_line (gfc_expr *e)
3027 {
3028   gfc_expr *result;
3029
3030   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3031   result->value.character.string = gfc_get_wide_string (2);
3032   result->value.character.length = 1;
3033   result->value.character.string[0] = '\n';
3034   result->value.character.string[1] = '\0';     /* For debugger */
3035   return result;
3036 }
3037
3038
3039 gfc_expr *
3040 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3041 {
3042   return simplify_nint ("NINT", e, k);
3043 }
3044
3045
3046 gfc_expr *
3047 gfc_simplify_idnint (gfc_expr *e)
3048 {
3049   return simplify_nint ("IDNINT", e, NULL);
3050 }
3051
3052
3053 gfc_expr *
3054 gfc_simplify_not (gfc_expr *e)
3055 {
3056   gfc_expr *result;
3057
3058   if (e->expr_type != EXPR_CONSTANT)
3059     return NULL;
3060
3061   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3062
3063   mpz_com (result->value.integer, e->value.integer);
3064
3065   return range_check (result, "NOT");
3066 }
3067
3068
3069 gfc_expr *
3070 gfc_simplify_null (gfc_expr *mold)
3071 {
3072   gfc_expr *result;
3073
3074   if (mold == NULL)
3075     {
3076       result = gfc_get_expr ();
3077       result->ts.type = BT_UNKNOWN;
3078     }
3079   else
3080     result = gfc_copy_expr (mold);
3081   result->expr_type = EXPR_NULL;
3082
3083   return result;
3084 }
3085
3086
3087 gfc_expr *
3088 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3089 {
3090   gfc_expr *result;
3091   int kind;
3092
3093   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3094     return NULL;
3095
3096   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3097   if (x->ts.type == BT_INTEGER)
3098     {
3099       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3100       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3101       return range_check (result, "OR");
3102     }
3103   else /* BT_LOGICAL */
3104     {
3105       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3106       result->value.logical = x->value.logical || y->value.logical;
3107       return result;
3108     }
3109 }
3110
3111
3112 gfc_expr *
3113 gfc_simplify_precision (gfc_expr *e)
3114 {
3115   gfc_expr *result;
3116   int i;
3117
3118   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3119
3120   result = gfc_int_expr (gfc_real_kinds[i].precision);
3121   result->where = e->where;
3122
3123   return result;
3124 }
3125
3126
3127 gfc_expr *
3128 gfc_simplify_radix (gfc_expr *e)
3129 {
3130   gfc_expr *result;
3131   int i;
3132
3133   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3134   switch (e->ts.type)
3135     {
3136     case BT_INTEGER:
3137       i = gfc_integer_kinds[i].radix;
3138       break;
3139
3140     case BT_REAL:
3141       i = gfc_real_kinds[i].radix;
3142       break;
3143
3144     default:
3145       gcc_unreachable ();
3146     }
3147
3148   result = gfc_int_expr (i);
3149   result->where = e->where;
3150
3151   return result;
3152 }
3153
3154
3155 gfc_expr *
3156 gfc_simplify_range (gfc_expr *e)
3157 {
3158   gfc_expr *result;
3159   int i;
3160   long j;
3161
3162   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3163
3164   switch (e->ts.type)
3165     {
3166     case BT_INTEGER:
3167       j = gfc_integer_kinds[i].range;
3168       break;
3169
3170     case BT_REAL:
3171     case BT_COMPLEX:
3172       j = gfc_real_kinds[i].range;
3173       break;
3174
3175     default:
3176       gcc_unreachable ();
3177     }
3178
3179   result = gfc_int_expr (j);
3180   result->where = e->where;
3181
3182   return result;
3183 }
3184
3185
3186 gfc_expr *
3187 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3188 {
3189   gfc_expr *result;
3190   int kind;
3191
3192   if (e->ts.type == BT_COMPLEX)
3193     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3194   else
3195     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3196
3197   if (kind == -1)
3198     return &gfc_bad_expr;
3199
3200   if (e->expr_type != EXPR_CONSTANT)
3201     return NULL;
3202
3203   switch (e->ts.type)
3204     {
3205     case BT_INTEGER:
3206       if (!e->is_boz)
3207         result = gfc_int2real (e, kind);
3208       break;
3209
3210     case BT_REAL:
3211       result = gfc_real2real (e, kind);
3212       break;
3213
3214     case BT_COMPLEX:
3215       result = gfc_complex2real (e, kind);
3216       break;
3217
3218     default:
3219       gfc_internal_error ("bad type in REAL");
3220       /* Not reached */
3221     }
3222
3223   if (e->ts.type == BT_INTEGER && e->is_boz)
3224     {
3225       gfc_typespec ts;
3226       gfc_clear_ts (&ts);
3227       ts.type = BT_REAL;
3228       ts.kind = kind;
3229       result = gfc_copy_expr (e);
3230       if (!gfc_convert_boz (result, &ts))
3231         {
3232           gfc_free_expr (result);
3233           return &gfc_bad_expr;
3234         }
3235     }
3236
3237   return range_check (result, "REAL");
3238 }
3239
3240
3241 gfc_expr *
3242 gfc_simplify_realpart (gfc_expr *e)
3243 {
3244   gfc_expr *result;
3245
3246   if (e->expr_type != EXPR_CONSTANT)
3247     return NULL;
3248
3249   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3250   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3251
3252   return range_check (result, "REALPART");
3253 }
3254
3255 gfc_expr *
3256 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3257 {
3258   gfc_expr *result;
3259   int i, j, len, ncop, nlen;
3260   mpz_t ncopies;
3261   bool have_length = false;
3262
3263   /* If NCOPIES isn't a constant, there's nothing we can do.  */
3264   if (n->expr_type != EXPR_CONSTANT)
3265     return NULL;
3266
3267   /* If NCOPIES is negative, it's an error.  */
3268   if (mpz_sgn (n->value.integer) < 0)
3269     {
3270       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3271                  &n->where);
3272       return &gfc_bad_expr;
3273     }
3274
3275   /* If we don't know the character length, we can do no more.  */
3276   if (e->ts.cl && e->ts.cl->length
3277         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3278     {
3279       len = mpz_get_si (e->ts.cl->length->value.integer);
3280       have_length = true;
3281     }
3282   else if (e->expr_type == EXPR_CONSTANT
3283              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3284     {
3285       len = e->value.character.length;
3286     }
3287   else
3288     return NULL;
3289
3290   /* If the source length is 0, any value of NCOPIES is valid
3291      and everything behaves as if NCOPIES == 0.  */
3292   mpz_init (ncopies);
3293   if (len == 0)
3294     mpz_set_ui (ncopies, 0);
3295   else
3296     mpz_set (ncopies, n->value.integer);
3297
3298   /* Check that NCOPIES isn't too large.  */
3299   if (len)
3300     {
3301       mpz_t max, mlen;
3302       int i;
3303
3304       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
3305       mpz_init (max);
3306       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3307
3308       if (have_length)
3309         {
3310           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3311                       e->ts.cl->length->value.integer);
3312         }
3313       else
3314         {
3315           mpz_init_set_si (mlen, len);
3316           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3317           mpz_clear (mlen);
3318         }
3319
3320       /* The check itself.  */
3321       if (mpz_cmp (ncopies, max) > 0)
3322         {
3323           mpz_clear (max);
3324           mpz_clear (ncopies);
3325           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3326                      &n->where);
3327           return &gfc_bad_expr;
3328         }
3329
3330       mpz_clear (max);
3331     }
3332   mpz_clear (ncopies);
3333
3334   /* For further simplification, we need the character string to be
3335      constant.  */
3336   if (e->expr_type != EXPR_CONSTANT)
3337     return NULL;
3338
3339   if (len ||
3340       (e->ts.cl->length &&
3341        mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3342     {
3343       const char *res = gfc_extract_int (n, &ncop);
3344       gcc_assert (res == NULL);
3345     }
3346   else
3347     ncop = 0;
3348
3349   len = e->value.character.length;
3350   nlen = ncop * len;
3351
3352   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3353
3354   if (ncop == 0)
3355     {
3356       result->value.character.string = gfc_get_wide_string (1);
3357       result->value.character.length = 0;
3358       result->value.character.string[0] = '\0';
3359       return result;
3360     }
3361
3362   result->value.character.length = nlen;
3363   result->value.character.string = gfc_get_wide_string (nlen + 1);
3364
3365   for (i = 0; i < ncop; i++)
3366     for (j = 0; j < len; j++)
3367       result->value.character.string[j+i*len]= e->value.character.string[j];
3368
3369   result->value.character.string[nlen] = '\0';  /* For debugger */
3370   return result;
3371 }
3372
3373
3374 /* Test that the expression is an constant array.  */
3375
3376 static bool
3377 is_constant_array_expr (gfc_expr *e)
3378 {
3379   gfc_constructor *c;
3380
3381   if (e == NULL)
3382     return true;
3383
3384   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3385     return false;
3386
3387   if (e->value.constructor == NULL)
3388     return false;
3389
3390   for (c = e->value.constructor; c; c = c->next)
3391     if (c->expr->expr_type != EXPR_CONSTANT)
3392       return false;
3393
3394   return true;
3395 }
3396
3397
3398 /* This one is a bear, but mainly has to do with shuffling elements.  */
3399
3400 gfc_expr *
3401 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3402                       gfc_expr *pad, gfc_expr *order_exp)
3403 {
3404   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3405   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3406   gfc_constructor *head, *tail;
3407   mpz_t index, size;
3408   unsigned long j;
3409   size_t nsource;
3410   gfc_expr *e;
3411
3412   /* Check that argument expression types are OK.  */
3413   if (!is_constant_array_expr (source))
3414     return NULL;
3415
3416   if (!is_constant_array_expr (shape_exp))
3417     return NULL;
3418
3419   if (!is_constant_array_expr (pad))
3420     return NULL;
3421
3422   if (!is_constant_array_expr (order_exp))
3423     return NULL;
3424
3425   /* Proceed with simplification, unpacking the array.  */
3426
3427   mpz_init (index);
3428   rank = 0;
3429   head = tail = NULL;
3430
3431   for (;;)
3432     {
3433       e = gfc_get_array_element (shape_exp, rank);
3434       if (e == NULL)
3435         break;
3436
3437       if (gfc_extract_int (e, &shape[rank]) != NULL)
3438         {
3439           gfc_error ("Integer too large in shape specification at %L",
3440                      &e->where);
3441           gfc_free_expr (e);
3442           goto bad_reshape;
3443         }
3444
3445       if (rank >= GFC_MAX_DIMENSIONS)
3446         {
3447           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3448                      "at %L", &e->where);
3449           gfc_free_expr (e);
3450           goto bad_reshape;
3451         }
3452
3453       if (shape[rank] < 0)
3454         {
3455           gfc_error ("Shape specification at %L cannot be negative",
3456                      &e->where);
3457           gfc_free_expr (e);
3458           goto bad_reshape;
3459         }
3460
3461       gfc_free_expr (e);
3462       rank++;
3463     }
3464
3465   if (rank == 0)
3466     {
3467       gfc_error ("Shape specification at %L cannot be the null array",
3468                  &shape_exp->where);
3469       goto bad_reshape;
3470     }
3471
3472   /* Now unpack the order array if present.  */
3473   if (order_exp == NULL)
3474     {
3475       for (i = 0; i < rank; i++)
3476         order[i] = i;
3477     }
3478   else
3479     {
3480       for (i = 0; i < rank; i++)
3481         x[i] = 0;
3482
3483       for (i = 0; i < rank; i++)
3484         {
3485           e = gfc_get_array_element (order_exp, i);
3486           if (e == NULL)
3487             {
3488               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3489                          "size as SHAPE parameter", &order_exp->where);
3490               goto bad_reshape;
3491             }
3492
3493           if (gfc_extract_int (e, &order[i]) != NULL)
3494             {
3495               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3496                          &e->where);
3497               gfc_free_expr (e);
3498               goto bad_reshape;
3499             }
3500
3501           if (order[i] < 1 || order[i] > rank)
3502             {
3503               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3504                          &e->where);
3505               gfc_free_expr (e);
3506               goto bad_reshape;
3507             }
3508
3509           order[i]--;
3510
3511           if (x[order[i]])
3512             {
3513               gfc_error ("Invalid permutation in ORDER parameter at %L",
3514                          &e->where);
3515               gfc_free_expr (e);
3516               goto bad_reshape;
3517             }
3518
3519           gfc_free_expr (e);
3520
3521           x[order[i]] = 1;
3522         }
3523     }
3524
3525   /* Count the elements in the source and padding arrays.  */
3526
3527   npad = 0;
3528   if (pad != NULL)
3529     {
3530       gfc_array_size (pad, &size);
3531       npad = mpz_get_ui (size);
3532       mpz_clear (size);
3533     }
3534
3535   gfc_array_size (source, &size);
3536   nsource = mpz_get_ui (size);
3537   mpz_clear (size);
3538
3539   /* If it weren't for that pesky permutation we could just loop
3540      through the source and round out any shortage with pad elements.
3541      But no, someone just had to have the compiler do something the
3542      user should be doing.  */
3543
3544   for (i = 0; i < rank; i++)
3545     x[i] = 0;
3546
3547   for (;;)
3548     {
3549       /* Figure out which element to extract.  */
3550       mpz_set_ui (index, 0);
3551
3552       for (i = rank - 1; i >= 0; i--)
3553         {
3554           mpz_add_ui (index, index, x[order[i]]);
3555           if (i != 0)
3556             mpz_mul_ui (index, index, shape[order[i - 1]]);
3557         }
3558
3559       if (mpz_cmp_ui (index, INT_MAX) > 0)
3560         gfc_internal_error ("Reshaped array too large at %C");
3561
3562       j = mpz_get_ui (index);
3563
3564       if (j < nsource)
3565         e = gfc_get_array_element (source, j);
3566       else
3567         {
3568           j = j - nsource;
3569
3570           if (npad == 0)
3571             {
3572               gfc_error ("PAD parameter required for short SOURCE parameter "
3573                          "at %L", &source->where);
3574               goto bad_reshape;
3575             }
3576
3577           j = j % npad;
3578           e = gfc_get_array_element (pad, j);
3579         }
3580
3581       if (head == NULL)
3582         head = tail = gfc_get_constructor ();
3583       else
3584         {
3585           tail->next = gfc_get_constructor ();
3586           tail = tail->next;
3587         }
3588
3589       if (e == NULL)
3590         goto bad_reshape;
3591
3592       tail->where = e->where;
3593       tail->expr = e;
3594
3595       /* Calculate the next element.  */
3596       i = 0;
3597
3598 inc:
3599       if (++x[i] < shape[i])
3600         continue;
3601       x[i++] = 0;
3602       if (i < rank)
3603         goto inc;
3604
3605       break;
3606     }
3607
3608   mpz_clear (index);
3609
3610   e = gfc_get_expr ();
3611   e->where = source->where;
3612   e->expr_type = EXPR_ARRAY;
3613   e->value.constructor = head;
3614   e->shape = gfc_get_shape (rank);
3615
3616   for (i = 0; i < rank; i++)
3617     mpz_init_set_ui (e->shape[i], shape[i]);
3618
3619   e->ts = source->ts;
3620   e->rank = rank;
3621
3622   return e;
3623
3624 bad_reshape:
3625   gfc_free_constructor (head);
3626   mpz_clear (index);
3627   return &gfc_bad_expr;
3628 }
3629
3630
3631 gfc_expr *
3632 gfc_simplify_rrspacing (gfc_expr *x)
3633 {
3634   gfc_expr *result;
3635   int i;
3636   long int e, p;
3637
3638   if (x->expr_type != EXPR_CONSTANT)
3639     return NULL;
3640
3641   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3642
3643   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3644
3645   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3646
3647   /* Special case x = -0 and 0.  */
3648   if (mpfr_sgn (result->value.real) == 0)
3649     {
3650       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3651       return result;
3652     }
3653
3654   /* | x * 2**(-e) | * 2**p.  */
3655   e = - (long int) mpfr_get_exp (x->value.real);
3656   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3657
3658   p = (long int) gfc_real_kinds[i].digits;
3659   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3660
3661   return range_check (result, "RRSPACING");
3662 }
3663
3664
3665 gfc_expr *
3666 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3667 {
3668   int k, neg_flag, power, exp_range;
3669   mpfr_t scale, radix;
3670   gfc_expr *result;
3671
3672   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3673     return NULL;
3674
3675   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3676
3677   if (mpfr_sgn (x->value.real) == 0)
3678     {
3679       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3680       return result;
3681     }
3682
3683   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3684
3685   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3686
3687   /* This check filters out values of i that would overflow an int.  */
3688   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3689       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3690     {
3691       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3692       gfc_free_expr (result);
3693       return &gfc_bad_expr;
3694     }
3695
3696   /* Compute scale = radix ** power.  */
3697   power = mpz_get_si (i->value.integer);
3698
3699   if (power >= 0)
3700     neg_flag = 0;
3701   else
3702     {
3703       neg_flag = 1;
3704       power = -power;
3705     }
3706
3707   gfc_set_model_kind (x->ts.kind);
3708   mpfr_init (scale);
3709   mpfr_init (radix);
3710   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3711   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3712
3713   if (neg_flag)
3714     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3715   else
3716     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3717
3718   mpfr_clear (scale);
3719   mpfr_clear (radix);
3720
3721   return range_check (result, "SCALE");
3722 }
3723
3724
3725 /* Variants of strspn and strcspn that operate on wide characters.  */
3726
3727 static size_t
3728 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3729 {
3730   size_t i = 0;
3731   const gfc_char_t *c;
3732
3733   while (s1[i])
3734     {
3735       for (c = s2; *c; c++)
3736         {
3737           if (s1[i] == *c)
3738             break;
3739         }
3740       if (*c == '\0')
3741         break;
3742       i++;
3743     }
3744
3745   return i;
3746 }
3747
3748 static size_t
3749 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
3750 {
3751   size_t i = 0;
3752   const gfc_char_t *c;
3753
3754   while (s1[i])
3755     {
3756       for (c = s2; *c; c++)
3757         {
3758           if (s1[i] == *c)
3759             break;
3760         }
3761       if (*c)
3762         break;
3763       i++;
3764     }
3765
3766   return i;
3767 }
3768
3769
3770 gfc_expr *
3771 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3772 {
3773   gfc_expr *result;
3774   int back;
3775   size_t i;
3776   size_t indx, len, lenc;
3777   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3778
3779   if (k == -1)
3780     return &gfc_bad_expr;
3781
3782   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3783     return NULL;
3784
3785   if (b != NULL && b->value.logical != 0)
3786     back = 1;
3787   else
3788     back = 0;
3789
3790   result = gfc_constant_result (BT_INTEGER, k, &e->where);
3791
3792   len = e->value.character.length;
3793   lenc = c->value.character.length;
3794
3795   if (len == 0 || lenc == 0)
3796     {
3797       indx = 0;
3798     }
3799   else
3800     {
3801       if (back == 0)
3802         {
3803           indx = wide_strcspn (e->value.character.string,
3804                                c->value.character.string) + 1;
3805           if (indx > len)
3806             indx = 0;
3807         }
3808       else
3809         {
3810           i = 0;
3811           for (indx = len; indx > 0; indx--)
3812             {
3813               for (i = 0; i < lenc; i++)
3814                 {
3815                   if (c->value.character.string[i]
3816                       == e->value.character.string[indx - 1])
3817                     break;
3818                 }
3819               if (i < lenc)
3820                 break;
3821             }
3822         }
3823     }
3824   mpz_set_ui (result->value.integer, indx);
3825   return range_check (result, "SCAN");
3826 }
3827
3828
3829 gfc_expr *
3830 gfc_simplify_selected_char_kind (gfc_expr *e)
3831 {
3832   int kind;
3833   gfc_expr *result;
3834
3835   if (e->expr_type != EXPR_CONSTANT)
3836     return NULL;
3837
3838   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
3839       || gfc_compare_with_Cstring (e, "default", false) == 0)
3840     kind = 1;
3841   else
3842     kind = -1;
3843
3844   result = gfc_int_expr (kind);
3845   result->where = e->where;
3846
3847   return result;
3848 }
3849
3850
3851 gfc_expr *
3852 gfc_simplify_selected_int_kind (gfc_expr *e)
3853 {
3854   int i, kind, range;
3855   gfc_expr *result;
3856
3857   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3858     return NULL;
3859
3860   kind = INT_MAX;
3861
3862   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3863     if (gfc_integer_kinds[i].range >= range
3864         && gfc_integer_kinds[i].kind < kind)
3865       kind = gfc_integer_kinds[i].kind;
3866
3867   if (kind == INT_MAX)
3868     kind = -1;
3869
3870   result = gfc_int_expr (kind);
3871   result->where = e->where;
3872
3873   return result;
3874 }
3875
3876
3877 gfc_expr *
3878 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3879 {
3880   int range, precision, i, kind, found_precision, found_range;
3881   gfc_expr *result;
3882
3883   if (p == NULL)
3884     precision = 0;
3885   else
3886     {
3887       if (p->expr_type != EXPR_CONSTANT
3888           || gfc_extract_int (p, &precision) != NULL)
3889         return NULL;
3890     }
3891
3892   if (q == NULL)
3893     range = 0;
3894   else
3895     {
3896       if (q->expr_type != EXPR_CONSTANT
3897           || gfc_extract_int (q, &range) != NULL)
3898         return NULL;
3899     }
3900
3901   kind = INT_MAX;
3902   found_precision = 0;
3903   found_range = 0;
3904
3905   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3906     {
3907       if (gfc_real_kinds[i].precision >= precision)
3908         found_precision = 1;
3909
3910       if (gfc_real_kinds[i].range >= range)
3911         found_range = 1;
3912
3913       if (gfc_real_kinds[i].precision >= precision
3914           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3915         kind = gfc_real_kinds[i].kind;
3916     }
3917
3918   if (kind == INT_MAX)
3919     {
3920       kind = 0;
3921
3922       if (!found_precision)
3923         kind = -1;
3924       if (!found_range)
3925         kind -= 2;
3926     }
3927
3928   result = gfc_int_expr (kind);
3929   result->where = (p != NULL) ? p->where : q->where;
3930
3931   return result;
3932 }
3933
3934
3935 gfc_expr *
3936 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3937 {
3938   gfc_expr *result;
3939   mpfr_t exp, absv, log2, pow2, frac;
3940   unsigned long exp2;
3941
3942   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3943     return NULL;
3944
3945   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3946
3947   gfc_set_model_kind (x->ts.kind);
3948
3949   if (mpfr_sgn (x->value.real) == 0)
3950     {
3951       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3952       return result;
3953     }
3954
3955   mpfr_init (absv);
3956   mpfr_init (log2);
3957   mpfr_init (exp);
3958   mpfr_init (pow2);
3959   mpfr_init (frac);
3960
3961   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3962   mpfr_log2 (log2, absv, GFC_RND_MODE);
3963
3964   mpfr_trunc (log2, log2);
3965   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3966
3967   /* Old exponent value, and fraction.  */
3968   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3969
3970   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3971
3972   /* New exponent.  */
3973   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3974   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3975
3976   mpfr_clear (absv);
3977   mpfr_clear (log2);
3978   mpfr_clear (pow2);
3979   mpfr_clear (frac);
3980
3981   return range_check (result, "SET_EXPONENT");
3982 }
3983
3984
3985 gfc_expr *
3986 gfc_simplify_shape (gfc_expr *source)
3987 {
3988   mpz_t shape[GFC_MAX_DIMENSIONS];
3989   gfc_expr *result, *e, *f;
3990   gfc_array_ref *ar;
3991   int n;
3992   try t;
3993
3994   if (source->rank == 0)
3995     return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3996                                   &source->where);
3997
3998   if (source->expr_type != EXPR_VARIABLE)
3999     return NULL;
4000
4001   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4002                                   &source->where);
4003
4004   ar = gfc_find_array_ref (source);
4005
4006   t = gfc_array_ref_shape (ar, shape);
4007
4008   for (n = 0; n < source->rank; n++)
4009     {
4010       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4011                                &source->where);
4012
4013       if (t == SUCCESS)
4014         {
4015           mpz_set (e->value.integer, shape[n]);
4016           mpz_clear (shape[n]);
4017         }
4018       else
4019         {
4020           mpz_set_ui (e->value.integer, n + 1);
4021
4022           f = gfc_simplify_size (source, e, NULL);
4023           gfc_free_expr (e);
4024           if (f == NULL)
4025             {
4026               gfc_free_expr (result);
4027               return NULL;
4028             }
4029           else
4030             {
4031               e = f;
4032             }
4033         }
4034
4035       gfc_append_constructor (result, e);
4036     }
4037
4038   return result;
4039 }
4040
4041
4042 gfc_expr *
4043 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4044 {
4045   mpz_t size;
4046   gfc_expr *result;
4047   int d;
4048   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4049
4050   if (k == -1)
4051     return &gfc_bad_expr;
4052
4053   if (dim == NULL)
4054     {
4055       if (gfc_array_size (array, &size) == FAILURE)
4056         return NULL;
4057     }
4058   else
4059     {
4060       if (dim->expr_type != EXPR_CONSTANT)
4061         return NULL;
4062
4063       d = mpz_get_ui (dim->value.integer) - 1;
4064       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4065         return NULL;
4066     }
4067
4068   result = gfc_constant_result (BT_INTEGER, k, &array->where);
4069   mpz_set (result->value.integer, size);
4070   return result;
4071 }
4072
4073
4074 gfc_expr *
4075 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4076 {
4077   gfc_expr *result;
4078
4079   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4080     return NULL;
4081
4082   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4083
4084   switch (x->ts.type)
4085     {
4086     case BT_INTEGER:
4087       mpz_abs (result->value.integer, x->value.integer);
4088       if (mpz_sgn (y->value.integer) < 0)
4089         mpz_neg (result->value.integer, result->value.integer);
4090
4091       break;
4092
4093     case BT_REAL:
4094       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4095          it.  */
4096       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4097       if (mpfr_sgn (y->value.real) < 0)
4098         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
4099
4100       break;
4101
4102     default:
4103       gfc_internal_error ("Bad type in gfc_simplify_sign");
4104     }
4105
4106   return result;
4107 }
4108
4109
4110 gfc_expr *
4111 gfc_simplify_sin (gfc_expr *x)
4112 {
4113   gfc_expr *result;
4114   mpfr_t xp, xq;
4115
4116   if (x->expr_type != EXPR_CONSTANT)
4117     return NULL;
4118
4119   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4120
4121   switch (x->ts.type)
4122     {
4123     case BT_REAL:
4124       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4125       break;
4126
4127     case BT_COMPLEX:
4128       gfc_set_model (x->value.real);
4129       mpfr_init (xp);
4130       mpfr_init (xq);
4131
4132       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
4133       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
4134       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
4135
4136       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
4137       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
4138       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
4139
4140       mpfr_clear (xp);
4141       mpfr_clear (xq);
4142       break;
4143
4144     default:
4145       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4146     }
4147
4148   return range_check (result, "SIN");
4149 }
4150
4151
4152 gfc_expr *
4153 gfc_simplify_sinh (gfc_expr *x)
4154 {
4155   gfc_expr *result;
4156
4157   if (x->expr_type != EXPR_CONSTANT)
4158     return NULL;
4159
4160   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4161
4162   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4163
4164   return range_check (result, "SINH");
4165 }
4166
4167
4168 /* The argument is always a double precision real that is converted to
4169    single precision.  TODO: Rounding!  */
4170
4171 gfc_expr *
4172 gfc_simplify_sngl (gfc_expr *a)
4173 {
4174   gfc_expr *result;
4175
4176   if (a->expr_type != EXPR_CONSTANT)
4177     return NULL;
4178
4179   result = gfc_real2real (a, gfc_default_real_kind);
4180   return range_check (result, "SNGL");
4181 }
4182
4183
4184 gfc_expr *
4185 gfc_simplify_spacing (gfc_expr *x)
4186 {
4187   gfc_expr *result;
4188   int i;
4189   long int en, ep;
4190
4191   if (x->expr_type != EXPR_CONSTANT)
4192     return NULL;
4193
4194   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4195
4196   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4197
4198   /* Special case x = 0 and -0.  */
4199   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4200   if (mpfr_sgn (result->value.real) == 0)
4201     {
4202       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4203       return result;
4204     }
4205
4206   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4207      are the radix, exponent of x, and precision.  This excludes the
4208      possibility of subnormal numbers.  Fortran 2003 states the result is
4209      b**max(e - p, emin - 1).  */
4210
4211   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4212   en = (long int) gfc_real_kinds[i].min_exponent - 1;
4213   en = en > ep ? en : ep;
4214
4215   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4216   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4217
4218   return range_check (result, "SPACING");
4219 }
4220
4221
4222 gfc_expr *
4223 gfc_simplify_sqrt (gfc_expr *e)
4224 {
4225   gfc_expr *result;
4226   mpfr_t ac, ad, s, t, w;
4227
4228   if (e->expr_type != EXPR_CONSTANT)
4229     return NULL;
4230
4231   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4232
4233   switch (e->ts.type)
4234     {
4235     case BT_REAL:
4236       if (mpfr_cmp_si (e->value.real, 0) < 0)
4237         goto negative_arg;
4238       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4239
4240       break;
4241
4242     case BT_COMPLEX:
4243       /* Formula taken from Numerical Recipes to avoid over- and
4244          underflow.  */
4245
4246       gfc_set_model (e->value.real);
4247       mpfr_init (ac);
4248       mpfr_init (ad);
4249       mpfr_init (s);
4250       mpfr_init (t);
4251       mpfr_init (w);
4252
4253       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4254           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4255         {
4256           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4257           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4258           break;
4259         }
4260
4261       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4262       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4263
4264       if (mpfr_cmp (ac, ad) >= 0)
4265         {
4266           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4267           mpfr_mul (t, t, t, GFC_RND_MODE);
4268           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4269           mpfr_sqrt (t, t, GFC_RND_MODE);
4270           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4271           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4272           mpfr_sqrt (t, t, GFC_RND_MODE);
4273           mpfr_sqrt (s, ac, GFC_RND_MODE);
4274           mpfr_mul (w, s, t, GFC_RND_MODE);
4275         }
4276       else
4277         {
4278           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4279           mpfr_mul (t, s, s, GFC_RND_MODE);
4280           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4281           mpfr_sqrt (t, t, GFC_RND_MODE);
4282           mpfr_abs (s, s, GFC_RND_MODE);
4283           mpfr_add (t, t, s, GFC_RND_MODE);
4284           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4285           mpfr_sqrt (t, t, GFC_RND_MODE);
4286           mpfr_sqrt (s, ad, GFC_RND_MODE);
4287           mpfr_mul (w, s, t, GFC_RND_MODE);
4288         }
4289
4290       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4291         {
4292           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4293           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4294           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4295         }
4296       else if (mpfr_cmp_ui (w, 0) != 0
4297                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4298                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4299         {
4300           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4301           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4302           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4303         }
4304       else if (mpfr_cmp_ui (w, 0) != 0
4305                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4306                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4307         {
4308           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4309           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4310           mpfr_neg (w, w, GFC_RND_MODE);
4311           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4312         }
4313       else
4314         gfc_internal_error ("invalid complex argument of SQRT at %L",
4315                             &e->where);
4316
4317       mpfr_clear (s);
4318       mpfr_clear (t);
4319       mpfr_clear (ac);
4320       mpfr_clear (ad);
4321       mpfr_clear (w);
4322
4323       break;
4324
4325     default:
4326       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4327     }
4328
4329   return range_check (result, "SQRT");
4330
4331 negative_arg:
4332   gfc_free_expr (result);
4333   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4334   return &gfc_bad_expr;
4335 }
4336
4337
4338 gfc_expr *
4339 gfc_simplify_tan (gfc_expr *x)
4340 {
4341   int i;
4342   gfc_expr *result;
4343
4344   if (x->expr_type != EXPR_CONSTANT)
4345     return NULL;
4346
4347   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4348
4349   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4350
4351   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4352
4353   return range_check (result, "TAN");
4354 }
4355
4356
4357 gfc_expr *
4358 gfc_simplify_tanh (gfc_expr *x)
4359 {
4360   gfc_expr *result;
4361
4362   if (x->expr_type != EXPR_CONSTANT)
4363     return NULL;
4364
4365   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4366
4367   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4368
4369   return range_check (result, "TANH");
4370
4371 }
4372
4373
4374 gfc_expr *
4375 gfc_simplify_tiny (gfc_expr *e)
4376 {
4377   gfc_expr *result;
4378   int i;
4379
4380   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4381
4382   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4383   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4384
4385   return result;
4386 }
4387
4388
4389 gfc_expr *
4390 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4391 {
4392   gfc_expr *result;
4393   gfc_expr *mold_element;
4394   size_t source_size;
4395   size_t result_size;
4396   size_t result_elt_size;
4397   size_t buffer_size;
4398   mpz_t tmp;
4399   unsigned char *buffer;
4400
4401   if (!gfc_is_constant_expr (source)
4402         || (gfc_init_expr && !gfc_is_constant_expr (mold))
4403         || !gfc_is_constant_expr (size))
4404     return NULL;
4405
4406   if (source->expr_type == EXPR_FUNCTION)
4407     return NULL;
4408
4409   /* Calculate the size of the source.  */
4410   if (source->expr_type == EXPR_ARRAY
4411       && gfc_array_size (source, &tmp) == FAILURE)
4412     gfc_internal_error ("Failure getting length of a constant array.");
4413
4414   source_size = gfc_target_expr_size (source);
4415
4416   /* Create an empty new expression with the appropriate characteristics.  */
4417   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4418                                 &source->where);
4419   result->ts = mold->ts;
4420
4421   mold_element = mold->expr_type == EXPR_ARRAY
4422                  ? mold->value.constructor->expr
4423                  : mold;
4424
4425   /* Set result character length, if needed.  Note that this needs to be
4426      set even for array expressions, in order to pass this information into
4427      gfc_target_interpret_expr.  */
4428   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4429     result->value.character.length = mold_element->value.character.length;
4430
4431   /* Set the number of elements in the result, and determine its size.  */
4432   result_elt_size = gfc_target_expr_size (mold_element);
4433   if (result_elt_size == 0)
4434     {
4435       gfc_free_expr (result);
4436       return NULL;
4437     }
4438
4439   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4440     {
4441       int result_length;
4442
4443       result->expr_type = EXPR_ARRAY;
4444       result->rank = 1;
4445
4446       if (size)
4447         result_length = (size_t)mpz_get_ui (size->value.integer);
4448       else
4449         {
4450           result_length = source_size / result_elt_size;
4451           if (result_length * result_elt_size < source_size)
4452             result_length += 1;
4453         }
4454
4455       result->shape = gfc_get_shape (1);
4456       mpz_init_set_ui (result->shape[0], result_length);
4457
4458       result_size = result_length * result_elt_size;
4459     }
4460   else
4461     {
4462       result->rank = 0;
4463       result_size = result_elt_size;
4464     }
4465
4466   if (gfc_option.warn_surprising && source_size < result_size)
4467     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4468                 "source size %ld < result size %ld", &source->where,
4469                 (long) source_size, (long) result_size);
4470
4471   /* Allocate the buffer to store the binary version of the source.  */
4472   buffer_size = MAX (source_size, result_size);
4473   buffer = (unsigned char*)alloca (buffer_size);
4474
4475   /* Now write source to the buffer.  */
4476   gfc_target_encode_expr (source, buffer, buffer_size);
4477
4478   /* And read the buffer back into the new expression.  */
4479   gfc_target_interpret_expr (buffer, buffer_size, result);
4480
4481   return result;
4482 }
4483
4484
4485 gfc_expr *
4486 gfc_simplify_trim (gfc_expr *e)
4487 {
4488   gfc_expr *result;
4489   int count, i, len, lentrim;
4490
4491   if (e->expr_type != EXPR_CONSTANT)
4492     return NULL;
4493
4494   len = e->value.character.length;
4495
4496   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4497
4498   for (count = 0, i = 1; i <= len; ++i)
4499     {
4500       if (e->value.character.string[len - i] == ' ')
4501         count++;
4502       else
4503         break;
4504     }
4505
4506   lentrim = len - count;
4507
4508   result->value.character.length = lentrim;
4509   result->value.character.string = gfc_get_wide_string (lentrim + 1);
4510
4511   for (i = 0; i < lentrim; i++)
4512     result->value.character.string[i] = e->value.character.string[i];
4513
4514   result->value.character.string[lentrim] = '\0';       /* For debugger */
4515
4516   return result;
4517 }
4518
4519
4520 gfc_expr *
4521 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4522 {
4523   return simplify_bound (array, dim, kind, 1);
4524 }
4525
4526
4527 gfc_expr *
4528 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4529 {
4530   gfc_expr *result;
4531   int back;
4532   size_t index, len, lenset;
4533   size_t i;
4534   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4535
4536   if (k == -1)
4537     return &gfc_bad_expr;
4538
4539   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4540     return NULL;
4541
4542   if (b != NULL && b->value.logical != 0)
4543     back = 1;
4544   else
4545     back = 0;
4546
4547   result = gfc_constant_result (BT_INTEGER, k, &s->where);
4548
4549   len = s->value.character.length;
4550   lenset = set->value.character.length;
4551
4552   if (len == 0)
4553     {
4554       mpz_set_ui (result->value.integer, 0);
4555       return result;
4556     }
4557
4558   if (back == 0)
4559     {
4560       if (lenset == 0)
4561         {
4562           mpz_set_ui (result->value.integer, 1);
4563           return result;
4564         }
4565
4566       index = wide_strspn (s->value.character.string,
4567                            set->value.character.string) + 1;
4568       if (index > len)
4569         index = 0;
4570
4571     }
4572   else
4573     {
4574       if (lenset == 0)
4575         {
4576           mpz_set_ui (result->value.integer, len);
4577           return result;
4578         }
4579       for (index = len; index > 0; index --)
4580         {
4581           for (i = 0; i < lenset; i++)
4582             {
4583               if (s->value.character.string[index - 1]
4584                   == set->value.character.string[i])
4585                 break;
4586             }
4587           if (i == lenset)
4588             break;
4589         }
4590     }
4591
4592   mpz_set_ui (result->value.integer, index);
4593   return result;
4594 }
4595
4596
4597 gfc_expr *
4598 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4599 {
4600   gfc_expr *result;
4601   int kind;
4602
4603   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4604     return NULL;
4605
4606   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4607   if (x->ts.type == BT_INTEGER)
4608     {
4609       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4610       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4611       return range_check (result, "XOR");
4612     }
4613   else /* BT_LOGICAL */
4614     {
4615       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4616       result->value.logical = (x->value.logical && !y->value.logical)
4617                               || (!x->value.logical && y->value.logical);
4618       return result;
4619     }
4620
4621 }
4622
4623
4624 /****************** Constant simplification *****************/
4625
4626 /* Master function to convert one constant to another.  While this is
4627    used as a simplification function, it requires the destination type
4628    and kind information which is supplied by a special case in
4629    do_simplify().  */
4630
4631 gfc_expr *
4632 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4633 {
4634   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4635   gfc_constructor *head, *c, *tail = NULL;
4636
4637   switch (e->ts.type)
4638     {
4639     case BT_INTEGER:
4640       switch (type)
4641         {
4642         case BT_INTEGER:
4643           f = gfc_int2int;
4644           break;
4645         case BT_REAL:
4646           f = gfc_int2real;
4647           break;
4648         case BT_COMPLEX:
4649           f = gfc_int2complex;
4650           break;
4651         case BT_LOGICAL:
4652           f = gfc_int2log;
4653           break;
4654         default:
4655           goto oops;
4656         }
4657       break;
4658
4659     case BT_REAL:
4660       switch (type)
4661         {
4662         case BT_INTEGER:
4663           f = gfc_real2int;
4664           break;
4665         case BT_REAL:
4666           f = gfc_real2real;
4667           break;
4668         case BT_COMPLEX:
4669           f = gfc_real2complex;
4670           break;
4671         default:
4672           goto oops;
4673         }
4674       break;
4675
4676     case BT_COMPLEX:
4677       switch (type)
4678         {
4679         case BT_INTEGER:
4680           f = gfc_complex2int;
4681           break;
4682         case BT_REAL:
4683           f = gfc_complex2real;
4684           break;
4685         case BT_COMPLEX:
4686           f = gfc_complex2complex;
4687           break;
4688
4689         default:
4690           goto oops;
4691         }
4692       break;
4693
4694     case BT_LOGICAL:
4695       switch (type)
4696         {
4697         case BT_INTEGER:
4698           f = gfc_log2int;
4699           break;
4700         case BT_LOGICAL:
4701           f = gfc_log2log;
4702           break;
4703         default:
4704           goto oops;
4705         }
4706       break;
4707
4708     case BT_HOLLERITH:
4709       switch (type)
4710         {
4711         case BT_INTEGER:
4712           f = gfc_hollerith2int;
4713           break;
4714
4715         case BT_REAL:
4716           f = gfc_hollerith2real;
4717           break;
4718
4719         case BT_COMPLEX:
4720           f = gfc_hollerith2complex;
4721           break;
4722
4723         case BT_CHARACTER:
4724           f = gfc_hollerith2character;
4725           break;
4726
4727         case BT_LOGICAL:
4728           f = gfc_hollerith2logical;
4729           break;
4730
4731         default:
4732           goto oops;
4733         }
4734       break;
4735
4736     default:
4737     oops:
4738       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4739     }
4740
4741   result = NULL;
4742
4743   switch (e->expr_type)
4744     {
4745     case EXPR_CONSTANT:
4746       result = f (e, kind);
4747       if (result == NULL)
4748         return &gfc_bad_expr;
4749       break;
4750
4751     case EXPR_ARRAY:
4752       if (!gfc_is_constant_expr (e))
4753         break;
4754
4755       head = NULL;
4756
4757       for (c = e->value.constructor; c; c = c->next)
4758         {
4759           if (head == NULL)
4760             head = tail = gfc_get_constructor ();
4761           else
4762             {
4763               tail->next = gfc_get_constructor ();
4764               tail = tail->next;
4765             }
4766
4767           tail->where = c->where;
4768
4769           if (c->iterator == NULL)
4770             tail->expr = f (c->expr, kind);
4771           else
4772             {
4773               g = gfc_convert_constant (c->expr, type, kind);
4774               if (g == &gfc_bad_expr)
4775                 return g;
4776               tail->expr = g;
4777             }
4778
4779           if (tail->expr == NULL)
4780             {
4781               gfc_free_constructor (head);
4782               return NULL;
4783             }
4784         }
4785
4786       result = gfc_get_expr ();
4787       result->ts.type = type;
4788       result->ts.kind = kind;
4789       result->expr_type = EXPR_ARRAY;
4790       result->value.constructor = head;
4791       result->shape = gfc_copy_shape (e->shape, e->rank);
4792       result->where = e->where;
4793       result->rank = e->rank;
4794       break;
4795
4796     default:
4797       break;
4798     }
4799
4800   return result;
4801 }