gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
   3    Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "arith.h"
  28 #include "intrinsic.h"
  29
  30 gfc_expr gfc_bad_expr;
  31
  32
  33 /* Note that 'simplification' is not just transforming expressions.
  34    For functions that are not simplified at compile time, range
  35    checking is done if possible.
  36
  37    The return convention is that each simplification function returns:
  38
  39      A new expression node corresponding to the simplified arguments.
  40      The original arguments are destroyed by the caller, and must not
  41      be a part of the new expression.
  42
  43      NULL pointer indicating that no simplification was possible and
  44      the original expression should remain intact.  If the
  45      simplification function sets the type and/or the function name
  46      via the pointer gfc_simple_expression, then this type is
  47      retained.
  48
  49      An expression pointer to gfc_bad_expr (a static placeholder)
  50      indicating that some error has prevented simplification.  For
  51      example, sqrt(-1.0).  The error is generated within the function
  52      and should be propagated upwards
  53
  54    By the time a simplification function gets control, it has been
  55    decided that the function call is really supposed to be the
  56    intrinsic.  No type checking is strictly necessary, since only
  57    valid types will be passed on.  On the other hand, a simplification
  58    subroutine may have to look at the type of an argument as part of
  59    its processing.
  60
  61    Array arguments are never passed to these subroutines.
  62
  63    The functions in this file don't have much comment with them, but
  64    everything is reasonably straight-forward.  The Standard, chapter 13
  65    is the best comment you'll find for this file anyway.  */
  66
  67 /* Static table for converting non-ascii character sets to ascii.
  68    The xascii_table[] is the inverse table.  */
  69
  70 static int ascii_table[256] = {
  71   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  72   '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
  73   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  74   '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
  75   ' ', '!', '\'', '#', '$', '%', '&', '\'',
  76   '(', ')', '*', '+', ',', '-', '.', '/',
  77   '0', '1', '2', '3', '4', '5', '6', '7',
  78   '8', '9', ':', ';', '<', '=', '>', '?',
  79   '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
  80   'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
  81   'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
  82   'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
  83   '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
  84   'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
  85   'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
  86   'x', 'y', 'z', '{', '|', '}', '~', '\?'
  87 };
  88
  89 static int xascii_table[256];
  90
  91
  92 /* Range checks an expression node.  If all goes well, returns the
  93    node, otherwise returns &gfc_bad_expr and frees the node.  */
  94
  95 static gfc_expr *
  96 range_check (gfc_expr * result, const char *name)
  97 {
  98   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 > UCHAR_MAX)
 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 = (unsigned char) e->value.character.string[0];
