gcc/fortran/simplify.c

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