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