gcc/fortran/simplify.c

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