1374
1375   if (index < 0 || index > UCHAR_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   if (mold == NULL)
2532     {
2533       result = gfc_get_expr ();
2534       result->ts.type = BT_UNKNOWN;
2535     }
2536   else
2537     result = gfc_copy_expr (mold);
2538   result->expr_type = EXPR_NULL;
2539
2540   return result;
2541 }
2542
2543
2544 gfc_expr *
2545 gfc_simplify_or (gfc_expr * x, gfc_expr * y)
2546 {
2547   gfc_expr *result;
2548   int kind;
2549
2550   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2551     return NULL;
2552
2553   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2554   if (x->ts.type == BT_INTEGER)
2555     {
2556       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2557       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2558     }
2559   else /* BT_LOGICAL */
2560     {
2561       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2562       result->value.logical = x->value.logical || y->value.logical;
2563     }
2564
2565   return range_check (result, "OR");
2566 }
2567
2568
2569 gfc_expr *
2570 gfc_simplify_precision (gfc_expr * e)
2571 {
2572   gfc_expr *result;
2573   int i;
2574
2575   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2576
2577   result = gfc_int_expr (gfc_real_kinds[i].precision);
2578   result->where = e->where;
2579
2580   return result;
2581 }
2582
2583
2584 gfc_expr *
2585 gfc_simplify_radix (gfc_expr * e)
2586 {
2587   gfc_expr *result;
2588   int i;
2589
2590   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2591   switch (e->ts.type)
2592     {
2593     case BT_INTEGER:
2594       i = gfc_integer_kinds[i].radix;
2595       break;
2596
2597     case BT_REAL:
2598       i = gfc_real_kinds[i].radix;
2599       break;
2600
2601     default:
2602       gcc_unreachable ();
2603     }
2604
2605   result = gfc_int_expr (i);
2606   result->where = e->where;
2607
2608   return result;
2609 }
2610
2611
2612 gfc_expr *
2613 gfc_simplify_range (gfc_expr * e)
2614 {
2615   gfc_expr *result;
2616   int i;
2617   long j;
2618
2619   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2620
2621   switch (e->ts.type)
2622     {
2623     case BT_INTEGER:
2624       j = gfc_integer_kinds[i].range;
2625       break;
2626
2627     case BT_REAL:
2628     case BT_COMPLEX:
2629       j = gfc_real_kinds[i].range;
2630       break;
2631
2632     default:
2633       gcc_unreachable ();
2634     }
2635
2636   result = gfc_int_expr (j);
2637   result->where = e->where;
2638
2639   return result;
2640 }
2641
2642
2643 gfc_expr *
2644 gfc_simplify_real (gfc_expr * e, gfc_expr * k)
2645 {
2646   gfc_expr *result;
2647   int kind;
2648
2649   if (e->ts.type == BT_COMPLEX)
2650     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2651   else
2652     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2653
2654   if (kind == -1)
2655     return &gfc_bad_expr;
2656
2657   if (e->expr_type != EXPR_CONSTANT)
2658     return NULL;
2659
2660   switch (e->ts.type)
2661     {
2662     case BT_INTEGER:
2663       result = gfc_int2real (e, kind);
2664       break;
2665
2666     case BT_REAL:
2667       result = gfc_real2real (e, kind);
2668       break;
2669
2670     case BT_COMPLEX:
2671       result = gfc_complex2real (e, kind);
2672       break;
2673
2674     default:
2675       gfc_internal_error ("bad type in REAL");
2676       /* Not reached */
2677     }
2678
2679   return range_check (result, "REAL");
2680 }
2681
2682
2683 gfc_expr *
2684 gfc_simplify_realpart (gfc_expr * e)
2685 {
2686   gfc_expr *result;
2687
2688   if (e->expr_type != EXPR_CONSTANT)
2689     return NULL;
2690
2691   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2692   mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2693
2694   return range_check (result, "REALPART");
2695 }
2696
2697 gfc_expr *
2698 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
2699 {
2700   gfc_expr *result;
2701   int i, j, len, ncopies, nlen;
2702
2703   if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
2704     return NULL;
2705
2706   if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
2707     {
2708       gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
2709       return &gfc_bad_expr;
2710     }
2711
2712   len = e->value.character.length;
2713   nlen = ncopies * len;
2714
2715   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2716
2717   if (ncopies == 0)
2718     {
2719       result->value.character.string = gfc_getmem (1);
2720       result->value.character.length = 0;
2721       result->value.character.string[0] = '\0';
2722       return result;
2723     }
2724
2725   result->value.character.length = nlen;
2726   result->value.character.string = gfc_getmem (nlen + 1);
2727
2728   for (i = 0; i < ncopies; i++)
2729     for (j = 0; j < len; j++)
2730       result->value.character.string[j + i * len] =
2731         e->value.character.string[j];
2732
2733   result->value.character.string[nlen] = '\0';  /* For debugger */
2734   return result;
2735 }
2736
2737
2738 /* This one is a bear, but mainly has to do with shuffling elements.  */
2739
2740 gfc_expr *
2741 gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
2742                       gfc_expr * pad, gfc_expr * order_exp)
2743 {
2744
2745   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2746   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2747   gfc_constructor *head, *tail;
2748   mpz_t index, size;
2749   unsigned long j;
2750   size_t nsource;
2751   gfc_expr *e;
2752
2753   /* Unpack the shape array.  */
2754   if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2755     return NULL;
2756
2757   if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2758     return NULL;
2759
2760   if (pad != NULL
2761       && (pad->expr_type != EXPR_ARRAY
2762           || !gfc_is_constant_expr (pad)))
2763     return NULL;
2764
2765   if (order_exp != NULL
2766       && (order_exp->expr_type != EXPR_ARRAY
2767           || !gfc_is_constant_expr (order_exp)))
2768     return NULL;
2769
2770   mpz_init (index);
2771   rank = 0;
2772   head = tail = NULL;
2773
2774   for (;;)
2775     {
2776       e = gfc_get_array_element (shape_exp, rank);
2777       if (e == NULL)
2778         break;
2779
2780       if (gfc_extract_int (e, &shape[rank]) != NULL)
2781         {
2782           gfc_error ("Integer too large in shape specification at %L",
2783                      &e->where);
2784           gfc_free_expr (e);
2785           goto bad_reshape;
2786         }
2787
2788       gfc_free_expr (e);
2789
2790       if (rank >= GFC_MAX_DIMENSIONS)
2791         {
2792           gfc_error ("Too many dimensions in shape specification for RESHAPE "
2793                      "at %L", &e->where);
2794
2795           goto bad_reshape;
2796         }
2797
2798       if (shape[rank] < 0)
2799         {
2800           gfc_error ("Shape specification at %L cannot be negative",
2801                      &e->where);
2802           goto bad_reshape;
2803         }
2804
2805       rank++;
2806     }
2807
2808   if (rank == 0)
2809     {
2810       gfc_error ("Shape specification at %L cannot be the null array",
2811                  &shape_exp->where);
2812       goto bad_reshape;
2813     }
2814
2815   /* Now unpack the order array if present.  */
2816   if (order_exp == NULL)
2817     {
2818       for (i = 0; i < rank; i++)
2819         order[i] = i;
2820
2821     }
2822   else
2823     {
2824
2825       for (i = 0; i < rank; i++)
2826         x[i] = 0;
2827
2828       for (i = 0; i < rank; i++)
2829         {
2830           e = gfc_get_array_element (order_exp, i);
2831           if (e == NULL)
2832             {
2833               gfc_error
2834                 ("ORDER parameter of RESHAPE at %L is not the same size "
2835                  "as SHAPE parameter", &order_exp->where);
2836               goto bad_reshape;
2837             }
2838
2839           if (gfc_extract_int (e, &order[i]) != NULL)
2840             {
2841               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2842                          &e->where);
2843               gfc_free_expr (e);
2844               goto bad_reshape;
2845             }
2846
2847           gfc_free_expr (e);
2848
2849           if (order[i] < 1 || order[i] > rank)
2850             {
2851               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2852                          &e->where);
2853               goto bad_reshape;
2854             }
2855
2856           order[i]--;
2857
2858           if (x[order[i]])
2859             {
2860               gfc_error ("Invalid permutation in ORDER parameter at %L",
2861                          &e->where);
2862               goto bad_reshape;
2863             }
2864
2865           x[order[i]] = 1;
2866         }
2867     }
2868
2869   /* Count the elements in the source and padding arrays.  */
2870
2871   npad = 0;
2872   if (pad != NULL)
2873     {
2874       gfc_array_size (pad, &size);
2875       npad = mpz_get_ui (size);
2876       mpz_clear (size);
2877     }
2878
2879   gfc_array_size (source, &size);
2880   nsource = mpz_get_ui (size);
2881   mpz_clear (size);
2882
2883   /* If it weren't for that pesky permutation we could just loop
2884      through the source and round out any shortage with pad elements.
2885      But no, someone just had to have the compiler do something the
2886      user should be doing.  */
2887
2888   for (i = 0; i < rank; i++)
2889     x[i] = 0;
2890
2891   for (;;)
2892     {
2893       /* Figure out which element to extract.  */
2894       mpz_set_ui (index, 0);
2895
2896       for (i = rank - 1; i >= 0; i--)
2897         {
2898           mpz_add_ui (index, index, x[order[i]]);
2899           if (i != 0)
2900             mpz_mul_ui (index, index, shape[order[i - 1]]);
2901         }
2902
2903       if (mpz_cmp_ui (index, INT_MAX) > 0)
2904         gfc_internal_error ("Reshaped array too large at %L", &e->where);
2905
2906       j = mpz_get_ui (index);
2907
2908       if (j < nsource)
2909         e = gfc_get_array_element (source, j);
2910       else
2911         {
2912           j = j - nsource;
2913
2914           if (npad == 0)
2915             {
2916               gfc_error
2917                 ("PAD parameter required for short SOURCE parameter at %L",
2918                  &source->where);
2919               goto bad_reshape;
2920             }
2921
2922           j = j % npad;
2923           e = gfc_get_array_element (pad, j);
2924         }
2925
2926       if (head == NULL)
2927         head = tail = gfc_get_constructor ();
2928       else
2929         {
2930           tail->next = gfc_get_constructor ();
2931           tail = tail->next;
2932         }
2933
2934       if (e == NULL)
2935         goto bad_reshape;
2936
2937       tail->where = e->where;
2938       tail->expr = e;
2939
2940       /* Calculate the next element.  */
2941       i = 0;
2942
2943 inc:
2944       if (++x[i] < shape[i])
2945         continue;
2946       x[i++] = 0;
2947       if (i < rank)
2948         goto inc;
2949
2950       break;
2951     }
2952
2953   mpz_clear (index);
2954
2955   e = gfc_get_expr ();
2956   e->where = source->where;
2957   e->expr_type = EXPR_ARRAY;
2958   e->value.constructor = head;
2959   e->shape = gfc_get_shape (rank);
2960
2961   for (i = 0; i < rank; i++)
2962     mpz_init_set_ui (e->shape[i], shape[i]);
2963
2964   e->ts = source->ts;
2965   e->rank = rank;
2966
2967   return e;
2968
2969 bad_reshape:
2970   gfc_free_constructor (head);
2971   mpz_clear (index);
2972   return &gfc_bad_expr;
2973 }
2974
2975
2976 gfc_expr *
2977 gfc_simplify_rrspacing (gfc_expr * x)
2978 {
2979   gfc_expr *result;
2980   mpfr_t absv, log2, exp, frac, pow2;
2981   int i, p;
2982
2983   if (x->expr_type != EXPR_CONSTANT)
2984     return NULL;
2985
2986   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2987
2988   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2989
2990   p = gfc_real_kinds[i].digits;
2991
2992   gfc_set_model_kind (x->ts.kind);
2993
2994   if (mpfr_sgn (x->value.real) == 0)
2995     {
2996       mpfr_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny, GFC_RND_MODE);
2997       return result;
2998     }
2999
3000   mpfr_init (log2);
3001   mpfr_init (absv);
3002   mpfr_init (frac);
3003   mpfr_init (pow2);
3004
3005   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3006   mpfr_log2 (log2, absv, GFC_RND_MODE);
3007
3008   mpfr_trunc (log2, log2);
3009   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3010
3011   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3012   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3013
3014   mpfr_mul_2exp (result->value.real, frac, (unsigned long)p, GFC_RND_MODE);
3015
3016   mpfr_clear (log2);
3017   mpfr_clear (absv);
3018   mpfr_clear (frac);
3019   mpfr_clear (pow2);
3020
3021   return range_check (result, "RRSPACING");
3022 }
3023
3024
3025 gfc_expr *
3026 gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
3027 {
3028   int k, neg_flag, power, exp_range;
3029   mpfr_t scale, radix;
3030   gfc_expr *result;
3031
3032   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3033     return NULL;
3034
3035   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3036
3037   if (mpfr_sgn (x->value.real) == 0)
3038     {
3039       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3040       return result;
3041     }
3042
3043   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3044
3045   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3046
3047   /* This check filters out values of i that would overflow an int.  */
3048   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3049       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3050     {
3051       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3052       return &gfc_bad_expr;
3053     }
3054
3055   /* Compute scale = radix ** power.  */
3056   power = mpz_get_si (i->value.integer);
3057
3058   if (power >= 0)
3059     neg_flag = 0;
3060   else
3061     {
3062       neg_flag = 1;
3063       power = -power;
3064     }
3065
3066   gfc_set_model_kind (x->ts.kind);
3067   mpfr_init (scale);
3068   mpfr_init (radix);
3069   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3070   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3071
3072   if (neg_flag)
3073     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3074   else
3075     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3076
3077   mpfr_clear (scale);
3078   mpfr_clear (radix);
3079
3080   return range_check (result, "SCALE");
3081 }
3082
3083
3084 gfc_expr *
3085 gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
3086 {
3087   gfc_expr *result;
3088   int back;
3089   size_t i;
3090   size_t indx, len, lenc;
3091
3092   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3093     return NULL;
3094
3095   if (b != NULL && b->value.logical != 0)
3096     back = 1;
3097   else
3098     back = 0;
3099
3100   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3101                                 &e->where);
3102
3103   len = e->value.character.length;
3104   lenc = c->value.character.length;
3105
3106   if (len == 0 || lenc == 0)
3107     {
3108       indx = 0;
3109     }
3110   else
3111     {
3112       if (back == 0)
3113         {
3114           indx =
3115             strcspn (e->value.character.string, c->value.character.string) + 1;
3116           if (indx > len)
3117             indx = 0;
3118         }
3119       else
3120         {
3121           i = 0;
3122           for (indx = len; indx > 0; indx--)
3123             {
3124               for (i = 0; i < lenc; i++)
3125                 {
3126                   if (c->value.character.string[i]
3127                         == e->value.character.string[indx - 1])
3128                     break;
3129                 }
3130               if (i < lenc)
3131                 break;
3132             }
3133         }
3134     }
3135   mpz_set_ui (result->value.integer, indx);
3136   return range_check (result, "SCAN");
3137 }
3138
3139
3140 gfc_expr *
3141 gfc_simplify_selected_int_kind (gfc_expr * e)
3142 {
3143   int i, kind, range;
3144   gfc_expr *result;
3145
3146   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3147     return NULL;
3148
3149   kind = INT_MAX;
3150
3151   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3152     if (gfc_integer_kinds[i].range >= range
3153         && gfc_integer_kinds[i].kind < kind)
3154       kind = gfc_integer_kinds[i].kind;
3155
3156   if (kind == INT_MAX)
3157     kind = -1;
3158
3159   result = gfc_int_expr (kind);
3160   result->where = e->where;
3161
3162   return result;
3163 }
3164
3165
3166 gfc_expr *
3167 gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
3168 {
3169   int range, precision, i, kind, found_precision, found_range;
3170   gfc_expr *result;
3171
3172   if (p == NULL)
3173     precision = 0;
3174   else
3175     {
3176       if (p->expr_type != EXPR_CONSTANT
3177           || gfc_extract_int (p, &precision) != NULL)
3178         return NULL;
3179     }
3180
3181   if (q == NULL)
3182     range = 0;
3183   else
3184     {
3185       if (q->expr_type != EXPR_CONSTANT
3186           || gfc_extract_int (q, &range) != NULL)
3187         return NULL;
3188     }
3189
3190   kind = INT_MAX;
3191   found_precision = 0;
3192   found_range = 0;
3193
3194   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3195     {
3196       if (gfc_real_kinds[i].precision >= precision)
3197         found_precision = 1;
3198
3199       if (gfc_real_kinds[i].range >= range)
3200         found_range = 1;
3201
3202       if (gfc_real_kinds[i].precision >= precision
3203           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3204         kind = gfc_real_kinds[i].kind;
3205     }
3206
3207   if (kind == INT_MAX)
3208     {
3209       kind = 0;
3210
3211       if (!found_precision)
3212         kind = -1;
3213       if (!found_range)
3214         kind -= 2;
3215     }
3216
3217   result = gfc_int_expr (kind);
3218   result->where = (p != NULL) ? p->where : q->where;
3219
3220   return result;
3221 }
3222
3223
3224 gfc_expr *
3225 gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
3226 {
3227   gfc_expr *result;
3228   mpfr_t exp, absv, log2, pow2, frac;
3229   unsigned long exp2;
3230
3231   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3232     return NULL;
3233
3234   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3235
3236   gfc_set_model_kind (x->ts.kind);
3237
3238   if (mpfr_sgn (x->value.real) == 0)
3239     {
3240       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3241       return result;
3242     }
3243
3244   mpfr_init (absv);
3245   mpfr_init (log2);
3246   mpfr_init (exp);
3247   mpfr_init (pow2);
3248   mpfr_init (frac);
3249
3250   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3251   mpfr_log2 (log2, absv, GFC_RND_MODE);
3252
3253   mpfr_trunc (log2, log2);
3254   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3255
3256   /* Old exponent value, and fraction.  */
3257   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3258
3259   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3260
3261   /* New exponent.  */
3262   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3263   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3264
3265   mpfr_clear (absv);
3266   mpfr_clear (log2);
3267   mpfr_clear (pow2);
3268   mpfr_clear (frac);
3269
3270   return range_check (result, "SET_EXPONENT");
3271 }
3272
3273
3274 gfc_expr *
3275 gfc_simplify_shape (gfc_expr * source)
3276 {
3277   mpz_t shape[GFC_MAX_DIMENSIONS];
3278   gfc_expr *result, *e, *f;
3279   gfc_array_ref *ar;
3280   int n;
3281   try t;
3282
3283   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3284     return NULL;
3285
3286   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3287                                   &source->where);
3288
3289   ar = gfc_find_array_ref (source);
3290
3291   t = gfc_array_ref_shape (ar, shape);
3292
3293   for (n = 0; n < source->rank; n++)
3294     {
3295       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3296                                &source->where);
3297
3298       if (t == SUCCESS)
3299         {
3300           mpz_set (e->value.integer, shape[n]);
3301           mpz_clear (shape[n]);
3302         }
3303       else
3304         {
3305           mpz_set_ui (e->value.integer, n + 1);
3306
3307           f = gfc_simplify_size (source, e);
3308           gfc_free_expr (e);
3309           if (f == NULL)
3310             {
3311               gfc_free_expr (result);
3312               return NULL;
3313             }
3314           else
3315             {
3316               e = f;
3317             }
3318         }
3319
3320       gfc_append_constructor (result, e);
3321     }
3322
3323   return result;
3324 }
3325
3326
3327 gfc_expr *
3328 gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
3329 {
3330   mpz_t size;
3331   gfc_expr *result;
3332   int d;
3333
3334   if (dim == NULL)
3335     {
3336       if (gfc_array_size (array, &size) == FAILURE)
3337         return NULL;
3338     }
3339   else
3340     {
3341       if (dim->expr_type != EXPR_CONSTANT)
3342         return NULL;
3343
3344       d = mpz_get_ui (dim->value.integer) - 1;
3345       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3346         return NULL;
3347     }
3348
3349   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3350                                 &array->where);
3351
3352   mpz_set (result->value.integer, size);
3353
3354   return result;
3355 }
3356
3357
3358 gfc_expr *
3359 gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
3360 {
3361   gfc_expr *result;
3362
3363   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3364     return NULL;
3365
3366   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3367
3368   switch (x->ts.type)
3369     {
3370     case BT_INTEGER:
3371       mpz_abs (result->value.integer, x->value.integer);
3372       if (mpz_sgn (y->value.integer) < 0)
3373         mpz_neg (result->value.integer, result->value.integer);
3374
3375       break;
3376
3377     case BT_REAL:
3378       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3379          it.  */
3380       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3381       if (mpfr_sgn (y->value.real) < 0)
3382         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3383
3384       break;
3385
3386     default:
3387       gfc_internal_error ("Bad type in gfc_simplify_sign");
3388     }
3389
3390   return result;
3391 }
3392
3393
3394 gfc_expr *
3395 gfc_simplify_sin (gfc_expr * x)
3396 {
3397   gfc_expr *result;
3398   mpfr_t xp, xq;
3399
3400   if (x->expr_type != EXPR_CONSTANT)
3401     return NULL;
3402
3403   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3404
3405   switch (x->ts.type)
3406     {
3407     case BT_REAL:
3408       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3409       break;
3410
3411     case BT_COMPLEX:
3412       gfc_set_model (x->value.real);
3413       mpfr_init (xp);
3414       mpfr_init (xq);
3415
3416       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3417       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3418       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3419
3420       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3421       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3422       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3423
3424       mpfr_clear (xp);
3425       mpfr_clear (xq);
3426       break;
3427
3428     default:
3429       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3430     }
3431
3432   return range_check (result, "SIN");
3433 }
3434
3435
3436 gfc_expr *
3437 gfc_simplify_sinh (gfc_expr * x)
3438 {
3439   gfc_expr *result;
3440
3441   if (x->expr_type != EXPR_CONSTANT)
3442     return NULL;
3443
3444   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3445
3446   mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
3447
3448   return range_check (result, "SINH");
3449 }
3450
3451
3452 /* The argument is always a double precision real that is converted to
3453    single precision.  TODO: Rounding!  */
3454
3455 gfc_expr *
3456 gfc_simplify_sngl (gfc_expr * a)
3457 {
3458   gfc_expr *result;
3459
3460   if (a->expr_type != EXPR_CONSTANT)
3461     return NULL;
3462
3463   result = gfc_real2real (a, gfc_default_real_kind);
3464   return range_check (result, "SNGL");
3465 }
3466
3467
3468 gfc_expr *
3469 gfc_simplify_spacing (gfc_expr * x)
3470 {
3471   gfc_expr *result;
3472   mpfr_t absv, log2;
3473   long diff;
3474   int i, p;
3475
3476   if (x->expr_type != EXPR_CONSTANT)
3477     return NULL;
3478
3479   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3480
3481   p = gfc_real_kinds[i].digits;
3482
3483   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3484
3485   gfc_set_model_kind (x->ts.kind);
3486
3487   if (mpfr_sgn (x->value.real) == 0)
3488     {
3489       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3490       return result;
3491     }
3492
3493   mpfr_init (log2);
3494   mpfr_init (absv);
3495
3496   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3497   mpfr_log2 (log2, absv, GFC_RND_MODE);
3498   mpfr_trunc (log2, log2);
3499
3500   mpfr_add_ui (log2, log2, 1, GFC_RND_MODE);
3501
3502   /* FIXME: We should be using mpfr_get_si here, but this function is
3503      not available with the version of mpfr distributed with gmp (as of
3504      2004-09-17). Replace once mpfr has been imported into the gcc cvs
3505      tree.  */
3506   diff = (long)mpfr_get_d (log2, GFC_RND_MODE) - (long)p;
3507   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3508   mpfr_mul_2si (result->value.real, result->value.real, diff, GFC_RND_MODE);
3509
3510   mpfr_clear (log2);
3511   mpfr_clear (absv);
3512
3513   if (mpfr_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
3514     mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3515
3516   return range_check (result, "SPACING");
3517 }
3518
3519
3520 gfc_expr *
3521 gfc_simplify_sqrt (gfc_expr * e)
3522 {
3523   gfc_expr *result;
3524   mpfr_t ac, ad, s, t, w;
3525
3526   if (e->expr_type != EXPR_CONSTANT)
3527     return NULL;
3528
3529   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3530
3531   switch (e->ts.type)
3532     {
3533     case BT_REAL:
3534       if (mpfr_cmp_si (e->value.real, 0) < 0)
3535         goto negative_arg;
3536       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3537
3538       break;
3539
3540     case BT_COMPLEX:
3541       /* Formula taken from Numerical Recipes to avoid over- and
3542          underflow.  */
3543
3544       gfc_set_model (e->value.real);
3545       mpfr_init (ac);
3546       mpfr_init (ad);
3547       mpfr_init (s);
3548       mpfr_init (t);
3549       mpfr_init (w);
3550
3551       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3552           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3553         {
3554
3555           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3556           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3557           break;
3558         }
3559
3560       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3561       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3562
3563       if (mpfr_cmp (ac, ad) >= 0)
3564         {
3565           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3566           mpfr_mul (t, t, t, GFC_RND_MODE);
3567           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3568           mpfr_sqrt (t, t, GFC_RND_MODE);
3569           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3570           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3571           mpfr_sqrt (t, t, GFC_RND_MODE);
3572           mpfr_sqrt (s, ac, GFC_RND_MODE);
3573           mpfr_mul (w, s, t, GFC_RND_MODE);
3574         }
3575       else
3576         {
3577           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3578           mpfr_mul (t, s, s, GFC_RND_MODE);
3579           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3580           mpfr_sqrt (t, t, GFC_RND_MODE);
3581           mpfr_abs (s, s, GFC_RND_MODE);
3582           mpfr_add (t, t, s, GFC_RND_MODE);
3583           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3584           mpfr_sqrt (t, t, GFC_RND_MODE);
3585           mpfr_sqrt (s, ad, GFC_RND_MODE);
3586           mpfr_mul (w, s, t, GFC_RND_MODE);
3587         }
3588
3589       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3590         {
3591           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3592           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3593           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3594         }
3595       else if (mpfr_cmp_ui (w, 0) != 0
3596                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3597                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3598         {
3599           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3600           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3601           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3602         }
3603       else if (mpfr_cmp_ui (w, 0) != 0
3604                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3605                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3606         {
3607           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3608           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3609           mpfr_neg (w, w, GFC_RND_MODE);
3610           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3611         }
3612       else
3613         gfc_internal_error ("invalid complex argument of SQRT at %L",
3614                             &e->where);
3615
3616       mpfr_clear (s);
3617       mpfr_clear (t);
3618       mpfr_clear (ac);
3619       mpfr_clear (ad);
3620       mpfr_clear (w);
3621
3622       break;
3623
3624     default:
3625       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3626     }
3627
3628   return range_check (result, "SQRT");
3629
3630 negative_arg:
3631   gfc_free_expr (result);
3632   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3633   return &gfc_bad_expr;
3634 }
3635
3636
3637 gfc_expr *
3638 gfc_simplify_tan (gfc_expr * x)
3639 {
3640   int i;
3641   gfc_expr *result;
3642
3643   if (x->expr_type != EXPR_CONSTANT)
3644     return NULL;
3645
3646   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3647
3648   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3649
3650   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3651
3652   return range_check (result, "TAN");
3653 }
3654
3655
3656 gfc_expr *
3657 gfc_simplify_tanh (gfc_expr * x)
3658 {
3659   gfc_expr *result;
3660
3661   if (x->expr_type != EXPR_CONSTANT)
3662     return NULL;
3663
3664   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3665
3666   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3667
3668   return range_check (result, "TANH");
3669
3670 }
3671
3672
3673 gfc_expr *
3674 gfc_simplify_tiny (gfc_expr * e)
3675 {
3676   gfc_expr *result;
3677   int i;
3678
3679   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3680
3681   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3682   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3683
3684   return result;
3685 }
3686
3687
3688 gfc_expr *
3689 gfc_simplify_trim (gfc_expr * e)
3690 {
3691   gfc_expr *result;
3692   int count, i, len, lentrim;
3693
3694   if (e->expr_type != EXPR_CONSTANT)
3695     return NULL;
3696
3697   len = e->value.character.length;
3698
3699   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3700
3701   for (count = 0, i = 1; i <= len; ++i)
3702     {
3703       if (e->value.character.string[len - i] == ' ')
3704         count++;
3705       else
3706         break;
3707     }
3708
3709   lentrim = len - count;
3710
3711   result->value.character.length = lentrim;
3712   result->value.character.string = gfc_getmem (lentrim + 1);
3713
3714   for (i = 0; i < lentrim; i++)
3715     result->value.character.string[i] = e->value.character.string[i];
3716
3717   result->value.character.string[lentrim] = '\0';       /* For debugger */
3718
3719   return result;
3720 }
3721
3722
3723 gfc_expr *
3724 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
3725 {
3726   return simplify_bound (array, dim, 1);
3727 }
3728
3729
3730 gfc_expr *
3731 gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
3732 {
3733   gfc_expr *result;
3734   int back;
3735   size_t index, len, lenset;
3736   size_t i;
3737
3738   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3739     return NULL;
3740
3741   if (b != NULL && b->value.logical != 0)
3742     back = 1;
3743   else
3744     back = 0;
3745
3746   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3747                                 &s->where);
3748
3749   len = s->value.character.length;
3750   lenset = set->value.character.length;
3751
3752   if (len == 0)
3753     {
3754       mpz_set_ui (result->value.integer, 0);
3755       return result;
3756     }
3757
3758   if (back == 0)
3759     {
3760       if (lenset == 0)
3761         {
3762           mpz_set_ui (result->value.integer, 1);
3763           return result;
3764         }
3765
3766       index =
3767         strspn (s->value.character.string, set->value.character.string) + 1;
3768       if (index > len)
3769         index = 0;
3770
3771     }
3772   else
3773     {
3774       if (lenset == 0)
3775         {
3776           mpz_set_ui (result->value.integer, len);
3777           return result;
3778         }
3779       for (index = len; index > 0; index --)
3780         {
3781           for (i = 0; i < lenset; i++)
3782             {
3783               if (s->value.character.string[index - 1]
3784                     == set->value.character.string[i])
3785                 break;
3786             }
3787           if (i == lenset)
3788             break;
3789         }
3790     }
3791
3792   mpz_set_ui (result->value.integer, index);
3793   return result;
3794 }
3795
3796
3797 gfc_expr *
3798 gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
3799 {
3800   gfc_expr *result;
3801   int kind;
3802
3803   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3804     return NULL;
3805
3806   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3807   if (x->ts.type == BT_INTEGER)
3808     {
3809       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3810       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3811     }
3812   else /* BT_LOGICAL */
3813     {
3814       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3815       result->value.logical = (x->value.logical && ! y->value.logical)
3816                               || (! x->value.logical && y->value.logical);
3817     }
3818
3819   return range_check (result, "XOR");
3820 }
3821
3822
3823
3824 /****************** Constant simplification *****************/
3825
3826 /* Master function to convert one constant to another.  While this is
3827    used as a simplification function, it requires the destination type
3828    and kind information which is supplied by a special case in
3829    do_simplify().  */
3830
3831 gfc_expr *
3832 gfc_convert_constant (gfc_expr * e, bt type, int kind)
3833 {
3834   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
3835   gfc_constructor *head, *c, *tail = NULL;
3836
3837   switch (e->ts.type)
3838     {
3839     case BT_INTEGER:
3840       switch (type)
3841         {
3842         case BT_INTEGER:
3843           f = gfc_int2int;
3844           break;
3845         case BT_REAL:
3846           f = gfc_int2real;
3847           break;
3848         case BT_COMPLEX:
3849           f = gfc_int2complex;
3850           break;
3851         case BT_LOGICAL:
3852           f = gfc_int2log;
3853           break;
3854         default:
3855           goto oops;
3856         }
3857       break;
3858
3859     case BT_REAL:
3860       switch (type)
3861         {
3862         case BT_INTEGER:
3863           f = gfc_real2int;
3864           break;
3865         case BT_REAL:
3866           f = gfc_real2real;
3867           break;
3868         case BT_COMPLEX:
3869           f = gfc_real2complex;
3870           break;
3871         default:
3872           goto oops;
3873         }
3874       break;
3875
3876     case BT_COMPLEX:
3877       switch (type)
3878         {
3879         case BT_INTEGER:
3880           f = gfc_complex2int;
3881           break;
3882         case BT_REAL:
3883           f = gfc_complex2real;
3884           break;
3885         case BT_COMPLEX:
3886           f = gfc_complex2complex;
3887           break;
3888
3889         default:
3890           goto oops;
3891         }
3892       break;
3893
3894     case BT_LOGICAL:
3895       switch (type)
3896         {
3897         case BT_INTEGER:
3898           f = gfc_log2int;
3899           break;
3900         case BT_LOGICAL:
3901           f = gfc_log2log;
3902           break;
3903         default:
3904           goto oops;
3905         }
3906       break;
3907
3908     case BT_HOLLERITH:
3909       switch (type)
3910         {
3911         case BT_INTEGER:
3912           f = gfc_hollerith2int;
3913           break;
3914
3915         case BT_REAL:
3916           f = gfc_hollerith2real;
3917           break;
3918
3919         case BT_COMPLEX:
3920           f = gfc_hollerith2complex;
3921           break;
3922
3923         case BT_CHARACTER:
3924           f = gfc_hollerith2character;
3925           break;
3926
3927         case BT_LOGICAL:
3928           f = gfc_hollerith2logical;
3929           break;
3930
3931         default:
3932           goto oops;
3933         }
3934       break;
3935
3936     default:
3937     oops:
3938       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3939     }
3940
3941   result = NULL;
3942
3943   switch (e->expr_type)
3944     {
3945     case EXPR_CONSTANT:
3946       result = f (e, kind);
3947       if (result == NULL)
3948         return &gfc_bad_expr;
3949       break;
3950
3951     case EXPR_ARRAY:
3952       if (!gfc_is_constant_expr (e))
3953         break;
3954
3955       head = NULL;
3956
3957       for (c = e->value.constructor; c; c = c->next)
3958         {
3959           if (head == NULL)
3960             head = tail = gfc_get_constructor ();
3961           else
3962             {
3963               tail->next = gfc_get_constructor ();
3964               tail = tail->next;
3965             }
3966
3967           tail->where = c->where;
3968
3969           if (c->iterator == NULL)
3970             tail->expr = f (c->expr, kind);
3971           else
3972             {
3973               g = gfc_convert_constant (c->expr, type, kind);
3974               if (g == &gfc_bad_expr)
3975                 return g;
3976               tail->expr = g;
3977             }
3978
3979           if (tail->expr == NULL)
3980             {
3981               gfc_free_constructor (head);
3982               return NULL;
3983             }
3984         }
3985
3986       result = gfc_get_expr ();
3987       result->ts.type = type;
3988       result->ts.kind = kind;
3989       result->expr_type = EXPR_ARRAY;
3990       result->value.constructor = head;
3991       result->shape = gfc_copy_shape (e->shape, e->rank);
3992       result->where = e->where;
3993       result->rank = e->rank;
3994       break;
3995
3996     default:
3997       break;
3998     }
3999
4000   return result;
4001 }
4002
4003
4004 /****************** Helper functions ***********************/
4005
4006 /* Given a collating table, create the inverse table.  */
4007
4008 static void
4009 invert_table (const int *table, int *xtable)
4010 {
4011   int i;
4012
4013   for (i = 0; i < 256; i++)
4014     xtable[i] = 0;
4015
4016   for (i = 0; i < 256; i++)
4017     xtable[table[i]] = i;
4018 }
4019
4020
4021 void
4022 gfc_simplify_init_1 (void)
4023 {
4024
4025   invert_table (ascii_table, xascii_table);
4026 }