gcc/fortran/simplify.c

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