gcc/fortran/simplify.c

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