gcc/fortran/simplify.c

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