gcc/fortran/simplify.c

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