gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "arith.h"
  28 #include "intrinsic.h"
  29
  30 gfc_expr gfc_bad_expr;
  31
  32
  33 /* Note that 'simplification' is not just transforming expressions.
  34    For functions that are not simplified at compile time, range
  35    checking is done if possible.
  36
  37    The return convention is that each simplification function returns:
  38
  39      A new expression node corresponding to the simplified arguments.
  40      The original arguments are destroyed by the caller, and must not
  41      be a part of the new expression.
  42
  43      NULL pointer indicating that no simplification was possible and
  44      the original expression should remain intact.  If the
  45      simplification function sets the type and/or the function name
  46      via the pointer gfc_simple_expression, then this type is
  47      retained.
  48
  49      An expression pointer to gfc_bad_expr (a static placeholder)
  50      indicating that some error has prevented simplification.  For
  51      example, sqrt(-1.0).  The error is generated within the function
  52      and should be propagated upwards
  53
  54    By the time a simplification function gets control, it has been
  55    decided that the function call is really supposed to be the
  56    intrinsic.  No type checking is strictly necessary, since only
  57    valid types will be passed on.  On the other hand, a simplification
  58    subroutine may have to look at the type of an argument as part of
  59    its processing.
  60
  61    Array arguments are never passed to these subroutines.
  62
  63    The functions in this file don't have much comment with them, but
  64    everything is reasonably straight-forward.  The Standard, chapter 13
  65    is the best comment you'll find for this file anyway.  */
  66
  67 /* Static table for converting non-ascii character sets to ascii.
  68    The xascii_table[] is the inverse table.  */
  69
  70 static int ascii_table[256] = {
  71   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  72   '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
  73   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  74   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  75   ' ', '!', '"', '#', '$', '%', '&', '\'',
  76   '(', ')', '*', '+', ',', '-', '.', '/',
  77   '0', '1', '2', '3', '4', '5', '6', '7',
  78   '8', '9', ':', ';', '<', '=', '>', '?',
  79   '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
  80   'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
  81   'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
  82   'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
  83   '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
  84   'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
  85   'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
  86   'x', 'y', 'z', '{', '|', '}', '~', '\?'
  87 };
  88
  89 static int xascii_table[256];
  90
  91
  92 /* Range checks an expression node.  If all goes well, returns the
  93    node, otherwise returns &gfc_bad_expr and frees the node.  */
  94
  95 static gfc_expr *
  96 range_check (gfc_expr * result, const char *name)
  97 {
  98
  99   switch (gfc_range_check (result))
 100     {
 101       case ARITH_OK:
 102         return result;
 103
 104       case ARITH_OVERFLOW:
 105         gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
 106         break;
 107
 108       case ARITH_UNDERFLOW:
 109         gfc_error ("Result of %s underflows its kind at %L", name, &result->where);
 110         break;
 111
 112       case ARITH_NAN:
 113         gfc_error ("Result of %s is NaN at %L", name, &result->where);
 114         break;
 115
 116       default:
 117         gfc_error ("Result of %s gives range error for its kind at %L", name, &result->where);
 118         break;
 119     }
 120
 121   gfc_free_expr (result);
 122   return &gfc_bad_expr;
 123 }
 124
 125
 126 /* A helper function that gets an optional and possibly missing
 127    kind parameter.  Returns the kind, -1 if something went wrong.  */
 128
 129 static int
 130 get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
 131 {
 132   int kind;
 133
 134   if (k == NULL)
 135     return default_kind;
 136
 137   if (k->expr_type != EXPR_CONSTANT)
 138     {
 139       gfc_error ("KIND parameter of %s at %L must be an initialization "
 140                  "expression", name, &k->where);
 141
 142       return -1;
 143     }
 144
 145   if (gfc_extract_int (k, &kind) != NULL
 146       || gfc_validate_kind (type, kind, true) < 0)
 147     {
 148
 149       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
 150       return -1;
 151     }
 152
 153   return kind;
 154 }
 155
 156
 157 /* 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   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 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   gfc_expr *result;
1058
1059   if (x->expr_type != EXPR_CONSTANT)
1060     return NULL;
1061
1062   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1063                                 &x->where);
1064
1065   gfc_set_model (x->value.real);
1066
1067   if (mpfr_sgn (x->value.real) == 0)
1068     {
1069       mpz_set_ui (result->value.integer, 0);
1070       return result;
1071     }
1072
1073   i = (int) mpfr_get_exp (x->value.real);
1074   mpz_set_si (result->value.integer, i);
1075
1076   return range_check (result, "EXPONENT");
1077 }
1078
1079
1080 gfc_expr *
1081 gfc_simplify_float (gfc_expr * a)
1082 {
1083   gfc_expr *result;
1084
1085   if (a->expr_type != EXPR_CONSTANT)
1086     return NULL;
1087
1088   result = gfc_int2real (a, gfc_default_real_kind);
1089   return range_check (result, "FLOAT");
1090 }
1091
1092
1093 gfc_expr *
1094 gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
1095 {
1096   gfc_expr *result;
1097   mpfr_t floor;
1098   int kind;
1099
1100   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1101   if (kind == -1)
1102     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1103
1104   if (e->expr_type != EXPR_CONSTANT)
1105     return NULL;
1106
1107   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1108
1109   gfc_set_model_kind (kind);
1110   mpfr_init (floor);
1111   mpfr_floor (floor, e->value.real);
1112
1113   gfc_mpfr_to_mpz (result->value.integer, floor);
1114
1115   mpfr_clear (floor);
1116
1117   return range_check (result, "FLOOR");
1118 }
1119
1120
1121 gfc_expr *
1122 gfc_simplify_fraction (gfc_expr * x)
1123 {
1124   gfc_expr *result;
1125   mpfr_t absv, exp, pow2;
1126
1127   if (x->expr_type != EXPR_CONSTANT)
1128     return NULL;
1129
1130   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1131
1132   gfc_set_model_kind (x->ts.kind);
1133
1134   if (mpfr_sgn (x->value.real) == 0)
1135     {
1136       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1137       return result;
1138     }
1139
1140   mpfr_init (exp);
1141   mpfr_init (absv);
1142   mpfr_init (pow2);
1143
1144   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1145   mpfr_log2 (exp, absv, GFC_RND_MODE);
1146
1147   mpfr_trunc (exp, exp);
1148   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1149
1150   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1151
1152   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1153
1154   mpfr_clear (exp);
1155   mpfr_clear (absv);
1156   mpfr_clear (pow2);
1157
1158   return range_check (result, "FRACTION");
1159 }
1160
1161
1162 gfc_expr *
1163 gfc_simplify_huge (gfc_expr * e)
1164 {
1165   gfc_expr *result;
1166   int i;
1167
1168   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1169
1170   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1171
1172   switch (e->ts.type)
1173     {
1174     case BT_INTEGER:
1175       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1176       break;
1177
1178     case BT_REAL:
1179       mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1180       break;
1181
1182     default:
1183       gcc_unreachable ();
1184     }
1185
1186   return result;
1187 }
1188
1189
1190 gfc_expr *
1191 gfc_simplify_iachar (gfc_expr * e)
1192 {
1193   gfc_expr *result;
1194   int index;
1195
1196   if (e->expr_type != EXPR_CONSTANT)
1197     return NULL;
1198
1199   if (e->value.character.length != 1)
1200     {
1201       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1202       return &gfc_bad_expr;
1203     }
1204
1205   index = xascii_table[(int) e->value.character.string[0] & 0xFF];
1206
1207   result = gfc_int_expr (index);
1208   result->where = e->where;
1209
1210   return range_check (result, "IACHAR");
1211 }
1212
1213
1214 gfc_expr *
1215 gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
1216 {
1217   gfc_expr *result;
1218
1219   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1220     return NULL;
1221
1222   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1223
1224   mpz_and (result->value.integer, x->value.integer, y->value.integer);
1225
1226   return range_check (result, "IAND");
1227 }
1228
1229
1230 gfc_expr *
1231 gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
1232 {
1233   gfc_expr *result;
1234   int k, pos;
1235
1236   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1237     return NULL;
1238
1239   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1240     {
1241       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1242       return &gfc_bad_expr;
1243     }
1244
1245   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1246
1247   if (pos > gfc_integer_kinds[k].bit_size)
1248     {
1249       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1250                  &y->where);
1251       return &gfc_bad_expr;
1252     }
1253
1254   result = gfc_copy_expr (x);
1255
1256   mpz_clrbit (result->value.integer, pos);
1257   return range_check (result, "IBCLR");
1258 }
1259
1260
1261 gfc_expr *
1262 gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1263 {
1264   gfc_expr *result;
1265   int pos, len;
1266   int i, k, bitsize;
1267   int *bits;
1268
1269   if (x->expr_type != EXPR_CONSTANT
1270       || y->expr_type != EXPR_CONSTANT
1271       || z->expr_type != EXPR_CONSTANT)
1272     return NULL;
1273
1274   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1275     {
1276       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1277       return &gfc_bad_expr;
1278     }
1279
1280   if (gfc_extract_int (z, &len) != NULL || len < 0)
1281     {
1282       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1283       return &gfc_bad_expr;
1284     }
1285
1286   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1287
1288   bitsize = gfc_integer_kinds[k].bit_size;
1289
1290   if (pos + len > bitsize)
1291     {
1292       gfc_error
1293         ("Sum of second and third arguments of IBITS exceeds bit size "
1294          "at %L", &y->where);
1295       return &gfc_bad_expr;
1296     }
1297
1298   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1299
1300   bits = gfc_getmem (bitsize * sizeof (int));
1301
1302   for (i = 0; i < bitsize; i++)
1303     bits[i] = 0;
1304
1305   for (i = 0; i < len; i++)
1306     bits[i] = mpz_tstbit (x->value.integer, i + pos);
1307
1308   for (i = 0; i < bitsize; i++)
1309     {
1310       if (bits[i] == 0)
1311         {
1312           mpz_clrbit (result->value.integer, i);
1313         }
1314       else if (bits[i] == 1)
1315         {
1316           mpz_setbit (result->value.integer, i);
1317         }
1318       else
1319         {
1320           gfc_internal_error ("IBITS: Bad bit");
1321         }
1322     }
1323
1324   gfc_free (bits);
1325
1326   return range_check (result, "IBITS");
1327 }
1328
1329
1330 gfc_expr *
1331 gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
1332 {
1333   gfc_expr *result;
1334   int k, pos;
1335
1336   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1337     return NULL;
1338
1339   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1340     {
1341       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1342       return &gfc_bad_expr;
1343     }
1344
1345   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1346
1347   if (pos > gfc_integer_kinds[k].bit_size)
1348     {
1349       gfc_error ("Second argument of IBSET exceeds bit size at %L",
1350                  &y->where);
1351       return &gfc_bad_expr;
1352     }
1353
1354   result = gfc_copy_expr (x);
1355
1356   mpz_setbit (result->value.integer, pos);
1357
1358   twos_complement (result->value.integer, gfc_integer_kinds[k].bit_size);
1359
1360   return range_check (result, "IBSET");
1361 }
1362
1363
1364 gfc_expr *
1365 gfc_simplify_ichar (gfc_expr * e)
1366 {
1367   gfc_expr *result;
1368   int index;
1369
1370   if (e->expr_type != EXPR_CONSTANT)
1371     return NULL;
1372
1373   if (e->value.character.length != 1)
1374     {
1375       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1376       return &gfc_bad_expr;
1377     }
1378
1379   index = (unsigned char) e->value.character.string[0];
1380
1381   if (index < 0 || index > UCHAR_MAX)
1382     {
1383       gfc_error ("Argument of ICHAR at %L out of range of this processor",
1384                  &e->where);
1385       return &gfc_bad_expr;
1386     }
1387
1388   result = gfc_int_expr (index);
1389   result->where = e->where;
1390   return range_check (result, "ICHAR");
1391 }
1392
1393
1394 gfc_expr *
1395 gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
1396 {
1397   gfc_expr *result;
1398
1399   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1400     return NULL;
1401
1402   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1403
1404   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1405
1406   return range_check (result, "IEOR");
1407 }
1408
1409
1410 gfc_expr *
1411 gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
1412 {
1413   gfc_expr *result;
1414   int back, len, lensub;
1415   int i, j, k, count, index = 0, start;
1416
1417   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1418     return NULL;
1419
1420   if (b != NULL && b->value.logical != 0)
1421     back = 1;
1422   else
1423     back = 0;
1424
1425   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1426                                 &x->where);
1427
1428   len = x->value.character.length;
1429   lensub = y->value.character.length;
1430
1431   if (len < lensub)
1432     {
1433       mpz_set_si (result->value.integer, 0);
1434       return result;
1435     }
1436
1437   if (back == 0)
1438     {
1439
1440       if (lensub == 0)
1441         {
1442           mpz_set_si (result->value.integer, 1);
1443           return result;
1444         }
1445       else if (lensub == 1)
1446         {
1447           for (i = 0; i < len; i++)
1448             {
1449               for (j = 0; j < lensub; j++)
1450                 {
1451                   if (y->value.character.string[j] ==
1452                       x->value.character.string[i])
1453                     {
1454                       index = i + 1;
1455                       goto done;
1456                     }
1457                 }
1458             }
1459         }
1460       else
1461         {
1462           for (i = 0; i < len; i++)
1463             {
1464               for (j = 0; j < lensub; j++)
1465                 {
1466                   if (y->value.character.string[j] ==
1467                       x->value.character.string[i])
1468                     {
1469                       start = i;
1470                       count = 0;
1471
1472                       for (k = 0; k < lensub; k++)
1473                         {
1474                           if (y->value.character.string[k] ==
1475                               x->value.character.string[k + start])
1476                             count++;
1477                         }
1478
1479                       if (count == lensub)
1480                         {
1481                           index = start + 1;
1482                           goto done;
1483                         }
1484                     }
1485                 }
1486             }
1487         }
1488
1489     }
1490   else
1491     {
1492
1493       if (lensub == 0)
1494         {
1495           mpz_set_si (result->value.integer, len + 1);
1496           return result;
1497         }
1498       else if (lensub == 1)
1499         {
1500           for (i = 0; i < len; i++)
1501             {
1502               for (j = 0; j < lensub; j++)
1503                 {
1504                   if (y->value.character.string[j] ==
1505                       x->value.character.string[len - i])
1506                     {
1507                       index = len - i + 1;
1508                       goto done;
1509                     }
1510                 }
1511             }
1512         }
1513       else
1514         {
1515           for (i = 0; i < len; i++)
1516             {
1517               for (j = 0; j < lensub; j++)
1518                 {
1519                   if (y->value.character.string[j] ==
1520                       x->value.character.string[len - i])
1521                     {
1522                       start = len - i;
1523                       if (start <= len - lensub)
1524                         {
1525                           count = 0;
1526                           for (k = 0; k < lensub; k++)
1527                             if (y->value.character.string[k] ==
1528                                 x->value.character.string[k + start])
1529                               count++;
1530
1531                           if (count == lensub)
1532                             {
1533                               index = start + 1;
1534                               goto done;
1535                             }
1536                         }
1537                       else
1538                         {
1539                           continue;
1540                         }
1541                     }
1542                 }
1543             }
1544         }
1545     }
1546
1547 done:
1548   mpz_set_si (result->value.integer, index);
1549   return range_check (result, "INDEX");
1550 }
1551
1552
1553 gfc_expr *
1554 gfc_simplify_int (gfc_expr * e, gfc_expr * k)
1555 {
1556   gfc_expr *rpart, *rtrunc, *result;
1557   int kind;
1558
1559   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1560   if (kind == -1)
1561     return &gfc_bad_expr;
1562
1563   if (e->expr_type != EXPR_CONSTANT)
1564     return NULL;
1565
1566   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1567
1568   switch (e->ts.type)
1569     {
1570     case BT_INTEGER:
1571       mpz_set (result->value.integer, e->value.integer);
1572       break;
1573
1574     case BT_REAL:
1575       rtrunc = gfc_copy_expr (e);
1576       mpfr_trunc (rtrunc->value.real, e->value.real);
1577       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1578       gfc_free_expr (rtrunc);
1579       break;
1580
1581     case BT_COMPLEX:
1582       rpart = gfc_complex2real (e, kind);
1583       rtrunc = gfc_copy_expr (rpart);
1584       mpfr_trunc (rtrunc->value.real, rpart->value.real);
1585       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1586       gfc_free_expr (rpart);
1587       gfc_free_expr (rtrunc);
1588       break;
1589
1590     default:
1591       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1592       gfc_free_expr (result);
1593       return &gfc_bad_expr;
1594     }
1595
1596   return range_check (result, "INT");
1597 }
1598
1599
1600 static gfc_expr *
1601 gfc_simplify_intconv (gfc_expr * e, int kind, const char *name)
1602 {
1603   gfc_expr *rpart, *rtrunc, *result;
1604
1605   if (e->expr_type != EXPR_CONSTANT)
1606     return NULL;
1607
1608   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1609
1610   switch (e->ts.type)
1611     {
1612     case BT_INTEGER:
1613       mpz_set (result->value.integer, e->value.integer);
1614       break;
1615
1616     case BT_REAL:
1617       rtrunc = gfc_copy_expr (e);
1618       mpfr_trunc (rtrunc->value.real, e->value.real);
1619       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1620       gfc_free_expr (rtrunc);
1621       break;
1622
1623     case BT_COMPLEX:
1624       rpart = gfc_complex2real (e, kind);
1625       rtrunc = gfc_copy_expr (rpart);
1626       mpfr_trunc (rtrunc->value.real, rpart->value.real);
1627       gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1628       gfc_free_expr (rpart);
1629       gfc_free_expr (rtrunc);
1630       break;
1631
1632     default:
1633       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1634       gfc_free_expr (result);
1635       return &gfc_bad_expr;
1636     }
1637
1638   return range_check (result, name);
1639 }
1640
1641 gfc_expr *
1642 gfc_simplify_int2 (gfc_expr * e)
1643 {
1644   return gfc_simplify_intconv (e, 2, "INT2");
1645 }
1646
1647 gfc_expr *
1648 gfc_simplify_int8 (gfc_expr * e)
1649 {
1650   return gfc_simplify_intconv (e, 8, "INT8");
1651 }
1652
1653 gfc_expr *
1654 gfc_simplify_long (gfc_expr * e)
1655 {
1656   return gfc_simplify_intconv (e, 4, "LONG");
1657 }
1658
1659
1660 gfc_expr *
1661 gfc_simplify_ifix (gfc_expr * e)
1662 {
1663   gfc_expr *rtrunc, *result;
1664
1665   if (e->expr_type != EXPR_CONSTANT)
1666     return NULL;
1667
1668   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1669                                 &e->where);
1670
1671   rtrunc = gfc_copy_expr (e);
1672
1673   mpfr_trunc (rtrunc->value.real, e->value.real);
1674   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1675
1676   gfc_free_expr (rtrunc);
1677   return range_check (result, "IFIX");
1678 }
1679
1680
1681 gfc_expr *
1682 gfc_simplify_idint (gfc_expr * e)
1683 {
1684   gfc_expr *rtrunc, *result;
1685
1686   if (e->expr_type != EXPR_CONSTANT)
1687     return NULL;
1688
1689   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1690                                 &e->where);
1691
1692   rtrunc = gfc_copy_expr (e);
1693
1694   mpfr_trunc (rtrunc->value.real, e->value.real);
1695   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1696
1697   gfc_free_expr (rtrunc);
1698   return range_check (result, "IDINT");
1699 }
1700
1701
1702 gfc_expr *
1703 gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
1704 {
1705   gfc_expr *result;
1706
1707   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1708     return NULL;
1709
1710   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1711
1712   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1713   return range_check (result, "IOR");
1714 }
1715
1716
1717 gfc_expr *
1718 gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
1719 {
1720   gfc_expr *result;
1721   int shift, ashift, isize, k, *bits, i;
1722
1723   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1724     return NULL;
1725
1726   if (gfc_extract_int (s, &shift) != NULL)
1727     {
1728       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1729       return &gfc_bad_expr;
1730     }
1731
1732   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1733
1734   isize = gfc_integer_kinds[k].bit_size;
1735
1736   if (shift >= 0)
1737     ashift = shift;
1738   else
1739     ashift = -shift;
1740
1741   if (ashift > isize)
1742     {
1743       gfc_error
1744         ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1745          &s->where);
1746       return &gfc_bad_expr;
1747     }
1748
1749   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1750
1751   if (shift == 0)
1752     {
1753       mpz_set (result->value.integer, e->value.integer);
1754       return range_check (result, "ISHFT");
1755     }
1756
1757   bits = gfc_getmem (isize * sizeof (int));
1758
1759   for (i = 0; i < isize; i++)
1760     bits[i] = mpz_tstbit (e->value.integer, i);
1761
1762   if (shift > 0)
1763     {
1764       for (i = 0; i < shift; i++)
1765         mpz_clrbit (result->value.integer, i);
1766
1767       for (i = 0; i < isize - shift; i++)
1768         {
1769           if (bits[i] == 0)
1770             mpz_clrbit (result->value.integer, i + shift);
1771           else
1772             mpz_setbit (result->value.integer, i + shift);
1773         }
1774     }
1775   else
1776     {
1777       for (i = isize - 1; i >= isize - ashift; i--)
1778         mpz_clrbit (result->value.integer, i);
1779
1780       for (i = isize - 1; i >= ashift; i--)
1781         {
1782           if (bits[i] == 0)
1783             mpz_clrbit (result->value.integer, i - ashift);
1784           else
1785             mpz_setbit (result->value.integer, i - ashift);
1786         }
1787     }
1788
1789   twos_complement (result->value.integer, isize);
1790
1791   gfc_free (bits);
1792   return result;
1793 }
1794
1795
1796 gfc_expr *
1797 gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
1798 {
1799   gfc_expr *result;
1800   int shift, ashift, isize, delta, k;
1801   int i, *bits;
1802
1803   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1804     return NULL;
1805
1806   if (gfc_extract_int (s, &shift) != NULL)
1807     {
1808       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1809       return &gfc_bad_expr;
1810     }
1811
1812   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1813
1814   if (sz != NULL)
1815     {
1816       if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
1817         {
1818           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1819           return &gfc_bad_expr;
1820         }
1821     }
1822   else
1823     isize = gfc_integer_kinds[k].bit_size;
1824
1825   if (shift >= 0)
1826     ashift = shift;
1827   else
1828     ashift = -shift;
1829
1830   if (ashift > isize)
1831     {
1832       gfc_error
1833         ("Magnitude of second argument of ISHFTC exceeds third argument "
1834          "at %L", &s->where);
1835       return &gfc_bad_expr;
1836     }
1837
1838   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1839
1840   if (shift == 0)
1841     {
1842       mpz_set (result->value.integer, e->value.integer);
1843       return result;
1844     }
1845
1846   bits = gfc_getmem (isize * sizeof (int));
1847
1848   for (i = 0; i < isize; i++)
1849     bits[i] = mpz_tstbit (e->value.integer, i);
1850
1851   delta = isize - ashift;
1852
1853   if (shift > 0)
1854     {
1855       for (i = 0; i < delta; i++)
1856         {
1857           if (bits[i] == 0)
1858             mpz_clrbit (result->value.integer, i + shift);
1859           else
1860             mpz_setbit (result->value.integer, i + shift);
1861         }
1862
1863       for (i = delta; i < isize; i++)
1864         {
1865           if (bits[i] == 0)
1866             mpz_clrbit (result->value.integer, i - delta);
1867           else
1868             mpz_setbit (result->value.integer, i - delta);
1869         }
1870     }
1871   else
1872     {
1873       for (i = 0; i < ashift; i++)
1874         {
1875           if (bits[i] == 0)
1876             mpz_clrbit (result->value.integer, i + delta);
1877           else
1878             mpz_setbit (result->value.integer, i + delta);
1879         }
1880
1881       for (i = ashift; i < isize; i++)
1882         {
1883           if (bits[i] == 0)
1884             mpz_clrbit (result->value.integer, i + shift);
1885           else
1886             mpz_setbit (result->value.integer, i + shift);
1887         }
1888     }
1889
1890   twos_complement (result->value.integer, isize);
1891
1892   gfc_free (bits);
1893   return result;
1894 }
1895
1896
1897 gfc_expr *
1898 gfc_simplify_kind (gfc_expr * e)
1899 {
1900
1901   if (e->ts.type == BT_DERIVED)
1902     {
1903       gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1904       return &gfc_bad_expr;
1905     }
1906
1907   return gfc_int_expr (e->ts.kind);
1908 }
1909
1910
1911 static gfc_expr *
1912 simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
1913 {
1914   gfc_ref *ref;
1915   gfc_array_spec *as;
1916   gfc_expr *e;
1917   int d;
1918
1919   if (array->expr_type != EXPR_VARIABLE)
1920     return NULL;
1921
1922   if (dim == NULL)
1923     /* TODO: Simplify constant multi-dimensional bounds.  */
1924     return NULL;
1925
1926   if (dim->expr_type != EXPR_CONSTANT)
1927     return NULL;
1928
1929   /* Follow any component references.  */
1930   as = array->symtree->n.sym->as;
1931   for (ref = array->ref; ref; ref = ref->next)
1932     {
1933       switch (ref->type)
1934         {
1935         case REF_ARRAY:
1936           switch (ref->u.ar.type)
1937             {
1938             case AR_ELEMENT:
1939               as = NULL;
1940               continue;
1941
1942             case AR_FULL:
1943               /* We're done because 'as' has already been set in the
1944                  previous iteration.  */
1945               goto done;
1946
1947             case AR_SECTION:
1948             case AR_UNKNOWN:
1949               return NULL;
1950             }
1951
1952           gcc_unreachable ();
1953
1954         case REF_COMPONENT:
1955           as = ref->u.c.component->as;
1956           continue;
1957
1958         case REF_SUBSTRING:
1959           continue;
1960         }
1961     }
1962
1963   gcc_unreachable ();
1964
1965  done:
1966   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
1967     return NULL;
1968
1969   d = mpz_get_si (dim->value.integer);
1970
1971   if (d < 1 || d > as->rank
1972       || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
1973     {
1974       gfc_error ("DIM argument at %L is out of bounds", &dim->where);
1975       return &gfc_bad_expr;
1976     }
1977
1978   e = upper ? as->upper[d-1] : as->lower[d-1];
1979
1980   if (e->expr_type != EXPR_CONSTANT)
1981     return NULL;
1982
1983   return gfc_copy_expr (e);
1984 }
1985
1986
1987 gfc_expr *
1988 gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
1989 {
1990   return simplify_bound (array, dim, 0);
1991 }
1992
1993
1994 gfc_expr *
1995 gfc_simplify_len (gfc_expr * e)
1996 {
1997   gfc_expr *result;
1998
1999   if (e->expr_type == EXPR_CONSTANT)
2000     {
2001       result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2002                                     &e->where);
2003       mpz_set_si (result->value.integer, e->value.character.length);
2004       return range_check (result, "LEN");
2005     }
2006
2007   if (e->ts.cl != NULL && e->ts.cl->length != NULL
2008       && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2009     {
2010       result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2011                                     &e->where);
2012       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2013       return range_check (result, "LEN");
2014     }
2015
2016   return NULL;
2017 }
2018
2019
2020 gfc_expr *
2021 gfc_simplify_len_trim (gfc_expr * e)
2022 {
2023   gfc_expr *result;
2024   int count, len, lentrim, i;
2025
2026   if (e->expr_type != EXPR_CONSTANT)
2027     return NULL;
2028
2029   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2030                                 &e->where);
2031
2032   len = e->value.character.length;
2033
2034   for (count = 0, i = 1; i <= len; i++)
2035     if (e->value.character.string[len - i] == ' ')
2036       count++;
2037     else
2038       break;
2039
2040   lentrim = len - count;
2041
2042   mpz_set_si (result->value.integer, lentrim);
2043   return range_check (result, "LEN_TRIM");
2044 }
2045
2046
2047 gfc_expr *
2048 gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
2049 {
2050
2051   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2052     return NULL;
2053
2054   return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0,
2055                            &a->where);
2056 }
2057
2058
2059 gfc_expr *
2060 gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
2061 {
2062
2063   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2064     return NULL;
2065
2066   return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0,
2067                            &a->where);
2068 }
2069
2070
2071 gfc_expr *
2072 gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
2073 {
2074
2075   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2076     return NULL;
2077
2078   return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0,
2079                            &a->where);
2080 }
2081
2082
2083 gfc_expr *
2084 gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
2085 {
2086
2087   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2088     return NULL;
2089
2090   return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0,
2091                            &a->where);
2092 }
2093
2094
2095 gfc_expr *
2096 gfc_simplify_log (gfc_expr * x)
2097 {
2098   gfc_expr *result;
2099   mpfr_t xr, xi;
2100
2101   if (x->expr_type != EXPR_CONSTANT)
2102     return NULL;
2103
2104   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2105
2106   gfc_set_model_kind (x->ts.kind);
2107
2108   switch (x->ts.type)
2109     {
2110     case BT_REAL:
2111       if (mpfr_sgn (x->value.real) <= 0)
2112         {
2113           gfc_error
2114             ("Argument of LOG at %L cannot be less than or equal to zero",
2115              &x->where);
2116           gfc_free_expr (result);
2117           return &gfc_bad_expr;
2118         }
2119
2120       mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
2121       break;
2122
2123     case BT_COMPLEX:
2124       if ((mpfr_sgn (x->value.complex.r) == 0)
2125           && (mpfr_sgn (x->value.complex.i) == 0))
2126         {
2127           gfc_error ("Complex argument of LOG at %L cannot be zero",
2128                      &x->where);
2129           gfc_free_expr (result);
2130           return &gfc_bad_expr;
2131         }
2132
2133       mpfr_init (xr);
2134       mpfr_init (xi);
2135
2136       mpfr_atan2 (result->value.complex.i, x->value.complex.i, x->value.complex.r,
2137                   GFC_RND_MODE);
2138
2139       mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2140       mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2141       mpfr_add (xr, xr, xi, GFC_RND_MODE);
2142       mpfr_sqrt (xr, xr, GFC_RND_MODE);
2143       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2144
2145       mpfr_clear (xr);
2146       mpfr_clear (xi);
2147
2148       break;
2149
2150     default:
2151       gfc_internal_error ("gfc_simplify_log: bad type");
2152     }
2153
2154   return range_check (result, "LOG");
2155 }
2156
2157
2158 gfc_expr *
2159 gfc_simplify_log10 (gfc_expr * x)
2160 {
2161   gfc_expr *result;
2162
2163   if (x->expr_type != EXPR_CONSTANT)
2164     return NULL;
2165
2166   gfc_set_model_kind (x->ts.kind);
2167
2168   if (mpfr_sgn (x->value.real) <= 0)
2169     {
2170       gfc_error
2171         ("Argument of LOG10 at %L cannot be less than or equal to zero",
2172          &x->where);
2173       return &gfc_bad_expr;
2174     }
2175
2176   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2177
2178   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2179
2180   return range_check (result, "LOG10");
2181 }
2182
2183
2184 gfc_expr *
2185 gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
2186 {
2187   gfc_expr *result;
2188   int kind;
2189
2190   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2191   if (kind < 0)
2192     return &gfc_bad_expr;
2193
2194   if (e->expr_type != EXPR_CONSTANT)
2195     return NULL;
2196
2197   result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2198
2199   result->value.logical = e->value.logical;
2200
2201   return result;
2202 }
2203
2204
2205 /* This function is special since MAX() can take any number of
2206    arguments.  The simplified expression is a rewritten version of the
2207    argument list containing at most one constant element.  Other
2208    constant elements are deleted.  Because the argument list has
2209    already been checked, this function always succeeds.  sign is 1 for
2210    MAX(), -1 for MIN().  */
2211
2212 static gfc_expr *
2213 simplify_min_max (gfc_expr * expr, int sign)
2214 {
2215   gfc_actual_arglist *arg, *last, *extremum;
2216   gfc_intrinsic_sym * specific;
2217
2218   last = NULL;
2219   extremum = NULL;
2220   specific = expr->value.function.isym;
2221
2222   arg = expr->value.function.actual;
2223
2224   for (; arg; last = arg, arg = arg->next)
2225     {
2226       if (arg->expr->expr_type != EXPR_CONSTANT)
2227         continue;
2228
2229       if (extremum == NULL)
2230         {
2231           extremum = arg;
2232           continue;
2233         }
2234
2235       switch (arg->expr->ts.type)
2236         {
2237         case BT_INTEGER:
2238           if (mpz_cmp (arg->expr->value.integer,
2239                        extremum->expr->value.integer) * sign > 0)
2240             mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2241
2242           break;
2243
2244         case BT_REAL:
2245           if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) *
2246               sign > 0)
2247             mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2248                       GFC_RND_MODE);
2249
2250           break;
2251
2252         default:
2253           gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2254         }
2255
2256       /* Delete the extra constant argument.  */
2257       if (last == NULL)
2258         expr->value.function.actual = arg->next;
2259       else
2260         last->next = arg->next;
2261
2262       arg->next = NULL;
2263       gfc_free_actual_arglist (arg);
2264       arg = last;
2265     }
2266
2267   /* If there is one value left, replace the function call with the
2268      expression.  */
2269   if (expr->value.function.actual->next != NULL)
2270     return NULL;
2271
2272   /* Convert to the correct type and kind.  */
2273   if (expr->ts.type != BT_UNKNOWN)
2274     return gfc_convert_constant (expr->value.function.actual->expr,
2275         expr->ts.type, expr->ts.kind);
2276
2277   if (specific->ts.type != BT_UNKNOWN)
2278     return gfc_convert_constant (expr->value.function.actual->expr,
2279         specific->ts.type, specific->ts.kind);
2280
2281   return gfc_copy_expr (expr->value.function.actual->expr);
2282 }
2283
2284
2285 gfc_expr *
2286 gfc_simplify_min (gfc_expr * e)
2287 {
2288   return simplify_min_max (e, -1);
2289 }
2290
2291
2292 gfc_expr *
2293 gfc_simplify_max (gfc_expr * e)
2294 {
2295   return simplify_min_max (e, 1);
2296 }
2297
2298
2299 gfc_expr *
2300 gfc_simplify_maxexponent (gfc_expr * x)
2301 {
2302   gfc_expr *result;
2303   int i;
2304
2305   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2306
2307   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2308   result->where = x->where;
2309
2310   return result;
2311 }
2312
2313
2314 gfc_expr *
2315 gfc_simplify_minexponent (gfc_expr * x)
2316 {
2317   gfc_expr *result;
2318   int i;
2319
2320   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2321
2322   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2323   result->where = x->where;
2324
2325   return result;
2326 }
2327
2328
2329 gfc_expr *
2330 gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
2331 {
2332   gfc_expr *result;
2333   mpfr_t quot, iquot, term;
2334   int kind;
2335
2336   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2337     return NULL;
2338
2339   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2340   result = gfc_constant_result (a->ts.type, kind, &a->where);
2341
2342   switch (a->ts.type)
2343     {
2344     case BT_INTEGER:
2345       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2346         {
2347           /* Result is processor-dependent.  */
2348           gfc_error ("Second argument MOD at %L is zero", &a->where);
2349           gfc_free_expr (result);
2350           return &gfc_bad_expr;
2351         }
2352       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2353       break;
2354
2355     case BT_REAL:
2356       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2357         {
2358           /* Result is processor-dependent.  */
2359           gfc_error ("Second argument of MOD at %L is zero", &p->where);
2360           gfc_free_expr (result);
2361           return &gfc_bad_expr;
2362         }
2363
2364       gfc_set_model_kind (kind);
2365       mpfr_init (quot);
2366       mpfr_init (iquot);
2367       mpfr_init (term);
2368
2369       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2370       mpfr_trunc (iquot, quot);
2371       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2372       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2373
2374       mpfr_clear (quot);
2375       mpfr_clear (iquot);
2376       mpfr_clear (term);
2377       break;
2378
2379     default:
2380       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2381     }
2382
2383   return range_check (result, "MOD");
2384 }
2385
2386
2387 gfc_expr *
2388 gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
2389 {
2390   gfc_expr *result;
2391   mpfr_t quot, iquot, term;
2392   int kind;
2393
2394   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2395     return NULL;
2396
2397   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2398   result = gfc_constant_result (a->ts.type, kind, &a->where);
2399
2400   switch (a->ts.type)
2401     {
2402     case BT_INTEGER:
2403       if (mpz_cmp_ui (p->value.integer, 0) == 0)
2404         {
2405           /* Result is processor-dependent. This processor just opts
2406              to not handle it at all.  */
2407           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2408           gfc_free_expr (result);
2409           return &gfc_bad_expr;
2410         }
2411       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2412
2413       break;
2414
2415     case BT_REAL:
2416       if (mpfr_cmp_ui (p->value.real, 0) == 0)
2417         {
2418           /* Result is processor-dependent.  */
2419           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2420           gfc_free_expr (result);
2421           return &gfc_bad_expr;
2422         }
2423
2424       gfc_set_model_kind (kind);
2425       mpfr_init (quot);
2426       mpfr_init (iquot);
2427       mpfr_init (term);
2428
2429       mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2430       mpfr_floor (iquot, quot);
2431       mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2432       mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2433
2434       mpfr_clear (quot);
2435       mpfr_clear (iquot);
2436       mpfr_clear (term);
2437       break;
2438
2439     default:
2440       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2441     }
2442
2443   return range_check (result, "MODULO");
2444 }
2445
2446
2447 /* Exists for the sole purpose of consistency with other intrinsics.  */
2448 gfc_expr *
2449 gfc_simplify_mvbits (gfc_expr * f  ATTRIBUTE_UNUSED,
2450                      gfc_expr * fp ATTRIBUTE_UNUSED,
2451                      gfc_expr * l  ATTRIBUTE_UNUSED,
2452                      gfc_expr * to ATTRIBUTE_UNUSED,
2453                      gfc_expr * tp ATTRIBUTE_UNUSED)
2454 {
2455   return NULL;
2456 }
2457
2458
2459 gfc_expr *
2460 gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
2461 {
2462   gfc_expr *result;
2463   mpfr_t tmp;
2464   int sgn;
2465
2466   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2467     return NULL;
2468
2469   if (mpfr_sgn (s->value.real) == 0)
2470     {
2471       gfc_error ("Second argument of NEAREST at %L shall not be zero", &s->where);
2472       return &gfc_bad_expr;
2473     }
2474
2475   gfc_set_model_kind (x->ts.kind);
2476   result = gfc_copy_expr (x);
2477
2478   sgn = mpfr_sgn (s->value.real);
2479   mpfr_init (tmp);
2480   mpfr_set_inf (tmp, sgn);
2481   mpfr_nexttoward (result->value.real, tmp);
2482   mpfr_clear(tmp);
2483
2484   return range_check (result, "NEAREST");
2485 }
2486
2487
2488 static gfc_expr *
2489 simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
2490 {
2491   gfc_expr *itrunc, *result;
2492   int kind;
2493
2494   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2495   if (kind == -1)
2496     return &gfc_bad_expr;
2497
2498   if (e->expr_type != EXPR_CONSTANT)
2499     return NULL;
2500
2501   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2502
2503   itrunc = gfc_copy_expr (e);
2504
2505   mpfr_round(itrunc->value.real, e->value.real);
2506
2507   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2508
2509   gfc_free_expr (itrunc);
2510
2511   return range_check (result, name);
2512 }
2513
2514
2515 gfc_expr *
2516 gfc_simplify_new_line (gfc_expr * e)
2517 {
2518   gfc_expr *result;
2519
2520   if (e->expr_type != EXPR_CONSTANT)
2521     return NULL;
2522
2523   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2524
2525   result->value.character.string = gfc_getmem (2);
2526
2527   result->value.character.length = 1;
2528   result->value.character.string[0] = '\n';
2529   result->value.character.string[1] = '\0';     /* For debugger */
2530   return result;
2531 }
2532
2533
2534 gfc_expr *
2535 gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
2536 {
2537   return simplify_nint ("NINT", e, k);
2538 }
2539
2540
2541 gfc_expr *
2542 gfc_simplify_idnint (gfc_expr * e)
2543 {
2544   return simplify_nint ("IDNINT", e, NULL);
2545 }
2546
2547
2548 gfc_expr *
2549 gfc_simplify_not (gfc_expr * e)
2550 {
2551   gfc_expr *result;
2552   int i;
2553   mpz_t mask;
2554
2555   if (e->expr_type != EXPR_CONSTANT)
2556     return NULL;
2557
2558   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2559
2560   mpz_com (result->value.integer, e->value.integer);
2561
2562   /* Because of how GMP handles numbers, the result must be ANDed with
2563      a mask.  For radices <> 2, this will require change.  */
2564
2565   i = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2566
2567   mpz_init (mask);
2568   mpz_add (mask, gfc_integer_kinds[i].huge, gfc_integer_kinds[i].huge);
2569   mpz_add_ui (mask, mask, 1);
2570
2571   mpz_and (result->value.integer, result->value.integer, mask);
2572
2573   twos_complement (result->value.integer, gfc_integer_kinds[i].bit_size);
2574
2575   mpz_clear (mask);
2576
2577   return range_check (result, "NOT");
2578 }
2579
2580
2581 gfc_expr *
2582 gfc_simplify_null (gfc_expr * mold)
2583 {
2584   gfc_expr *result;
2585
2586   if (mold == NULL)
2587     {
2588       result = gfc_get_expr ();
2589       result->ts.type = BT_UNKNOWN;
2590     }
2591   else
2592     result = gfc_copy_expr (mold);
2593   result->expr_type = EXPR_NULL;
2594
2595   return result;
2596 }
2597
2598
2599 gfc_expr *
2600 gfc_simplify_or (gfc_expr * x, gfc_expr * y)
2601 {
2602   gfc_expr *result;
2603   int kind;
2604
2605   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2606     return NULL;
2607
2608   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2609   if (x->ts.type == BT_INTEGER)
2610     {
2611       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2612       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2613     }
2614   else /* BT_LOGICAL */
2615     {
2616       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2617       result->value.logical = x->value.logical || y->value.logical;
2618     }
2619
2620   return range_check (result, "OR");
2621 }
2622
2623
2624 gfc_expr *
2625 gfc_simplify_precision (gfc_expr * e)
2626 {
2627   gfc_expr *result;
2628   int i;
2629
2630   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2631
2632   result = gfc_int_expr (gfc_real_kinds[i].precision);
2633   result->where = e->where;
2634
2635   return result;
2636 }
2637
2638
2639 gfc_expr *
2640 gfc_simplify_radix (gfc_expr * e)
2641 {
2642   gfc_expr *result;
2643   int i;
2644
2645   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2646   switch (e->ts.type)
2647     {
2648     case BT_INTEGER:
2649       i = gfc_integer_kinds[i].radix;
2650       break;
2651
2652     case BT_REAL:
2653       i = gfc_real_kinds[i].radix;
2654       break;
2655
2656     default:
2657       gcc_unreachable ();
2658     }
2659
2660   result = gfc_int_expr (i);
2661   result->where = e->where;
2662
2663   return result;
2664 }
2665
2666
2667 gfc_expr *
2668 gfc_simplify_range (gfc_expr * e)
2669 {
2670   gfc_expr *result;
2671   int i;
2672   long j;
2673
2674   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2675
2676   switch (e->ts.type)
2677     {
2678     case BT_INTEGER:
2679       j = gfc_integer_kinds[i].range;
2680       break;
2681
2682     case BT_REAL:
2683     case BT_COMPLEX:
2684       j = gfc_real_kinds[i].range;
2685       break;
2686
2687     default:
2688       gcc_unreachable ();
2689     }
2690
2691   result = gfc_int_expr (j);
2692   result->where = e->where;
2693
2694   return result;
2695 }
2696
2697
2698 gfc_expr *
2699 gfc_simplify_real (gfc_expr * e, gfc_expr * k)
2700 {
2701   gfc_expr *result;
2702   int kind;
2703
2704   if (e->ts.type == BT_COMPLEX)
2705     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2706   else
2707     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2708
2709   if (kind == -1)
2710     return &gfc_bad_expr;
2711
2712   if (e->expr_type != EXPR_CONSTANT)
2713     return NULL;
2714
2715   switch (e->ts.type)
2716     {
2717     case BT_INTEGER:
2718       result = gfc_int2real (e, kind);
2719       break;
2720
2721     case BT_REAL:
2722       result = gfc_real2real (e, kind);
2723       break;
2724
2725     case BT_COMPLEX:
2726       result = gfc_complex2real (e, kind);
2727       break;
2728
2729     default:
2730       gfc_internal_error ("bad type in REAL");
2731       /* Not reached */
2732     }
2733
2734   return range_check (result, "REAL");
2735 }
2736
2737
2738 gfc_expr *
2739 gfc_simplify_realpart (gfc_expr * e)
2740 {
2741   gfc_expr *result;
2742
2743   if (e->expr_type != EXPR_CONSTANT)
2744     return NULL;
2745
2746   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2747   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2748
2749   return range_check (result, "REALPART");
2750 }
2751
2752 gfc_expr *
2753 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
2754 {
2755   gfc_expr *result;
2756   int i, j, len, ncopies, nlen;
2757
2758   if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
2759     return NULL;
2760
2761   if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
2762     {
2763       gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
2764       return &gfc_bad_expr;
2765     }
2766
2767   len = e->value.character.length;
2768   nlen = ncopies * len;
2769
2770   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2771
2772   if (ncopies == 0)
2773     {
2774       result->value.character.string = gfc_getmem (1);
2775       result->value.character.length = 0;
2776       result->value.character.string[0] = '\0';
2777       return result;
2778     }
2779
2780   result->value.character.length = nlen;
2781   result->value.character.string = gfc_getmem (nlen + 1);
2782
2783   for (i = 0; i < ncopies; i++)
2784     for (j = 0; j < len; j++)
2785       result->value.character.string[j + i * len] =
2786         e->value.character.string[j];
2787
2788   result->value.character.string[nlen] = '\0';  /* For debugger */
2789   return result;
2790 }
2791
2792
2793 /* This one is a bear, but mainly has to do with shuffling elements.  */
2794
2795 gfc_expr *
2796 gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
2797                       gfc_expr * pad, gfc_expr * order_exp)
2798 {
2799
2800   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2801   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2802   gfc_constructor *head, *tail;
2803   mpz_t index, size;
2804   unsigned long j;
2805   size_t nsource;
2806   gfc_expr *e;
2807
2808   /* Unpack the shape array.  */
2809   if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2810     return NULL;
2811
2812   if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2813     return NULL;
2814
2815   if (pad != NULL
2816       && (pad->expr_type != EXPR_ARRAY
2817           || !gfc_is_constant_expr (pad)))
2818     return NULL;
2819
2820   if (order_exp != NULL
2821       && (order_exp->expr_type != EXPR_ARRAY
2822           || !gfc_is_constant_expr (order_exp)))
2823     return NULL;
2824
2825   mpz_init (index);
2826   rank = 0;
2827   head = tail = NULL;
2828
2829   for (;;)
2830     {
2831       e = gfc_get_array_element (shape_exp, rank);
2832       if (e == NULL)
2833         break;
2834
2835       if (gfc_extract_int (e, &shape[rank]) != NULL)
2836         {
2837           gfc_error ("Integer too large in shape specification at %L",
2838                      &e->where);
2839           gfc_free_expr (e);
2840           goto bad_reshape;
2841         }
2842
2843       gfc_free_expr (e);
2844
2845       if (rank >= GFC_MAX_DIMENSIONS)
2846         {
2847           gfc_error ("Too many dimensions in shape specification for RESHAPE "
2848                      "at %L", &e->where);
2849
2850           goto bad_reshape;
2851         }
2852
2853       if (shape[rank] < 0)
2854         {
2855           gfc_error ("Shape specification at %L cannot be negative",
2856                      &e->where);
2857           goto bad_reshape;
2858         }
2859
2860       rank++;
2861     }
2862
2863   if (rank == 0)
2864     {
2865       gfc_error ("Shape specification at %L cannot be the null array",
2866                  &shape_exp->where);
2867       goto bad_reshape;
2868     }
2869
2870   /* Now unpack the order array if present.  */
2871   if (order_exp == NULL)
2872     {
2873       for (i = 0; i < rank; i++)
2874         order[i] = i;
2875
2876     }
2877   else
2878     {
2879
2880       for (i = 0; i < rank; i++)
2881         x[i] = 0;
2882
2883       for (i = 0; i < rank; i++)
2884         {
2885           e = gfc_get_array_element (order_exp, i);
2886           if (e == NULL)
2887             {
2888               gfc_error
2889                 ("ORDER parameter of RESHAPE at %L is not the same size "
2890                  "as SHAPE parameter", &order_exp->where);
2891               goto bad_reshape;
2892             }
2893
2894           if (gfc_extract_int (e, &order[i]) != NULL)
2895             {
2896               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2897                          &e->where);
2898               gfc_free_expr (e);
2899               goto bad_reshape;
2900             }
2901
2902           gfc_free_expr (e);
2903
2904           if (order[i] < 1 || order[i] > rank)
2905             {
2906               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2907                          &e->where);
2908               goto bad_reshape;
2909             }
2910
2911           order[i]--;
2912
2913           if (x[order[i]])
2914             {
2915               gfc_error ("Invalid permutation in ORDER parameter at %L",
2916                          &e->where);
2917               goto bad_reshape;
2918             }
2919
2920           x[order[i]] = 1;
2921         }
2922     }
2923
2924   /* Count the elements in the source and padding arrays.  */
2925
2926   npad = 0;
2927   if (pad != NULL)
2928     {
2929       gfc_array_size (pad, &size);
2930       npad = mpz_get_ui (size);
2931       mpz_clear (size);
2932     }
2933
2934   gfc_array_size (source, &size);
2935   nsource = mpz_get_ui (size);
2936   mpz_clear (size);
2937
2938   /* If it weren't for that pesky permutation we could just loop
2939      through the source and round out any shortage with pad elements.
2940      But no, someone just had to have the compiler do something the
2941      user should be doing.  */
2942
2943   for (i = 0; i < rank; i++)
2944     x[i] = 0;
2945
2946   for (;;)
2947     {
2948       /* Figure out which element to extract.  */
2949       mpz_set_ui (index, 0);
2950
2951       for (i = rank - 1; i >= 0; i--)
2952         {
2953           mpz_add_ui (index, index, x[order[i]]);
2954           if (i != 0)
2955             mpz_mul_ui (index, index, shape[order[i - 1]]);
2956         }
2957
2958       if (mpz_cmp_ui (index, INT_MAX) > 0)
2959         gfc_internal_error ("Reshaped array too large at %L", &e->where);
2960
2961       j = mpz_get_ui (index);
2962
2963       if (j < nsource)
2964         e = gfc_get_array_element (source, j);
2965       else
2966         {
2967           j = j - nsource;
2968
2969           if (npad == 0)
2970             {
2971               gfc_error
2972                 ("PAD parameter required for short SOURCE parameter at %L",
2973                  &source->where);
2974               goto bad_reshape;
2975             }
2976
2977           j = j % npad;
2978           e = gfc_get_array_element (pad, j);
2979         }
2980
2981       if (head == NULL)
2982         head = tail = gfc_get_constructor ();
2983       else
2984         {
2985           tail->next = gfc_get_constructor ();
2986           tail = tail->next;
2987         }
2988
2989       if (e == NULL)
2990         goto bad_reshape;
2991
2992       tail->where = e->where;
2993       tail->expr = e;
2994
2995       /* Calculate the next element.  */
2996       i = 0;
2997
2998 inc:
2999       if (++x[i] < shape[i])
3000         continue;
3001       x[i++] = 0;
3002       if (i < rank)
3003         goto inc;
3004
3005       break;
3006     }
3007
3008   mpz_clear (index);
3009
3010   e = gfc_get_expr ();
3011   e->where = source->where;
3012   e->expr_type = EXPR_ARRAY;
3013   e->value.constructor = head;
3014   e->shape = gfc_get_shape (rank);
3015
3016   for (i = 0; i < rank; i++)
3017     mpz_init_set_ui (e->shape[i], shape[i]);
3018
3019   e->ts = source->ts;
3020   e->rank = rank;
3021
3022   return e;
3023
3024 bad_reshape:
3025   gfc_free_constructor (head);
3026   mpz_clear (index);
3027   return &gfc_bad_expr;
3028 }
3029
3030
3031 gfc_expr *
3032 gfc_simplify_rrspacing (gfc_expr * x)
3033 {
3034   gfc_expr *result;
3035   int i;
3036   long int e, p;
3037
3038   if (x->expr_type != EXPR_CONSTANT)
3039     return NULL;
3040
3041   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3042
3043   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3044
3045   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3046
3047   /* Special case x = 0 and 0.  */
3048   if (mpfr_sgn (result->value.real) == 0)
3049     {
3050       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3051       return result;
3052     }
3053
3054   /* | x * 2**(-e) | * 2**p.  */
3055   e = - (long int) mpfr_get_exp (x->value.real);
3056   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3057
3058   p = (long int) gfc_real_kinds[i].digits;
3059   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3060
3061   return range_check (result, "RRSPACING");
3062 }
3063
3064
3065 gfc_expr *
3066 gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
3067 {
3068   int k, neg_flag, power, exp_range;
3069   mpfr_t scale, radix;
3070   gfc_expr *result;
3071
3072   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3073     return NULL;
3074
3075   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3076
3077   if (mpfr_sgn (x->value.real) == 0)
3078     {
3079       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3080       return result;
3081     }
3082
3083   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3084
3085   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3086
3087   /* This check filters out values of i that would overflow an int.  */
3088   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3089       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3090     {
3091       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3092       return &gfc_bad_expr;
3093     }
3094
3095   /* Compute scale = radix ** power.  */
3096   power = mpz_get_si (i->value.integer);
3097
3098   if (power >= 0)
3099     neg_flag = 0;
3100   else
3101     {
3102       neg_flag = 1;
3103       power = -power;
3104     }
3105
3106   gfc_set_model_kind (x->ts.kind);
3107   mpfr_init (scale);
3108   mpfr_init (radix);
3109   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3110   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3111
3112   if (neg_flag)
3113     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3114   else
3115     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3116
3117   mpfr_clear (scale);
3118   mpfr_clear (radix);
3119
3120   return range_check (result, "SCALE");
3121 }
3122
3123
3124 gfc_expr *
3125 gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
3126 {
3127   gfc_expr *result;
3128   int back;
3129   size_t i;
3130   size_t indx, len, lenc;
3131
3132   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3133     return NULL;
3134
3135   if (b != NULL && b->value.logical != 0)
3136     back = 1;
3137   else
3138     back = 0;
3139
3140   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3141                                 &e->where);
3142
3143   len = e->value.character.length;
3144   lenc = c->value.character.length;
3145
3146   if (len == 0 || lenc == 0)
3147     {
3148       indx = 0;
3149     }
3150   else
3151     {
3152       if (back == 0)
3153         {
3154           indx =
3155             strcspn (e->value.character.string, c->value.character.string) + 1;
3156           if (indx > len)
3157             indx = 0;
3158         }
3159       else
3160         {
3161           i = 0;
3162           for (indx = len; indx > 0; indx--)
3163             {
3164               for (i = 0; i < lenc; i++)
3165                 {
3166                   if (c->value.character.string[i]
3167                         == e->value.character.string[indx - 1])
3168                     break;
3169                 }
3170               if (i < lenc)
3171                 break;
3172             }
3173         }
3174     }
3175   mpz_set_ui (result->value.integer, indx);
3176   return range_check (result, "SCAN");
3177 }
3178
3179
3180 gfc_expr *
3181 gfc_simplify_selected_int_kind (gfc_expr * e)
3182 {
3183   int i, kind, range;
3184   gfc_expr *result;
3185
3186   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3187     return NULL;
3188
3189   kind = INT_MAX;
3190
3191   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3192     if (gfc_integer_kinds[i].range >= range
3193         && gfc_integer_kinds[i].kind < kind)
3194       kind = gfc_integer_kinds[i].kind;
3195
3196   if (kind == INT_MAX)
3197     kind = -1;
3198
3199   result = gfc_int_expr (kind);
3200   result->where = e->where;
3201
3202   return result;
3203 }
3204
3205
3206 gfc_expr *
3207 gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
3208 {
3209   int range, precision, i, kind, found_precision, found_range;
3210   gfc_expr *result;
3211
3212   if (p == NULL)
3213     precision = 0;
3214   else
3215     {
3216       if (p->expr_type != EXPR_CONSTANT
3217           || gfc_extract_int (p, &precision) != NULL)
3218         return NULL;
3219     }
3220
3221   if (q == NULL)
3222     range = 0;
3223   else
3224     {
3225       if (q->expr_type != EXPR_CONSTANT
3226           || gfc_extract_int (q, &range) != NULL)
3227         return NULL;
3228     }
3229
3230   kind = INT_MAX;
3231   found_precision = 0;
3232   found_range = 0;
3233
3234   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3235     {
3236       if (gfc_real_kinds[i].precision >= precision)
3237         found_precision = 1;
3238
3239       if (gfc_real_kinds[i].range >= range)
3240         found_range = 1;
3241
3242       if (gfc_real_kinds[i].precision >= precision
3243           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3244         kind = gfc_real_kinds[i].kind;
3245     }
3246
3247   if (kind == INT_MAX)
3248     {
3249       kind = 0;
3250
3251       if (!found_precision)
3252         kind = -1;
3253       if (!found_range)
3254         kind -= 2;
3255     }
3256
3257   result = gfc_int_expr (kind);
3258   result->where = (p != NULL) ? p->where : q->where;
3259
3260   return result;
3261 }
3262
3263
3264 gfc_expr *
3265 gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
3266 {
3267   gfc_expr *result;
3268   mpfr_t exp, absv, log2, pow2, frac;
3269   unsigned long exp2;
3270
3271   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3272     return NULL;
3273
3274   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3275
3276   gfc_set_model_kind (x->ts.kind);
3277
3278   if (mpfr_sgn (x->value.real) == 0)
3279     {
3280       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3281       return result;
3282     }
3283
3284   mpfr_init (absv);
3285   mpfr_init (log2);
3286   mpfr_init (exp);
3287   mpfr_init (pow2);
3288   mpfr_init (frac);
3289
3290   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3291   mpfr_log2 (log2, absv, GFC_RND_MODE);
3292
3293   mpfr_trunc (log2, log2);
3294   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3295
3296   /* Old exponent value, and fraction.  */
3297   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3298
3299   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3300
3301   /* New exponent.  */
3302   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3303   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3304
3305   mpfr_clear (absv);
3306   mpfr_clear (log2);
3307   mpfr_clear (pow2);
3308   mpfr_clear (frac);
3309
3310   return range_check (result, "SET_EXPONENT");
3311 }
3312
3313
3314 gfc_expr *
3315 gfc_simplify_shape (gfc_expr * source)
3316 {
3317   mpz_t shape[GFC_MAX_DIMENSIONS];
3318   gfc_expr *result, *e, *f;
3319   gfc_array_ref *ar;
3320   int n;
3321   try t;
3322
3323   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3324     return NULL;
3325
3326   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3327                                   &source->where);
3328
3329   ar = gfc_find_array_ref (source);
3330
3331   t = gfc_array_ref_shape (ar, shape);
3332
3333   for (n = 0; n < source->rank; n++)
3334     {
3335       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3336                                &source->where);
3337
3338       if (t == SUCCESS)
3339         {
3340           mpz_set (e->value.integer, shape[n]);
3341           mpz_clear (shape[n]);
3342         }
3343       else
3344         {
3345           mpz_set_ui (e->value.integer, n + 1);
3346
3347           f = gfc_simplify_size (source, e);
3348           gfc_free_expr (e);
3349           if (f == NULL)
3350             {
3351               gfc_free_expr (result);
3352               return NULL;
3353             }
3354           else
3355             {
3356               e = f;
3357             }
3358         }
3359
3360       gfc_append_constructor (result, e);
3361     }
3362
3363   return result;
3364 }
3365
3366
3367 gfc_expr *
3368 gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
3369 {
3370   mpz_t size;
3371   gfc_expr *result;
3372   int d;
3373
3374   if (dim == NULL)
3375     {
3376       if (gfc_array_size (array, &size) == FAILURE)
3377         return NULL;
3378     }
3379   else
3380     {
3381       if (dim->expr_type != EXPR_CONSTANT)
3382         return NULL;
3383
3384       d = mpz_get_ui (dim->value.integer) - 1;
3385       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3386         return NULL;
3387     }
3388
3389   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3390                                 &array->where);
3391
3392   mpz_set (result->value.integer, size);
3393
3394   return result;
3395 }
3396
3397
3398 gfc_expr *
3399 gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
3400 {
3401   gfc_expr *result;
3402
3403   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3404     return NULL;
3405
3406   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3407
3408   switch (x->ts.type)
3409     {
3410     case BT_INTEGER:
3411       mpz_abs (result->value.integer, x->value.integer);
3412       if (mpz_sgn (y->value.integer) < 0)
3413         mpz_neg (result->value.integer, result->value.integer);
3414
3415       break;
3416
3417     case BT_REAL:
3418       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3419          it.  */
3420       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3421       if (mpfr_sgn (y->value.real) < 0)
3422         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3423
3424       break;
3425
3426     default:
3427       gfc_internal_error ("Bad type in gfc_simplify_sign");
3428     }
3429
3430   return result;
3431 }
3432
3433
3434 gfc_expr *
3435 gfc_simplify_sin (gfc_expr * x)
3436 {
3437   gfc_expr *result;
3438   mpfr_t xp, xq;
3439
3440   if (x->expr_type != EXPR_CONSTANT)
3441     return NULL;
3442
3443   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3444
3445   switch (x->ts.type)
3446     {
3447     case BT_REAL:
3448       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3449       break;
3450
3451     case BT_COMPLEX:
3452       gfc_set_model (x->value.real);
3453       mpfr_init (xp);
3454       mpfr_init (xq);
3455
3456       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3457       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3458       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3459
3460       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3461       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3462       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3463
3464       mpfr_clear (xp);
3465       mpfr_clear (xq);
3466       break;
3467
3468     default:
3469       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3470     }
3471
3472   return range_check (result, "SIN");
3473 }
3474
3475
3476 gfc_expr *
3477 gfc_simplify_sinh (gfc_expr * x)
3478 {
3479   gfc_expr *result;
3480
3481   if (x->expr_type != EXPR_CONSTANT)
3482     return NULL;
3483
3484   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3485
3486   mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
3487
3488   return range_check (result, "SINH");
3489 }
3490
3491
3492 /* The argument is always a double precision real that is converted to
3493    single precision.  TODO: Rounding!  */
3494
3495 gfc_expr *
3496 gfc_simplify_sngl (gfc_expr * a)
3497 {
3498   gfc_expr *result;
3499
3500   if (a->expr_type != EXPR_CONSTANT)
3501     return NULL;
3502
3503   result = gfc_real2real (a, gfc_default_real_kind);
3504   return range_check (result, "SNGL");
3505 }
3506
3507
3508 gfc_expr *
3509 gfc_simplify_spacing (gfc_expr * x)
3510 {
3511   gfc_expr *result;
3512   int i;
3513   long int en, ep;
3514
3515   if (x->expr_type != EXPR_CONSTANT)
3516     return NULL;
3517
3518   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3519
3520   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3521
3522   /* Special case x = 0 and -0.  */
3523   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3524   if (mpfr_sgn (result->value.real) == 0)
3525     {
3526       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3527       return result;
3528     }
3529
3530   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3531      are the radix, exponent of x, and precision.  This excludes the
3532      possibility of subnormal numbers.  Fortran 2003 states the result is
3533      b**max(e - p, emin - 1).  */
3534
3535   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3536   en = (long int) gfc_real_kinds[i].min_exponent - 1;
3537   en = en > ep ? en : ep;
3538
3539   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3540   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3541
3542   return range_check (result, "SPACING");
3543 }
3544
3545
3546 gfc_expr *
3547 gfc_simplify_sqrt (gfc_expr * e)
3548 {
3549   gfc_expr *result;
3550   mpfr_t ac, ad, s, t, w;
3551
3552   if (e->expr_type != EXPR_CONSTANT)
3553     return NULL;
3554
3555   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3556
3557   switch (e->ts.type)
3558     {
3559     case BT_REAL:
3560       if (mpfr_cmp_si (e->value.real, 0) < 0)
3561         goto negative_arg;
3562       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3563
3564       break;
3565
3566     case BT_COMPLEX:
3567       /* Formula taken from Numerical Recipes to avoid over- and
3568          underflow.  */
3569
3570       gfc_set_model (e->value.real);
3571       mpfr_init (ac);
3572       mpfr_init (ad);
3573       mpfr_init (s);
3574       mpfr_init (t);
3575       mpfr_init (w);
3576
3577       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3578           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3579         {
3580
3581           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3582           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3583           break;
3584         }
3585
3586       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3587       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3588
3589       if (mpfr_cmp (ac, ad) >= 0)
3590         {
3591           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3592           mpfr_mul (t, t, t, GFC_RND_MODE);
3593           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3594           mpfr_sqrt (t, t, GFC_RND_MODE);
3595           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3596           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3597           mpfr_sqrt (t, t, GFC_RND_MODE);
3598           mpfr_sqrt (s, ac, GFC_RND_MODE);
3599           mpfr_mul (w, s, t, GFC_RND_MODE);
3600         }
3601       else
3602         {
3603           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3604           mpfr_mul (t, s, s, GFC_RND_MODE);
3605           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3606           mpfr_sqrt (t, t, GFC_RND_MODE);
3607           mpfr_abs (s, s, GFC_RND_MODE);
3608           mpfr_add (t, t, s, GFC_RND_MODE);
3609           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3610           mpfr_sqrt (t, t, GFC_RND_MODE);
3611           mpfr_sqrt (s, ad, GFC_RND_MODE);
3612           mpfr_mul (w, s, t, GFC_RND_MODE);
3613         }
3614
3615       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3616         {
3617           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3618           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3619           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3620         }
3621       else if (mpfr_cmp_ui (w, 0) != 0
3622                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3623                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3624         {
3625           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3626           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3627           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3628         }
3629       else if (mpfr_cmp_ui (w, 0) != 0
3630                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3631                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3632         {
3633           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3634           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3635           mpfr_neg (w, w, GFC_RND_MODE);
3636           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3637         }
3638       else
3639         gfc_internal_error ("invalid complex argument of SQRT at %L",
3640                             &e->where);
3641
3642       mpfr_clear (s);
3643       mpfr_clear (t);
3644       mpfr_clear (ac);
3645       mpfr_clear (ad);
3646       mpfr_clear (w);
3647
3648       break;
3649
3650     default:
3651       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3652     }
3653
3654   return range_check (result, "SQRT");
3655
3656 negative_arg:
3657   gfc_free_expr (result);
3658   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3659   return &gfc_bad_expr;
3660 }
3661
3662
3663 gfc_expr *
3664 gfc_simplify_tan (gfc_expr * x)
3665 {
3666   int i;
3667   gfc_expr *result;
3668
3669   if (x->expr_type != EXPR_CONSTANT)
3670     return NULL;
3671
3672   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3673
3674   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3675
3676   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3677
3678   return range_check (result, "TAN");
3679 }
3680
3681
3682 gfc_expr *
3683 gfc_simplify_tanh (gfc_expr * x)
3684 {
3685   gfc_expr *result;
3686
3687   if (x->expr_type != EXPR_CONSTANT)
3688     return NULL;
3689
3690   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3691
3692   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3693
3694   return range_check (result, "TANH");
3695
3696 }
3697
3698
3699 gfc_expr *
3700 gfc_simplify_tiny (gfc_expr * e)
3701 {
3702   gfc_expr *result;
3703   int i;
3704
3705   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3706
3707   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3708   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3709
3710   return result;
3711 }
3712
3713
3714 gfc_expr *
3715 gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
3716 {
3717
3718   /* Reference mold and size to suppress warning.  */
3719   if (gfc_init_expr && (mold || size))
3720     gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
3721                &source->where);
3722
3723   return NULL;
3724 }
3725
3726
3727 gfc_expr *
3728 gfc_simplify_trim (gfc_expr * e)
3729 {
3730   gfc_expr *result;
3731   int count, i, len, lentrim;
3732
3733   if (e->expr_type != EXPR_CONSTANT)
3734     return NULL;
3735
3736   len = e->value.character.length;
3737
3738   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3739
3740   for (count = 0, i = 1; i <= len; ++i)
3741     {
3742       if (e->value.character.string[len - i] == ' ')
3743         count++;
3744       else
3745         break;
3746     }
3747
3748   lentrim = len - count;
3749
3750   result->value.character.length = lentrim;
3751   result->value.character.string = gfc_getmem (lentrim + 1);
3752
3753   for (i = 0; i < lentrim; i++)
3754     result->value.character.string[i] = e->value.character.string[i];
3755
3756   result->value.character.string[lentrim] = '\0';       /* For debugger */
3757
3758   return result;
3759 }
3760
3761
3762 gfc_expr *
3763 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
3764 {
3765   return simplify_bound (array, dim, 1);
3766 }
3767
3768
3769 gfc_expr *
3770 gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
3771 {
3772   gfc_expr *result;
3773   int back;
3774   size_t index, len, lenset;
3775   size_t i;
3776
3777   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3778     return NULL;
3779
3780   if (b != NULL && b->value.logical != 0)
3781     back = 1;
3782   else
3783     back = 0;
3784
3785   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3786                                 &s->where);
3787
3788   len = s->value.character.length;
3789   lenset = set->value.character.length;
3790
3791   if (len == 0)
3792     {
3793       mpz_set_ui (result->value.integer, 0);
3794       return result;
3795     }
3796
3797   if (back == 0)
3798     {
3799       if (lenset == 0)
3800         {
3801           mpz_set_ui (result->value.integer, 1);
3802           return result;
3803         }
3804
3805       index =
3806         strspn (s->value.character.string, set->value.character.string) + 1;
3807       if (index > len)
3808         index = 0;
3809
3810     }
3811   else
3812     {
3813       if (lenset == 0)
3814         {
3815           mpz_set_ui (result->value.integer, len);
3816           return result;
3817         }
3818       for (index = len; index > 0; index --)
3819         {
3820           for (i = 0; i < lenset; i++)
3821             {
3822               if (s->value.character.string[index - 1]
3823                     == set->value.character.string[i])
3824                 break;
3825             }
3826           if (i == lenset)
3827             break;
3828         }
3829     }
3830
3831   mpz_set_ui (result->value.integer, index);
3832   return result;
3833 }
3834
3835
3836 gfc_expr *
3837 gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
3838 {
3839   gfc_expr *result;
3840   int kind;
3841
3842   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3843     return NULL;
3844
3845   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3846   if (x->ts.type == BT_INTEGER)
3847     {
3848       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3849       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3850     }
3851   else /* BT_LOGICAL */
3852     {
3853       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3854       result->value.logical = (x->value.logical && ! y->value.logical)
3855                               || (! x->value.logical && y->value.logical);
3856     }
3857
3858   return range_check (result, "XOR");
3859 }
3860
3861
3862
3863 /****************** Constant simplification *****************/
3864
3865 /* Master function to convert one constant to another.  While this is
3866    used as a simplification function, it requires the destination type
3867    and kind information which is supplied by a special case in
3868    do_simplify().  */
3869
3870 gfc_expr *
3871 gfc_convert_constant (gfc_expr * e, bt type, int kind)
3872 {
3873   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
3874   gfc_constructor *head, *c, *tail = NULL;
3875
3876   switch (e->ts.type)
3877     {
3878     case BT_INTEGER:
3879       switch (type)
3880         {
3881         case BT_INTEGER:
3882           f = gfc_int2int;
3883           break;
3884         case BT_REAL:
3885           f = gfc_int2real;
3886           break;
3887         case BT_COMPLEX:
3888           f = gfc_int2complex;
3889           break;
3890         case BT_LOGICAL:
3891           f = gfc_int2log;
3892           break;
3893         default:
3894           goto oops;
3895         }
3896       break;
3897
3898     case BT_REAL:
3899       switch (type)
3900         {
3901         case BT_INTEGER:
3902           f = gfc_real2int;
3903           break;
3904         case BT_REAL:
3905           f = gfc_real2real;
3906           break;
3907         case BT_COMPLEX:
3908           f = gfc_real2complex;
3909           break;
3910         default:
3911           goto oops;
3912         }
3913       break;
3914
3915     case BT_COMPLEX:
3916       switch (type)
3917         {
3918         case BT_INTEGER:
3919           f = gfc_complex2int;
3920           break;
3921         case BT_REAL:
3922           f = gfc_complex2real;
3923           break;
3924         case BT_COMPLEX:
3925           f = gfc_complex2complex;
3926           break;
3927
3928         default:
3929           goto oops;
3930         }
3931       break;
3932
3933     case BT_LOGICAL:
3934       switch (type)
3935         {
3936         case BT_INTEGER:
3937           f = gfc_log2int;
3938           break;
3939         case BT_LOGICAL:
3940           f = gfc_log2log;
3941           break;
3942         default:
3943           goto oops;
3944         }
3945       break;
3946
3947     case BT_HOLLERITH:
3948       switch (type)
3949         {
3950         case BT_INTEGER:
3951           f = gfc_hollerith2int;
3952           break;
3953
3954         case BT_REAL:
3955           f = gfc_hollerith2real;
3956           break;
3957
3958         case BT_COMPLEX:
3959           f = gfc_hollerith2complex;
3960           break;
3961
3962         case BT_CHARACTER:
3963           f = gfc_hollerith2character;
3964           break;
3965
3966         case BT_LOGICAL:
3967           f = gfc_hollerith2logical;
3968           break;
3969
3970         default:
3971           goto oops;
3972         }
3973       break;
3974
3975     default:
3976     oops:
3977       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3978     }
3979
3980   result = NULL;
3981
3982   switch (e->expr_type)
3983     {
3984     case EXPR_CONSTANT:
3985       result = f (e, kind);
3986       if (result == NULL)
3987         return &gfc_bad_expr;
3988       break;
3989
3990     case EXPR_ARRAY:
3991       if (!gfc_is_constant_expr (e))
3992         break;
3993
3994       head = NULL;
3995
3996       for (c = e->value.constructor; c; c = c->next)
3997         {
3998           if (head == NULL)
3999             head = tail = gfc_get_constructor ();
4000           else
4001             {
4002               tail->next = gfc_get_constructor ();
4003               tail = tail->next;
4004             }
4005
4006           tail->where = c->where;
4007
4008           if (c->iterator == NULL)
4009             tail->expr = f (c->expr, kind);
4010           else
4011             {
4012               g = gfc_convert_constant (c->expr, type, kind);
4013               if (g == &gfc_bad_expr)
4014                 return g;
4015               tail->expr = g;
4016             }
4017
4018           if (tail->expr == NULL)
4019             {
4020               gfc_free_constructor (head);
4021               return NULL;
4022             }
4023         }
4024
4025       result = gfc_get_expr ();
4026       result->ts.type = type;
4027       result->ts.kind = kind;
4028       result->expr_type = EXPR_ARRAY;
4029       result->value.constructor = head;
4030       result->shape = gfc_copy_shape (e->shape, e->rank);
4031       result->where = e->where;
4032       result->rank = e->rank;
4033       break;
4034
4035     default:
4036       break;
4037     }
4038
4039   return result;
4040 }
4041
4042
4043 /****************** Helper functions ***********************/
4044
4045 /* Given a collating table, create the inverse table.  */
4046
4047 static void
4048 invert_table (const int *table, int *xtable)
4049 {
4050   int i;
4051
4052   for (i = 0; i < 256; i++)
4053     xtable[i] = 0;
4054
4055   for (i = 0; i < 256; i++)
4056     xtable[table[i]] = i;
4057 }
4058
4059
4060 void
4061 gfc_simplify_init_1 (void)
4062 {
4063
4064   invert_table (ascii_table, xascii_table);
4065 }