gcc/fortran/simplify.c

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