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   bool have_length = false;
2862
2863   /* If NCOPIES isn't a constant, there's nothing we can do.  */
2864   if (n->expr_type != EXPR_CONSTANT)
2865     return NULL;
2866
2867   /* If NCOPIES is negative, it's an error.  */
2868   if (mpz_sgn (n->value.integer) < 0)
2869     {
2870       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2871                  &n->where);
2872       return &gfc_bad_expr;
2873     }
2874
2875   /* If we don't know the character length, we can do no more.  */
2876   if (e->ts.cl && e->ts.cl->length
2877         && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2878     {
2879       len = mpz_get_si (e->ts.cl->length->value.integer);
2880       have_length = true;
2881     }
2882   else if (e->expr_type == EXPR_CONSTANT
2883              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
2884     {
2885       len = e->value.character.length;
2886     }
2887   else
2888     return NULL;
2889
2890   /* If the source length is 0, any value of NCOPIES is valid
2891      and everything behaves as if NCOPIES == 0.  */
2892   mpz_init (ncopies);
2893   if (len == 0)
2894     mpz_set_ui (ncopies, 0);
2895   else
2896     mpz_set (ncopies, n->value.integer);
2897
2898   /* Check that NCOPIES isn't too large.  */
2899   if (len)
2900     {
2901       mpz_t max, mlen;
2902       int i;
2903
2904       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
2905       mpz_init (max);
2906       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2907
2908       if (have_length)
2909         {
2910           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
2911                       e->ts.cl->length->value.integer);
2912         }
2913       else
2914         {
2915           mpz_init_set_si (mlen, len);
2916           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
2917           mpz_clear (mlen);
2918         }
2919
2920       /* The check itself.  */
2921       if (mpz_cmp (ncopies, max) > 0)
2922         {
2923           mpz_clear (max);
2924           mpz_clear (ncopies);
2925           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2926                      &n->where);
2927           return &gfc_bad_expr;
2928         }
2929
2930       mpz_clear (max);
2931     }
2932   mpz_clear (ncopies);
2933
2934   /* For further simplification, we need the character string to be
2935      constant.  */
2936   if (e->expr_type != EXPR_CONSTANT)
2937     return NULL;
2938
2939   if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
2940     {
2941       const char *res = gfc_extract_int (n, &ncop);
2942       gcc_assert (res == NULL);
2943     }
2944   else
2945     ncop = 0;
2946
2947   len = e->value.character.length;
2948   nlen = ncop * len;
2949
2950   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2951
2952   if (ncop == 0)
2953     {
2954       result->value.character.string = gfc_getmem (1);
2955       result->value.character.length = 0;
2956       result->value.character.string[0] = '\0';
2957       return result;
2958     }
2959
2960   result->value.character.length = nlen;
2961   result->value.character.string = gfc_getmem (nlen + 1);
2962
2963   for (i = 0; i < ncop; i++)
2964     for (j = 0; j < len; j++)
2965       result->value.character.string[j + i * len]
2966       = e->value.character.string[j];
2967
2968   result->value.character.string[nlen] = '\0';  /* For debugger */
2969   return result;
2970 }
2971
2972
2973 /* This one is a bear, but mainly has to do with shuffling elements.  */
2974
2975 gfc_expr *
2976 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
2977                       gfc_expr *pad, gfc_expr *order_exp)
2978 {
2979   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2980   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2981   gfc_constructor *head, *tail;
2982   mpz_t index, size;
2983   unsigned long j;
2984   size_t nsource;
2985   gfc_expr *e;
2986
2987   /* Unpack the shape array.  */
2988   if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2989     return NULL;
2990
2991   if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2992     return NULL;
2993
2994   if (pad != NULL
2995       && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
2996     return NULL;
2997
2998   if (order_exp != NULL
2999       && (order_exp->expr_type != EXPR_ARRAY
3000           || !gfc_is_constant_expr (order_exp)))
3001     return NULL;
3002
3003   mpz_init (index);
3004   rank = 0;
3005   head = tail = NULL;
3006
3007   for (;;)
3008     {
3009       e = gfc_get_array_element (shape_exp, rank);
3010       if (e == NULL)
3011         break;
3012
3013       if (gfc_extract_int (e, &shape[rank]) != NULL)
3014         {
3015           gfc_error ("Integer too large in shape specification at %L",
3016                      &e->where);
3017           gfc_free_expr (e);
3018           goto bad_reshape;
3019         }
3020
3021       gfc_free_expr (e);
3022
3023       if (rank >= GFC_MAX_DIMENSIONS)
3024         {
3025           gfc_error ("Too many dimensions in shape specification for RESHAPE "
3026                      "at %L", &e->where);
3027
3028           goto bad_reshape;
3029         }
3030
3031       if (shape[rank] < 0)
3032         {
3033           gfc_error ("Shape specification at %L cannot be negative",
3034                      &e->where);
3035           goto bad_reshape;
3036         }
3037
3038       rank++;
3039     }
3040
3041   if (rank == 0)
3042     {
3043       gfc_error ("Shape specification at %L cannot be the null array",
3044                  &shape_exp->where);
3045       goto bad_reshape;
3046     }
3047
3048   /* Now unpack the order array if present.  */
3049   if (order_exp == NULL)
3050     {
3051       for (i = 0; i < rank; i++)
3052         order[i] = i;
3053     }
3054   else
3055     {
3056       for (i = 0; i < rank; i++)
3057         x[i] = 0;
3058
3059       for (i = 0; i < rank; i++)
3060         {
3061           e = gfc_get_array_element (order_exp, i);
3062           if (e == NULL)
3063             {
3064               gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3065                          "size as SHAPE parameter", &order_exp->where);
3066               goto bad_reshape;
3067             }
3068
3069           if (gfc_extract_int (e, &order[i]) != NULL)
3070             {
3071               gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3072                          &e->where);
3073               gfc_free_expr (e);
3074               goto bad_reshape;
3075             }
3076
3077           gfc_free_expr (e);
3078
3079           if (order[i] < 1 || order[i] > rank)
3080             {
3081               gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3082                          &e->where);
3083               goto bad_reshape;
3084             }
3085
3086           order[i]--;
3087
3088           if (x[order[i]])
3089             {
3090               gfc_error ("Invalid permutation in ORDER parameter at %L",
3091                          &e->where);
3092               goto bad_reshape;
3093             }
3094
3095           x[order[i]] = 1;
3096         }
3097     }
3098
3099   /* Count the elements in the source and padding arrays.  */
3100
3101   npad = 0;
3102   if (pad != NULL)
3103     {
3104       gfc_array_size (pad, &size);
3105       npad = mpz_get_ui (size);
3106       mpz_clear (size);
3107     }
3108
3109   gfc_array_size (source, &size);
3110   nsource = mpz_get_ui (size);
3111   mpz_clear (size);
3112
3113   /* If it weren't for that pesky permutation we could just loop
3114      through the source and round out any shortage with pad elements.
3115      But no, someone just had to have the compiler do something the
3116      user should be doing.  */
3117
3118   for (i = 0; i < rank; i++)
3119     x[i] = 0;
3120
3121   for (;;)
3122     {
3123       /* Figure out which element to extract.  */
3124       mpz_set_ui (index, 0);
3125
3126       for (i = rank - 1; i >= 0; i--)
3127         {
3128           mpz_add_ui (index, index, x[order[i]]);
3129           if (i != 0)
3130             mpz_mul_ui (index, index, shape[order[i - 1]]);
3131         }
3132
3133       if (mpz_cmp_ui (index, INT_MAX) > 0)
3134         gfc_internal_error ("Reshaped array too large at %L", &e->where);
3135
3136       j = mpz_get_ui (index);
3137
3138       if (j < nsource)
3139         e = gfc_get_array_element (source, j);
3140       else
3141         {
3142           j = j - nsource;
3143
3144           if (npad == 0)
3145             {
3146               gfc_error ("PAD parameter required for short SOURCE parameter "
3147                          "at %L", &source->where);
3148               goto bad_reshape;
3149             }
3150
3151           j = j % npad;
3152           e = gfc_get_array_element (pad, j);
3153         }
3154
3155       if (head == NULL)
3156         head = tail = gfc_get_constructor ();
3157       else
3158         {
3159           tail->next = gfc_get_constructor ();
3160           tail = tail->next;
3161         }
3162
3163       if (e == NULL)
3164         goto bad_reshape;
3165
3166       tail->where = e->where;
3167       tail->expr = e;
3168
3169       /* Calculate the next element.  */
3170       i = 0;
3171
3172 inc:
3173       if (++x[i] < shape[i])
3174         continue;
3175       x[i++] = 0;
3176       if (i < rank)
3177         goto inc;
3178
3179       break;
3180     }
3181
3182   mpz_clear (index);
3183
3184   e = gfc_get_expr ();
3185   e->where = source->where;
3186   e->expr_type = EXPR_ARRAY;
3187   e->value.constructor = head;
3188   e->shape = gfc_get_shape (rank);
3189
3190   for (i = 0; i < rank; i++)
3191     mpz_init_set_ui (e->shape[i], shape[i]);
3192
3193   e->ts = source->ts;
3194   e->rank = rank;
3195
3196   return e;
3197
3198 bad_reshape:
3199   gfc_free_constructor (head);
3200   mpz_clear (index);
3201   return &gfc_bad_expr;
3202 }
3203
3204
3205 gfc_expr *
3206 gfc_simplify_rrspacing (gfc_expr *x)
3207 {
3208   gfc_expr *result;
3209   int i;
3210   long int e, p;
3211
3212   if (x->expr_type != EXPR_CONSTANT)
3213     return NULL;
3214
3215   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3216
3217   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3218
3219   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3220
3221   /* Special case x = -0 and 0.  */
3222   if (mpfr_sgn (result->value.real) == 0)
3223     {
3224       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3225       return result;
3226     }
3227
3228   /* | x * 2**(-e) | * 2**p.  */
3229   e = - (long int) mpfr_get_exp (x->value.real);
3230   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3231
3232   p = (long int) gfc_real_kinds[i].digits;
3233   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3234
3235   return range_check (result, "RRSPACING");
3236 }
3237
3238
3239 gfc_expr *
3240 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3241 {
3242   int k, neg_flag, power, exp_range;
3243   mpfr_t scale, radix;
3244   gfc_expr *result;
3245
3246   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3247     return NULL;
3248
3249   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3250
3251   if (mpfr_sgn (x->value.real) == 0)
3252     {
3253       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3254       return result;
3255     }
3256
3257   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3258
3259   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3260
3261   /* This check filters out values of i that would overflow an int.  */
3262   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3263       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3264     {
3265       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3266       return &gfc_bad_expr;
3267     }
3268
3269   /* Compute scale = radix ** power.  */
3270   power = mpz_get_si (i->value.integer);
3271
3272   if (power >= 0)
3273     neg_flag = 0;
3274   else
3275     {
3276       neg_flag = 1;
3277       power = -power;
3278     }
3279
3280   gfc_set_model_kind (x->ts.kind);
3281   mpfr_init (scale);
3282   mpfr_init (radix);
3283   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3284   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3285
3286   if (neg_flag)
3287     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3288   else
3289     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3290
3291   mpfr_clear (scale);
3292   mpfr_clear (radix);
3293
3294   return range_check (result, "SCALE");
3295 }
3296
3297
3298 gfc_expr *
3299 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
3300 {
3301   gfc_expr *result;
3302   int back;
3303   size_t i;
3304   size_t indx, len, lenc;
3305
3306   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3307     return NULL;
3308
3309   if (b != NULL && b->value.logical != 0)
3310     back = 1;
3311   else
3312     back = 0;
3313
3314   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3315                                 &e->where);
3316
3317   len = e->value.character.length;
3318   lenc = c->value.character.length;
3319
3320   if (len == 0 || lenc == 0)
3321     {
3322       indx = 0;
3323     }
3324   else
3325     {
3326       if (back == 0)
3327         {
3328           indx = strcspn (e->value.character.string, c->value.character.string)
3329                + 1;
3330           if (indx > len)
3331             indx = 0;
3332         }
3333       else
3334         {
3335           i = 0;
3336           for (indx = len; indx > 0; indx--)
3337             {
3338               for (i = 0; i < lenc; i++)
3339                 {
3340                   if (c->value.character.string[i]
3341                       == e->value.character.string[indx - 1])
3342                     break;
3343                 }
3344               if (i < lenc)
3345                 break;
3346             }
3347         }
3348     }
3349   mpz_set_ui (result->value.integer, indx);
3350   return range_check (result, "SCAN");
3351 }
3352
3353
3354 gfc_expr *
3355 gfc_simplify_selected_int_kind (gfc_expr *e)
3356 {
3357   int i, kind, range;
3358   gfc_expr *result;
3359
3360   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3361     return NULL;
3362
3363   kind = INT_MAX;
3364
3365   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3366     if (gfc_integer_kinds[i].range >= range
3367         && gfc_integer_kinds[i].kind < kind)
3368       kind = gfc_integer_kinds[i].kind;
3369
3370   if (kind == INT_MAX)
3371     kind = -1;
3372
3373   result = gfc_int_expr (kind);
3374   result->where = e->where;
3375
3376   return result;
3377 }
3378
3379
3380 gfc_expr *
3381 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3382 {
3383   int range, precision, i, kind, found_precision, found_range;
3384   gfc_expr *result;
3385
3386   if (p == NULL)
3387     precision = 0;
3388   else
3389     {
3390       if (p->expr_type != EXPR_CONSTANT
3391           || gfc_extract_int (p, &precision) != NULL)
3392         return NULL;
3393     }
3394
3395   if (q == NULL)
3396     range = 0;
3397   else
3398     {
3399       if (q->expr_type != EXPR_CONSTANT
3400           || gfc_extract_int (q, &range) != NULL)
3401         return NULL;
3402     }
3403
3404   kind = INT_MAX;
3405   found_precision = 0;
3406   found_range = 0;
3407
3408   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3409     {
3410       if (gfc_real_kinds[i].precision >= precision)
3411         found_precision = 1;
3412
3413       if (gfc_real_kinds[i].range >= range)
3414         found_range = 1;
3415
3416       if (gfc_real_kinds[i].precision >= precision
3417           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3418         kind = gfc_real_kinds[i].kind;
3419     }
3420
3421   if (kind == INT_MAX)
3422     {
3423       kind = 0;
3424
3425       if (!found_precision)
3426         kind = -1;
3427       if (!found_range)
3428         kind -= 2;
3429     }
3430
3431   result = gfc_int_expr (kind);
3432   result->where = (p != NULL) ? p->where : q->where;
3433
3434   return result;
3435 }
3436
3437
3438 gfc_expr *
3439 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3440 {
3441   gfc_expr *result;
3442   mpfr_t exp, absv, log2, pow2, frac;
3443   unsigned long exp2;
3444
3445   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3446     return NULL;
3447
3448   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3449
3450   gfc_set_model_kind (x->ts.kind);
3451
3452   if (mpfr_sgn (x->value.real) == 0)
3453     {
3454       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3455       return result;
3456     }
3457
3458   mpfr_init (absv);
3459   mpfr_init (log2);
3460   mpfr_init (exp);
3461   mpfr_init (pow2);
3462   mpfr_init (frac);
3463
3464   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3465   mpfr_log2 (log2, absv, GFC_RND_MODE);
3466
3467   mpfr_trunc (log2, log2);
3468   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3469
3470   /* Old exponent value, and fraction.  */
3471   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3472
3473   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3474
3475   /* New exponent.  */
3476   exp2 = (unsigned long) mpz_get_d (i->value.integer);
3477   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3478
3479   mpfr_clear (absv);
3480   mpfr_clear (log2);
3481   mpfr_clear (pow2);
3482   mpfr_clear (frac);
3483
3484   return range_check (result, "SET_EXPONENT");
3485 }
3486
3487
3488 gfc_expr *
3489 gfc_simplify_shape (gfc_expr *source)
3490 {
3491   mpz_t shape[GFC_MAX_DIMENSIONS];
3492   gfc_expr *result, *e, *f;
3493   gfc_array_ref *ar;
3494   int n;
3495   try t;
3496
3497   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3498     return NULL;
3499
3500   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3501                                   &source->where);
3502
3503   ar = gfc_find_array_ref (source);
3504
3505   t = gfc_array_ref_shape (ar, shape);
3506
3507   for (n = 0; n < source->rank; n++)
3508     {
3509       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3510                                &source->where);
3511
3512       if (t == SUCCESS)
3513         {
3514           mpz_set (e->value.integer, shape[n]);
3515           mpz_clear (shape[n]);
3516         }
3517       else
3518         {
3519           mpz_set_ui (e->value.integer, n + 1);
3520
3521           f = gfc_simplify_size (source, e);
3522           gfc_free_expr (e);
3523           if (f == NULL)
3524             {
3525               gfc_free_expr (result);
3526               return NULL;
3527             }
3528           else
3529             {
3530               e = f;
3531             }
3532         }
3533
3534       gfc_append_constructor (result, e);
3535     }
3536
3537   return result;
3538 }
3539
3540
3541 gfc_expr *
3542 gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
3543 {
3544   mpz_t size;
3545   gfc_expr *result;
3546   int d;
3547
3548   if (dim == NULL)
3549     {
3550       if (gfc_array_size (array, &size) == FAILURE)
3551         return NULL;
3552     }
3553   else
3554     {
3555       if (dim->expr_type != EXPR_CONSTANT)
3556         return NULL;
3557
3558       d = mpz_get_ui (dim->value.integer) - 1;
3559       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3560         return NULL;
3561     }
3562
3563   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3564                                 &array->where);
3565
3566   mpz_set (result->value.integer, size);
3567
3568   return result;
3569 }
3570
3571
3572 gfc_expr *
3573 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3574 {
3575   gfc_expr *result;
3576
3577   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3578     return NULL;
3579
3580   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3581
3582   switch (x->ts.type)
3583     {
3584     case BT_INTEGER:
3585       mpz_abs (result->value.integer, x->value.integer);
3586       if (mpz_sgn (y->value.integer) < 0)
3587         mpz_neg (result->value.integer, result->value.integer);
3588
3589       break;
3590
3591     case BT_REAL:
3592       /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3593          it.  */
3594       mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3595       if (mpfr_sgn (y->value.real) < 0)
3596         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3597
3598       break;
3599
3600     default:
3601       gfc_internal_error ("Bad type in gfc_simplify_sign");
3602     }
3603
3604   return result;
3605 }
3606
3607
3608 gfc_expr *
3609 gfc_simplify_sin (gfc_expr *x)
3610 {
3611   gfc_expr *result;
3612   mpfr_t xp, xq;
3613
3614   if (x->expr_type != EXPR_CONSTANT)
3615     return NULL;
3616
3617   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3618
3619   switch (x->ts.type)
3620     {
3621     case BT_REAL:
3622       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3623       break;
3624
3625     case BT_COMPLEX:
3626       gfc_set_model (x->value.real);
3627       mpfr_init (xp);
3628       mpfr_init (xq);
3629
3630       mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
3631       mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3632       mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3633
3634       mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
3635       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3636       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3637
3638       mpfr_clear (xp);
3639       mpfr_clear (xq);
3640       break;
3641
3642     default:
3643       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3644     }
3645
3646   return range_check (result, "SIN");
3647 }
3648
3649
3650 gfc_expr *
3651 gfc_simplify_sinh (gfc_expr *x)
3652 {
3653   gfc_expr *result;
3654
3655   if (x->expr_type != EXPR_CONSTANT)
3656     return NULL;
3657
3658   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3659
3660   mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3661
3662   return range_check (result, "SINH");
3663 }
3664
3665
3666 /* The argument is always a double precision real that is converted to
3667    single precision.  TODO: Rounding!  */
3668
3669 gfc_expr *
3670 gfc_simplify_sngl (gfc_expr *a)
3671 {
3672   gfc_expr *result;
3673
3674   if (a->expr_type != EXPR_CONSTANT)
3675     return NULL;
3676
3677   result = gfc_real2real (a, gfc_default_real_kind);
3678   return range_check (result, "SNGL");
3679 }
3680
3681
3682 gfc_expr *
3683 gfc_simplify_spacing (gfc_expr *x)
3684 {
3685   gfc_expr *result;
3686   int i;
3687   long int en, ep;
3688
3689   if (x->expr_type != EXPR_CONSTANT)
3690     return NULL;
3691
3692   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3693
3694   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3695
3696   /* Special case x = 0 and -0.  */
3697   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3698   if (mpfr_sgn (result->value.real) == 0)
3699     {
3700       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3701       return result;
3702     }
3703
3704   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3705      are the radix, exponent of x, and precision.  This excludes the
3706      possibility of subnormal numbers.  Fortran 2003 states the result is
3707      b**max(e - p, emin - 1).  */
3708
3709   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3710   en = (long int) gfc_real_kinds[i].min_exponent - 1;
3711   en = en > ep ? en : ep;
3712
3713   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3714   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3715
3716   return range_check (result, "SPACING");
3717 }
3718
3719
3720 gfc_expr *
3721 gfc_simplify_sqrt (gfc_expr *e)
3722 {
3723   gfc_expr *result;
3724   mpfr_t ac, ad, s, t, w;
3725
3726   if (e->expr_type != EXPR_CONSTANT)
3727     return NULL;
3728
3729   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3730
3731   switch (e->ts.type)
3732     {
3733     case BT_REAL:
3734       if (mpfr_cmp_si (e->value.real, 0) < 0)
3735         goto negative_arg;
3736       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3737
3738       break;
3739
3740     case BT_COMPLEX:
3741       /* Formula taken from Numerical Recipes to avoid over- and
3742          underflow.  */
3743
3744       gfc_set_model (e->value.real);
3745       mpfr_init (ac);
3746       mpfr_init (ad);
3747       mpfr_init (s);
3748       mpfr_init (t);
3749       mpfr_init (w);
3750
3751       if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3752           && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3753         {
3754           mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3755           mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3756           break;
3757         }
3758
3759       mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3760       mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3761
3762       if (mpfr_cmp (ac, ad) >= 0)
3763         {
3764           mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3765           mpfr_mul (t, t, t, GFC_RND_MODE);
3766           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3767           mpfr_sqrt (t, t, GFC_RND_MODE);
3768           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3769           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3770           mpfr_sqrt (t, t, GFC_RND_MODE);
3771           mpfr_sqrt (s, ac, GFC_RND_MODE);
3772           mpfr_mul (w, s, t, GFC_RND_MODE);
3773         }
3774       else
3775         {
3776           mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3777           mpfr_mul (t, s, s, GFC_RND_MODE);
3778           mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3779           mpfr_sqrt (t, t, GFC_RND_MODE);
3780           mpfr_abs (s, s, GFC_RND_MODE);
3781           mpfr_add (t, t, s, GFC_RND_MODE);
3782           mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3783           mpfr_sqrt (t, t, GFC_RND_MODE);
3784           mpfr_sqrt (s, ad, GFC_RND_MODE);
3785           mpfr_mul (w, s, t, GFC_RND_MODE);
3786         }
3787
3788       if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3789         {
3790           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3791           mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3792           mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3793         }
3794       else if (mpfr_cmp_ui (w, 0) != 0
3795                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3796                && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3797         {
3798           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3799           mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3800           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3801         }
3802       else if (mpfr_cmp_ui (w, 0) != 0
3803                && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3804                && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3805         {
3806           mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3807           mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3808           mpfr_neg (w, w, GFC_RND_MODE);
3809           mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3810         }
3811       else
3812         gfc_internal_error ("invalid complex argument of SQRT at %L",
3813                             &e->where);
3814
3815       mpfr_clear (s);
3816       mpfr_clear (t);
3817       mpfr_clear (ac);
3818       mpfr_clear (ad);
3819       mpfr_clear (w);
3820
3821       break;
3822
3823     default:
3824       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3825     }
3826
3827   return range_check (result, "SQRT");
3828
3829 negative_arg:
3830   gfc_free_expr (result);
3831   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3832   return &gfc_bad_expr;
3833 }
3834
3835
3836 gfc_expr *
3837 gfc_simplify_tan (gfc_expr *x)
3838 {
3839   int i;
3840   gfc_expr *result;
3841
3842   if (x->expr_type != EXPR_CONSTANT)
3843     return NULL;
3844
3845   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3846
3847   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3848
3849   mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3850
3851   return range_check (result, "TAN");
3852 }
3853
3854
3855 gfc_expr *
3856 gfc_simplify_tanh (gfc_expr *x)
3857 {
3858   gfc_expr *result;
3859
3860   if (x->expr_type != EXPR_CONSTANT)
3861     return NULL;
3862
3863   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3864
3865   mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3866
3867   return range_check (result, "TANH");
3868
3869 }
3870
3871
3872 gfc_expr *
3873 gfc_simplify_tiny (gfc_expr *e)
3874 {
3875   gfc_expr *result;
3876   int i;
3877
3878   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3879
3880   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3881   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3882
3883   return result;
3884 }
3885
3886
3887 gfc_expr *
3888 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3889 {
3890   gfc_expr *result;
3891   gfc_expr *mold_element;
3892   size_t source_size;
3893   size_t result_size;
3894   size_t result_elt_size;
3895   size_t buffer_size;
3896   mpz_t tmp;
3897   unsigned char *buffer;
3898
3899   if (!gfc_is_constant_expr (source)
3900         || !gfc_is_constant_expr (size))
3901     return NULL;
3902
3903   /* Calculate the size of the source.  */
3904   if (source->expr_type == EXPR_ARRAY
3905       && gfc_array_size (source, &tmp) == FAILURE)
3906     gfc_internal_error ("Failure getting length of a constant array.");
3907
3908   source_size = gfc_target_expr_size (source);
3909
3910   /* Create an empty new expression with the appropriate characteristics.  */
3911   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
3912                                 &source->where);
3913   result->ts = mold->ts;
3914
3915   mold_element = mold->expr_type == EXPR_ARRAY
3916                  ? mold->value.constructor->expr
3917                  : mold;
3918
3919   /* Set result character length, if needed.  Note that this needs to be
3920      set even for array expressions, in order to pass this information into
3921      gfc_target_interpret_expr.  */
3922   if (result->ts.type == BT_CHARACTER)
3923     result->value.character.length = mold_element->value.character.length;
3924
3925   /* Set the number of elements in the result, and determine its size.  */
3926   result_elt_size = gfc_target_expr_size (mold_element);
3927   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
3928     {
3929       int result_length;
3930
3931       result->expr_type = EXPR_ARRAY;
3932       result->rank = 1;
3933
3934       if (size)
3935         result_length = (size_t)mpz_get_ui (size->value.integer);
3936       else
3937         {
3938           result_length = source_size / result_elt_size;
3939           if (result_length * result_elt_size < source_size)
3940             result_length += 1;
3941         }
3942
3943       result->shape = gfc_get_shape (1);
3944       mpz_init_set_ui (result->shape[0], result_length);
3945
3946       result_size = result_length * result_elt_size;
3947     }
3948   else
3949     {
3950       result->rank = 0;
3951       result_size = result_elt_size;
3952     }
3953
3954   /* Allocate the buffer to store the binary version of the source.  */
3955   buffer_size = MAX (source_size, result_size);
3956   buffer = (unsigned char*)alloca (buffer_size);
3957
3958   /* Now write source to the buffer.  */
3959   gfc_target_encode_expr (source, buffer, buffer_size);
3960
3961   /* And read the buffer back into the new expression.  */
3962   gfc_target_interpret_expr (buffer, buffer_size, result);
3963
3964   return result;
3965 }
3966
3967
3968 gfc_expr *
3969 gfc_simplify_trim (gfc_expr *e)
3970 {
3971   gfc_expr *result;
3972   int count, i, len, lentrim;
3973
3974   if (e->expr_type != EXPR_CONSTANT)
3975     return NULL;
3976
3977   len = e->value.character.length;
3978
3979   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3980
3981   for (count = 0, i = 1; i <= len; ++i)
3982     {
3983       if (e->value.character.string[len - i] == ' ')
3984         count++;
3985       else
3986         break;
3987     }
3988
3989   lentrim = len - count;
3990
3991   result->value.character.length = lentrim;
3992   result->value.character.string = gfc_getmem (lentrim + 1);
3993
3994   for (i = 0; i < lentrim; i++)
3995     result->value.character.string[i] = e->value.character.string[i];
3996
3997   result->value.character.string[lentrim] = '\0';       /* For debugger */
3998
3999   return result;
4000 }
4001
4002
4003 gfc_expr *
4004 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
4005 {
4006   return simplify_bound (array, dim, 1);
4007 }
4008
4009
4010 gfc_expr *
4011 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
4012 {
4013   gfc_expr *result;
4014   int back;
4015   size_t index, len, lenset;
4016   size_t i;
4017
4018   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4019     return NULL;
4020
4021   if (b != NULL && b->value.logical != 0)
4022     back = 1;
4023   else
4024     back = 0;
4025
4026   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4027                                 &s->where);
4028
4029   len = s->value.character.length;
4030   lenset = set->value.character.length;
4031
4032   if (len == 0)
4033     {
4034       mpz_set_ui (result->value.integer, 0);
4035       return result;
4036     }
4037
4038   if (back == 0)
4039     {
4040       if (lenset == 0)
4041         {
4042           mpz_set_ui (result->value.integer, 1);
4043           return result;
4044         }
4045
4046       index = strspn (s->value.character.string, set->value.character.string)
4047             + 1;
4048       if (index > len)
4049         index = 0;
4050
4051     }
4052   else
4053     {
4054       if (lenset == 0)
4055         {
4056           mpz_set_ui (result->value.integer, len);
4057           return result;
4058         }
4059       for (index = len; index > 0; index --)
4060         {
4061           for (i = 0; i < lenset; i++)
4062             {
4063               if (s->value.character.string[index - 1]
4064                   == set->value.character.string[i])
4065                 break;
4066             }
4067           if (i == lenset)
4068             break;
4069         }
4070     }
4071
4072   mpz_set_ui (result->value.integer, index);
4073   return result;
4074 }
4075
4076
4077 gfc_expr *
4078 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4079 {
4080   gfc_expr *result;
4081   int kind;
4082
4083   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4084     return NULL;
4085
4086   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4087   if (x->ts.type == BT_INTEGER)
4088     {
4089       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4090       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4091     }
4092   else /* BT_LOGICAL */
4093     {
4094       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4095       result->value.logical = (x->value.logical && !y->value.logical)
4096                               || (!x->value.logical && y->value.logical);
4097     }
4098
4099   return range_check (result, "XOR");
4100 }
4101
4102
4103 /****************** Constant simplification *****************/
4104
4105 /* Master function to convert one constant to another.  While this is
4106    used as a simplification function, it requires the destination type
4107    and kind information which is supplied by a special case in
4108    do_simplify().  */
4109
4110 gfc_expr *
4111 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4112 {
4113   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4114   gfc_constructor *head, *c, *tail = NULL;
4115
4116   switch (e->ts.type)
4117     {
4118     case BT_INTEGER:
4119       switch (type)
4120         {
4121         case BT_INTEGER:
4122           f = gfc_int2int;
4123           break;
4124         case BT_REAL:
4125           f = gfc_int2real;
4126           break;
4127         case BT_COMPLEX:
4128           f = gfc_int2complex;
4129           break;
4130         case BT_LOGICAL:
4131           f = gfc_int2log;
4132           break;
4133         default:
4134           goto oops;
4135         }
4136       break;
4137
4138     case BT_REAL:
4139       switch (type)
4140         {
4141         case BT_INTEGER:
4142           f = gfc_real2int;
4143           break;
4144         case BT_REAL:
4145           f = gfc_real2real;
4146           break;
4147         case BT_COMPLEX:
4148           f = gfc_real2complex;
4149           break;
4150         default:
4151           goto oops;
4152         }
4153       break;
4154
4155     case BT_COMPLEX:
4156       switch (type)
4157         {
4158         case BT_INTEGER:
4159           f = gfc_complex2int;
4160           break;
4161         case BT_REAL:
4162           f = gfc_complex2real;
4163           break;
4164         case BT_COMPLEX:
4165           f = gfc_complex2complex;
4166           break;
4167
4168         default:
4169           goto oops;
4170         }
4171       break;
4172
4173     case BT_LOGICAL:
4174       switch (type)
4175         {
4176         case BT_INTEGER:
4177           f = gfc_log2int;
4178           break;
4179         case BT_LOGICAL:
4180           f = gfc_log2log;
4181           break;
4182         default:
4183           goto oops;
4184         }
4185       break;
4186
4187     case BT_HOLLERITH:
4188       switch (type)
4189         {
4190         case BT_INTEGER:
4191           f = gfc_hollerith2int;
4192           break;
4193
4194         case BT_REAL:
4195           f = gfc_hollerith2real;
4196           break;
4197
4198         case BT_COMPLEX:
4199           f = gfc_hollerith2complex;
4200           break;
4201
4202         case BT_CHARACTER:
4203           f = gfc_hollerith2character;
4204           break;
4205
4206         case BT_LOGICAL:
4207           f = gfc_hollerith2logical;
4208           break;
4209
4210         default:
4211           goto oops;
4212         }
4213       break;
4214
4215     default:
4216     oops:
4217       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4218     }
4219
4220   result = NULL;
4221
4222   switch (e->expr_type)
4223     {
4224     case EXPR_CONSTANT:
4225       result = f (e, kind);
4226       if (result == NULL)
4227         return &gfc_bad_expr;
4228       break;
4229
4230     case EXPR_ARRAY:
4231       if (!gfc_is_constant_expr (e))
4232         break;
4233
4234       head = NULL;
4235
4236       for (c = e->value.constructor; c; c = c->next)
4237         {
4238           if (head == NULL)
4239             head = tail = gfc_get_constructor ();
4240           else
4241             {
4242               tail->next = gfc_get_constructor ();
4243               tail = tail->next;
4244             }
4245
4246           tail->where = c->where;
4247
4248           if (c->iterator == NULL)
4249             tail->expr = f (c->expr, kind);
4250           else
4251             {
4252               g = gfc_convert_constant (c->expr, type, kind);
4253               if (g == &gfc_bad_expr)
4254                 return g;
4255               tail->expr = g;
4256             }
4257
4258           if (tail->expr == NULL)
4259             {
4260               gfc_free_constructor (head);
4261               return NULL;
4262             }
4263         }
4264
4265       result = gfc_get_expr ();
4266       result->ts.type = type;
4267       result->ts.kind = kind;
4268       result->expr_type = EXPR_ARRAY;
4269       result->value.constructor = head;
4270       result->shape = gfc_copy_shape (e->shape, e->rank);
4271       result->where = e->where;
4272       result->rank = e->rank;
4273       break;
4274
4275     default:
4276       break;
4277     }
4278
4279   return result;
4280 }