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);
 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);
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);
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);
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 /* This function is special since MAX() can take any number of
2623    arguments.  The simplified expression is a rewritten version of the
2624    argument list containing at most one constant element.  Other
2625    constant elements are deleted.  Because the argument list has
2626    already been checked, this function always succeeds.  sign is 1 for
2627    MAX(), -1 for MIN().  */
2628
2629 static gfc_expr *
2630 simplify_min_max (gfc_expr *expr, int sign)
2631 {
2632   gfc_actual_arglist *arg, *last, *extremum;
2633   gfc_intrinsic_sym * specific;
2634
2635   last = NULL;
2636   extremum = NULL;
2637   specific = expr->value.function.isym;
2638
2639   arg = expr->value.function.actual;
2640
2641   for (; arg; last = arg, arg = arg->next)
2642     {
2643       if (arg->expr->expr_type != EXPR_CONSTANT)
2644         continue;
2645
2646       if (extremum == NULL)
2647         {
2648           extremum = arg;
2649           continue;
2650         }
2651
2652       switch (arg->expr->ts.type)
2653         {
2654         case BT_INTEGER:
2655           if (mpz_cmp (arg->expr->value.integer,
2656                        extremum->expr->value.integer) * sign > 0)
2657             mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2658           break;
2659
2660         case BT_REAL:
2661           /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
2662           if (sign > 0)
2663             mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2664                       arg->expr->value.real, GFC_RND_MODE);
2665           else
2666             mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2667                       arg->expr->value.real, GFC_RND_MODE);
2668           break;
2669
2670         case BT_CHARACTER:
2671 #define LENGTH(x) ((x)->expr->value.character.length)
2672 #define STRING(x) ((x)->expr->value.character.string)
2673           if (LENGTH(extremum) < LENGTH(arg))
2674             {
2675               gfc_char_t *tmp = STRING(extremum);
2676
2677               STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2678               memcpy (STRING(extremum), tmp,
2679                       LENGTH(extremum) * sizeof (gfc_char_t));
2680               gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2681                                LENGTH(arg) - LENGTH(extremum));
2682               STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
2683               LENGTH(extremum) = LENGTH(arg);
2684               gfc_free (tmp);
2685             }
2686
2687           if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2688             {
2689               gfc_free (STRING(extremum));
2690               STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2691               memcpy (STRING(extremum), STRING(arg),
2692                       LENGTH(arg) * sizeof (gfc_char_t));
2693               gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2694                                LENGTH(extremum) - LENGTH(arg));
2695               STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
2696             }
2697 #undef LENGTH
2698 #undef STRING
2699           break;
2700
2701
2702         default:
2703           gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2704         }
2705
2706       /* Delete the extra constant argument.  */
2707       if (last == NULL)
2708         expr->value.function.actual = arg->next;
2709       else
2710         last->next = arg->next;
2711
2712       arg->next = NULL;
2713       gfc_free_actual_arglist (arg);
2714       arg = last;
2715     }
2716
2717   /* If there is one value left, replace the function call with the
2718      expression.  */
2719   if (expr->value.function.actual->next != NULL)
2720     return NULL;
2721
2722   /* Convert to the correct type and kind.  */
2723   if (expr->ts.type != BT_UNKNOWN)
2724     return gfc_convert_constant (expr->value.function.actual->expr,
2725         expr->ts.type, expr->ts.kind);
2726
2727   if (specific->ts.type != BT_UNKNOWN)
2728     return gfc_convert_constant (expr->value.function.actual->expr,
2729         specific->ts.type, specific->ts.kind);
2730
2731   return gfc_copy_expr (expr->value.function.actual->expr);
2732 }
2733
2734
2735 gfc_expr *
2736 gfc_simplify_min (gfc_expr *e)
2737 {
2738   return simplify_min_max (e, -1);
2739 }
2740
2741
2742 gfc_expr *
2743 gfc_simplify_max (gfc_expr *e)
2744 {
2745   return simplify_min_max (e, 1);
2746 }
2747
2748
2749 gfc_expr *
2750 gfc_simplify_maxexponent (gfc_expr *x)
2751 {
2752   gfc_expr *result;
2753   int i;
2754
2755   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2756
2757   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2758   result->where = x->where;
2759
2760   return result;
2761 }
2762
2763
2764 gfc_expr *
2765 gfc_simplify_minexponent (gfc_expr *x)
2766 {
2767   gfc_expr *result;
2768   int i;
2769
2770   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2771
2772   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2773   result->where = x->where;
2774
2775   return result;
2776 }
2777
2778
2779 gfc_expr *
2780 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2781 {
2782   gfc_expr *result;
2783   mpfr_t tmp;
2784   int kind;
2785
2786   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2787     return NULL;
2788
2789   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2790   result = gfc_constant_result (a->ts.type, kind, &a->where);
2791
2792   switch (a->ts.type)
2793     {
2794     case BT_INTEGER:
2795       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2796         {
2797           /* Result is processor-dependent.  */
2798           gfc_error ("Second argument MOD at %L is zero", &a->where);
2799           gfc_free_expr (result);
2800           return &gfc_bad_expr;
2801         }
2802       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2803       break;
2804
2805     case BT_REAL:
2806       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2807         {
2808           /* Result is processor-dependent.  */
2809           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2810           gfc_free_expr (result);
2811           return &gfc_bad_expr;
2812         }
2813
2814       gfc_set_model_kind (kind);
2815       mpfr_init (tmp);
2816       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2817       mpfr_trunc (tmp, tmp);
2818       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2819       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2820       mpfr_clear (tmp);
2821       break;
2822
2823     default:
2824       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2825     }
2826
2827   return range_check (result, "MOD");
2828 }
2829
2830
2831 gfc_expr *
2832 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2833 {
2834   gfc_expr *result;
2835   mpfr_t tmp;
2836   int kind;
2837
2838   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2839     return NULL;
2840
2841   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2842   result = gfc_constant_result (a->ts.type, kind, &a->where);
2843
2844   switch (a->ts.type)
2845     {
2846     case BT_INTEGER:
2847       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2848         {
2849           /* Result is processor-dependent. This processor just opts
2850              to not handle it at all.  */
2851           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2852           gfc_free_expr (result);
2853           return &gfc_bad_expr;
2854         }
2855       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2856
2857       break;
2858
2859     case BT_REAL:
2860       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2861         {
2862           /* Result is processor-dependent.  */
2863           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2864           gfc_free_expr (result);
2865           return &gfc_bad_expr;
2866         }
2867
2868       gfc_set_model_kind (kind);
2869       mpfr_init (tmp);
2870       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2871       mpfr_floor (tmp, tmp);
2872       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2873       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2874       mpfr_clear (tmp);
2875       break;
2876
2877     default:
2878       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2879     }
2880
2881   return range_check (result, "MODULO");
2882 }
2883
2884
2885 /* Exists for the sole purpose of consistency with other intrinsics.  */
2886 gfc_expr *
2887 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
2888                      gfc_expr *fp ATTRIBUTE_UNUSED,
2889                      gfc_expr *l  ATTRIBUTE_UNUSED,
2890                      gfc_expr *to ATTRIBUTE_UNUSED,
2891                      gfc_expr *tp ATTRIBUTE_UNUSED)
2892 {
2893   return NULL;
2894 }
2895
2896
2897 gfc_expr *
2898 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2899 {
2900   gfc_expr *result;
2901   mp_exp_t emin, emax;
2902   int kind;
2903
2904   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2905     return NULL;
2906
2907   if (mpfr_sgn (s->value.real) == 0)
2908     {
2909       gfc_error ("Second argument of NEAREST at %L shall not be zero",
2910                  &s->where);
2911       return &gfc_bad_expr;
2912     }
2913
2914   result = gfc_copy_expr (x);
2915
2916   /* Save current values of emin and emax.  */
2917   emin = mpfr_get_emin ();
2918   emax = mpfr_get_emax ();
2919
2920   /* Set emin and emax for the current model number.  */
2921   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2922   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2923                 mpfr_get_prec(result->value.real) + 1);
2924   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2925
2926   if (mpfr_sgn (s->value.real) > 0)
2927     {
2928       mpfr_nextabove (result->value.real);
2929       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2930     }
2931   else
2932     {
2933       mpfr_nextbelow (result->value.real);
2934       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2935     }
2936
2937   mpfr_set_emin (emin);
2938   mpfr_set_emax (emax);
2939
2940   /* Only NaN can occur. Do not use range check as it gives an
2941      error for denormal numbers.  */
2942   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2943     {
2944       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2945       gfc_free_expr (result);
2946       return &gfc_bad_expr;
2947     }
2948
2949   return result;
2950 }
2951
2952
2953 static gfc_expr *
2954 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2955 {
2956   gfc_expr *itrunc, *result;
2957   int kind;
2958
2959   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2960   if (kind == -1)
2961     return &gfc_bad_expr;
2962
2963   if (e->expr_type != EXPR_CONSTANT)
2964     return NULL;
2965
2966   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2967
2968   itrunc = gfc_copy_expr (e);
2969
2970   mpfr_round (itrunc->value.real, e->value.real);
2971
2972   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2973
2974   gfc_free_expr (itrunc);
2975
2976   return range_check (result, name);
2977 }
2978
2979
2980 gfc_expr *
2981 gfc_simplify_new_line (gfc_expr *e)
2982 {
2983   gfc_expr *result;
2984
2985   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2986   result->value.character.string = gfc_get_wide_string (2);
2987   result->value.character.length = 1;
2988   result->value.character.string[0] = '\n';
2989   result->value.character.string[1] = '\0';     /* For debugger */
2990   return result;
2991 }
2992
2993
2994 gfc_expr *
2995 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2996 {
2997   return simplify_nint ("NINT", e, k);
2998 }
2999
3000
3001 gfc_expr *
3002 gfc_simplify_idnint (gfc_expr *e)
3003 {
3004   return simplify_nint ("IDNINT", e, NULL);
3005 }
3006
3007
3008 gfc_expr *
3009 gfc_simplify_not (gfc_expr *e)
3010 {
3011   gfc_expr *result;
3012
3013   if (e->expr_type != EXPR_CONSTANT)
3014     return NULL;
3015
3016   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3017
3018   mpz_com (result->value.integer, e->value.integer);
3019
3020   return range_check (result, "NOT");
3021 }
3022
3023
3024 gfc_expr *
3025 gfc_simplify_null (gfc_expr *mold)
3026 {
3027   gfc_expr *result;
3028
3029   if (mold == NULL)
3030     {
3031       result = gfc_get_expr ();
3032       result->ts.type = BT_UNKNOWN;
3033     }
3034   else
3035     result = gfc_copy_expr (mold);
3036   result->expr_type = EXPR_NULL;
3037
3038   return result;
3039 }
3040
3041
3042 gfc_expr *
3043 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3044 {
3045   gfc_expr *result;
3046   int kind;
3047
3048   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3049     return NULL;
3050
3051   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3052   if (x->ts.type == BT_INTEGER)
3053     {
3054       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3055       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3056       return range_check (result, "OR");
3057     }
3058   else /* BT_LOGICAL */
3059     {
3060       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3061       result->value.logical = x->value.logical || y->value.logical;
3062       return result;
3063     }
3064 }
3065
3066
3067 gfc_expr *
3068 gfc_simplify_precision (gfc_expr *e)
3069 {
3070   gfc_expr *result;
3071   int i;
3072
3073   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3074
3075   result = gfc_int_expr (gfc_real_kinds[i].precision);
3076   result->where = e->where;
3077
3078   return result;
3079 }
3080
3081
3082 gfc_expr *
3083 gfc_simplify_radix (gfc_expr *e)
3084 {
3085   gfc_expr *result;
3086   int i;
3087
3088   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3089   switch (e->ts.type)
3090     {
3091     case BT_INTEGER:
3092       i = gfc_integer_kinds[i].radix;
3093       break;
3094
3095     case BT_REAL:
3096       i = gfc_real_kinds[i].radix;
3097       break;
3098
3099     default:
3100       gcc_unreachable ();
3101     }
3102
3103   result = gfc_int_expr (i);
3104   result->where = e->where;
3105
3106   return result;
3107 }
3108
3109
3110 gfc_expr *
3111 gfc_simplify_range (gfc_expr *e)
3112 {
3113   gfc_expr *result;
3114   int i;
3115   long j;
3116
3117   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3118
3119   switch (e->ts.type)
3120     {
3121     case BT_INTEGER:
3122       j = gfc_integer_kinds[i].range;
3123       break;
3124
3125     case BT_REAL:
3126     case BT_COMPLEX:
3127       j = gfc_real_kinds[i].range;
3128       break;
3129
3130     default:
3131       gcc_unreachable ();
3132     }
3133
3134   result = gfc_int_expr (j);
3135   result->where = e->where;
3136
3137   return result;
3138 }
3139
3140
3141 gfc_expr *
3142 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3143 {
3144   gfc_expr *result = NULL;
3145   int kind;
3146
3147   if (e->ts.type == BT_COMPLEX)
3148     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3149   else
3150     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3151
3152   if (kind == -1)
3153     return &gfc_bad_expr;
3154
3155   if (e->expr_type != EXPR_CONSTANT)
3156     return NULL;
3157
3158   switch (e->ts.type)
3159     {
3160     case BT_INTEGER:
3161       if (!e->is_boz)
3162         result = gfc_int2real (e, kind);
3163       break;
3164
3165     case BT_REAL:
3166       result = gfc_real2real (e, kind);
3167       break;
3168
3169     case BT_COMPLEX:
3170       result = gfc_complex2real (e, kind);
3171       break;
3172
3173     default:
3174       gfc_internal_error ("bad type in REAL");
3175       /* Not reached */
3176     }
3177
3178   if (e->ts.type == BT_INTEGER && e->is_boz)
3179     {
3180       gfc_typespec ts;
3181       gfc_clear_ts (&ts);
3182       ts.type = BT_REAL;
3183       ts.kind = kind;
3184       result = gfc_copy_expr (e);
3185       if (!gfc_convert_boz (result, &ts))
3186         {
3187           gfc_free_expr (result);
3188           return &gfc_bad_expr;
3189         }
3190     }
3191
3192   return range_check (result, "REAL");
3193 }
3194
3195
3196 gfc_expr *
3197 gfc_simplify_realpart (gfc_expr *e)
3198 {
3199   gfc_expr *result;
3200
3201   if (e->expr_type != EXPR_CONSTANT)
3202     return NULL;
3203
3204   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3205   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3206
3207   return range_check (result, "REALPART");
3208 }
3209
3210 gfc_expr *
3211 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3212 {
3213   gfc_expr *result;
3214   int i, j, len, ncop, nlen;
3215   mpz_t ncopies;
3216   bool have_length = false;
3217
3218   /* If NCOPIES isn't a constant, there's nothing we can do.  */
3219   if (n->expr_type != EXPR_CONSTANT)
3220     return NULL;
3221
3222   /* If NCOPIES is negative, it's an error.  */
3223   if (mpz_sgn (n->value.integer) < 0)
3224     {
3225       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3226                  &n->where);
3227       return &gfc_bad_expr;
3228     }
3229
3230   /* If we don't know the character length, we can do no more.  */
3231   if (e->ts.cl && e->ts.cl->length
3232         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3233     {
3234       len = mpz_get_si (e->ts.cl->length->value.integer);
3235       have_length = true;
3236     }
3237   else if (e->expr_type == EXPR_CONSTANT
3238              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3239     {
3240       len = e->value.character.length;
3241     }
3242   else
3243     return NULL;
3244
3245   /* If the source length is 0, any value of NCOPIES is valid
3246      and everything behaves as if NCOPIES == 0.  */
3247   mpz_init (ncopies);
3248   if (len == 0)
3249     mpz_set_ui (ncopies, 0);
3250   else
3251     mpz_set (ncopies, n->value.integer);
3252
3253   /* Check that NCOPIES isn't too large.  */
3254   if (len)
3255     {
3256       mpz_t max, mlen;
3257       int i;
3258
3259       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
3260       mpz_init (max);
3261       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3262
3263       if (have_length)
3264         {
3265           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3266                       e->ts.cl->length->value.integer);
3267         }
3268       else
3269         {
3270           mpz_init_set_si (mlen, len);
3271           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3272           mpz_clear (mlen);
3273         }
3274
3275       /* The check itself.  */
3276       if (mpz_cmp (ncopies, max) > 0)
3277         {
3278           mpz_clear (max);
3279           mpz_clear (ncopies);
3280           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3281                      &n->where);
3282           return &gfc_bad_expr;
3283         }
3284
3285       mpz_clear (max);
3286     }
3287   mpz_clear (ncopies);
3288
3289   /* For further simplification, we need the character string to be
3290      constant.  */
3291   if (e->expr_type != EXPR_CONSTANT)
3292     return NULL;
3293
3294   if (len ||
3295       (e->ts.cl->length &&
3296        mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3297     {
3298       const char *res = gfc_extract_int (n, &ncop);
3299       gcc_assert (res == NULL);
3300     }
3301   else
3302     ncop = 0;
3303
3304   len = e->value.character.length;
3305   nlen = ncop * len;
3306
3307   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3308
3309   if (ncop == 0)
3310     {
3311       result->value.character.string = gfc_get_wide_string (1);
3312       result->value.character.length = 0;
3313       result->value.character.string[0] = '\0';
3314       return result;
3315     }
3316
3317   result->value.character.length = nlen;
3318   result->value.character.string = gfc_get_wide_string (nlen + 1);
3319
3320   for (i = 0; i < ncop; i++)
3321     for (j = 0; j < len; j++)
3322       result->value.character.string[j+i*len]= e->value.character.string[j];
3323
3324   result->value.character.string[nlen] = '\0';  /* For debugger */
3325   return result;
3326 }
3327
3328
3329 /* Test that the expression is an constant array.  */
3330
3331 static bool
3332 is_constant_array_expr (gfc_expr *e)
3333 {
3334   gfc_constructor *c;
3335
3336   if (e == NULL)
3337     return true;
3338
3339   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3340     return false;
3341
3342   if (e->value.constructor == NULL)
3343     return false;
3344
3345   for (c = e->value.constructor; c; c = c->next)
3346     if (c->expr->expr_type != EXPR_CONSTANT)
3347       return false;
3348
3349   return true;
3350 }
3351
3352
3353 /* This one is a bear, but mainly has to do with shuffling elements.  */
3354
3355 gfc_expr *
3356 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3357                       gfc_expr *pad, gfc_expr *order_exp)
3358 {
3359   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3360   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3361   gfc_constructor *head, *tail;
3362   mpz_t index, size;
3363   unsigned long j;
3364   size_t nsource;
3365   gfc_expr *e;
3366
3367   /* Check that argument expression types are OK.  */
3368   if (!is_constant_array_expr (source))
3369     return NULL;
3370
3371   if (!is_constant_array_expr (shape_exp))
3372     return NULL;
3373
3374   if (!is_constant_array_expr (pad))
3375     return NULL;
3376
3377   if (!is_constant_array_expr (order_exp))
3378     return NULL;
3379
3380   /* Proceed with simplification, unpacking the array.  */
3381
3382   mpz_init (index);
3383   rank = 0;
3384   head = tail = NULL;
3385
3386   for (;;)
3387     {
3388       e = gfc_get_array_element (shape_exp, rank);
3389       if (e == NULL)
3390         break;
3391
3392       if (gfc_extract_int (e, &shape[rank]) != NULL)
3393         {
3394           gfc_error ("Integer too large in shape specification at %L",
3395                      &e->where);
3396           gfc_free_expr (e);
3397           goto bad_reshape;
3398         }
3399
3400       if (rank >= GFC_MAX_DIMENSIONS)
3401         {
3402           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3403                      "at %L", &e->where);
3404           gfc_free_expr (e);
3405           goto bad_reshape;
3406         }
3407
3408       if (shape[rank] < 0)
3409         {
3410           gfc_error ("Shape specification at %L cannot be negative",
3411                      &e->where);
3412           gfc_free_expr (e);
3413           goto bad_reshape;
3414         }
3415
3416       gfc_free_expr (e);
3417       rank++;
3418     }
3419
3420   if (rank == 0)
3421     {
3422       gfc_error ("Shape specification at %L cannot be the null array",
3423                  &shape_exp->where);
3424       goto bad_reshape;
3425     }
3426
3427   /* Now unpack the order array if present.  */
3428   if (order_exp == NULL)
3429     {
3430       for (i = 0; i < rank; i++)
3431         order[i] = i;
3432     }
3433   else
3434     {
3435       for (i = 0; i < rank; i++)
3436         x[i] = 0;
3437
3438       for (i = 0; i < rank; i++)
3439         {
3440           e = gfc_get_array_element (order_exp, i);
3441           if (e == NULL)
3442             {
3443               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3444                          "size as SHAPE parameter", &order_exp->where);
3445               goto bad_reshape;
3446             }
3447
3448           if (gfc_extract_int (e, &order[i]) != NULL)
3449             {
3450               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3451                          &e->where);
3452               gfc_free_expr (e);
3453               goto bad_reshape;
3454             }
3455
3456           if (order[i] < 1 || order[i] > rank)
3457             {
3458               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3459                          &e->where);
3460               gfc_free_expr (e);
3461               goto bad_reshape;
3462             }
3463
3464           order[i]--;
3465
3466           if (x[order[i]])
3467             {
3468               gfc_error ("Invalid permutation in ORDER parameter at %L",
3469                          &e->where);
3470               gfc_free_expr (e);
3471               goto bad_reshape;
3472             }
3473
3474           gfc_free_expr (e);
3475
3476           x[order[i]] = 1;
3477         }
3478     }
3479
3480   /* Count the elements in the source and padding arrays.  */
3481
3482   npad = 0;
3483   if (pad != NULL)
3484     {
3485       gfc_array_size (pad, &size);
3486       npad = mpz_get_ui (size);
3487       mpz_clear (size);
3488     }
3489
3490   gfc_array_size (source, &size);
3491   nsource = mpz_get_ui (size);
3492   mpz_clear (size);
3493
3494   /* If it weren't for that pesky permutation we could just loop
3495      through the source and round out any shortage with pad elements.
3496      But no, someone just had to have the compiler do something the
3497      user should be doing.  */
3498
3499   for (i = 0; i < rank; i++)
3500     x[i] = 0;
3501
3502   for (;;)
3503     {
3504       /* Figure out which element to extract.  */
3505       mpz_set_ui (index, 0);
3506
3507       for (i = rank - 1; i >= 0; i--)
3508         {
3509           mpz_add_ui (index, index, x[order[i]]);
3510           if (i != 0)
3511             mpz_mul_ui (index, index, shape[order[i - 1]]);
3512         }
3513
3514       if (mpz_cmp_ui (index, INT_MAX) > 0)
3515         gfc_internal_error ("Reshaped array too large at %C");
3516
3517       j = mpz_get_ui (index);
3518
3519       if (j < nsource)
3520         e = gfc_get_array_element (source, j);
3521       else
3522         {
3523           j = j - nsource;
3524
3525           if (npad == 0)
3526             {
3527               gfc_error ("PAD parameter required for short SOURCE parameter "
3528                          "at %L", &source->where);
3529               goto bad_reshape;
3530             }
3531
3532           j = j % npad;
3533           e = gfc_get_array_element (pad, j);
3534         }
3535
3536       if (head == NULL)
3537         head = tail = gfc_get_constructor ();
3538       else
3539         {
3540           tail->next = gfc_get_constructor ();
3541           tail = tail->next;
3542         }
3543
3544       if (e == NULL)
3545         goto bad_reshape;
3546
3547       tail->where = e->where;
3548       tail->expr = e;
3549
3550       /* Calculate the next element.  */
3551       i = 0;
3552
3553 inc:
3554       if (++x[i] < shape[i])
3555         continue;
3556       x[i++] = 0;
3557       if (i < rank)
3558         goto inc;
3559
3560       break;
3561     }
3562
3563   mpz_clear (index);
3564
3565   e = gfc_get_expr ();
3566   e->where = source->where;
3567   e->expr_type = EXPR_ARRAY;
3568   e->value.constructor = head;
3569   e->shape = gfc_get_shape (rank);
3570
3571   for (i = 0; i < rank; i++)
3572     mpz_init_set_ui (e->shape[i], shape[i]);
3573
3574   e->ts = source->ts;
3575   e->rank = rank;
3576
3577   return e;
3578
3579 bad_reshape:
3580   gfc_free_constructor (head);
3581   mpz_clear (index);
3582   return &gfc_bad_expr;
3583 }
3584
3585
3586 gfc_expr *
3587 gfc_simplify_rrspacing (gfc_expr *x)
3588 {
3589   gfc_expr *result;
3590   int i;
3591   long int e, p;
3592
3593   if (x->expr_type != EXPR_CONSTANT)
3594     return NULL;
3595
3596   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3597
3598   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3599
3600   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3601
3602   /* Special case x = -0 and 0.  */
3603   if (mpfr_sgn (result->value.real) == 0)
3604     {
3605       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3606       return result;
3607     }
3608
3609   /* | x * 2**(-e) | * 2**p.  */
3610   e = - (long int) mpfr_get_exp (x->value.real);
3611   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3612
3613   p = (long int) gfc_real_kinds[i].digits;
3614   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3615
3616   return range_check (result, "RRSPACING");
3617 }
3618
3619
3620 gfc_expr *
3621 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3622 {
3623   int k, neg_flag, power, exp_range;
3624   mpfr_t scale, radix;
3625   gfc_expr *result;
3626
3627   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3628     return NULL;
3629
3630   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3631
3632   if (mpfr_sgn (x->value.real) == 0)
3633     {
3634       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3635       return result;
3636     }
3637
3638   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3639
3640   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3641
3642   /* This check filters out values of i that would overflow an int.  */
3643   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3644       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3645     {
3646       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3647       gfc_free_expr (result);
3648       return &gfc_bad_expr;
3649     }
3650
3651   /* Compute scale = radix ** power.  */
3652   power = mpz_get_si (i->value.integer);
3653
3654   if (power >= 0)
3655     neg_flag = 0;
3656   else
3657     {
3658       neg_flag = 1;
3659       power = -power;
3660     }
3661
3662   gfc_set_model_kind (x->ts.kind);
3663   mpfr_init (scale);
3664   mpfr_init (radix);
3665   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3666   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3667
3668   if (neg_flag)
3669     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3670   else
3671     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3672
3673   mpfr_clears (scale, radix, NULL);
3674
3675   return range_check (result, "SCALE");
3676 }
3677
3678
3679 /* Variants of strspn and strcspn that operate on wide characters.  */
3680
3681 static size_t
3682 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3683 {
3684   size_t i = 0;
3685   const gfc_char_t *c;
3686
3687   while (s1[i])
3688     {
3689       for (c = s2; *c; c++)
3690         {
3691           if (s1[i] == *c)
3692             break;
3693         }
3694       if (*c == '\0')
3695         break;
3696       i++;
3697     }
3698
3699   return i;
3700 }
3701
3702 static size_t
3703 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
3704 {
3705   size_t i = 0;
3706   const gfc_char_t *c;
3707
3708   while (s1[i])
3709     {
3710       for (c = s2; *c; c++)
3711         {
3712           if (s1[i] == *c)
3713             break;
3714         }
3715       if (*c)
3716         break;
3717       i++;
3718     }
3719
3720   return i;
3721 }
3722
3723
3724 gfc_expr *
3725 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3726 {
3727   gfc_expr *result;
3728   int back;
3729   size_t i;
3730   size_t indx, len, lenc;
3731   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3732
3733   if (k == -1)
3734     return &gfc_bad_expr;
3735
3736   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3737     return NULL;
3738
3739   if (b != NULL && b->value.logical != 0)
3740     back = 1;
3741   else
3742     back = 0;
3743
3744   result = gfc_constant_result (BT_INTEGER, k, &e->where);
3745
3746   len = e->value.character.length;
3747   lenc = c->value.character.length;
3748
3749   if (len == 0 || lenc == 0)
3750     {
3751       indx = 0;
3752     }
3753   else
3754     {
3755       if (back == 0)
3756         {
3757           indx = wide_strcspn (e->value.character.string,
3758                                c->value.character.string) + 1;
3759           if (indx > len)
3760             indx = 0;
3761         }
3762       else
3763         {
3764           i = 0;
3765           for (indx = len; indx > 0; indx--)
3766             {
3767               for (i = 0; i < lenc; i++)
3768                 {
3769                   if (c->value.character.string[i]
3770                       == e->value.character.string[indx - 1])
3771                     break;
3772                 }
3773               if (i < lenc)
3774                 break;
3775             }
3776         }
3777     }
3778   mpz_set_ui (result->value.integer, indx);
3779   return range_check (result, "SCAN");
3780 }
3781
3782
3783 gfc_expr *
3784 gfc_simplify_selected_char_kind (gfc_expr *e)
3785 {
3786   int kind;
3787   gfc_expr *result;
3788
3789   if (e->expr_type != EXPR_CONSTANT)
3790     return NULL;
3791
3792   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
3793       || gfc_compare_with_Cstring (e, "default", false) == 0)
3794     kind = 1;
3795   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
3796     kind = 4;
3797   else
3798     kind = -1;
3799
3800   result = gfc_int_expr (kind);
3801   result->where = e->where;
3802
3803   return result;
3804 }
3805
3806
3807 gfc_expr *
3808 gfc_simplify_selected_int_kind (gfc_expr *e)
3809 {
3810   int i, kind, range;
3811   gfc_expr *result;
3812
3813   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3814     return NULL;
3815
3816   kind = INT_MAX;
3817
3818   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3819     if (gfc_integer_kinds[i].range >= range
3820         && gfc_integer_kinds[i].kind < kind)
3821       kind = gfc_integer_kinds[i].kind;
3822
3823   if (kind == INT_MAX)
3824     kind = -1;
3825
3826   result = gfc_int_expr (kind);
3827   result->where = e->where;
3828
3829   return result;
3830 }
3831
3832
3833 gfc_expr *
3834 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3835 {
3836   int range, precision, i, kind, found_precision, found_range;
3837   gfc_expr *result;
3838
3839   if (p == NULL)
3840     precision = 0;
3841   else
3842     {
3843       if (p->expr_type != EXPR_CONSTANT
3844           || gfc_extract_int (p, &precision) != NULL)
3845         return NULL;
3846     }
3847
3848   if (q == NULL)
3849     range = 0;
3850   else
3851     {
3852       if (q->expr_type != EXPR_CONSTANT
3853           || gfc_extract_int (q, &range) != NULL)
3854         return NULL;
3855     }
3856
3857   kind = INT_MAX;
3858   found_precision = 0;
3859   found_range = 0;
3860
3861   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3862     {
3863       if (gfc_real_kinds[i].precision >= precision)
3864         found_precision = 1;
3865
3866       if (gfc_real_kinds[i].range >= range)
3867         found_range = 1;
3868
3869       if (gfc_real_kinds[i].precision >= precision
3870           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3871         kind = gfc_real_kinds[i].kind;
3872     }
3873
3874   if (kind == INT_MAX)
3875     {
3876       kind = 0;
3877
3878       if (!found_precision)
3879         kind = -1;
3880       if (!found_range)
3881         kind -= 2;
3882     }
3883
3884   result = gfc_int_expr (kind);
3885   result->where = (p != NULL) ? p->where : q->where;
3886
3887   return result;
3888 }
3889
3890
3891 gfc_expr *
3892 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3893 {
3894   gfc_expr *result;
3895   mpfr_t exp, absv, log2, pow2, frac;
3896   unsigned long exp2;
3897
3898   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3899     return NULL;
3900
3901   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3902
3903   if (mpfr_sgn (x->value.real) == 0)
3904     {
3905       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3906       return result;
3907     }
3908
3909   gfc_set_model_kind (x->ts.kind);
3910   mpfr_init (absv);
3911   mpfr_init (log2);
3912   mpfr_init (exp);
3913   mpfr_init (pow2);
3914   mpfr_init (frac);
3915
3916   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3917   mpfr_log2 (log2, absv, GFC_RND_MODE);
3918
3919   mpfr_trunc (log2, log2);
3920   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3921
3922   /* Old exponent value, and fraction.  */
3923   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3924
3925   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3926
3927   /* New exponent.  */
3928   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3929   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3930
3931   mpfr_clears (absv, log2, pow2, frac, NULL);
3932
3933   return range_check (result, "SET_EXPONENT");
3934 }
3935
3936
3937 gfc_expr *
3938 gfc_simplify_shape (gfc_expr *source)
3939 {
3940   mpz_t shape[GFC_MAX_DIMENSIONS];
3941   gfc_expr *result, *e, *f;
3942   gfc_array_ref *ar;
3943   int n;
3944   gfc_try t;
3945
3946   if (source->rank == 0)
3947     return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3948                                   &source->where);
3949
3950   if (source->expr_type != EXPR_VARIABLE)
3951     return NULL;
3952
3953   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3954                                   &source->where);
3955
3956   ar = gfc_find_array_ref (source);
3957
3958   t = gfc_array_ref_shape (ar, shape);
3959
3960   for (n = 0; n < source->rank; n++)
3961     {
3962       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3963                                &source->where);
3964
3965       if (t == SUCCESS)
3966         {
3967           mpz_set (e->value.integer, shape[n]);
3968           mpz_clear (shape[n]);
3969         }
3970       else
3971         {
3972           mpz_set_ui (e->value.integer, n + 1);
3973
3974           f = gfc_simplify_size (source, e, NULL);
3975           gfc_free_expr (e);
3976           if (f == NULL)
3977             {
3978               gfc_free_expr (result);
3979               return NULL;
3980             }
3981           else
3982             {
3983               e = f;
3984             }
3985         }
3986
3987       gfc_append_constructor (result, e);
3988     }
3989
3990   return result;
3991 }
3992
3993
3994 gfc_expr *
3995 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3996 {
3997   mpz_t size;
3998   gfc_expr *result;
3999   int d;
4000   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4001
4002   if (k == -1)
4003     return &gfc_bad_expr;
4004
4005   if (dim == NULL)
4006     {
4007       if (gfc_array_size (array, &size) == FAILURE)
4008         return NULL;
4009     }
4010   else
4011     {
4012       if (dim->expr_type != EXPR_CONSTANT)
4013         return NULL;
4014
4015       d = mpz_get_ui (dim->value.integer) - 1;
4016       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4017         return NULL;
4018     }
4019
4020   result = gfc_constant_result (BT_INTEGER, k, &array->where);
4021   mpz_set (result->value.integer, size);
4022   return result;
4023 }
4024
4025
4026 gfc_expr *
4027 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4028 {
4029   gfc_expr *result;
4030
4031   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4032     return NULL;
4033
4034   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4035
4036   switch (x->ts.type)
4037     {
4038     case BT_INTEGER:
4039       mpz_abs (result->value.integer, x->value.integer);
4040       if (mpz_sgn (y->value.integer) < 0)
4041         mpz_neg (result->value.integer, result->value.integer);
4042
4043       break;
4044
4045     case BT_REAL:
4046       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4047          it.  */
4048       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4049       if (mpfr_sgn (y->value.real) < 0)
4050         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
4051
4052       break;
4053
4054     default:
4055       gfc_internal_error ("Bad type in gfc_simplify_sign");
4056     }
4057
4058   return result;
4059 }
4060
4061
4062 gfc_expr *
4063 gfc_simplify_sin (gfc_expr *x)
4064 {
4065   gfc_expr *result;
4066   mpfr_t xp, xq;
4067
4068   if (x->expr_type != EXPR_CONSTANT)
4069     return NULL;
4070
4071   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4072
4073   switch (x->ts.type)
4074     {
4075     case BT_REAL:
4076       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4077       break;
4078
4079     case BT_COMPLEX:
4080       gfc_set_model (x->value.real);
4081       mpfr_init (xp);
4082       mpfr_init (xq);
4083
4084       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
4085       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
4086       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
4087
4088       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
4089       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
4090       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
4091
4092       mpfr_clears (xp, xq, NULL);
4093       break;
4094
4095     default:
4096       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4097     }
4098
4099   return range_check (result, "SIN");
4100 }
4101
4102
4103 gfc_expr *
4104 gfc_simplify_sinh (gfc_expr *x)
4105 {
4106   gfc_expr *result;
4107
4108   if (x->expr_type != EXPR_CONSTANT)
4109     return NULL;
4110
4111   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4112
4113   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4114
4115   return range_check (result, "SINH");
4116 }
4117
4118
4119 /* The argument is always a double precision real that is converted to
4120    single precision.  TODO: Rounding!  */
4121
4122 gfc_expr *
4123 gfc_simplify_sngl (gfc_expr *a)
4124 {
4125   gfc_expr *result;
4126
4127   if (a->expr_type != EXPR_CONSTANT)
4128     return NULL;
4129
4130   result = gfc_real2real (a, gfc_default_real_kind);
4131   return range_check (result, "SNGL");
4132 }
4133
4134
4135 gfc_expr *
4136 gfc_simplify_spacing (gfc_expr *x)
4137 {
4138   gfc_expr *result;
4139   int i;
4140   long int en, ep;
4141
4142   if (x->expr_type != EXPR_CONSTANT)
4143     return NULL;
4144
4145   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4146
4147   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4148
4149   /* Special case x = 0 and -0.  */
4150   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4151   if (mpfr_sgn (result->value.real) == 0)
4152     {
4153       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4154       return result;
4155     }
4156
4157   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4158      are the radix, exponent of x, and precision.  This excludes the
4159      possibility of subnormal numbers.  Fortran 2003 states the result is
4160      b**max(e - p, emin - 1).  */
4161
4162   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4163   en = (long int) gfc_real_kinds[i].min_exponent - 1;
4164   en = en > ep ? en : ep;
4165
4166   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4167   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4168
4169   return range_check (result, "SPACING");
4170 }
4171
4172
4173 gfc_expr *
4174 gfc_simplify_sqrt (gfc_expr *e)
4175 {
4176   gfc_expr *result;
4177   mpfr_t ac, ad, s, t, w;
4178
4179   if (e->expr_type != EXPR_CONSTANT)
4180     return NULL;
4181
4182   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4183
4184   switch (e->ts.type)
4185     {
4186     case BT_REAL:
4187       if (mpfr_cmp_si (e->value.real, 0) < 0)
4188         goto negative_arg;
4189       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4190
4191       break;
4192
4193     case BT_COMPLEX:
4194       /* Formula taken from Numerical Recipes to avoid over- and
4195          underflow.  */
4196
4197       gfc_set_model (e->value.real);
4198       mpfr_init (ac);
4199       mpfr_init (ad);
4200       mpfr_init (s);
4201       mpfr_init (t);
4202       mpfr_init (w);
4203
4204       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4205           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4206         {
4207           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4208           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4209           break;
4210         }
4211
4212       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4213       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4214
4215       if (mpfr_cmp (ac, ad) >= 0)
4216         {
4217           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4218           mpfr_mul (t, t, t, GFC_RND_MODE);
4219           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4220           mpfr_sqrt (t, t, GFC_RND_MODE);
4221           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4222           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4223           mpfr_sqrt (t, t, GFC_RND_MODE);
4224           mpfr_sqrt (s, ac, GFC_RND_MODE);
4225           mpfr_mul (w, s, t, GFC_RND_MODE);
4226         }
4227       else
4228         {
4229           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4230           mpfr_mul (t, s, s, GFC_RND_MODE);
4231           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4232           mpfr_sqrt (t, t, GFC_RND_MODE);
4233           mpfr_abs (s, s, GFC_RND_MODE);
4234           mpfr_add (t, t, s, GFC_RND_MODE);
4235           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4236           mpfr_sqrt (t, t, GFC_RND_MODE);
4237           mpfr_sqrt (s, ad, GFC_RND_MODE);
4238           mpfr_mul (w, s, t, GFC_RND_MODE);
4239         }
4240
4241       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4242         {
4243           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4244           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4245           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4246         }
4247       else if (mpfr_cmp_ui (w, 0) != 0
4248                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4249                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4250         {
4251           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4252           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4253           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4254         }
4255       else if (mpfr_cmp_ui (w, 0) != 0
4256                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4257                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4258         {
4259           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4260           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4261           mpfr_neg (w, w, GFC_RND_MODE);
4262           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4263         }
4264       else
4265         gfc_internal_error ("invalid complex argument of SQRT at %L",
4266                             &e->where);
4267
4268       mpfr_clears (s, t, ac, ad, w, NULL);
4269
4270       break;
4271
4272     default:
4273       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4274     }
4275
4276   return range_check (result, "SQRT");
4277
4278 negative_arg:
4279   gfc_free_expr (result);
4280   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4281   return &gfc_bad_expr;
4282 }
4283
4284
4285 gfc_expr *
4286 gfc_simplify_tan (gfc_expr *x)
4287 {
4288   int i;
4289   gfc_expr *result;
4290
4291   if (x->expr_type != EXPR_CONSTANT)
4292     return NULL;
4293
4294   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4295
4296   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4297
4298   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4299
4300   return range_check (result, "TAN");
4301 }
4302
4303
4304 gfc_expr *
4305 gfc_simplify_tanh (gfc_expr *x)
4306 {
4307   gfc_expr *result;
4308
4309   if (x->expr_type != EXPR_CONSTANT)
4310     return NULL;
4311
4312   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4313
4314   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4315
4316   return range_check (result, "TANH");
4317
4318 }
4319
4320
4321 gfc_expr *
4322 gfc_simplify_tiny (gfc_expr *e)
4323 {
4324   gfc_expr *result;
4325   int i;
4326
4327   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4328
4329   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4330   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4331
4332   return result;
4333 }
4334
4335
4336 gfc_expr *
4337 gfc_simplify_trailz (gfc_expr *e)
4338 {
4339   gfc_expr *result;
4340   unsigned long tz, bs;
4341   int i;
4342
4343   if (e->expr_type != EXPR_CONSTANT)
4344     return NULL;
4345
4346   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4347   bs = gfc_integer_kinds[i].bit_size;
4348   tz = mpz_scan1 (e->value.integer, 0);
4349
4350   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
4351   mpz_set_ui (result->value.integer, MIN (tz, bs));
4352
4353   return result;
4354 }
4355
4356
4357 gfc_expr *
4358 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4359 {
4360   gfc_expr *result;
4361   gfc_expr *mold_element;
4362   size_t source_size;
4363   size_t result_size;
4364   size_t result_elt_size;
4365   size_t buffer_size;
4366   mpz_t tmp;
4367   unsigned char *buffer;
4368
4369   if (!gfc_is_constant_expr (source)
4370         || (gfc_init_expr && !gfc_is_constant_expr (mold))
4371         || !gfc_is_constant_expr (size))
4372     return NULL;
4373
4374   if (source->expr_type == EXPR_FUNCTION)
4375     return NULL;
4376
4377   /* Calculate the size of the source.  */
4378   if (source->expr_type == EXPR_ARRAY
4379       && gfc_array_size (source, &tmp) == FAILURE)
4380     gfc_internal_error ("Failure getting length of a constant array.");
4381
4382   source_size = gfc_target_expr_size (source);
4383
4384   /* Create an empty new expression with the appropriate characteristics.  */
4385   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4386                                 &source->where);
4387   result->ts = mold->ts;
4388
4389   mold_element = mold->expr_type == EXPR_ARRAY
4390                  ? mold->value.constructor->expr
4391                  : mold;
4392
4393   /* Set result character length, if needed.  Note that this needs to be
4394      set even for array expressions, in order to pass this information into
4395      gfc_target_interpret_expr.  */
4396   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4397     result->value.character.length = mold_element->value.character.length;
4398
4399   /* Set the number of elements in the result, and determine its size.  */
4400   result_elt_size = gfc_target_expr_size (mold_element);
4401   if (result_elt_size == 0)
4402     {
4403       gfc_free_expr (result);
4404       return NULL;
4405     }
4406
4407   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4408     {
4409       int result_length;
4410
4411       result->expr_type = EXPR_ARRAY;
4412       result->rank = 1;
4413
4414       if (size)
4415         result_length = (size_t)mpz_get_ui (size->value.integer);
4416       else
4417         {
4418           result_length = source_size / result_elt_size;
4419           if (result_length * result_elt_size < source_size)
4420             result_length += 1;
4421         }
4422
4423       result->shape = gfc_get_shape (1);
4424       mpz_init_set_ui (result->shape[0], result_length);
4425
4426       result_size = result_length * result_elt_size;
4427     }
4428   else
4429     {
4430       result->rank = 0;
4431       result_size = result_elt_size;
4432     }
4433
4434   if (gfc_option.warn_surprising && source_size < result_size)
4435     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4436                 "source size %ld < result size %ld", &source->where,
4437                 (long) source_size, (long) result_size);
4438
4439   /* Allocate the buffer to store the binary version of the source.  */
4440   buffer_size = MAX (source_size, result_size);
4441   buffer = (unsigned char*)alloca (buffer_size);
4442
4443   /* Now write source to the buffer.  */
4444   gfc_target_encode_expr (source, buffer, buffer_size);
4445
4446   /* And read the buffer back into the new expression.  */
4447   gfc_target_interpret_expr (buffer, buffer_size, result);
4448
4449   return result;
4450 }
4451
4452
4453 gfc_expr *
4454 gfc_simplify_trim (gfc_expr *e)
4455 {
4456   gfc_expr *result;
4457   int count, i, len, lentrim;
4458
4459   if (e->expr_type != EXPR_CONSTANT)
4460     return NULL;
4461
4462   len = e->value.character.length;
4463
4464   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4465
4466   for (count = 0, i = 1; i <= len; ++i)
4467     {
4468       if (e->value.character.string[len - i] == ' ')
4469         count++;
4470       else
4471         break;
4472     }
4473
4474   lentrim = len - count;
4475
4476   result->value.character.length = lentrim;
4477   result->value.character.string = gfc_get_wide_string (lentrim + 1);
4478
4479   for (i = 0; i < lentrim; i++)
4480     result->value.character.string[i] = e->value.character.string[i];
4481
4482   result->value.character.string[lentrim] = '\0';       /* For debugger */
4483
4484   return result;
4485 }
4486
4487
4488 gfc_expr *
4489 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4490 {
4491   return simplify_bound (array, dim, kind, 1);
4492 }
4493
4494
4495 gfc_expr *
4496 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4497 {
4498   gfc_expr *result;
4499   int back;
4500   size_t index, len, lenset;
4501   size_t i;
4502   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4503
4504   if (k == -1)
4505     return &gfc_bad_expr;
4506
4507   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4508     return NULL;
4509
4510   if (b != NULL && b->value.logical != 0)
4511     back = 1;
4512   else
4513     back = 0;
4514
4515   result = gfc_constant_result (BT_INTEGER, k, &s->where);
4516
4517   len = s->value.character.length;
4518   lenset = set->value.character.length;
4519
4520   if (len == 0)
4521     {
4522       mpz_set_ui (result->value.integer, 0);
4523       return result;
4524     }
4525
4526   if (back == 0)
4527     {
4528       if (lenset == 0)
4529         {
4530           mpz_set_ui (result->value.integer, 1);
4531           return result;
4532         }
4533
4534       index = wide_strspn (s->value.character.string,
4535                            set->value.character.string) + 1;
4536       if (index > len)
4537         index = 0;
4538
4539     }
4540   else
4541     {
4542       if (lenset == 0)
4543         {
4544           mpz_set_ui (result->value.integer, len);
4545           return result;
4546         }
4547       for (index = len; index > 0; index --)
4548         {
4549           for (i = 0; i < lenset; i++)
4550             {
4551               if (s->value.character.string[index - 1]
4552                   == set->value.character.string[i])
4553                 break;
4554             }
4555           if (i == lenset)
4556             break;
4557         }
4558     }
4559
4560   mpz_set_ui (result->value.integer, index);
4561   return result;
4562 }
4563
4564
4565 gfc_expr *
4566 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4567 {
4568   gfc_expr *result;
4569   int kind;
4570
4571   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4572     return NULL;
4573
4574   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4575   if (x->ts.type == BT_INTEGER)
4576     {
4577       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4578       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4579       return range_check (result, "XOR");
4580     }
4581   else /* BT_LOGICAL */
4582     {
4583       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4584       result->value.logical = (x->value.logical && !y->value.logical)
4585                               || (!x->value.logical && y->value.logical);
4586       return result;
4587     }
4588
4589 }
4590
4591
4592 /****************** Constant simplification *****************/
4593
4594 /* Master function to convert one constant to another.  While this is
4595    used as a simplification function, it requires the destination type
4596    and kind information which is supplied by a special case in
4597    do_simplify().  */
4598
4599 gfc_expr *
4600 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4601 {
4602   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4603   gfc_constructor *head, *c, *tail = NULL;
4604
4605   switch (e->ts.type)
4606     {
4607     case BT_INTEGER:
4608       switch (type)
4609         {
4610         case BT_INTEGER:
4611           f = gfc_int2int;
4612           break;
4613         case BT_REAL:
4614           f = gfc_int2real;
4615           break;
4616         case BT_COMPLEX:
4617           f = gfc_int2complex;
4618           break;
4619         case BT_LOGICAL:
4620           f = gfc_int2log;
4621           break;
4622         default:
4623           goto oops;
4624         }
4625       break;
4626
4627     case BT_REAL:
4628       switch (type)
4629         {
4630         case BT_INTEGER:
4631           f = gfc_real2int;
4632           break;
4633         case BT_REAL:
4634           f = gfc_real2real;
4635           break;
4636         case BT_COMPLEX:
4637           f = gfc_real2complex;
4638           break;
4639         default:
4640           goto oops;
4641         }
4642       break;
4643
4644     case BT_COMPLEX:
4645       switch (type)
4646         {
4647         case BT_INTEGER:
4648           f = gfc_complex2int;
4649           break;
4650         case BT_REAL:
4651           f = gfc_complex2real;
4652           break;
4653         case BT_COMPLEX:
4654           f = gfc_complex2complex;
4655           break;
4656
4657         default:
4658           goto oops;
4659         }
4660       break;
4661
4662     case BT_LOGICAL:
4663       switch (type)
4664         {
4665         case BT_INTEGER:
4666           f = gfc_log2int;
4667           break;
4668         case BT_LOGICAL:
4669           f = gfc_log2log;
4670           break;
4671         default:
4672           goto oops;
4673         }
4674       break;
4675
4676     case BT_HOLLERITH:
4677       switch (type)
4678         {
4679         case BT_INTEGER:
4680           f = gfc_hollerith2int;
4681           break;
4682
4683         case BT_REAL:
4684           f = gfc_hollerith2real;
4685           break;
4686
4687         case BT_COMPLEX:
4688           f = gfc_hollerith2complex;
4689           break;
4690
4691         case BT_CHARACTER:
4692           f = gfc_hollerith2character;
4693           break;
4694
4695         case BT_LOGICAL:
4696           f = gfc_hollerith2logical;
4697           break;
4698
4699         default:
4700           goto oops;
4701         }
4702       break;
4703
4704     default:
4705     oops:
4706       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4707     }
4708
4709   result = NULL;
4710
4711   switch (e->expr_type)
4712     {
4713     case EXPR_CONSTANT:
4714       result = f (e, kind);
4715       if (result == NULL)
4716         return &gfc_bad_expr;
4717       break;
4718
4719     case EXPR_ARRAY:
4720       if (!gfc_is_constant_expr (e))
4721         break;
4722
4723       head = NULL;
4724
4725       for (c = e->value.constructor; c; c = c->next)
4726         {
4727           if (head == NULL)
4728             head = tail = gfc_get_constructor ();
4729           else
4730             {
4731               tail->next = gfc_get_constructor ();
4732               tail = tail->next;
4733             }
4734
4735           tail->where = c->where;
4736
4737           if (c->iterator == NULL)
4738             tail->expr = f (c->expr, kind);
4739           else
4740             {
4741               g = gfc_convert_constant (c->expr, type, kind);
4742               if (g == &gfc_bad_expr)
4743                 return g;
4744               tail->expr = g;
4745             }
4746
4747           if (tail->expr == NULL)
4748             {
4749               gfc_free_constructor (head);
4750               return NULL;
4751             }
4752         }
4753
4754       result = gfc_get_expr ();
4755       result->ts.type = type;
4756       result->ts.kind = kind;
4757       result->expr_type = EXPR_ARRAY;
4758       result->value.constructor = head;
4759       result->shape = gfc_copy_shape (e->shape, e->rank);
4760       result->where = e->where;
4761       result->rank = e->rank;
4762       break;
4763
4764     default:
4765       break;
4766     }
4767
4768   return result;
4769 }
4770
4771
4772 /* Function for converting character constants.  */
4773 gfc_expr *
4774 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
4775 {
4776   gfc_expr *result;
4777   int i;
4778
4779   if (!gfc_is_constant_expr (e))
4780     return NULL;
4781
4782   if (e->expr_type == EXPR_CONSTANT)
4783     {
4784       /* Simple case of a scalar.  */
4785       result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
4786       if (result == NULL)
4787         return &gfc_bad_expr;
4788
4789       result->value.character.length = e->value.character.length;
4790       result->value.character.string
4791         = gfc_get_wide_string (e->value.character.length + 1);
4792       memcpy (result->value.character.string, e->value.character.string,
4793               (e->value.character.length + 1) * sizeof (gfc_char_t));
4794
4795       /* Check we only have values representable in the destination kind.  */
4796       for (i = 0; i < result->value.character.length; i++)
4797         if (!gfc_check_character_range (result->value.character.string[i],
4798                                         kind))
4799           {
4800             gfc_error ("Character '%s' in string at %L cannot be converted "
4801                        "into character kind %d",
4802                        gfc_print_wide_char (result->value.character.string[i]),
4803                        &e->where, kind);
4804             return &gfc_bad_expr;
4805           }
4806
4807       return result;
4808     }
4809   else if (e->expr_type == EXPR_ARRAY)
4810     {
4811       /* For an array constructor, we convert each constructor element.  */
4812       gfc_constructor *head = NULL, *tail = NULL, *c;
4813
4814       for (c = e->value.constructor; c; c = c->next)
4815         {
4816           if (head == NULL)
4817             head = tail = gfc_get_constructor ();
4818           else
4819             {
4820               tail->next = gfc_get_constructor ();
4821               tail = tail->next;
4822             }
4823
4824           tail->where = c->where;
4825           tail->expr = gfc_convert_char_constant (c->expr, type, kind);
4826           if (tail->expr == &gfc_bad_expr)
4827             {
4828               tail->expr = NULL;
4829               return &gfc_bad_expr;
4830             }
4831
4832           if (tail->expr == NULL)
4833             {
4834               gfc_free_constructor (head);
4835               return NULL;
4836             }
4837         }
4838
4839       result = gfc_get_expr ();
4840       result->ts.type = type;
4841       result->ts.kind = kind;
4842       result->expr_type = EXPR_ARRAY;
4843       result->value.constructor = head;
4844       result->shape = gfc_copy_shape (e->shape, e->rank);
4845       result->where = e->where;
4846       result->rank = e->rank;
4847       result->ts.cl = e->ts.cl;
4848
4849       return result;
4850     }
4851   else
4852     return NULL;
4853 }