gcc/fortran/simplify.c

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