gcc/fortran/simplify.c

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