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
 260 static gfc_expr *
 261 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
 262 {
 263   gfc_expr *result;
 264   int kind;
 265   bool too_large = false;
 266
 267   if (e->expr_type != EXPR_CONSTANT)
 268     return NULL;
 269
 270   kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
 271   if (kind == -1)
 272     return &gfc_bad_expr;
 273
 274   if (mpz_cmp_si (e->value.integer, 0) < 0)
 275     {
 276       gfc_error ("Argument of %s function at %L is negative", name,
 277                  &e->where);
 278       return &gfc_bad_expr;
 279     }
 280
 281   if (ascii && gfc_option.warn_surprising
 282       && mpz_cmp_si (e->value.integer, 127) > 0)
 283     gfc_warning ("Argument of %s function at %L outside of range [0,127]",
 284                  name, &e->where);
 285
 286   if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
 287     too_large = true;
 288   else if (kind == 4)
 289     {
 290       mpz_t t;
 291       mpz_init_set_ui (t, 2);
 292       mpz_pow_ui (t, t, 32);
 293       mpz_sub_ui (t, t, 1);
 294       if (mpz_cmp (e->value.integer, t) > 0)
 295         too_large = true;
 296       mpz_clear (t);
 297     }
 298
 299   if (too_large)
 300     {
 301       gfc_error ("Argument of %s function at %L is too large for the "
 302                  "collating sequence of kind %d", name, &e->where, kind);
 303       return &gfc_bad_expr;
 304     }
 305
 306   result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
 307   result->value.character.string = gfc_get_wide_string (2);
 308   result->value.character.length = 1;
 309   result->value.character.string[0] = mpz_get_ui (e->value.integer);
 310   result->value.character.string[1] = '\0';     /* For debugger */
 311   return result;
 312 }
 313
 314
 315
 316 /* We use the processor's collating sequence, because all
 317    systems that gfortran currently works on are ASCII.  */
 318
 319 gfc_expr *
 320 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
 321 {
 322   return simplify_achar_char (e, k, "ACHAR", true);
 323 }
 324
 325
 326 gfc_expr *
 327 gfc_simplify_acos (gfc_expr *x)
 328 {
 329   gfc_expr *result;
 330
 331   if (x->expr_type != EXPR_CONSTANT)
 332     return NULL;
 333
 334   if (mpfr_cmp_si (x->value.real, 1) > 0
 335       || mpfr_cmp_si (x->value.real, -1) < 0)
 336     {
 337       gfc_error ("Argument of ACOS at %L must be between -1 and 1",
 338                  &x->where);
 339       return &gfc_bad_expr;
 340     }
 341
 342   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 343
 344   mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 345
 346   return range_check (result, "ACOS");
 347 }
 348
 349 gfc_expr *
 350 gfc_simplify_acosh (gfc_expr *x)
 351 {
 352   gfc_expr *result;
 353
 354   if (x->expr_type != EXPR_CONSTANT)
 355     return NULL;
 356
 357   if (mpfr_cmp_si (x->value.real, 1) < 0)
 358     {
 359       gfc_error ("Argument of ACOSH at %L must not be less than 1",
 360                  &x->where);
 361       return &gfc_bad_expr;
 362     }
 363
 364   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 365
 366   mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
 367
 368   return range_check (result, "ACOSH");
 369 }
 370
 371 gfc_expr *
 372 gfc_simplify_adjustl (gfc_expr *e)
 373 {
 374   gfc_expr *result;
 375   int count, i, len;
 376   gfc_char_t ch;
 377
 378   if (e->expr_type != EXPR_CONSTANT)
 379     return NULL;
 380
 381   len = e->value.character.length;
 382
 383   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 384
 385   result->value.character.length = len;
 386   result->value.character.string = gfc_get_wide_string (len + 1);
 387
 388   for (count = 0, i = 0; i < len; ++i)
 389     {
 390       ch = e->value.character.string[i];
 391       if (ch != ' ')
 392         break;
 393       ++count;
 394     }
 395
 396   for (i = 0; i < len - count; ++i)
 397     result->value.character.string[i] = e->value.character.string[count + i];
 398
 399   for (i = len - count; i < len; ++i)
 400     result->value.character.string[i] = ' ';
 401
 402   result->value.character.string[len] = '\0';   /* For debugger */
 403
 404   return result;
 405 }
 406
 407
 408 gfc_expr *
 409 gfc_simplify_adjustr (gfc_expr *e)
 410 {
 411   gfc_expr *result;
 412   int count, i, len;
 413   gfc_char_t ch;
 414
 415   if (e->expr_type != EXPR_CONSTANT)
 416     return NULL;
 417
 418   len = e->value.character.length;
 419
 420   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 421
 422   result->value.character.length = len;
 423   result->value.character.string = gfc_get_wide_string (len + 1);
 424
 425   for (count = 0, i = len - 1; i >= 0; --i)
 426     {
 427       ch = e->value.character.string[i];
 428       if (ch != ' ')
 429         break;
 430       ++count;
 431     }
 432
 433   for (i = 0; i < count; ++i)
 434     result->value.character.string[i] = ' ';
 435
 436   for (i = count; i < len; ++i)
 437     result->value.character.string[i] = e->value.character.string[i - count];
 438
 439   result->value.character.string[len] = '\0';   /* For debugger */
 440
 441   return result;
 442 }
 443
 444
 445 gfc_expr *
 446 gfc_simplify_aimag (gfc_expr *e)
 447 {
 448   gfc_expr *result;
 449
 450   if (e->expr_type != EXPR_CONSTANT)
 451     return NULL;
 452
 453   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 454   mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
 455
 456   return range_check (result, "AIMAG");
 457 }
 458
 459
 460 gfc_expr *
 461 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 462 {
 463   gfc_expr *rtrunc, *result;
 464   int kind;
 465
 466   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
 467   if (kind == -1)
 468     return &gfc_bad_expr;
 469
 470   if (e->expr_type != EXPR_CONSTANT)
 471     return NULL;
 472
 473   rtrunc = gfc_copy_expr (e);
 474
 475   mpfr_trunc (rtrunc->value.real, e->value.real);
 476
 477   result = gfc_real2real (rtrunc, kind);
 478   gfc_free_expr (rtrunc);
 479
 480   return range_check (result, "AINT");
 481 }
 482
 483
 484 gfc_expr *
 485 gfc_simplify_dint (gfc_expr *e)
 486 {
 487   gfc_expr *rtrunc, *result;
 488
 489   if (e->expr_type != EXPR_CONSTANT)
 490     return NULL;
 491
 492   rtrunc = gfc_copy_expr (e);
 493
 494   mpfr_trunc (rtrunc->value.real, e->value.real);
 495
 496   result = gfc_real2real (rtrunc, gfc_default_double_kind);
 497   gfc_free_expr (rtrunc);
 498
 499   return range_check (result, "DINT");
 500 }
 501
 502
 503 gfc_expr *
 504 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
 505 {
 506   gfc_expr *result;
 507   int kind;
 508
 509   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
 510   if (kind == -1)
 511     return &gfc_bad_expr;
 512
 513   if (e->expr_type != EXPR_CONSTANT)
 514     return NULL;
 515
 516   result = gfc_constant_result (e->ts.type, kind, &e->where);
 517
 518   mpfr_round (result->value.real, e->value.real);
 519
 520   return range_check (result, "ANINT");
 521 }
 522
 523
 524 gfc_expr *
 525 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 526 {
 527   gfc_expr *result;
 528   int kind;
 529
 530   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 531     return NULL;
 532
 533   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
 534   if (x->ts.type == BT_INTEGER)
 535     {
 536       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
 537       mpz_and (result->value.integer, x->value.integer, y->value.integer);
 538       return range_check (result, "AND");
 539     }
 540   else /* BT_LOGICAL */
 541     {
 542       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
 543       result->value.logical = x->value.logical && y->value.logical;
 544       return result;
 545     }
 546 }
 547
 548
 549 gfc_expr *
 550 gfc_simplify_dnint (gfc_expr *e)
 551 {
 552   gfc_expr *result;
 553
 554   if (e->expr_type != EXPR_CONSTANT)
 555     return NULL;
 556
 557   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
 558
 559   mpfr_round (result->value.real, e->value.real);
 560
 561   return range_check (result, "DNINT");
 562 }
 563
 564
 565 gfc_expr *
 566 gfc_simplify_asin (gfc_expr *x)
 567 {
 568   gfc_expr *result;
 569
 570   if (x->expr_type != EXPR_CONSTANT)
 571     return NULL;
 572
 573   if (mpfr_cmp_si (x->value.real, 1) > 0
 574       || mpfr_cmp_si (x->value.real, -1) < 0)
 575     {
 576       gfc_error ("Argument of ASIN at %L must be between -1 and 1",
 577                  &x->where);
 578       return &gfc_bad_expr;
 579     }
 580
 581   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 582
 583   mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
 584
 585   return range_check (result, "ASIN");
 586 }
 587
 588
 589 gfc_expr *
 590 gfc_simplify_asinh (gfc_expr *x)
 591 {
 592   gfc_expr *result;
 593
 594   if (x->expr_type != EXPR_CONSTANT)
 595     return NULL;
 596
 597   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 598
 599   mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
 600
 601   return range_check (result, "ASINH");
 602 }
 603
 604
 605 gfc_expr *
 606 gfc_simplify_atan (gfc_expr *x)
 607 {
 608   gfc_expr *result;
 609
 610   if (x->expr_type != EXPR_CONSTANT)
 611     return NULL;
 612
 613   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 614
 615   mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
 616
 617   return range_check (result, "ATAN");
 618 }
 619
 620
 621 gfc_expr *
 622 gfc_simplify_atanh (gfc_expr *x)
 623 {
 624   gfc_expr *result;
 625
 626   if (x->expr_type != EXPR_CONSTANT)
 627     return NULL;
 628
 629   if (mpfr_cmp_si (x->value.real, 1) >= 0
 630       || mpfr_cmp_si (x->value.real, -1) <= 0)
 631     {
 632       gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
 633                  &x->where);
 634       return &gfc_bad_expr;
 635     }
 636
 637   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 638
 639   mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
 640
 641   return range_check (result, "ATANH");
 642 }
 643
 644
 645 gfc_expr *
 646 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
 647 {
 648   gfc_expr *result;
 649
 650   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 651     return NULL;
 652
 653   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
 654     {
 655       gfc_error ("If first argument of ATAN2 %L is zero, then the "
 656                  "second argument must not be zero", &x->where);
 657       return &gfc_bad_expr;
 658     }
 659
 660   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 661
 662   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 663
 664   return range_check (result, "ATAN2");
 665 }
 666
 667
 668 gfc_expr *
 669 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
 670 {
 671   gfc_expr *result;
 672
 673   if (x->expr_type != EXPR_CONSTANT)
 674     return NULL;
 675
 676   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 677   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
 678
 679   return range_check (result, "BESSEL_J0");
 680 }
 681
 682
 683 gfc_expr *
 684 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
 685 {
 686   gfc_expr *result;
 687
 688   if (x->expr_type != EXPR_CONSTANT)
 689     return NULL;
 690
 691   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 692   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
 693
 694   return range_check (result, "BESSEL_J1");
 695 }
 696
 697
 698 gfc_expr *
 699 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
 700                         gfc_expr *x ATTRIBUTE_UNUSED)
 701 {
 702   gfc_expr *result;
 703   long n;
 704
 705   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
 706     return NULL;
 707
 708   n = mpz_get_si (order->value.integer);
 709   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 710   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
 711
 712   return range_check (result, "BESSEL_JN");
 713 }
 714
 715
 716 gfc_expr *
 717 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
 718 {
 719   gfc_expr *result;
 720
 721   if (x->expr_type != EXPR_CONSTANT)
 722     return NULL;
 723
 724   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 725   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
 726
 727   return range_check (result, "BESSEL_Y0");
 728 }
 729
 730
 731 gfc_expr *
 732 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
 733 {
 734   gfc_expr *result;
 735
 736   if (x->expr_type != EXPR_CONSTANT)
 737     return NULL;
 738
 739   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 740   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
 741
 742   return range_check (result, "BESSEL_Y1");
 743 }
 744
 745
 746 gfc_expr *
 747 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
 748                         gfc_expr *x ATTRIBUTE_UNUSED)
 749 {
 750   gfc_expr *result;
 751   long n;
 752
 753   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
 754     return NULL;
 755
 756   n = mpz_get_si (order->value.integer);
 757   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 758   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
 759
 760   return range_check (result, "BESSEL_YN");
 761 }
 762
 763
 764 gfc_expr *
 765 gfc_simplify_bit_size (gfc_expr *e)
 766 {
 767   gfc_expr *result;
 768   int i;
 769
 770   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 771   result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
 772   mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
 773
 774   return result;
 775 }
 776
 777
 778 gfc_expr *
 779 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
 780 {
 781   int b;
 782
 783   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
 784     return NULL;
 785
 786   if (gfc_extract_int (bit, &b) != NULL || b < 0)
 787     return gfc_logical_expr (0, &e->where);
 788
 789   return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
 790 }
 791
 792
 793 gfc_expr *
 794 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 795 {
 796   gfc_expr *ceil, *result;
 797   int kind;
 798
 799   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
 800   if (kind == -1)
 801     return &gfc_bad_expr;
 802
 803   if (e->expr_type != EXPR_CONSTANT)
 804     return NULL;
 805
 806   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
 807
 808   ceil = gfc_copy_expr (e);
 809
 810   mpfr_ceil (ceil->value.real, e->value.real);
 811   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
 812
 813   gfc_free_expr (ceil);
 814
 815   return range_check (result, "CEILING");
 816 }
 817
 818
 819 gfc_expr *
 820 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 821 {
 822   return simplify_achar_char (e, k, "CHAR", false);
 823 }
 824
 825
 826 /* Common subroutine for simplifying CMPLX and DCMPLX.  */
 827
 828 static gfc_expr *
 829 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
 830 {
 831   gfc_expr *result;
 832
 833   result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
 834
 835   mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
 836
 837   switch (x->ts.type)
 838     {
 839     case BT_INTEGER:
 840       if (!x->is_boz)
 841         mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
 842       break;
 843
 844     case BT_REAL:
 845       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 846       break;
 847
 848     case BT_COMPLEX:
 849       mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
 850       mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
 851       break;
 852
 853     default:
 854       gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
 855     }
 856
 857   if (y != NULL)
 858     {
 859       switch (y->ts.type)
 860         {
 861         case BT_INTEGER:
 862           if (!y->is_boz)
 863             mpfr_set_z (result->value.complex.i, y->value.integer,
 864                         GFC_RND_MODE);
 865           break;
 866
 867         case BT_REAL:
 868           mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 869           break;
 870
 871         default:
 872           gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
 873         }
 874     }
 875
 876   /* Handle BOZ.  */
 877   if (x->is_boz)
 878     {
 879       gfc_typespec ts;
 880       gfc_clear_ts (&ts);
 881       ts.kind = result->ts.kind;
 882       ts.type = BT_REAL;
 883       if (!gfc_convert_boz (x, &ts))
 884         return &gfc_bad_expr;
 885       mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
 886     }
 887
 888   if (y && y->is_boz)
 889     {
 890       gfc_typespec ts;
 891       gfc_clear_ts (&ts);
 892       ts.kind = result->ts.kind;
 893       ts.type = BT_REAL;
 894       if (!gfc_convert_boz (y, &ts))
 895         return &gfc_bad_expr;
 896       mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
 897     }
 898
 899   return range_check (result, name);
 900 }
 901
 902
 903 /* Function called when we won't simplify an expression like CMPLX (or
 904    COMPLEX or DCMPLX) but still want to convert BOZ arguments.  */
 905
 906 static gfc_expr *
 907 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
 908 {
 909   gfc_typespec ts;
 910   gfc_clear_ts (&ts);
 911   ts.type = BT_REAL;
 912   ts.kind = kind;
 913
 914   if (x->is_boz && !gfc_convert_boz (x, &ts))
 915     return &gfc_bad_expr;
 916
 917   if (y && y->is_boz && !gfc_convert_boz (y, &ts))
 918     return &gfc_bad_expr;
 919
 920   return NULL;
 921 }
 922
 923
 924 gfc_expr *
 925 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
 926 {
 927   int kind;
 928
 929   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
 930   if (kind == -1)
 931     return &gfc_bad_expr;
 932
 933   if (x->expr_type != EXPR_CONSTANT
 934       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 935     return only_convert_cmplx_boz (x, y, kind);
 936
 937   return simplify_cmplx ("CMPLX", x, y, kind);
 938 }
 939
 940
 941 gfc_expr *
 942 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
 943 {
 944   int kind;
 945
 946   if (x->ts.type == BT_INTEGER)
 947     {
 948       if (y->ts.type == BT_INTEGER)
 949         kind = gfc_default_real_kind;
 950       else
 951         kind = y->ts.kind;
 952     }
 953   else
 954     {
 955       if (y->ts.type == BT_REAL)
 956         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 957       else
 958         kind = x->ts.kind;
 959     }
 960
 961   if (x->expr_type != EXPR_CONSTANT
 962       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 963     return only_convert_cmplx_boz (x, y, kind);
 964
 965   return simplify_cmplx ("COMPLEX", x, y, kind);
 966 }
 967
 968
 969 gfc_expr *
 970 gfc_simplify_conjg (gfc_expr *e)
 971 {
 972   gfc_expr *result;
 973
 974   if (e->expr_type != EXPR_CONSTANT)
 975     return NULL;
 976
 977   result = gfc_copy_expr (e);
 978   mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
 979
 980   return range_check (result, "CONJG");
 981 }
 982
 983
 984 gfc_expr *
 985 gfc_simplify_cos (gfc_expr *x)
 986 {
 987   gfc_expr *result;
 988   mpfr_t xp, xq;
 989
 990   if (x->expr_type != EXPR_CONSTANT)
 991     return NULL;
 992
 993   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 994
 995   switch (x->ts.type)
 996     {
 997     case BT_REAL:
 998       mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
 999       break;
1000     case BT_COMPLEX:
1001       gfc_set_model_kind (x->ts.kind);
1002       mpfr_init (xp);
1003       mpfr_init (xq);
1004
1005       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
1006       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1007       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1008
1009       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
1010       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1011       mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1012       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1013
1014       mpfr_clears (xp, xq, NULL);
1015       break;
1016     default:
1017       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1018     }
1019
1020   return range_check (result, "COS");
1021
1022 }
1023
1024
1025 gfc_expr *
1026 gfc_simplify_cosh (gfc_expr *x)
1027 {
1028   gfc_expr *result;
1029
1030   if (x->expr_type != EXPR_CONSTANT)
1031     return NULL;
1032
1033   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1034
1035   mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1036
1037   return range_check (result, "COSH");
1038 }
1039
1040
1041 gfc_expr *
1042 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1043 {
1044
1045   if (x->expr_type != EXPR_CONSTANT
1046       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1047     return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1048
1049   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1050 }
1051
1052
1053 gfc_expr *
1054 gfc_simplify_dble (gfc_expr *e)
1055 {
1056   gfc_expr *result = NULL;
1057
1058   if (e->expr_type != EXPR_CONSTANT)
1059     return NULL;
1060
1061   switch (e->ts.type)
1062     {
1063     case BT_INTEGER:
1064       if (!e->is_boz)
1065         result = gfc_int2real (e, gfc_default_double_kind);
1066       break;
1067
1068     case BT_REAL:
1069       result = gfc_real2real (e, gfc_default_double_kind);
1070       break;
1071
1072     case BT_COMPLEX:
1073       result = gfc_complex2real (e, gfc_default_double_kind);
1074       break;
1075
1076     default:
1077       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1078     }
1079
1080   if (e->ts.type == BT_INTEGER && e->is_boz)
1081     {
1082       gfc_typespec ts;
1083       gfc_clear_ts (&ts);
1084       ts.type = BT_REAL;
1085       ts.kind = gfc_default_double_kind;
1086       result = gfc_copy_expr (e);
1087       if (!gfc_convert_boz (result, &ts))
1088         {
1089           gfc_free_expr (result);
1090           return &gfc_bad_expr;
1091         }
1092     }
1093
1094   return range_check (result, "DBLE");
1095 }
1096
1097
1098 gfc_expr *
1099 gfc_simplify_digits (gfc_expr *x)
1100 {
1101   int i, digits;
1102
1103   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1104   switch (x->ts.type)
1105     {
1106     case BT_INTEGER:
1107       digits = gfc_integer_kinds[i].digits;
1108       break;
1109
1110     case BT_REAL:
1111     case BT_COMPLEX:
1112       digits = gfc_real_kinds[i].digits;
1113       break;
1114
1115     default:
1116       gcc_unreachable ();
1117     }
1118
1119   return gfc_int_expr (digits);
1120 }
1121
1122
1123 gfc_expr *
1124 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1125 {
1126   gfc_expr *result;
1127   int kind;
1128
1129   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1130     return NULL;
1131
1132   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1133   result = gfc_constant_result (x->ts.type, kind, &x->where);
1134
1135   switch (x->ts.type)
1136     {
1137     case BT_INTEGER:
1138       if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1139         mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1140       else
1141         mpz_set_ui (result->value.integer, 0);
1142
1143       break;
1144
1145     case BT_REAL:
1146       if (mpfr_cmp (x->value.real, y->value.real) > 0)
1147         mpfr_sub (result->value.real, x->value.real, y->value.real,
1148                   GFC_RND_MODE);
1149       else
1150         mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1151
1152       break;
1153
1154     default:
1155       gfc_internal_error ("gfc_simplify_dim(): Bad type");
1156     }
1157
1158   return range_check (result, "DIM");
1159 }
1160
1161
1162 gfc_expr *
1163 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1164 {
1165   gfc_expr *a1, *a2, *result;
1166
1167   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1168     return NULL;
1169
1170   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1171
1172   a1 = gfc_real2real (x, gfc_default_double_kind);
1173   a2 = gfc_real2real (y, gfc_default_double_kind);
1174
1175   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1176
1177   gfc_free_expr (a1);
1178   gfc_free_expr (a2);
1179
1180   return range_check (result, "DPROD");
1181 }
1182
1183
1184 gfc_expr *
1185 gfc_simplify_erf (gfc_expr *x)
1186 {
1187   gfc_expr *result;
1188
1189   if (x->expr_type != EXPR_CONSTANT)
1190     return NULL;
1191
1192   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1193
1194   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1195
1196   return range_check (result, "ERF");
1197 }
1198
1199
1200 gfc_expr *
1201 gfc_simplify_erfc (gfc_expr *x)
1202 {
1203   gfc_expr *result;
1204
1205   if (x->expr_type != EXPR_CONSTANT)
1206     return NULL;
1207
1208   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1209
1210   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1211
1212   return range_check (result, "ERFC");
1213 }
1214
1215
1216 gfc_expr *
1217 gfc_simplify_epsilon (gfc_expr *e)
1218 {
1219   gfc_expr *result;
1220   int i;
1221
1222   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1223
1224   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1225
1226   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1227
1228   return range_check (result, "EPSILON");
1229 }
1230
1231
1232 gfc_expr *
1233 gfc_simplify_exp (gfc_expr *x)
1234 {
1235   gfc_expr *result;
1236   mpfr_t xp, xq;
1237
1238   if (x->expr_type != EXPR_CONSTANT)
1239     return NULL;
1240
1241   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1242
1243   switch (x->ts.type)
1244     {
1245     case BT_REAL:
1246       mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1247       break;
1248
1249     case BT_COMPLEX:
1250       gfc_set_model_kind (x->ts.kind);
1251       mpfr_init (xp);
1252       mpfr_init (xq);
1253       mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1254       mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1255       mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1256       mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1257       mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1258       mpfr_clears (xp, xq, NULL);
1259       break;
1260
1261     default:
1262       gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1263     }
1264
1265   return range_check (result, "EXP");
1266 }
1267
1268 gfc_expr *
1269 gfc_simplify_exponent (gfc_expr *x)
1270 {
1271   int i;
1272   gfc_expr *result;
1273
1274   if (x->expr_type != EXPR_CONSTANT)
1275     return NULL;
1276
1277   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1278                                 &x->where);
1279
1280   gfc_set_model (x->value.real);
1281
1282   if (mpfr_sgn (x->value.real) == 0)
1283     {
1284       mpz_set_ui (result->value.integer, 0);
1285       return result;
1286     }
1287
1288   i = (int) mpfr_get_exp (x->value.real);
1289   mpz_set_si (result->value.integer, i);
1290
1291   return range_check (result, "EXPONENT");
1292 }
1293
1294
1295 gfc_expr *
1296 gfc_simplify_float (gfc_expr *a)
1297 {
1298   gfc_expr *result;
1299
1300   if (a->expr_type != EXPR_CONSTANT)
1301     return NULL;
1302
1303   if (a->is_boz)
1304     {
1305       gfc_typespec ts;
1306       gfc_clear_ts (&ts);
1307
1308       ts.type = BT_REAL;
1309       ts.kind = gfc_default_real_kind;
1310
1311       result = gfc_copy_expr (a);
1312       if (!gfc_convert_boz (result, &ts))
1313         {
1314           gfc_free_expr (result);
1315           return &gfc_bad_expr;
1316         }
1317     }
1318   else
1319     result = gfc_int2real (a, gfc_default_real_kind);
1320   return range_check (result, "FLOAT");
1321 }
1322
1323
1324 gfc_expr *
1325 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1326 {
1327   gfc_expr *result;
1328   mpfr_t floor;
1329   int kind;
1330
1331   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1332   if (kind == -1)
1333     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1334
1335   if (e->expr_type != EXPR_CONSTANT)
1336     return NULL;
1337
1338   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1339
1340   gfc_set_model_kind (kind);
1341   mpfr_init (floor);
1342   mpfr_floor (floor, e->value.real);
1343
1344   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
1345
1346   mpfr_clear (floor);
1347
1348   return range_check (result, "FLOOR");
1349 }
1350
1351
1352 gfc_expr *
1353 gfc_simplify_fraction (gfc_expr *x)
1354 {
1355   gfc_expr *result;
1356   mpfr_t absv, exp, pow2;
1357
1358   if (x->expr_type != EXPR_CONSTANT)
1359     return NULL;
1360
1361   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1362
1363   if (mpfr_sgn (x->value.real) == 0)
1364     {
1365       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1366       return result;
1367     }
1368
1369   gfc_set_model_kind (x->ts.kind);
1370   mpfr_init (exp);
1371   mpfr_init (absv);
1372   mpfr_init (pow2);
1373
1374   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1375   mpfr_log2 (exp, absv, GFC_RND_MODE);
1376
1377   mpfr_trunc (exp, exp);
1378   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1379
1380   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1381
1382   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1383
1384   mpfr_clears (exp, absv, pow2, NULL);
1385
1386   return range_check (result, "FRACTION");
1387 }
1388
1389
1390 gfc_expr *
1391 gfc_simplify_gamma (gfc_expr *x)
1392 {
1393   gfc_expr *result;
1394
1395   if (x->expr_type != EXPR_CONSTANT)
1396     return NULL;
1397
1398   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1399
1400   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1401
1402   return range_check (result, "GAMMA");
1403 }
1404
1405
1406 gfc_expr *
1407 gfc_simplify_huge (gfc_expr *e)
1408 {
1409   gfc_expr *result;
1410   int i;
1411
1412   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1413
1414   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1415
1416   switch (e->ts.type)
1417     {
1418     case BT_INTEGER:
1419       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1420       break;
1421
1422     case BT_REAL:
1423       mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1424       break;
1425
1426     default:
1427       gcc_unreachable ();
1428     }
1429
1430   return result;
1431 }
1432
1433
1434 gfc_expr *
1435 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1436 {
1437   gfc_expr *result;
1438
1439   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1440     return NULL;
1441
1442   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1443   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1444   return range_check (result, "HYPOT");
1445 }
1446
1447
1448 /* We use the processor's collating sequence, because all
1449    systems that gfortran currently works on are ASCII.  */
1450
1451 gfc_expr *
1452 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1453 {
1454   gfc_expr *result;
1455   gfc_char_t index;
1456
1457   if (e->expr_type != EXPR_CONSTANT)
1458     return NULL;
1459
1460   if (e->value.character.length != 1)
1461     {
1462       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1463       return &gfc_bad_expr;
1464     }
1465
1466   index = e->value.character.string[0];
1467
1468   if (gfc_option.warn_surprising && index > 127)
1469     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1470                  &e->where);
1471
1472   if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1473     return &gfc_bad_expr;
1474
1475   result->where = e->where;
1476
1477   return range_check (result, "IACHAR");
1478 }
1479
1480
1481 gfc_expr *
1482 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1483 {
1484   gfc_expr *result;
1485
1486   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1487     return NULL;
1488
1489   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1490
1491   mpz_and (result->value.integer, x->value.integer, y->value.integer);
1492
1493   return range_check (result, "IAND");
1494 }
1495
1496
1497 gfc_expr *
1498 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1499 {
1500   gfc_expr *result;
1501   int k, pos;
1502
1503   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1504     return NULL;
1505
1506   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1507     {
1508       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1509       return &gfc_bad_expr;
1510     }
1511
1512   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1513
1514   if (pos >= gfc_integer_kinds[k].bit_size)
1515     {
1516       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1517                  &y->where);
1518       return &gfc_bad_expr;
1519     }
1520
1521   result = gfc_copy_expr (x);
1522
1523   convert_mpz_to_unsigned (result->value.integer,
1524                            gfc_integer_kinds[k].bit_size);
1525
1526   mpz_clrbit (result->value.integer, pos);
1527
1528   convert_mpz_to_signed (result->value.integer,
1529                          gfc_integer_kinds[k].bit_size);
1530
1531   return result;
1532 }
1533
1534
1535 gfc_expr *
1536 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1537 {
1538   gfc_expr *result;
1539   int pos, len;
1540   int i, k, bitsize;
1541   int *bits;
1542
1543   if (x->expr_type != EXPR_CONSTANT
1544       || y->expr_type != EXPR_CONSTANT
1545       || z->expr_type != EXPR_CONSTANT)
1546     return NULL;
1547
1548   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1549     {
1550       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1551       return &gfc_bad_expr;
1552     }
1553
1554   if (gfc_extract_int (z, &len) != NULL || len < 0)
1555     {
1556       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1557       return &gfc_bad_expr;
1558     }
1559
1560   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1561
1562   bitsize = gfc_integer_kinds[k].bit_size;
1563
1564   if (pos + len > bitsize)
1565     {
1566       gfc_error ("Sum of second and third arguments of IBITS exceeds "
1567                  "bit size at %L", &y->where);
1568       return &gfc_bad_expr;
1569     }
1570
1571   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1572   convert_mpz_to_unsigned (result->value.integer,
1573                            gfc_integer_kinds[k].bit_size);
1574
1575   bits = XCNEWVEC (int, bitsize);
1576
1577   for (i = 0; i < bitsize; i++)
1578     bits[i] = 0;
1579
1580   for (i = 0; i < len; i++)
1581     bits[i] = mpz_tstbit (x->value.integer, i + pos);
1582
1583   for (i = 0; i < bitsize; i++)
1584     {
1585       if (bits[i] == 0)
1586         mpz_clrbit (result->value.integer, i);
1587       else if (bits[i] == 1)
1588         mpz_setbit (result->value.integer, i);
1589       else
1590         gfc_internal_error ("IBITS: Bad bit");
1591     }
1592
1593   gfc_free (bits);
1594
1595   convert_mpz_to_signed (result->value.integer,
1596                          gfc_integer_kinds[k].bit_size);
1597
1598   return result;
1599 }
1600
1601
1602 gfc_expr *
1603 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1604 {
1605   gfc_expr *result;
1606   int k, pos;
1607
1608   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1609     return NULL;
1610
1611   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1612     {
1613       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1614       return &gfc_bad_expr;
1615     }
1616
1617   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1618
1619   if (pos >= gfc_integer_kinds[k].bit_size)
1620     {
1621       gfc_error ("Second argument of IBSET exceeds bit size at %L",
1622                  &y->where);
1623       return &gfc_bad_expr;
1624     }
1625
1626   result = gfc_copy_expr (x);
1627
1628   convert_mpz_to_unsigned (result->value.integer,
1629                            gfc_integer_kinds[k].bit_size);
1630
1631   mpz_setbit (result->value.integer, pos);
1632
1633   convert_mpz_to_signed (result->value.integer,
1634                          gfc_integer_kinds[k].bit_size);
1635
1636   return result;
1637 }
1638
1639
1640 gfc_expr *
1641 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1642 {
1643   gfc_expr *result;
1644   gfc_char_t index;
1645
1646   if (e->expr_type != EXPR_CONSTANT)
1647     return NULL;
1648
1649   if (e->value.character.length != 1)
1650     {
1651       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1652       return &gfc_bad_expr;
1653     }
1654
1655   index = e->value.character.string[0];
1656
1657   if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1658     return &gfc_bad_expr;
1659
1660   result->where = e->where;
1661   return range_check (result, "ICHAR");
1662 }
1663
1664
1665 gfc_expr *
1666 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1667 {
1668   gfc_expr *result;
1669
1670   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1671     return NULL;
1672
1673   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1674
1675   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1676
1677   return range_check (result, "IEOR");
1678 }
1679
1680
1681 gfc_expr *
1682 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1683 {
1684   gfc_expr *result;
1685   int back, len, lensub;
1686   int i, j, k, count, index = 0, start;
1687
1688   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
1689       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
1690     return NULL;
1691
1692   if (b != NULL && b->value.logical != 0)
1693     back = 1;
1694   else
1695     back = 0;
1696
1697   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1698   if (k == -1)
1699     return &gfc_bad_expr;
1700
1701   result = gfc_constant_result (BT_INTEGER, k, &x->where);
1702
1703   len = x->value.character.length;
1704   lensub = y->value.character.length;
1705
1706   if (len < lensub)
1707     {
1708       mpz_set_si (result->value.integer, 0);
1709       return result;
1710     }
1711
1712   if (back == 0)
1713     {
1714       if (lensub == 0)
1715         {
1716           mpz_set_si (result->value.integer, 1);
1717           return result;
1718         }
1719       else if (lensub == 1)
1720         {
1721           for (i = 0; i < len; i++)
1722             {
1723               for (j = 0; j < lensub; j++)
1724                 {
1725                   if (y->value.character.string[j]
1726                       == x->value.character.string[i])
1727                     {
1728                       index = i + 1;
1729                       goto done;
1730                     }
1731                 }
1732             }
1733         }
1734       else
1735         {
1736           for (i = 0; i < len; i++)
1737             {
1738               for (j = 0; j < lensub; j++)
1739                 {
1740                   if (y->value.character.string[j]
1741                       == x->value.character.string[i])
1742                     {
1743                       start = i;
1744                       count = 0;
1745
1746                       for (k = 0; k < lensub; k++)
1747                         {
1748                           if (y->value.character.string[k]
1749                               == x->value.character.string[k + start])
1750                             count++;
1751                         }
1752
1753                       if (count == lensub)
1754                         {
1755                           index = start + 1;
1756                           goto done;
1757                         }
1758                     }
1759                 }
1760             }
1761         }
1762
1763     }
1764   else
1765     {
1766       if (lensub == 0)
1767         {
1768           mpz_set_si (result->value.integer, len + 1);
1769           return result;
1770         }
1771       else if (lensub == 1)
1772         {
1773           for (i = 0; i < len; i++)
1774             {
1775               for (j = 0; j < lensub; j++)
1776                 {
1777                   if (y->value.character.string[j]
1778                       == x->value.character.string[len - i])
1779                     {
1780                       index = len - i + 1;
1781                       goto done;
1782                     }
1783                 }
1784             }
1785         }
1786       else
1787         {
1788           for (i = 0; i < len; i++)
1789             {
1790               for (j = 0; j < lensub; j++)
1791                 {
1792                   if (y->value.character.string[j]
1793                       == x->value.character.string[len - i])
1794                     {
1795                       start = len - i;
1796                       if (start <= len - lensub)
1797                         {
1798                           count = 0;
1799                           for (k = 0; k < lensub; k++)
1800                             if (y->value.character.string[k]
1801                                 == x->value.character.string[k + start])
1802                               count++;
1803
1804                           if (count == lensub)
1805                             {
1806                               index = start + 1;
1807                               goto done;
1808                             }
1809                         }
1810                       else
1811                         {
1812                           continue;
1813                         }
1814                     }
1815                 }
1816             }
1817         }
1818     }
1819
1820 done:
1821   mpz_set_si (result->value.integer, index);
1822   return range_check (result, "INDEX");
1823 }
1824
1825
1826 gfc_expr *
1827 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1828 {
1829   gfc_expr *result = NULL;
1830   int kind;
1831
1832   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1833   if (kind == -1)
1834     return &gfc_bad_expr;
1835
1836   if (e->expr_type != EXPR_CONSTANT)
1837     return NULL;
1838
1839   switch (e->ts.type)
1840     {
1841     case BT_INTEGER:
1842       result = gfc_int2int (e, kind);
1843       break;
1844
1845     case BT_REAL:
1846       result = gfc_real2int (e, kind);
1847       break;
1848
1849     case BT_COMPLEX:
1850       result = gfc_complex2int (e, kind);
1851       break;
1852
1853     default:
1854       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1855       return &gfc_bad_expr;
1856     }
1857
1858   return range_check (result, "INT");
1859 }
1860
1861
1862 static gfc_expr *
1863 simplify_intconv (gfc_expr *e, int kind, const char *name)
1864 {
1865   gfc_expr *result = NULL;
1866
1867   if (e->expr_type != EXPR_CONSTANT)
1868     return NULL;
1869
1870   switch (e->ts.type)
1871     {
1872     case BT_INTEGER:
1873       result = gfc_int2int (e, kind);
1874       break;
1875
1876     case BT_REAL:
1877       result = gfc_real2int (e, kind);
1878       break;
1879
1880     case BT_COMPLEX:
1881       result = gfc_complex2int (e, kind);
1882       break;
1883
1884     default:
1885       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1886       return &gfc_bad_expr;
1887     }
1888
1889   return range_check (result, name);
1890 }
1891
1892
1893 gfc_expr *
1894 gfc_simplify_int2 (gfc_expr *e)
1895 {
1896   return simplify_intconv (e, 2, "INT2");
1897 }
1898
1899
1900 gfc_expr *
1901 gfc_simplify_int8 (gfc_expr *e)
1902 {
1903   return simplify_intconv (e, 8, "INT8");
1904 }
1905
1906
1907 gfc_expr *
1908 gfc_simplify_long (gfc_expr *e)
1909 {
1910   return simplify_intconv (e, 4, "LONG");
1911 }
1912
1913
1914 gfc_expr *
1915 gfc_simplify_ifix (gfc_expr *e)
1916 {
1917   gfc_expr *rtrunc, *result;
1918
1919   if (e->expr_type != EXPR_CONSTANT)
1920     return NULL;
1921
1922   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1923                                 &e->where);
1924
1925   rtrunc = gfc_copy_expr (e);
1926
1927   mpfr_trunc (rtrunc->value.real, e->value.real);
1928   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
1929
1930   gfc_free_expr (rtrunc);
1931   return range_check (result, "IFIX");
1932 }
1933
1934
1935 gfc_expr *
1936 gfc_simplify_idint (gfc_expr *e)
1937 {
1938   gfc_expr *rtrunc, *result;
1939
1940   if (e->expr_type != EXPR_CONSTANT)
1941     return NULL;
1942
1943   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1944                                 &e->where);
1945
1946   rtrunc = gfc_copy_expr (e);
1947
1948   mpfr_trunc (rtrunc->value.real, e->value.real);
1949   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
1950
1951   gfc_free_expr (rtrunc);
1952   return range_check (result, "IDINT");
1953 }
1954
1955
1956 gfc_expr *
1957 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1958 {
1959   gfc_expr *result;
1960
1961   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1962     return NULL;
1963
1964   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1965
1966   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1967   return range_check (result, "IOR");
1968 }
1969
1970
1971 gfc_expr *
1972 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1973 {
1974   gfc_expr *result;
1975   int shift, ashift, isize, k, *bits, i;
1976
1977   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1978     return NULL;
1979
1980   if (gfc_extract_int (s, &shift) != NULL)
1981     {
1982       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1983       return &gfc_bad_expr;
1984     }
1985
1986   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1987
1988   isize = gfc_integer_kinds[k].bit_size;
1989
1990   if (shift >= 0)
1991     ashift = shift;
1992   else
1993     ashift = -shift;
1994
1995   if (ashift > isize)
1996     {
1997       gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1998                  "at %L", &s->where);
1999       return &gfc_bad_expr;
2000     }
2001
2002   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2003
2004   if (shift == 0)
2005     {
2006       mpz_set (result->value.integer, e->value.integer);
2007       return range_check (result, "ISHFT");
2008     }
2009
2010   bits = XCNEWVEC (int, isize);
2011
2012   for (i = 0; i < isize; i++)
2013     bits[i] = mpz_tstbit (e->value.integer, i);
2014
2015   if (shift > 0)
2016     {
2017       for (i = 0; i < shift; i++)
2018         mpz_clrbit (result->value.integer, i);
2019
2020       for (i = 0; i < isize - shift; i++)
2021         {
2022           if (bits[i] == 0)
2023             mpz_clrbit (result->value.integer, i + shift);
2024           else
2025             mpz_setbit (result->value.integer, i + shift);
2026         }
2027     }
2028   else
2029     {
2030       for (i = isize - 1; i >= isize - ashift; i--)
2031         mpz_clrbit (result->value.integer, i);
2032
2033       for (i = isize - 1; i >= ashift; i--)
2034         {
2035           if (bits[i] == 0)
2036             mpz_clrbit (result->value.integer, i - ashift);
2037           else
2038             mpz_setbit (result->value.integer, i - ashift);
2039         }
2040     }
2041
2042   convert_mpz_to_signed (result->value.integer, isize);
2043
2044   gfc_free (bits);
2045   return result;
2046 }
2047
2048
2049 gfc_expr *
2050 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2051 {
2052   gfc_expr *result;
2053   int shift, ashift, isize, ssize, delta, k;
2054   int i, *bits;
2055
2056   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2057     return NULL;
2058
2059   if (gfc_extract_int (s, &shift) != NULL)
2060     {
2061       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2062       return &gfc_bad_expr;
2063     }
2064
2065   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2066   isize = gfc_integer_kinds[k].bit_size;
2067
2068   if (sz != NULL)
2069     {
2070       if (sz->expr_type != EXPR_CONSTANT)
2071         return NULL;
2072
2073       if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2074         {
2075           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2076           return &gfc_bad_expr;
2077         }
2078
2079       if (ssize > isize)
2080         {
2081           gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2082                      "BIT_SIZE of first argument at %L", &s->where);
2083           return &gfc_bad_expr;
2084         }
2085     }
2086   else
2087     ssize = isize;
2088
2089   if (shift >= 0)
2090     ashift = shift;
2091   else
2092     ashift = -shift;
2093
2094   if (ashift > ssize)
2095     {
2096       if (sz != NULL)
2097         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2098                    "third argument at %L", &s->where);
2099       else
2100         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2101                    "BIT_SIZE of first argument at %L", &s->where);
2102       return &gfc_bad_expr;
2103     }
2104
2105   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2106
2107   mpz_set (result->value.integer, e->value.integer);
2108
2109   if (shift == 0)
2110     return result;
2111
2112   convert_mpz_to_unsigned (result->value.integer, isize);
2113
2114   bits = XCNEWVEC (int, ssize);
2115
2116   for (i = 0; i < ssize; i++)
2117     bits[i] = mpz_tstbit (e->value.integer, i);
2118
2119   delta = ssize - ashift;
2120
2121   if (shift > 0)
2122     {
2123       for (i = 0; i < delta; i++)
2124         {
2125           if (bits[i] == 0)
2126             mpz_clrbit (result->value.integer, i + shift);
2127           else
2128             mpz_setbit (result->value.integer, i + shift);
2129         }
2130
2131       for (i = delta; i < ssize; i++)
2132         {
2133           if (bits[i] == 0)
2134             mpz_clrbit (result->value.integer, i - delta);
2135           else
2136             mpz_setbit (result->value.integer, i - delta);
2137         }
2138     }
2139   else
2140     {
2141       for (i = 0; i < ashift; i++)
2142         {
2143           if (bits[i] == 0)
2144             mpz_clrbit (result->value.integer, i + delta);
2145           else
2146             mpz_setbit (result->value.integer, i + delta);
2147         }
2148
2149       for (i = ashift; i < ssize; i++)
2150         {
2151           if (bits[i] == 0)
2152             mpz_clrbit (result->value.integer, i + shift);
2153           else
2154             mpz_setbit (result->value.integer, i + shift);
2155         }
2156     }
2157
2158   convert_mpz_to_signed (result->value.integer, isize);
2159
2160   gfc_free (bits);
2161   return result;
2162 }
2163
2164
2165 gfc_expr *
2166 gfc_simplify_kind (gfc_expr *e)
2167 {
2168
2169   if (e->ts.type == BT_DERIVED)
2170     {
2171       gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2172       return &gfc_bad_expr;
2173     }
2174
2175   return gfc_int_expr (e->ts.kind);
2176 }
2177
2178
2179 static gfc_expr *
2180 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2181                     gfc_array_spec *as)
2182 {
2183   gfc_expr *l, *u, *result;
2184   int k;
2185
2186   /* The last dimension of an assumed-size array is special.  */
2187   if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2188     {
2189       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2190         return gfc_copy_expr (as->lower[d-1]);
2191       else
2192         return NULL;
2193     }
2194
2195   /* Then, we need to know the extent of the given dimension.  */
2196   l = as->lower[d-1];
2197   u = as->upper[d-1];
2198
2199   if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2200     return NULL;
2201
2202   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2203                 gfc_default_integer_kind);
2204   if (k == -1)
2205     return &gfc_bad_expr;
2206
2207   result = gfc_constant_result (BT_INTEGER, k, &array->where);
2208
2209   if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2210     {
2211       /* Zero extent.  */
2212       if (upper)
2213         mpz_set_si (result->value.integer, 0);
2214       else
2215         mpz_set_si (result->value.integer, 1);
2216     }
2217   else
2218     {
2219       /* Nonzero extent.  */
2220       if (upper)
2221         mpz_set (result->value.integer, u->value.integer);
2222       else
2223         mpz_set (result->value.integer, l->value.integer);
2224     }
2225
2226   return range_check (result, upper ? "UBOUND" : "LBOUND");
2227 }
2228
2229
2230 static gfc_expr *
2231 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2232 {
2233   gfc_ref *ref;
2234   gfc_array_spec *as;
2235   int d;
2236
2237   if (array->expr_type != EXPR_VARIABLE)
2238     return NULL;
2239
2240   /* Follow any component references.  */
2241   as = array->symtree->n.sym->as;
2242   for (ref = array->ref; ref; ref = ref->next)
2243     {
2244       switch (ref->type)
2245         {
2246         case REF_ARRAY:
2247           switch (ref->u.ar.type)
2248             {
2249             case AR_ELEMENT:
2250               as = NULL;
2251               continue;
2252
2253             case AR_FULL:
2254               /* We're done because 'as' has already been set in the
2255                  previous iteration.  */
2256               goto done;
2257
2258             case AR_SECTION:
2259             case AR_UNKNOWN:
2260               return NULL;
2261             }
2262
2263           gcc_unreachable ();
2264
2265         case REF_COMPONENT:
2266           as = ref->u.c.component->as;
2267           continue;
2268
2269         case REF_SUBSTRING:
2270           continue;
2271         }
2272     }
2273
2274   gcc_unreachable ();
2275
2276  done:
2277
2278   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2279     return NULL;
2280
2281   if (dim == NULL)
2282     {
2283       /* Multi-dimensional bounds.  */
2284       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2285       gfc_expr *e;
2286       gfc_constructor *head, *tail;
2287       int k;
2288
2289       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
2290       if (upper && as->type == AS_ASSUMED_SIZE)
2291         {
2292           /* An error message will be emitted in
2293              check_assumed_size_reference (resolve.c).  */
2294           return &gfc_bad_expr;
2295         }
2296
2297       /* Simplify the bounds for each dimension.  */
2298       for (d = 0; d < array->rank; d++)
2299         {
2300           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2301           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2302             {
2303               int j;
2304
2305               for (j = 0; j < d; j++)
2306                 gfc_free_expr (bounds[j]);
2307               return bounds[d];
2308             }
2309         }
2310
2311       /* Allocate the result expression.  */
2312       e = gfc_get_expr ();
2313       e->where = array->where;
2314       e->expr_type = EXPR_ARRAY;
2315       e->ts.type = BT_INTEGER;
2316       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2317                     gfc_default_integer_kind);
2318       if (k == -1)
2319         {
2320           gfc_free_expr (e);
2321           return &gfc_bad_expr;
2322         }
2323       e->ts.kind = k;
2324
2325       /* The result is a rank 1 array; its size is the rank of the first
2326          argument to {L,U}BOUND.  */
2327       e->rank = 1;
2328       e->shape = gfc_get_shape (1);
2329       mpz_init_set_ui (e->shape[0], array->rank);
2330
2331       /* Create the constructor for this array.  */
2332       head = tail = NULL;
2333       for (d = 0; d < array->rank; d++)
2334         {
2335           /* Get a new constructor element.  */
2336           if (head == NULL)
2337             head = tail = gfc_get_constructor ();
2338           else
2339             {
2340               tail->next = gfc_get_constructor ();
2341               tail = tail->next;
2342             }
2343
2344           tail->where = e->where;
2345           tail->expr = bounds[d];
2346         }
2347       e->value.constructor = head;
2348
2349       return e;
2350     }
2351   else
2352     {
2353       /* A DIM argument is specified.  */
2354       if (dim->expr_type != EXPR_CONSTANT)
2355         return NULL;
2356
2357       d = mpz_get_si (dim->value.integer);
2358
2359       if (d < 1 || d > as->rank
2360           || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2361         {
2362           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2363           return &gfc_bad_expr;
2364         }
2365
2366       return simplify_bound_dim (array, kind, d, upper, as);
2367     }
2368 }
2369
2370
2371 gfc_expr *
2372 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2373 {
2374   return simplify_bound (array, dim, kind, 0);
2375 }
2376
2377
2378 gfc_expr *
2379 gfc_simplify_leadz (gfc_expr *e)
2380 {
2381   gfc_expr *result;
2382   unsigned long lz, bs;
2383   int i;
2384
2385   if (e->expr_type != EXPR_CONSTANT)
2386     return NULL;
2387
2388   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2389   bs = gfc_integer_kinds[i].bit_size;
2390   if (mpz_cmp_si (e->value.integer, 0) == 0)
2391     lz = bs;
2392   else
2393     lz = bs - mpz_sizeinbase (e->value.integer, 2);
2394
2395   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
2396   mpz_set_ui (result->value.integer, lz);
2397
2398   return result;
2399 }
2400
2401
2402 gfc_expr *
2403 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2404 {
2405   gfc_expr *result;
2406   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2407
2408   if (k == -1)
2409     return &gfc_bad_expr;
2410
2411   if (e->expr_type == EXPR_CONSTANT)
2412     {
2413       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2414       mpz_set_si (result->value.integer, e->value.character.length);
2415       return range_check (result, "LEN");
2416     }
2417
2418   if (e->ts.cl != NULL && e->ts.cl->length != NULL
2419       && e->ts.cl->length->expr_type == EXPR_CONSTANT
2420       && e->ts.cl->length->ts.type == BT_INTEGER)
2421     {
2422       result = gfc_constant_result (BT_INTEGER, k, &e->where);
2423       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2424       return range_check (result, "LEN");
2425     }
2426
2427   return NULL;
2428 }
2429
2430
2431 gfc_expr *
2432 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2433 {
2434   gfc_expr *result;
2435   int count, len, lentrim, i;
2436   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2437
2438   if (k == -1)
2439     return &gfc_bad_expr;
2440
2441   if (e->expr_type != EXPR_CONSTANT)
2442     return NULL;
2443
2444   result = gfc_constant_result (BT_INTEGER, k, &e->where);
2445   len = e->value.character.length;
2446
2447   for (count = 0, i = 1; i <= len; i++)
2448     if (e->value.character.string[len - i] == ' ')
2449       count++;
2450     else
2451       break;
2452
2453   lentrim = len - count;
2454
2455   mpz_set_si (result->value.integer, lentrim);
2456   return range_check (result, "LEN_TRIM");
2457 }
2458
2459 gfc_expr *
2460 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
2461 {
2462   gfc_expr *result;
2463   int sg;
2464
2465   if (x->expr_type != EXPR_CONSTANT)
2466     return NULL;
2467
2468   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2469
2470   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2471
2472   return range_check (result, "LGAMMA");
2473 }
2474
2475
2476 gfc_expr *
2477 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2478 {
2479   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2480     return NULL;
2481
2482   return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2483 }
2484
2485
2486 gfc_expr *
2487 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2488 {
2489   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2490     return NULL;
2491
2492   return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2493                            &a->where);
2494 }
2495
2496
2497 gfc_expr *
2498 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2499 {
2500   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2501     return NULL;
2502
2503   return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2504 }
2505
2506
2507 gfc_expr *
2508 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2509 {
2510   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2511     return NULL;
2512
2513   return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2514 }
2515
2516
2517 gfc_expr *
2518 gfc_simplify_log (gfc_expr *x)
2519 {
2520   gfc_expr *result;
2521   mpfr_t xr, xi;
2522
2523   if (x->expr_type != EXPR_CONSTANT)
2524     return NULL;
2525
2526   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2527
2528
2529   switch (x->ts.type)
2530     {
2531     case BT_REAL:
2532       if (mpfr_sgn (x->value.real) <= 0)
2533         {
2534           gfc_error ("Argument of LOG at %L cannot be less than or equal "
2535                      "to zero", &x->where);
2536           gfc_free_expr (result);
2537           return &gfc_bad_expr;
2538         }
2539
2540       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2541       break;
2542
2543     case BT_COMPLEX:
2544       if ((mpfr_sgn (x->value.complex.r) == 0)
2545           && (mpfr_sgn (x->value.complex.i) == 0))
2546         {
2547           gfc_error ("Complex argument of LOG at %L cannot be zero",
2548                      &x->where);
2549           gfc_free_expr (result);
2550           return &gfc_bad_expr;
2551         }
2552
2553       gfc_set_model_kind (x->ts.kind);
2554       mpfr_init (xr);
2555       mpfr_init (xi);
2556
2557       mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2558                   x->value.complex.r, GFC_RND_MODE);
2559
2560       mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2561       mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2562       mpfr_add (xr, xr, xi, GFC_RND_MODE);
2563       mpfr_sqrt (xr, xr, GFC_RND_MODE);
2564       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2565
2566       mpfr_clears (xr, xi, NULL);
2567
2568       break;
2569
2570     default:
2571       gfc_internal_error ("gfc_simplify_log: bad type");
2572     }
2573
2574   return range_check (result, "LOG");
2575 }
2576
2577
2578 gfc_expr *
2579 gfc_simplify_log10 (gfc_expr *x)
2580 {
2581   gfc_expr *result;
2582
2583   if (x->expr_type != EXPR_CONSTANT)
2584     return NULL;
2585
2586   if (mpfr_sgn (x->value.real) <= 0)
2587     {
2588       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2589                  "to zero", &x->where);
2590       return &gfc_bad_expr;
2591     }
2592
2593   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2594
2595   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2596
2597   return range_check (result, "LOG10");
2598 }
2599
2600
2601 gfc_expr *
2602 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2603 {
2604   gfc_expr *result;
2605   int kind;
2606
2607   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2608   if (kind < 0)
2609     return &gfc_bad_expr;
2610
2611   if (e->expr_type != EXPR_CONSTANT)
2612     return NULL;
2613
2614   result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2615
2616   result->value.logical = e->value.logical;
2617
2618   return result;
2619 }
2620
2621
2622 /* Selects bewteen current value and extremum for simplify_min_max
2623    and simplify_minval_maxval.  */
2624 static void
2625 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
2626 {
2627   switch (arg->ts.type)
2628     {
2629       case BT_INTEGER:
2630         if (mpz_cmp (arg->value.integer,
2631                         extremum->value.integer) * sign > 0)
2632         mpz_set (extremum->value.integer, arg->value.integer);
2633         break;
2634
2635       case BT_REAL:
2636         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
2637         if (sign > 0)
2638           mpfr_max (extremum->value.real, extremum->value.real,
2639                       arg->value.real, GFC_RND_MODE);
2640         else
2641           mpfr_min (extremum->value.real, extremum->value.real,
2642                       arg->value.real, GFC_RND_MODE);
2643         break;
2644
2645       case BT_CHARACTER:
2646 #define LENGTH(x) ((x)->value.character.length)
2647 #define STRING(x) ((x)->value.character.string)
2648         if (LENGTH(extremum) < LENGTH(arg))
2649           {
2650             gfc_char_t *tmp = STRING(extremum);
2651
2652             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2653             memcpy (STRING(extremum), tmp,
2654                       LENGTH(extremum) * sizeof (gfc_char_t));
2655             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2656                                LENGTH(arg) - LENGTH(extremum));
2657             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
2658             LENGTH(extremum) = LENGTH(arg);
2659             gfc_free (tmp);
2660           }
2661
2662         if (gfc_compare_string (arg, extremum) * sign > 0)
2663           {
2664             gfc_free (STRING(extremum));
2665             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2666             memcpy (STRING(extremum), STRING(arg),
2667                       LENGTH(arg) * sizeof (gfc_char_t));
2668             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2669                                LENGTH(extremum) - LENGTH(arg));
2670             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
2671           }
2672 #undef LENGTH
2673 #undef STRING
2674         break;
2675
2676       default:
2677         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2678     }
2679 }
2680
2681
2682 /* This function is special since MAX() can take any number of
2683    arguments.  The simplified expression is a rewritten version of the
2684    argument list containing at most one constant element.  Other
2685    constant elements are deleted.  Because the argument list has
2686    already been checked, this function always succeeds.  sign is 1 for
2687    MAX(), -1 for MIN().  */
2688
2689 static gfc_expr *
2690 simplify_min_max (gfc_expr *expr, int sign)
2691 {
2692   gfc_actual_arglist *arg, *last, *extremum;
2693   gfc_intrinsic_sym * specific;
2694
2695   last = NULL;
2696   extremum = NULL;
2697   specific = expr->value.function.isym;
2698
2699   arg = expr->value.function.actual;
2700
2701   for (; arg; last = arg, arg = arg->next)
2702     {
2703       if (arg->expr->expr_type != EXPR_CONSTANT)
2704         continue;
2705
2706       if (extremum == NULL)
2707         {
2708           extremum = arg;
2709           continue;
2710         }
2711
2712       min_max_choose (arg->expr, extremum->expr, sign);
2713
2714       /* Delete the extra constant argument.  */
2715       if (last == NULL)
2716         expr->value.function.actual = arg->next;
2717       else
2718         last->next = arg->next;
2719
2720       arg->next = NULL;
2721       gfc_free_actual_arglist (arg);
2722       arg = last;
2723     }
2724
2725   /* If there is one value left, replace the function call with the
2726      expression.  */
2727   if (expr->value.function.actual->next != NULL)
2728     return NULL;
2729
2730   /* Convert to the correct type and kind.  */
2731   if (expr->ts.type != BT_UNKNOWN)
2732     return gfc_convert_constant (expr->value.function.actual->expr,
2733         expr->ts.type, expr->ts.kind);
2734
2735   if (specific->ts.type != BT_UNKNOWN)
2736     return gfc_convert_constant (expr->value.function.actual->expr,
2737         specific->ts.type, specific->ts.kind);
2738
2739   return gfc_copy_expr (expr->value.function.actual->expr);
2740 }
2741
2742
2743 gfc_expr *
2744 gfc_simplify_min (gfc_expr *e)
2745 {
2746   return simplify_min_max (e, -1);
2747 }
2748
2749
2750 gfc_expr *
2751 gfc_simplify_max (gfc_expr *e)
2752 {
2753   return simplify_min_max (e, 1);
2754 }
2755
2756
2757 /* This is a simplified version of simplify_min_max to provide
2758    simplification of minval and maxval for a vector.  */
2759
2760 static gfc_expr *
2761 simplify_minval_maxval (gfc_expr *expr, int sign)
2762 {
2763   gfc_constructor *ctr, *extremum;
2764   gfc_intrinsic_sym * specific;
2765
2766   extremum = NULL;
2767   specific = expr->value.function.isym;
2768
2769   ctr = expr->value.constructor;
2770
2771   for (; ctr; ctr = ctr->next)
2772     {
2773       if (ctr->expr->expr_type != EXPR_CONSTANT)
2774         return NULL;
2775
2776       if (extremum == NULL)
2777         {
2778           extremum = ctr;
2779           continue;
2780         }
2781
2782       min_max_choose (ctr->expr, extremum->expr, sign);
2783      }
2784
2785   if (extremum == NULL)
2786     return NULL;
2787
2788   /* Convert to the correct type and kind.  */
2789   if (expr->ts.type != BT_UNKNOWN)
2790     return gfc_convert_constant (extremum->expr,
2791         expr->ts.type, expr->ts.kind);
2792
2793   if (specific->ts.type != BT_UNKNOWN)
2794     return gfc_convert_constant (extremum->expr,
2795         specific->ts.type, specific->ts.kind);
2796
2797   return gfc_copy_expr (extremum->expr);
2798 }
2799
2800
2801 gfc_expr *
2802 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
2803 {
2804   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
2805     return NULL;
2806
2807   return simplify_minval_maxval (array, -1);
2808 }
2809
2810
2811 gfc_expr *
2812 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
2813 {
2814   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
2815     return NULL;
2816   return simplify_minval_maxval (array, 1);
2817 }
2818
2819
2820 gfc_expr *
2821 gfc_simplify_maxexponent (gfc_expr *x)
2822 {
2823   gfc_expr *result;
2824   int i;
2825
2826   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2827
2828   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2829   result->where = x->where;
2830
2831   return result;
2832 }
2833
2834
2835 gfc_expr *
2836 gfc_simplify_minexponent (gfc_expr *x)
2837 {
2838   gfc_expr *result;
2839   int i;
2840
2841   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2842
2843   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2844   result->where = x->where;
2845
2846   return result;
2847 }
2848
2849
2850 gfc_expr *
2851 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2852 {
2853   gfc_expr *result;
2854   mpfr_t tmp;
2855   int kind;
2856
2857   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2858     return NULL;
2859
2860   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2861   result = gfc_constant_result (a->ts.type, kind, &a->where);
2862
2863   switch (a->ts.type)
2864     {
2865     case BT_INTEGER:
2866       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2867         {
2868           /* Result is processor-dependent.  */
2869           gfc_error ("Second argument MOD at %L is zero", &a->where);
2870           gfc_free_expr (result);
2871           return &gfc_bad_expr;
2872         }
2873       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2874       break;
2875
2876     case BT_REAL:
2877       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2878         {
2879           /* Result is processor-dependent.  */
2880           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2881           gfc_free_expr (result);
2882           return &gfc_bad_expr;
2883         }
2884
2885       gfc_set_model_kind (kind);
2886       mpfr_init (tmp);
2887       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2888       mpfr_trunc (tmp, tmp);
2889       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2890       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2891       mpfr_clear (tmp);
2892       break;
2893
2894     default:
2895       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2896     }
2897
2898   return range_check (result, "MOD");
2899 }
2900
2901
2902 gfc_expr *
2903 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2904 {
2905   gfc_expr *result;
2906   mpfr_t tmp;
2907   int kind;
2908
2909   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2910     return NULL;
2911
2912   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2913   result = gfc_constant_result (a->ts.type, kind, &a->where);
2914
2915   switch (a->ts.type)
2916     {
2917     case BT_INTEGER:
2918       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2919         {
2920           /* Result is processor-dependent. This processor just opts
2921              to not handle it at all.  */
2922           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2923           gfc_free_expr (result);
2924           return &gfc_bad_expr;
2925         }
2926       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2927
2928       break;
2929
2930     case BT_REAL:
2931       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2932         {
2933           /* Result is processor-dependent.  */
2934           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2935           gfc_free_expr (result);
2936           return &gfc_bad_expr;
2937         }
2938
2939       gfc_set_model_kind (kind);
2940       mpfr_init (tmp);
2941       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2942       mpfr_floor (tmp, tmp);
2943       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2944       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2945       mpfr_clear (tmp);
2946       break;
2947
2948     default:
2949       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2950     }
2951
2952   return range_check (result, "MODULO");
2953 }
2954
2955
2956 /* Exists for the sole purpose of consistency with other intrinsics.  */
2957 gfc_expr *
2958 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
2959                      gfc_expr *fp ATTRIBUTE_UNUSED,
2960                      gfc_expr *l  ATTRIBUTE_UNUSED,
2961                      gfc_expr *to ATTRIBUTE_UNUSED,
2962                      gfc_expr *tp ATTRIBUTE_UNUSED)
2963 {
2964   return NULL;
2965 }
2966
2967
2968 gfc_expr *
2969 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2970 {
2971   gfc_expr *result;
2972   mp_exp_t emin, emax;
2973   int kind;
2974
2975   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2976     return NULL;
2977
2978   if (mpfr_sgn (s->value.real) == 0)
2979     {
2980       gfc_error ("Second argument of NEAREST at %L shall not be zero",
2981                  &s->where);
2982       return &gfc_bad_expr;
2983     }
2984
2985   result = gfc_copy_expr (x);
2986
2987   /* Save current values of emin and emax.  */
2988   emin = mpfr_get_emin ();
2989   emax = mpfr_get_emax ();
2990
2991   /* Set emin and emax for the current model number.  */
2992   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2993   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2994                 mpfr_get_prec(result->value.real) + 1);
2995   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2996   mpfr_check_range (result->value.real, 0, GMP_RNDU);
2997
2998   if (mpfr_sgn (s->value.real) > 0)
2999     {
3000       mpfr_nextabove (result->value.real);
3001       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3002     }
3003   else
3004     {
3005       mpfr_nextbelow (result->value.real);
3006       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3007     }
3008
3009   mpfr_set_emin (emin);
3010   mpfr_set_emax (emax);
3011
3012   /* Only NaN can occur. Do not use range check as it gives an
3013      error for denormal numbers.  */
3014   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3015     {
3016       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3017       gfc_free_expr (result);
3018       return &gfc_bad_expr;
3019     }
3020
3021   return result;
3022 }
3023
3024
3025 static gfc_expr *
3026 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3027 {
3028   gfc_expr *itrunc, *result;
3029   int kind;
3030
3031   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3032   if (kind == -1)
3033     return &gfc_bad_expr;
3034
3035   if (e->expr_type != EXPR_CONSTANT)
3036     return NULL;
3037
3038   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
3039
3040   itrunc = gfc_copy_expr (e);
3041
3042   mpfr_round (itrunc->value.real, e->value.real);
3043
3044   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3045
3046   gfc_free_expr (itrunc);
3047
3048   return range_check (result, name);
3049 }
3050
3051
3052 gfc_expr *
3053 gfc_simplify_new_line (gfc_expr *e)
3054 {
3055   gfc_expr *result;
3056
3057   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3058   result->value.character.string = gfc_get_wide_string (2);
3059   result->value.character.length = 1;
3060   result->value.character.string[0] = '\n';
3061   result->value.character.string[1] = '\0';     /* For debugger */
3062   return result;
3063 }
3064
3065
3066 gfc_expr *
3067 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3068 {
3069   return simplify_nint ("NINT", e, k);
3070 }
3071
3072
3073 gfc_expr *
3074 gfc_simplify_idnint (gfc_expr *e)
3075 {
3076   return simplify_nint ("IDNINT", e, NULL);
3077 }
3078
3079
3080 gfc_expr *
3081 gfc_simplify_not (gfc_expr *e)
3082 {
3083   gfc_expr *result;
3084
3085   if (e->expr_type != EXPR_CONSTANT)
3086     return NULL;
3087
3088   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3089
3090   mpz_com (result->value.integer, e->value.integer);
3091
3092   return range_check (result, "NOT");
3093 }
3094
3095
3096 gfc_expr *
3097 gfc_simplify_null (gfc_expr *mold)
3098 {
3099   gfc_expr *result;
3100
3101   if (mold == NULL)
3102     {
3103       result = gfc_get_expr ();
3104       result->ts.type = BT_UNKNOWN;
3105     }
3106   else
3107     result = gfc_copy_expr (mold);
3108   result->expr_type = EXPR_NULL;
3109
3110   return result;
3111 }
3112
3113
3114 gfc_expr *
3115 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3116 {
3117   gfc_expr *result;
3118   int kind;
3119
3120   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3121     return NULL;
3122
3123   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3124   if (x->ts.type == BT_INTEGER)
3125     {
3126       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3127       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3128       return range_check (result, "OR");
3129     }
3130   else /* BT_LOGICAL */
3131     {
3132       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3133       result->value.logical = x->value.logical || y->value.logical;
3134       return result;
3135     }
3136 }
3137
3138
3139 gfc_expr *
3140 gfc_simplify_precision (gfc_expr *e)
3141 {
3142   gfc_expr *result;
3143   int i;
3144
3145   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3146
3147   result = gfc_int_expr (gfc_real_kinds[i].precision);
3148   result->where = e->where;
3149
3150   return result;
3151 }
3152
3153
3154 gfc_expr *
3155 gfc_simplify_radix (gfc_expr *e)
3156 {
3157   gfc_expr *result;
3158   int i;
3159
3160   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3161   switch (e->ts.type)
3162     {
3163     case BT_INTEGER:
3164       i = gfc_integer_kinds[i].radix;
3165       break;
3166
3167     case BT_REAL:
3168       i = gfc_real_kinds[i].radix;
3169       break;
3170
3171     default:
3172       gcc_unreachable ();
3173     }
3174
3175   result = gfc_int_expr (i);
3176   result->where = e->where;
3177
3178   return result;
3179 }
3180
3181
3182 gfc_expr *
3183 gfc_simplify_range (gfc_expr *e)
3184 {
3185   gfc_expr *result;
3186   int i;
3187   long j;
3188
3189   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3190
3191   switch (e->ts.type)
3192     {
3193     case BT_INTEGER:
3194       j = gfc_integer_kinds[i].range;
3195       break;
3196
3197     case BT_REAL:
3198     case BT_COMPLEX:
3199       j = gfc_real_kinds[i].range;
3200       break;
3201
3202     default:
3203       gcc_unreachable ();
3204     }
3205
3206   result = gfc_int_expr (j);
3207   result->where = e->where;
3208
3209   return result;
3210 }
3211
3212
3213 gfc_expr *
3214 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3215 {
3216   gfc_expr *result = NULL;
3217   int kind;
3218
3219   if (e->ts.type == BT_COMPLEX)
3220     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3221   else
3222     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3223
3224   if (kind == -1)
3225     return &gfc_bad_expr;
3226
3227   if (e->expr_type != EXPR_CONSTANT)
3228     return NULL;
3229
3230   switch (e->ts.type)
3231     {
3232     case BT_INTEGER:
3233       if (!e->is_boz)
3234         result = gfc_int2real (e, kind);
3235       break;
3236
3237     case BT_REAL:
3238       result = gfc_real2real (e, kind);
3239       break;
3240
3241     case BT_COMPLEX:
3242       result = gfc_complex2real (e, kind);
3243       break;
3244
3245     default:
3246       gfc_internal_error ("bad type in REAL");
3247       /* Not reached */
3248     }
3249
3250   if (e->ts.type == BT_INTEGER && e->is_boz)
3251     {
3252       gfc_typespec ts;
3253       gfc_clear_ts (&ts);
3254       ts.type = BT_REAL;
3255       ts.kind = kind;
3256       result = gfc_copy_expr (e);
3257       if (!gfc_convert_boz (result, &ts))
3258         {
3259           gfc_free_expr (result);
3260           return &gfc_bad_expr;
3261         }
3262     }
3263
3264   return range_check (result, "REAL");
3265 }
3266
3267
3268 gfc_expr *
3269 gfc_simplify_realpart (gfc_expr *e)
3270 {
3271   gfc_expr *result;
3272
3273   if (e->expr_type != EXPR_CONSTANT)
3274     return NULL;
3275
3276   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3277   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3278
3279   return range_check (result, "REALPART");
3280 }
3281
3282 gfc_expr *
3283 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3284 {
3285   gfc_expr *result;
3286   int i, j, len, ncop, nlen;
3287   mpz_t ncopies;
3288   bool have_length = false;
3289
3290   /* If NCOPIES isn't a constant, there's nothing we can do.  */
3291   if (n->expr_type != EXPR_CONSTANT)
3292     return NULL;
3293
3294   /* If NCOPIES is negative, it's an error.  */
3295   if (mpz_sgn (n->value.integer) < 0)
3296     {
3297       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3298                  &n->where);
3299       return &gfc_bad_expr;
3300     }
3301
3302   /* If we don't know the character length, we can do no more.  */
3303   if (e->ts.cl && e->ts.cl->length
3304         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3305     {
3306       len = mpz_get_si (e->ts.cl->length->value.integer);
3307       have_length = true;
3308     }
3309   else if (e->expr_type == EXPR_CONSTANT
3310              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3311     {
3312       len = e->value.character.length;
3313     }
3314   else
3315     return NULL;
3316
3317   /* If the source length is 0, any value of NCOPIES is valid
3318      and everything behaves as if NCOPIES == 0.  */
3319   mpz_init (ncopies);
3320   if (len == 0)
3321     mpz_set_ui (ncopies, 0);
3322   else
3323     mpz_set (ncopies, n->value.integer);
3324
3325   /* Check that NCOPIES isn't too large.  */
3326   if (len)
3327     {
3328       mpz_t max, mlen;
3329       int i;
3330
3331       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
3332       mpz_init (max);
3333       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3334
3335       if (have_length)
3336         {
3337           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3338                       e->ts.cl->length->value.integer);
3339         }
3340       else
3341         {
3342           mpz_init_set_si (mlen, len);
3343           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3344           mpz_clear (mlen);
3345         }
3346
3347       /* The check itself.  */
3348       if (mpz_cmp (ncopies, max) > 0)
3349         {
3350           mpz_clear (max);
3351           mpz_clear (ncopies);
3352           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3353                      &n->where);
3354           return &gfc_bad_expr;
3355         }
3356
3357       mpz_clear (max);
3358     }
3359   mpz_clear (ncopies);
3360
3361   /* For further simplification, we need the character string to be
3362      constant.  */
3363   if (e->expr_type != EXPR_CONSTANT)
3364     return NULL;
3365
3366   if (len ||
3367       (e->ts.cl->length &&
3368        mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3369     {
3370       const char *res = gfc_extract_int (n, &ncop);
3371       gcc_assert (res == NULL);
3372     }
3373   else
3374     ncop = 0;
3375
3376   len = e->value.character.length;
3377   nlen = ncop * len;
3378
3379   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3380
3381   if (ncop == 0)
3382     {
3383       result->value.character.string = gfc_get_wide_string (1);
3384       result->value.character.length = 0;
3385       result->value.character.string[0] = '\0';
3386       return result;
3387     }
3388
3389   result->value.character.length = nlen;
3390   result->value.character.string = gfc_get_wide_string (nlen + 1);
3391
3392   for (i = 0; i < ncop; i++)
3393     for (j = 0; j < len; j++)
3394       result->value.character.string[j+i*len]= e->value.character.string[j];
3395
3396   result->value.character.string[nlen] = '\0';  /* For debugger */
3397   return result;
3398 }
3399
3400
3401 /* Test that the expression is an constant array.  */
3402
3403 static bool
3404 is_constant_array_expr (gfc_expr *e)
3405 {
3406   gfc_constructor *c;
3407
3408   if (e == NULL)
3409     return true;
3410
3411   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3412     return false;
3413
3414   for (c = e->value.constructor; c; c = c->next)
3415     if (c->expr->expr_type != EXPR_CONSTANT)
3416       return false;
3417
3418   return true;
3419 }
3420
3421
3422 /* This one is a bear, but mainly has to do with shuffling elements.  */
3423
3424 gfc_expr *
3425 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3426                       gfc_expr *pad, gfc_expr *order_exp)
3427 {
3428   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3429   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3430   gfc_constructor *head, *tail;
3431   mpz_t index, size;
3432   unsigned long j;
3433   size_t nsource;
3434   gfc_expr *e;
3435
3436   /* Check that argument expression types are OK.  */
3437   if (!is_constant_array_expr (source))
3438     return NULL;
3439
3440   if (!is_constant_array_expr (shape_exp))
3441     return NULL;
3442
3443   if (!is_constant_array_expr (pad))
3444     return NULL;
3445
3446   if (!is_constant_array_expr (order_exp))
3447     return NULL;
3448
3449   /* Proceed with simplification, unpacking the array.  */
3450
3451   mpz_init (index);
3452   rank = 0;
3453   head = tail = NULL;
3454
3455   for (;;)
3456     {
3457       e = gfc_get_array_element (shape_exp, rank);
3458       if (e == NULL)
3459         break;
3460
3461       if (gfc_extract_int (e, &shape[rank]) != NULL)
3462         {
3463           gfc_error ("Integer too large in shape specification at %L",
3464                      &e->where);
3465           gfc_free_expr (e);
3466           goto bad_reshape;
3467         }
3468
3469       if (rank >= GFC_MAX_DIMENSIONS)
3470         {
3471           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3472                      "at %L", &e->where);
3473           gfc_free_expr (e);
3474           goto bad_reshape;
3475         }
3476
3477       if (shape[rank] < 0)
3478         {
3479           gfc_error ("Shape specification at %L cannot be negative",
3480                      &e->where);
3481           gfc_free_expr (e);
3482           goto bad_reshape;
3483         }
3484
3485       gfc_free_expr (e);
3486       rank++;
3487     }
3488
3489   if (rank == 0)
3490     {
3491       gfc_error ("Shape specification at %L cannot be the null array",
3492                  &shape_exp->where);
3493       goto bad_reshape;
3494     }
3495
3496   /* Now unpack the order array if present.  */
3497   if (order_exp == NULL)
3498     {
3499       for (i = 0; i < rank; i++)
3500         order[i] = i;
3501     }
3502   else
3503     {
3504       for (i = 0; i < rank; i++)
3505         x[i] = 0;
3506
3507       for (i = 0; i < rank; i++)
3508         {
3509           e = gfc_get_array_element (order_exp, i);
3510           if (e == NULL)
3511             {
3512               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3513                          "size as SHAPE parameter", &order_exp->where);
3514               goto bad_reshape;
3515             }
3516
3517           if (gfc_extract_int (e, &order[i]) != NULL)
3518             {
3519               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3520                          &e->where);
3521               gfc_free_expr (e);
3522               goto bad_reshape;
3523             }
3524
3525           if (order[i] < 1 || order[i] > rank)
3526             {
3527               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3528                          &e->where);
3529               gfc_free_expr (e);
3530               goto bad_reshape;
3531             }
3532
3533           order[i]--;
3534
3535           if (x[order[i]])
3536             {
3537               gfc_error ("Invalid permutation in ORDER parameter at %L",
3538                          &e->where);
3539               gfc_free_expr (e);
3540               goto bad_reshape;
3541             }
3542
3543           gfc_free_expr (e);
3544
3545           x[order[i]] = 1;
3546         }
3547     }
3548
3549   /* Count the elements in the source and padding arrays.  */
3550
3551   npad = 0;
3552   if (pad != NULL)
3553     {
3554       gfc_array_size (pad, &size);
3555       npad = mpz_get_ui (size);
3556       mpz_clear (size);
3557     }
3558
3559   gfc_array_size (source, &size);
3560   nsource = mpz_get_ui (size);
3561   mpz_clear (size);
3562
3563   /* If it weren't for that pesky permutation we could just loop
3564      through the source and round out any shortage with pad elements.
3565      But no, someone just had to have the compiler do something the
3566      user should be doing.  */
3567
3568   for (i = 0; i < rank; i++)
3569     x[i] = 0;
3570
3571   for (;;)
3572     {
3573       /* Figure out which element to extract.  */
3574       mpz_set_ui (index, 0);
3575
3576       for (i = rank - 1; i >= 0; i--)
3577         {
3578           mpz_add_ui (index, index, x[order[i]]);
3579           if (i != 0)
3580             mpz_mul_ui (index, index, shape[order[i - 1]]);
3581         }
3582
3583       if (mpz_cmp_ui (index, INT_MAX) > 0)
3584         gfc_internal_error ("Reshaped array too large at %C");
3585
3586       j = mpz_get_ui (index);
3587
3588       if (j < nsource)
3589         e = gfc_get_array_element (source, j);
3590       else
3591         {
3592           j = j - nsource;
3593
3594           if (npad == 0)
3595             {
3596               gfc_error ("PAD parameter required for short SOURCE parameter "
3597                          "at %L", &source->where);
3598               goto bad_reshape;
3599             }
3600
3601           j = j % npad;
3602           e = gfc_get_array_element (pad, j);
3603         }
3604
3605       if (head == NULL)
3606         head = tail = gfc_get_constructor ();
3607       else
3608         {
3609           tail->next = gfc_get_constructor ();
3610           tail = tail->next;
3611         }
3612
3613       if (e == NULL)
3614         goto bad_reshape;
3615
3616       tail->where = e->where;
3617       tail->expr = e;
3618
3619       /* Calculate the next element.  */
3620       i = 0;
3621
3622 inc:
3623       if (++x[i] < shape[i])
3624         continue;
3625       x[i++] = 0;
3626       if (i < rank)
3627         goto inc;
3628
3629       break;
3630     }
3631
3632   mpz_clear (index);
3633
3634   e = gfc_get_expr ();
3635   e->where = source->where;
3636   e->expr_type = EXPR_ARRAY;
3637   e->value.constructor = head;
3638   e->shape = gfc_get_shape (rank);
3639
3640   for (i = 0; i < rank; i++)
3641     mpz_init_set_ui (e->shape[i], shape[i]);
3642
3643   e->ts = source->ts;
3644   e->rank = rank;
3645
3646   return e;
3647
3648 bad_reshape:
3649   gfc_free_constructor (head);
3650   mpz_clear (index);
3651   return &gfc_bad_expr;
3652 }
3653
3654
3655 gfc_expr *
3656 gfc_simplify_rrspacing (gfc_expr *x)
3657 {
3658   gfc_expr *result;
3659   int i;
3660   long int e, p;
3661
3662   if (x->expr_type != EXPR_CONSTANT)
3663     return NULL;
3664
3665   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3666
3667   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3668
3669   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3670
3671   /* Special case x = -0 and 0.  */
3672   if (mpfr_sgn (result->value.real) == 0)
3673     {
3674       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3675       return result;
3676     }
3677
3678   /* | x * 2**(-e) | * 2**p.  */
3679   e = - (long int) mpfr_get_exp (x->value.real);
3680   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3681
3682   p = (long int) gfc_real_kinds[i].digits;
3683   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3684
3685   return range_check (result, "RRSPACING");
3686 }
3687
3688
3689 gfc_expr *
3690 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3691 {
3692   int k, neg_flag, power, exp_range;
3693   mpfr_t scale, radix;
3694   gfc_expr *result;
3695
3696   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3697     return NULL;
3698
3699   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3700
3701   if (mpfr_sgn (x->value.real) == 0)
3702     {
3703       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3704       return result;
3705     }
3706
3707   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3708
3709   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3710
3711   /* This check filters out values of i that would overflow an int.  */
3712   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3713       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3714     {
3715       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3716       gfc_free_expr (result);
3717       return &gfc_bad_expr;
3718     }
3719
3720   /* Compute scale = radix ** power.  */
3721   power = mpz_get_si (i->value.integer);
3722
3723   if (power >= 0)
3724     neg_flag = 0;
3725   else
3726     {
3727       neg_flag = 1;
3728       power = -power;
3729     }
3730
3731   gfc_set_model_kind (x->ts.kind);
3732   mpfr_init (scale);
3733   mpfr_init (radix);
3734   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3735   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3736
3737   if (neg_flag)
3738     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3739   else
3740     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3741
3742   mpfr_clears (scale, radix, NULL);
3743
3744   return range_check (result, "SCALE");
3745 }
3746
3747
3748 /* Variants of strspn and strcspn that operate on wide characters.  */
3749
3750 static size_t
3751 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3752 {
3753   size_t i = 0;