gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
   3    2010, 2011 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 "coretypes.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "arith.h"
  28 #include "intrinsic.h"
  29 #include "target-memory.h"
  30 #include "constructor.h"
  31 #include "version.h"  /* For version_string.  */
  32
  33
  34 gfc_expr gfc_bad_expr;
  35
  36
  37 /* Note that 'simplification' is not just transforming expressions.
  38    For functions that are not simplified at compile time, range
  39    checking is done if possible.
  40
  41    The return convention is that each simplification function returns:
  42
  43      A new expression node corresponding to the simplified arguments.
  44      The original arguments are destroyed by the caller, and must not
  45      be a part of the new expression.
  46
  47      NULL pointer indicating that no simplification was possible and
  48      the original expression should remain intact.
  49
  50      An expression pointer to gfc_bad_expr (a static placeholder)
  51      indicating that some error has prevented simplification.  The
  52      error is generated within the function and should be propagated
  53      upwards
  54
  55    By the time a simplification function gets control, it has been
  56    decided that the function call is really supposed to be the
  57    intrinsic.  No type checking is strictly necessary, since only
  58    valid types will be passed on.  On the other hand, a simplification
  59    subroutine may have to look at the type of an argument as part of
  60    its processing.
  61
  62    Array arguments are only passed to these subroutines that implement
  63    the simplification of transformational intrinsics.
  64
  65    The functions in this file don't have much comment with them, but
  66    everything is reasonably straight-forward.  The Standard, chapter 13
  67    is the best comment you'll find for this file anyway.  */
  68
  69 /* Range checks an expression node.  If all goes well, returns the
  70    node, otherwise returns &gfc_bad_expr and frees the node.  */
  71
  72 static gfc_expr *
  73 range_check (gfc_expr *result, const char *name)
  74 {
  75   if (result == NULL)
  76     return &gfc_bad_expr;
  77
  78   if (result->expr_type != EXPR_CONSTANT)
  79     return result;
  80
  81   switch (gfc_range_check (result))
  82     {
  83       case ARITH_OK:
  84         return result;
  85
  86       case ARITH_OVERFLOW:
  87         gfc_error ("Result of %s overflows its kind at %L", name,
  88                    &result->where);
  89         break;
  90
  91       case ARITH_UNDERFLOW:
  92         gfc_error ("Result of %s underflows its kind at %L", name,
  93                    &result->where);
  94         break;
  95
  96       case ARITH_NAN:
  97         gfc_error ("Result of %s is NaN at %L", name, &result->where);
  98         break;
  99
 100       default:
 101         gfc_error ("Result of %s gives range error for its kind at %L", name,
 102                    &result->where);
 103         break;
 104     }
 105
 106   gfc_free_expr (result);
 107   return &gfc_bad_expr;
 108 }
 109
 110
 111 /* A helper function that gets an optional and possibly missing
 112    kind parameter.  Returns the kind, -1 if something went wrong.  */
 113
 114 static int
 115 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 116 {
 117   int kind;
 118
 119   if (k == NULL)
 120     return default_kind;
 121
 122   if (k->expr_type != EXPR_CONSTANT)
 123     {
 124       gfc_error ("KIND parameter of %s at %L must be an initialization "
 125                  "expression", name, &k->where);
 126       return -1;
 127     }
 128
 129   if (gfc_extract_int (k, &kind) != NULL
 130       || gfc_validate_kind (type, kind, true) < 0)
 131     {
 132       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
 133       return -1;
 134     }
 135
 136   return kind;
 137 }
 138
 139
 140 /* Converts an mpz_t signed variable into an unsigned one, assuming
 141    two's complement representations and a binary width of bitsize.
 142    The conversion is a no-op unless x is negative; otherwise, it can
 143    be accomplished by masking out the high bits.  */
 144
 145 static void
 146 convert_mpz_to_unsigned (mpz_t x, int bitsize)
 147 {
 148   mpz_t mask;
 149
 150   if (mpz_sgn (x) < 0)
 151     {
 152       /* Confirm that no bits above the signed range are unset.  */
 153       gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
 154
 155       mpz_init_set_ui (mask, 1);
 156       mpz_mul_2exp (mask, mask, bitsize);
 157       mpz_sub_ui (mask, mask, 1);
 158
 159       mpz_and (x, x, mask);
 160
 161       mpz_clear (mask);
 162     }
 163   else
 164     {
 165       /* Confirm that no bits above the signed range are set.  */
 166       gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
 167     }
 168 }
 169
 170
 171 /* Converts an mpz_t unsigned variable into a signed one, assuming
 172    two's complement representations and a binary width of bitsize.
 173    If the bitsize-1 bit is set, this is taken as a sign bit and
 174    the number is converted to the corresponding negative number.  */
 175
 176 static void
 177 convert_mpz_to_signed (mpz_t x, int bitsize)
 178 {
 179   mpz_t mask;
 180
 181   /* Confirm that no bits above the unsigned range are set.  */
 182   gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
 183
 184   if (mpz_tstbit (x, bitsize - 1) == 1)
 185     {
 186       mpz_init_set_ui (mask, 1);
 187       mpz_mul_2exp (mask, mask, bitsize);
 188       mpz_sub_ui (mask, mask, 1);
 189
 190       /* We negate the number by hand, zeroing the high bits, that is
 191          make it the corresponding positive number, and then have it
 192          negated by GMP, giving the correct representation of the
 193          negative number.  */
 194       mpz_com (x, x);
 195       mpz_add_ui (x, x, 1);
 196       mpz_and (x, x, mask);
 197
 198       mpz_neg (x, x);
 199
 200       mpz_clear (mask);
 201     }
 202 }
 203
 204
 205 /* In-place convert BOZ to REAL of the specified kind.  */
 206
 207 static gfc_expr *
 208 convert_boz (gfc_expr *x, int kind)
 209 {
 210   if (x && x->ts.type == BT_INTEGER && x->is_boz)
 211     {
 212       gfc_typespec ts;
 213       gfc_clear_ts (&ts);
 214       ts.type = BT_REAL;
 215       ts.kind = kind;
 216
 217       if (!gfc_convert_boz (x, &ts))
 218         return &gfc_bad_expr;
 219     }
 220
 221   return x;
 222 }
 223
 224
 225 /* Test that the expression is an constant array.  */
 226
 227 static bool
 228 is_constant_array_expr (gfc_expr *e)
 229 {
 230   gfc_constructor *c;
 231
 232   if (e == NULL)
 233     return true;
 234
 235   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
 236     return false;
 237
 238   for (c = gfc_constructor_first (e->value.constructor);
 239        c; c = gfc_constructor_next (c))
 240     if (c->expr->expr_type != EXPR_CONSTANT
 241           && c->expr->expr_type != EXPR_STRUCTURE)
 242       return false;
 243
 244   return true;
 245 }
 246
 247
 248 /* Initialize a transformational result expression with a given value.  */
 249
 250 static void
 251 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
 252 {
 253   if (e && e->expr_type == EXPR_ARRAY)
 254     {
 255       gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
 256       while (ctor)
 257         {
 258           init_result_expr (ctor->expr, init, array);
 259           ctor = gfc_constructor_next (ctor);
 260         }
 261     }
 262   else if (e && e->expr_type == EXPR_CONSTANT)
 263     {
 264       int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 265       int length;
 266       gfc_char_t *string;
 267
 268       switch (e->ts.type)
 269         {
 270           case BT_LOGICAL:
 271             e->value.logical = (init ? 1 : 0);
 272             break;
 273
 274           case BT_INTEGER:
 275             if (init == INT_MIN)
 276               mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
 277             else if (init == INT_MAX)
 278               mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
 279             else
 280               mpz_set_si (e->value.integer, init);
 281             break;
 282
 283           case BT_REAL:
 284             if (init == INT_MIN)
 285               {
 286                 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 287                 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
 288               }
 289             else if (init == INT_MAX)
 290               mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 291             else
 292               mpfr_set_si (e->value.real, init, GFC_RND_MODE);
 293             break;
 294
 295           case BT_COMPLEX:
 296             mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
 297             break;
 298
 299           case BT_CHARACTER:
 300             if (init == INT_MIN)
 301               {
 302                 gfc_expr *len = gfc_simplify_len (array, NULL);
 303                 gfc_extract_int (len, &length);
 304                 string = gfc_get_wide_string (length + 1);
 305                 gfc_wide_memset (string, 0, length);
 306               }
 307             else if (init == INT_MAX)
 308               {
 309                 gfc_expr *len = gfc_simplify_len (array, NULL);
 310                 gfc_extract_int (len, &length);
 311                 string = gfc_get_wide_string (length + 1);
 312                 gfc_wide_memset (string, 255, length);
 313               }
 314             else
 315               {
 316                 length = 0;
 317                 string = gfc_get_wide_string (1);
 318               }
 319
 320             string[length] = '\0';
 321             e->value.character.length = length;
 322             e->value.character.string = string;
 323             break;
 324
 325           default:
 326             gcc_unreachable();
 327         }
 328     }
 329   else
 330     gcc_unreachable();
 331 }
 332
 333
 334 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul.  */
 335
 336 static gfc_expr *
 337 compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
 338                      gfc_expr *matrix_b, int stride_b, int offset_b)
 339 {
 340   gfc_expr *result, *a, *b;
 341
 342   result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
 343                                   &matrix_a->where);
 344   init_result_expr (result, 0, NULL);
 345
 346   a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
 347   b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
 348   while (a && b)
 349     {
 350       /* Copying of expressions is required as operands are free'd
 351          by the gfc_arith routines.  */
 352       switch (result->ts.type)
 353         {
 354           case BT_LOGICAL:
 355             result = gfc_or (result,
 356                              gfc_and (gfc_copy_expr (a),
 357                                       gfc_copy_expr (b)));
 358             break;
 359
 360           case BT_INTEGER:
 361           case BT_REAL:
 362           case BT_COMPLEX:
 363             result = gfc_add (result,
 364                               gfc_multiply (gfc_copy_expr (a),
 365                                             gfc_copy_expr (b)));
 366             break;
 367
 368           default:
 369             gcc_unreachable();
 370         }
 371
 372       offset_a += stride_a;
 373       a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
 374
 375       offset_b += stride_b;
 376       b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
 377     }
 378
 379   return result;
 380 }
 381
 382
 383 /* Build a result expression for transformational intrinsics,
 384    depending on DIM. */
 385
 386 static gfc_expr *
 387 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
 388                          int kind, locus* where)
 389 {
 390   gfc_expr *result;
 391   int i, nelem;
 392
 393   if (!dim || array->rank == 1)
 394     return gfc_get_constant_expr (type, kind, where);
 395
 396   result = gfc_get_array_expr (type, kind, where);
 397   result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
 398   result->rank = array->rank - 1;
 399
 400   /* gfc_array_size() would count the number of elements in the constructor,
 401      we have not built those yet.  */
 402   nelem = 1;
 403   for  (i = 0; i < result->rank; ++i)
 404     nelem *= mpz_get_ui (result->shape[i]);
 405
 406   for (i = 0; i < nelem; ++i)
 407     {
 408       gfc_constructor_append_expr (&result->value.constructor,
 409                                    gfc_get_constant_expr (type, kind, where),
 410                                    NULL);
 411     }
 412
 413   return result;
 414 }
 415
 416
 417 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
 418
 419 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
 420    of COUNT intrinsic is .TRUE..
 421
 422    Interface and implementation mimics arith functions as
 423    gfc_add, gfc_multiply, etc.  */
 424
 425 static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
 426 {
 427   gfc_expr *result;
 428
 429   gcc_assert (op1->ts.type == BT_INTEGER);
 430   gcc_assert (op2->ts.type == BT_LOGICAL);
 431   gcc_assert (op2->value.logical);
 432
 433   result = gfc_copy_expr (op1);
 434   mpz_add_ui (result->value.integer, result->value.integer, 1);
 435
 436   gfc_free_expr (op1);
 437   gfc_free_expr (op2);
 438   return result;
 439 }
 440
 441
 442 /* Transforms an ARRAY with operation OP, according to MASK, to a
 443    scalar RESULT. E.g. called if
 444
 445      REAL, PARAMETER :: array(n, m) = ...
 446      REAL, PARAMETER :: s = SUM(array)
 447
 448   where OP == gfc_add().  */
 449
 450 static gfc_expr *
 451 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
 452                                    transformational_op op)
 453 {
 454   gfc_expr *a, *m;
 455   gfc_constructor *array_ctor, *mask_ctor;
 456
 457   /* Shortcut for constant .FALSE. MASK.  */
 458   if (mask
 459       && mask->expr_type == EXPR_CONSTANT
 460       && !mask->value.logical)
 461     return result;
 462
 463   array_ctor = gfc_constructor_first (array->value.constructor);
 464   mask_ctor = NULL;
 465   if (mask && mask->expr_type == EXPR_ARRAY)
 466     mask_ctor = gfc_constructor_first (mask->value.constructor);
 467
 468   while (array_ctor)
 469     {
 470       a = array_ctor->expr;
 471       array_ctor = gfc_constructor_next (array_ctor);
 472
 473       /* A constant MASK equals .TRUE. here and can be ignored.  */
 474       if (mask_ctor)
 475         {
 476           m = mask_ctor->expr;
 477           mask_ctor = gfc_constructor_next (mask_ctor);
 478           if (!m->value.logical)
 479             continue;
 480         }
 481
 482       result = op (result, gfc_copy_expr (a));
 483     }
 484
 485   return result;
 486 }
 487
 488 /* Transforms an ARRAY with operation OP, according to MASK, to an
 489    array RESULT. E.g. called if
 490
 491      REAL, PARAMETER :: array(n, m) = ...
 492      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
 493
 494   where OP == gfc_multiply(). The result might be post processed using post_op. */
 495
 496 static gfc_expr *
 497 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
 498                                   gfc_expr *mask, transformational_op op,
 499                                   transformational_op post_op)
 500 {
 501   mpz_t size;
 502   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
 503   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
 504   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
 505
 506   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
 507       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
 508       tmpstride[GFC_MAX_DIMENSIONS];
 509
 510   /* Shortcut for constant .FALSE. MASK.  */
 511   if (mask
 512       && mask->expr_type == EXPR_CONSTANT
 513       && !mask->value.logical)
 514     return result;
 515
 516   /* Build an indexed table for array element expressions to minimize
 517      linked-list traversal. Masked elements are set to NULL.  */
 518   gfc_array_size (array, &size);
 519   arraysize = mpz_get_ui (size);
 520   mpz_clear (size);
 521
 522   arrayvec = XCNEWVEC (gfc_expr*, arraysize);
 523
 524   array_ctor = gfc_constructor_first (array->value.constructor);
 525   mask_ctor = NULL;
 526   if (mask && mask->expr_type == EXPR_ARRAY)
 527     mask_ctor = gfc_constructor_first (mask->value.constructor);
 528
 529   for (i = 0; i < arraysize; ++i)
 530     {
 531       arrayvec[i] = array_ctor->expr;
 532       array_ctor = gfc_constructor_next (array_ctor);
 533
 534       if (mask_ctor)
 535         {
 536           if (!mask_ctor->expr->value.logical)
 537             arrayvec[i] = NULL;
 538
 539           mask_ctor = gfc_constructor_next (mask_ctor);
 540         }
 541     }
 542
 543   /* Same for the result expression.  */
 544   gfc_array_size (result, &size);
 545   resultsize = mpz_get_ui (size);
 546   mpz_clear (size);
 547
 548   resultvec = XCNEWVEC (gfc_expr*, resultsize);
 549   result_ctor = gfc_constructor_first (result->value.constructor);
 550   for (i = 0; i < resultsize; ++i)
 551     {
 552       resultvec[i] = result_ctor->expr;
 553       result_ctor = gfc_constructor_next (result_ctor);
 554     }
 555
 556   gfc_extract_int (dim, &dim_index);
 557   dim_index -= 1;               /* zero-base index */
 558   dim_extent = 0;
 559   dim_stride = 0;
 560
 561   for (i = 0, n = 0; i < array->rank; ++i)
 562     {
 563       count[i] = 0;
 564       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
 565       if (i == dim_index)
 566         {
 567           dim_extent = mpz_get_si (array->shape[i]);
 568           dim_stride = tmpstride[i];
 569           continue;
 570         }
 571
 572       extent[n] = mpz_get_si (array->shape[i]);
 573       sstride[n] = tmpstride[i];
 574       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
 575       n += 1;
 576     }
 577
 578   done = false;
 579   base = arrayvec;
 580   dest = resultvec;
 581   while (!done)
 582     {
 583       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
 584         if (*src)
 585           *dest = op (*dest, gfc_copy_expr (*src));
 586
 587       count[0]++;
 588       base += sstride[0];
 589       dest += dstride[0];
 590
 591       n = 0;
 592       while (!done && count[n] == extent[n])
 593         {
 594           count[n] = 0;
 595           base -= sstride[n] * extent[n];
 596           dest -= dstride[n] * extent[n];
 597
 598           n++;
 599           if (n < result->rank)
 600             {
 601               count [n]++;
 602               base += sstride[n];
 603               dest += dstride[n];
 604             }
 605           else
 606             done = true;
 607        }
 608     }
 609
 610   /* Place updated expression in result constructor.  */
 611   result_ctor = gfc_constructor_first (result->value.constructor);
 612   for (i = 0; i < resultsize; ++i)
 613     {
 614       if (post_op)
 615         result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
 616       else
 617         result_ctor->expr = resultvec[i];
 618       result_ctor = gfc_constructor_next (result_ctor);
 619     }
 620
 621   free (arrayvec);
 622   free (resultvec);
 623   return result;
 624 }
 625
 626
 627 static gfc_expr *
 628 simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
 629                          int init_val, transformational_op op)
 630 {
 631   gfc_expr *result;
 632
 633   if (!is_constant_array_expr (array)
 634       || !gfc_is_constant_expr (dim))
 635     return NULL;
 636
 637   if (mask
 638       && !is_constant_array_expr (mask)
 639       && mask->expr_type != EXPR_CONSTANT)
 640     return NULL;
 641
 642   result = transformational_result (array, dim, array->ts.type,
 643                                     array->ts.kind, &array->where);
 644   init_result_expr (result, init_val, NULL);
 645
 646   return !dim || array->rank == 1 ?
 647     simplify_transformation_to_scalar (result, array, mask, op) :
 648     simplify_transformation_to_array (result, array, dim, mask, op, NULL);
 649 }
 650
 651
 652 /********************** Simplification functions *****************************/
 653
 654 gfc_expr *
 655 gfc_simplify_abs (gfc_expr *e)
 656 {
 657   gfc_expr *result;
 658
 659   if (e->expr_type != EXPR_CONSTANT)
 660     return NULL;
 661
 662   switch (e->ts.type)
 663     {
 664       case BT_INTEGER:
 665         result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
 666         mpz_abs (result->value.integer, e->value.integer);
 667         return range_check (result, "IABS");
 668
 669       case BT_REAL:
 670         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 671         mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
 672         return range_check (result, "ABS");
 673
 674       case BT_COMPLEX:
 675         gfc_set_model_kind (e->ts.kind);
 676         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 677         mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
 678         return range_check (result, "CABS");
 679
 680       default:
 681         gfc_internal_error ("gfc_simplify_abs(): Bad type");
 682     }
 683 }
 684
 685
 686 static gfc_expr *
 687 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
 688 {
 689   gfc_expr *result;
 690   int kind;
 691   bool too_large = false;
 692
 693   if (e->expr_type != EXPR_CONSTANT)
 694     return NULL;
 695
 696   kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
 697   if (kind == -1)
 698     return &gfc_bad_expr;
 699
 700   if (mpz_cmp_si (e->value.integer, 0) < 0)
 701     {
 702       gfc_error ("Argument of %s function at %L is negative", name,
 703                  &e->where);
 704       return &gfc_bad_expr;
 705     }
 706
 707   if (ascii && gfc_option.warn_surprising
 708       && mpz_cmp_si (e->value.integer, 127) > 0)
 709     gfc_warning ("Argument of %s function at %L outside of range [0,127]",
 710                  name, &e->where);
 711
 712   if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
 713     too_large = true;
 714   else if (kind == 4)
 715     {
 716       mpz_t t;
 717       mpz_init_set_ui (t, 2);
 718       mpz_pow_ui (t, t, 32);
 719       mpz_sub_ui (t, t, 1);
 720       if (mpz_cmp (e->value.integer, t) > 0)
 721         too_large = true;
 722       mpz_clear (t);
 723     }
 724
 725   if (too_large)
 726     {
 727       gfc_error ("Argument of %s function at %L is too large for the "
 728                  "collating sequence of kind %d", name, &e->where, kind);
 729       return &gfc_bad_expr;
 730     }
 731
 732   result = gfc_get_character_expr (kind, &e->where, NULL, 1);
 733   result->value.character.string[0] = mpz_get_ui (e->value.integer);
 734
 735   return result;
 736 }
 737
 738
 739
 740 /* We use the processor's collating sequence, because all
 741    systems that gfortran currently works on are ASCII.  */
 742
 743 gfc_expr *
 744 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
 745 {
 746   return simplify_achar_char (e, k, "ACHAR", true);
 747 }
 748
 749
 750 gfc_expr *
 751 gfc_simplify_acos (gfc_expr *x)
 752 {
 753   gfc_expr *result;
 754
 755   if (x->expr_type != EXPR_CONSTANT)
 756     return NULL;
 757
 758   switch (x->ts.type)
 759     {
 760       case BT_REAL:
 761         if (mpfr_cmp_si (x->value.real, 1) > 0
 762             || mpfr_cmp_si (x->value.real, -1) < 0)
 763           {
 764             gfc_error ("Argument of ACOS at %L must be between -1 and 1",
 765                        &x->where);
 766             return &gfc_bad_expr;
 767           }
 768         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 769         mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 770         break;
 771
 772       case BT_COMPLEX:
 773         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 774         mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 775         break;
 776
 777       default:
 778         gfc_internal_error ("in gfc_simplify_acos(): Bad type");
 779     }
 780
 781   return range_check (result, "ACOS");
 782 }
 783
 784 gfc_expr *
 785 gfc_simplify_acosh (gfc_expr *x)
 786 {
 787   gfc_expr *result;
 788
 789   if (x->expr_type != EXPR_CONSTANT)
 790     return NULL;
 791
 792   switch (x->ts.type)
 793     {
 794       case BT_REAL:
 795         if (mpfr_cmp_si (x->value.real, 1) < 0)
 796           {
 797             gfc_error ("Argument of ACOSH at %L must not be less than 1",
 798                        &x->where);
 799             return &gfc_bad_expr;
 800           }
 801
 802         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 803         mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
 804         break;
 805
 806       case BT_COMPLEX:
 807         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 808         mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 809         break;
 810
 811       default:
 812         gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
 813     }
 814
 815   return range_check (result, "ACOSH");
 816 }
 817
 818 gfc_expr *
 819 gfc_simplify_adjustl (gfc_expr *e)
 820 {
 821   gfc_expr *result;
 822   int count, i, len;
 823   gfc_char_t ch;
 824
 825   if (e->expr_type != EXPR_CONSTANT)
 826     return NULL;
 827
 828   len = e->value.character.length;
 829
 830   for (count = 0, i = 0; i < len; ++i)
 831     {
 832       ch = e->value.character.string[i];
 833       if (ch != ' ')
 834         break;
 835       ++count;
 836     }
 837
 838   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
 839   for (i = 0; i < len - count; ++i)
 840     result->value.character.string[i] = e->value.character.string[count + i];
 841
 842   return result;
 843 }
 844
 845
 846 gfc_expr *
 847 gfc_simplify_adjustr (gfc_expr *e)
 848 {
 849   gfc_expr *result;
 850   int count, i, len;
 851   gfc_char_t ch;
 852
 853   if (e->expr_type != EXPR_CONSTANT)
 854     return NULL;
 855
 856   len = e->value.character.length;
 857
 858   for (count = 0, i = len - 1; i >= 0; --i)
 859     {
 860       ch = e->value.character.string[i];
 861       if (ch != ' ')
 862         break;
 863       ++count;
 864     }
 865
 866   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
 867   for (i = 0; i < count; ++i)
 868     result->value.character.string[i] = ' ';
 869
 870   for (i = count; i < len; ++i)
 871     result->value.character.string[i] = e->value.character.string[i - count];
 872
 873   return result;
 874 }
 875
 876
 877 gfc_expr *
 878 gfc_simplify_aimag (gfc_expr *e)
 879 {
 880   gfc_expr *result;
 881
 882   if (e->expr_type != EXPR_CONSTANT)
 883     return NULL;
 884
 885   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 886   mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
 887
 888   return range_check (result, "AIMAG");
 889 }
 890
 891
 892 gfc_expr *
 893 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 894 {
 895   gfc_expr *rtrunc, *result;
 896   int kind;
 897
 898   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
 899   if (kind == -1)
 900     return &gfc_bad_expr;
 901
 902   if (e->expr_type != EXPR_CONSTANT)
 903     return NULL;
 904
 905   rtrunc = gfc_copy_expr (e);
 906   mpfr_trunc (rtrunc->value.real, e->value.real);
 907
 908   result = gfc_real2real (rtrunc, kind);
 909
 910   gfc_free_expr (rtrunc);
 911
 912   return range_check (result, "AINT");
 913 }
 914
 915
 916 gfc_expr *
 917 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 918 {
 919   return simplify_transformation (mask, dim, NULL, true, gfc_and);
 920 }
 921
 922
 923 gfc_expr *
 924 gfc_simplify_dint (gfc_expr *e)
 925 {
 926   gfc_expr *rtrunc, *result;
 927
 928   if (e->expr_type != EXPR_CONSTANT)
 929     return NULL;
 930
 931   rtrunc = gfc_copy_expr (e);
 932   mpfr_trunc (rtrunc->value.real, e->value.real);
 933
 934   result = gfc_real2real (rtrunc, gfc_default_double_kind);
 935
 936   gfc_free_expr (rtrunc);
 937
 938   return range_check (result, "DINT");
 939 }
 940
 941
 942 gfc_expr *
 943 gfc_simplify_dreal (gfc_expr *e)
 944 {
 945   gfc_expr *result = NULL;
 946
 947   if (e->expr_type != EXPR_CONSTANT)
 948     return NULL;
 949
 950   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 951   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
 952
 953   return range_check (result, "DREAL");
 954 }
 955
 956
 957 gfc_expr *
 958 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
 959 {
 960   gfc_expr *result;
 961   int kind;
 962
 963   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
 964   if (kind == -1)
 965     return &gfc_bad_expr;
 966
 967   if (e->expr_type != EXPR_CONSTANT)
 968     return NULL;
 969
 970   result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
 971   mpfr_round (result->value.real, e->value.real);
 972
 973   return range_check (result, "ANINT");
 974 }
 975
 976
 977 gfc_expr *
 978 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 979 {
 980   gfc_expr *result;
 981   int kind;
 982
 983   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 984     return NULL;
 985
 986   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
 987
 988   switch (x->ts.type)
 989     {
 990       case BT_INTEGER:
 991         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
 992         mpz_and (result->value.integer, x->value.integer, y->value.integer);
 993         return range_check (result, "AND");
 994
 995       case BT_LOGICAL:
 996         return gfc_get_logical_expr (kind, &x->where,
 997                                      x->value.logical && y->value.logical);
 998
 999       default:
1000         gcc_unreachable ();
1001     }
1002 }
1003
1004
1005 gfc_expr *
1006 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1007 {
1008   return simplify_transformation (mask, dim, NULL, false, gfc_or);
1009 }
1010
1011
1012 gfc_expr *
1013 gfc_simplify_dnint (gfc_expr *e)
1014 {
1015   gfc_expr *result;
1016
1017   if (e->expr_type != EXPR_CONSTANT)
1018     return NULL;
1019
1020   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
1021   mpfr_round (result->value.real, e->value.real);
1022
1023   return range_check (result, "DNINT");
1024 }
1025
1026
1027 gfc_expr *
1028 gfc_simplify_asin (gfc_expr *x)
1029 {
1030   gfc_expr *result;
1031
1032   if (x->expr_type != EXPR_CONSTANT)
1033     return NULL;
1034
1035   switch (x->ts.type)
1036     {
1037       case BT_REAL:
1038         if (mpfr_cmp_si (x->value.real, 1) > 0
1039             || mpfr_cmp_si (x->value.real, -1) < 0)
1040           {
1041             gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1042                        &x->where);
1043             return &gfc_bad_expr;
1044           }
1045         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1046         mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1047         break;
1048
1049       case BT_COMPLEX:
1050         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1051         mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1052         break;
1053
1054       default:
1055         gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1056     }
1057
1058   return range_check (result, "ASIN");
1059 }
1060
1061
1062 gfc_expr *
1063 gfc_simplify_asinh (gfc_expr *x)
1064 {
1065   gfc_expr *result;
1066
1067   if (x->expr_type != EXPR_CONSTANT)
1068     return NULL;
1069
1070   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1071
1072   switch (x->ts.type)
1073     {
1074       case BT_REAL:
1075         mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1076         break;
1077
1078       case BT_COMPLEX:
1079         mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1080         break;
1081
1082       default:
1083         gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1084     }
1085
1086   return range_check (result, "ASINH");
1087 }
1088
1089
1090 gfc_expr *
1091 gfc_simplify_atan (gfc_expr *x)
1092 {
1093   gfc_expr *result;
1094
1095   if (x->expr_type != EXPR_CONSTANT)
1096     return NULL;
1097
1098   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1099
1100   switch (x->ts.type)
1101     {
1102       case BT_REAL:
1103         mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1104         break;
1105
1106       case BT_COMPLEX:
1107         mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1108         break;
1109
1110       default:
1111         gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1112     }
1113
1114   return range_check (result, "ATAN");
1115 }
1116
1117
1118 gfc_expr *
1119 gfc_simplify_atanh (gfc_expr *x)
1120 {
1121   gfc_expr *result;
1122
1123   if (x->expr_type != EXPR_CONSTANT)
1124     return NULL;
1125
1126   switch (x->ts.type)
1127     {
1128       case BT_REAL:
1129         if (mpfr_cmp_si (x->value.real, 1) >= 0
1130             || mpfr_cmp_si (x->value.real, -1) <= 0)
1131           {
1132             gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1133                        "to 1", &x->where);
1134             return &gfc_bad_expr;
1135           }
1136         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1137         mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1138         break;
1139
1140       case BT_COMPLEX:
1141         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1142         mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1143         break;
1144
1145       default:
1146         gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1147     }
1148
1149   return range_check (result, "ATANH");
1150 }
1151
1152
1153 gfc_expr *
1154 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1155 {
1156   gfc_expr *result;
1157
1158   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1159     return NULL;
1160
1161   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
1162     {
1163       gfc_error ("If first argument of ATAN2 %L is zero, then the "
1164                  "second argument must not be zero", &x->where);
1165       return &gfc_bad_expr;
1166     }
1167
1168   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1169   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1170
1171   return range_check (result, "ATAN2");
1172 }
1173
1174
1175 gfc_expr *
1176 gfc_simplify_bessel_j0 (gfc_expr *x)
1177 {
1178   gfc_expr *result;
1179
1180   if (x->expr_type != EXPR_CONSTANT)
1181     return NULL;
1182
1183   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1184   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1185
1186   return range_check (result, "BESSEL_J0");
1187 }
1188
1189
1190 gfc_expr *
1191 gfc_simplify_bessel_j1 (gfc_expr *x)
1192 {
1193   gfc_expr *result;
1194
1195   if (x->expr_type != EXPR_CONSTANT)
1196     return NULL;
1197
1198   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1199   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1200
1201   return range_check (result, "BESSEL_J1");
1202 }
1203
1204
1205 gfc_expr *
1206 gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1207 {
1208   gfc_expr *result;
1209   long n;
1210
1211   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1212     return NULL;
1213
1214   n = mpz_get_si (order->value.integer);
1215   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1216   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1217
1218   return range_check (result, "BESSEL_JN");
1219 }
1220
1221
1222 /* Simplify transformational form of JN and YN.  */
1223
1224 static gfc_expr *
1225 gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1226                         bool jn)
1227 {
1228   gfc_expr *result;
1229   gfc_expr *e;
1230   long n1, n2;
1231   int i;
1232   mpfr_t x2rev, last1, last2;
1233
1234   if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1235       || order2->expr_type != EXPR_CONSTANT)
1236     return NULL;
1237
1238   n1 = mpz_get_si (order1->value.integer);
1239   n2 = mpz_get_si (order2->value.integer);
1240   result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1241   result->rank = 1;
1242   result->shape = gfc_get_shape (1);
1243   mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1244
1245   if (n2 < n1)
1246     return result;
1247
1248   /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1249      YN(N, 0.0) = -Inf.  */
1250
1251   if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1252     {
1253       if (!jn && gfc_option.flag_range_check)
1254         {
1255           gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1256           gfc_free_expr (result);
1257           return &gfc_bad_expr;
1258         }
1259
1260       if (jn && n1 == 0)
1261         {
1262           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1263           mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
1264           gfc_constructor_append_expr (&result->value.constructor, e,
1265                                        &x->where);
1266           n1++;
1267         }
1268
1269       for (i = n1; i <= n2; i++)
1270         {
1271           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1272           if (jn)
1273             mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
1274           else
1275             mpfr_set_inf (e->value.real, -1);
1276           gfc_constructor_append_expr (&result->value.constructor, e,
1277                                        &x->where);
1278         }
1279
1280       return result;
1281     }
1282
1283   /* Use the faster but more verbose recurrence algorithm. Bessel functions
1284      are stable for downward recursion and Neumann functions are stable
1285      for upward recursion. It is
1286        x2rev = 2.0/x,
1287        J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1288        Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1289      Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1  */
1290
1291   gfc_set_model_kind (x->ts.kind);
1292
1293   /* Get first recursion anchor.  */
1294
1295   mpfr_init (last1);
1296   if (jn)
1297     mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1298   else
1299     mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1300
1301   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1302   mpfr_set (e->value.real, last1, GFC_RND_MODE);
1303   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1304     {
1305       mpfr_clear (last1);
1306       gfc_free_expr (e);
1307       gfc_free_expr (result);
1308       return &gfc_bad_expr;
1309     }
1310   gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1311
1312   if (n1 == n2)
1313     {
1314       mpfr_clear (last1);
1315       return result;
1316     }
1317
1318   /* Get second recursion anchor.  */
1319
1320   mpfr_init (last2);
1321   if (jn)
1322     mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1323   else
1324     mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1325
1326   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1327   mpfr_set (e->value.real, last2, GFC_RND_MODE);
1328   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1329     {
1330       mpfr_clear (last1);
1331       mpfr_clear (last2);
1332       gfc_free_expr (e);
1333       gfc_free_expr (result);
1334       return &gfc_bad_expr;
1335     }
1336   if (jn)
1337     gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
1338   else
1339     gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1340
1341   if (n1 + 1 == n2)
1342     {
1343       mpfr_clear (last1);
1344       mpfr_clear (last2);
1345       return result;
1346     }
1347
1348   /* Start actual recursion.  */
1349
1350   mpfr_init (x2rev);
1351   mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
1352
1353   for (i = 2; i <= n2-n1; i++)
1354     {
1355       e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1356
1357       /* Special case: For YN, if the previous N gave -INF, set
1358          also N+1 to -INF.  */
1359       if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2))
1360         {
1361           mpfr_set_inf (e->value.real, -1);
1362           gfc_constructor_append_expr (&result->value.constructor, e,
1363                                        &x->where);
1364           continue;
1365         }
1366
1367       mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1368                    GFC_RND_MODE);
1369       mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1370       mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1371
1372       if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1373         {
1374           /* Range_check frees "e" in that case.  */
1375           e = NULL;
1376           goto error;
1377         }
1378
1379       if (jn)
1380         gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1381                                      -i-1);
1382       else
1383         gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1384
1385       mpfr_set (last1, last2, GFC_RND_MODE);
1386       mpfr_set (last2, e->value.real, GFC_RND_MODE);
1387     }
1388
1389   mpfr_clear (last1);
1390   mpfr_clear (last2);
1391   mpfr_clear (x2rev);
1392   return result;
1393
1394 error:
1395   mpfr_clear (last1);
1396   mpfr_clear (last2);
1397   mpfr_clear (x2rev);
1398   gfc_free_expr (e);
1399   gfc_free_expr (result);
1400   return &gfc_bad_expr;
1401 }
1402
1403
1404 gfc_expr *
1405 gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1406 {
1407   return gfc_simplify_bessel_n2 (order1, order2, x, true);
1408 }
1409
1410
1411 gfc_expr *
1412 gfc_simplify_bessel_y0 (gfc_expr *x)
1413 {
1414   gfc_expr *result;
1415
1416   if (x->expr_type != EXPR_CONSTANT)
1417     return NULL;
1418
1419   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1420   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1421
1422   return range_check (result, "BESSEL_Y0");
1423 }
1424
1425
1426 gfc_expr *
1427 gfc_simplify_bessel_y1 (gfc_expr *x)
1428 {
1429   gfc_expr *result;
1430
1431   if (x->expr_type != EXPR_CONSTANT)
1432     return NULL;
1433
1434   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1435   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1436
1437   return range_check (result, "BESSEL_Y1");
1438 }
1439
1440
1441 gfc_expr *
1442 gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1443 {
1444   gfc_expr *result;
1445   long n;
1446
1447   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1448     return NULL;
1449
1450   n = mpz_get_si (order->value.integer);
1451   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1452   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1453
1454   return range_check (result, "BESSEL_YN");
1455 }
1456
1457
1458 gfc_expr *
1459 gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1460 {
1461   return gfc_simplify_bessel_n2 (order1, order2, x, false);
1462 }
1463
1464
1465 gfc_expr *
1466 gfc_simplify_bit_size (gfc_expr *e)
1467 {
1468   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1469   return gfc_get_int_expr (e->ts.kind, &e->where,
1470                            gfc_integer_kinds[i].bit_size);
1471 }
1472
1473
1474 gfc_expr *
1475 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1476 {
1477   int b;
1478
1479   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1480     return NULL;
1481
1482   if (gfc_extract_int (bit, &b) != NULL || b < 0)
1483     return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1484
1485   return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1486                                mpz_tstbit (e->value.integer, b));
1487 }
1488
1489
1490 static int
1491 compare_bitwise (gfc_expr *i, gfc_expr *j)
1492 {
1493   mpz_t x, y;
1494   int k, res;
1495
1496   gcc_assert (i->ts.type == BT_INTEGER);
1497   gcc_assert (j->ts.type == BT_INTEGER);
1498
1499   mpz_init_set (x, i->value.integer);
1500   k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1501   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
1502
1503   mpz_init_set (y, j->value.integer);
1504   k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1505   convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
1506
1507   res = mpz_cmp (x, y);
1508   mpz_clear (x);
1509   mpz_clear (y);
1510   return res;
1511 }
1512
1513
1514 gfc_expr *
1515 gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1516 {
1517   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1518     return NULL;
1519
1520   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1521                                compare_bitwise (i, j) >= 0);
1522 }
1523
1524
1525 gfc_expr *
1526 gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1527 {
1528   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1529     return NULL;
1530
1531   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1532                                compare_bitwise (i, j) > 0);
1533 }
1534
1535
1536 gfc_expr *
1537 gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1538 {
1539   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1540     return NULL;
1541
1542   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1543                                compare_bitwise (i, j) <= 0);
1544 }
1545
1546
1547 gfc_expr *
1548 gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1549 {
1550   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1551     return NULL;
1552
1553   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1554                                compare_bitwise (i, j) < 0);
1555 }
1556
1557
1558 gfc_expr *
1559 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1560 {
1561   gfc_expr *ceil, *result;
1562   int kind;
1563
1564   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1565   if (kind == -1)
1566     return &gfc_bad_expr;
1567
1568   if (e->expr_type != EXPR_CONSTANT)
1569     return NULL;
1570
1571   ceil = gfc_copy_expr (e);
1572   mpfr_ceil (ceil->value.real, e->value.real);
1573
1574   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1575   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1576
1577   gfc_free_expr (ceil);
1578
1579   return range_check (result, "CEILING");
1580 }
1581
1582
1583 gfc_expr *
1584 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1585 {
1586   return simplify_achar_char (e, k, "CHAR", false);
1587 }
1588
1589
1590 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX.  */
1591
1592 static gfc_expr *
1593 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1594 {
1595   gfc_expr *result;
1596
1597   if (convert_boz (x, kind) == &gfc_bad_expr)
1598     return &gfc_bad_expr;
1599
1600   if (convert_boz (y, kind) == &gfc_bad_expr)
1601     return &gfc_bad_expr;
1602
1603   if (x->expr_type != EXPR_CONSTANT
1604       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1605     return NULL;
1606
1607   result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1608
1609   switch (x->ts.type)
1610     {
1611       case BT_INTEGER:
1612         mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1613         break;
1614
1615       case BT_REAL:
1616         mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1617         break;
1618
1619       case BT_COMPLEX:
1620         mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1621         break;
1622
1623       default:
1624         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1625     }
1626
1627   if (!y)
1628     return range_check (result, name);
1629
1630   switch (y->ts.type)
1631     {
1632       case BT_INTEGER:
1633         mpfr_set_z (mpc_imagref (result->value.complex),
1634                     y->value.integer, GFC_RND_MODE);
1635         break;
1636
1637       case BT_REAL:
1638         mpfr_set (mpc_imagref (result->value.complex),
1639                   y->value.real, GFC_RND_MODE);
1640         break;
1641
1642       default:
1643         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1644     }
1645
1646   return range_check (result, name);
1647 }
1648
1649
1650 gfc_expr *
1651 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1652 {
1653   int kind;
1654
1655   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1656   if (kind == -1)
1657     return &gfc_bad_expr;
1658
1659   return simplify_cmplx ("CMPLX", x, y, kind);
1660 }
1661
1662
1663 gfc_expr *
1664 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1665 {
1666   int kind;
1667
1668   if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1669     kind = gfc_default_complex_kind;
1670   else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1671     kind = x->ts.kind;
1672   else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1673     kind = y->ts.kind;
1674   else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1675     kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1676   else
1677     gcc_unreachable ();
1678
1679   return simplify_cmplx ("COMPLEX", x, y, kind);
1680 }
1681
1682
1683 gfc_expr *
1684 gfc_simplify_conjg (gfc_expr *e)
1685 {
1686   gfc_expr *result;
1687
1688   if (e->expr_type != EXPR_CONSTANT)
1689     return NULL;
1690
1691   result = gfc_copy_expr (e);
1692   mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1693
1694   return range_check (result, "CONJG");
1695 }
1696
1697
1698 gfc_expr *
1699 gfc_simplify_cos (gfc_expr *x)
1700 {
1701   gfc_expr *result;
1702
1703   if (x->expr_type != EXPR_CONSTANT)
1704     return NULL;
1705
1706   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1707
1708   switch (x->ts.type)
1709     {
1710       case BT_REAL:
1711         mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1712         break;
1713
1714       case BT_COMPLEX:
1715         gfc_set_model_kind (x->ts.kind);
1716         mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1717         break;
1718
1719       default:
1720         gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1721     }
1722
1723   return range_check (result, "COS");
1724 }
1725
1726
1727 gfc_expr *
1728 gfc_simplify_cosh (gfc_expr *x)
1729 {
1730   gfc_expr *result;
1731
1732   if (x->expr_type != EXPR_CONSTANT)
1733     return NULL;
1734
1735   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1736
1737   switch (x->ts.type)
1738     {
1739       case BT_REAL:
1740         mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1741         break;
1742
1743       case BT_COMPLEX:
1744         mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1745         break;
1746
1747       default:
1748         gcc_unreachable ();
1749     }
1750
1751   return range_check (result, "COSH");
1752 }
1753
1754
1755 gfc_expr *
1756 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1757 {
1758   gfc_expr *result;
1759
1760   if (!is_constant_array_expr (mask)
1761       || !gfc_is_constant_expr (dim)
1762       || !gfc_is_constant_expr (kind))
1763     return NULL;
1764
1765   result = transformational_result (mask, dim,
1766                                     BT_INTEGER,
1767                                     get_kind (BT_INTEGER, kind, "COUNT",
1768                                               gfc_default_integer_kind),
1769                                     &mask->where);
1770
1771   init_result_expr (result, 0, NULL);
1772
1773   /* Passing MASK twice, once as data array, once as mask.
1774      Whenever gfc_count is called, '1' is added to the result.  */
1775   return !dim || mask->rank == 1 ?
1776     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1777     simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
1778 }
1779
1780
1781 gfc_expr *
1782 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1783 {
1784   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1785 }
1786
1787
1788 gfc_expr *
1789 gfc_simplify_dble (gfc_expr *e)
1790 {
1791   gfc_expr *result = NULL;
1792
1793   if (e->expr_type != EXPR_CONSTANT)
1794     return NULL;
1795
1796   if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
1797     return &gfc_bad_expr;
1798
1799   result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
1800   if (result == &gfc_bad_expr)
1801     return &gfc_bad_expr;
1802
1803   return range_check (result, "DBLE");
1804 }
1805
1806
1807 gfc_expr *
1808 gfc_simplify_digits (gfc_expr *x)
1809 {
1810   int i, digits;
1811
1812   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1813
1814   switch (x->ts.type)
1815     {
1816       case BT_INTEGER:
1817         digits = gfc_integer_kinds[i].digits;
1818         break;
1819
1820       case BT_REAL:
1821       case BT_COMPLEX:
1822         digits = gfc_real_kinds[i].digits;
1823         break;
1824
1825       default:
1826         gcc_unreachable ();
1827     }
1828
1829   return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
1830 }
1831
1832
1833 gfc_expr *
1834 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1835 {
1836   gfc_expr *result;
1837   int kind;
1838
1839   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1840     return NULL;
1841
1842   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1843   result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
1844
1845   switch (x->ts.type)
1846     {
1847       case BT_INTEGER:
1848         if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1849           mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1850         else
1851           mpz_set_ui (result->value.integer, 0);
1852
1853         break;
1854
1855       case BT_REAL:
1856         if (mpfr_cmp (x->value.real, y->value.real) > 0)
1857           mpfr_sub (result->value.real, x->value.real, y->value.real,
1858                     GFC_RND_MODE);
1859         else
1860           mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1861
1862         break;
1863
1864       default:
1865         gfc_internal_error ("gfc_simplify_dim(): Bad type");
1866     }
1867
1868   return range_check (result, "DIM");
1869 }
1870
1871
1872 gfc_expr*
1873 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1874 {
1875   if (!is_constant_array_expr (vector_a)
1876       || !is_constant_array_expr (vector_b))
1877     return NULL;
1878
1879   gcc_assert (vector_a->rank == 1);
1880   gcc_assert (vector_b->rank == 1);
1881   gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1882
1883   return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
1884 }
1885
1886
1887 gfc_expr *
1888 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1889 {
1890   gfc_expr *a1, *a2, *result;
1891
1892   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1893     return NULL;
1894
1895   a1 = gfc_real2real (x, gfc_default_double_kind);
1896   a2 = gfc_real2real (y, gfc_default_double_kind);
1897
1898   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
1899   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1900
1901   gfc_free_expr (a2);
1902   gfc_free_expr (a1);
1903
1904   return range_check (result, "DPROD");
1905 }
1906
1907
1908 static gfc_expr *
1909 simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
1910                       bool right)
1911 {
1912   gfc_expr *result;
1913   int i, k, size, shift;
1914
1915   if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
1916       || shiftarg->expr_type != EXPR_CONSTANT)
1917     return NULL;
1918
1919   k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
1920   size = gfc_integer_kinds[k].bit_size;
1921
1922   gfc_extract_int (shiftarg, &shift);
1923
1924   /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT).  */
1925   if (right)
1926     shift = size - shift;
1927
1928   result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
1929   mpz_set_ui (result->value.integer, 0);
1930
1931   for (i = 0; i < shift; i++)
1932     if (mpz_tstbit (arg2->value.integer, size - shift + i))
1933       mpz_setbit (result->value.integer, i);
1934
1935   for (i = 0; i < size - shift; i++)
1936     if (mpz_tstbit (arg1->value.integer, i))
1937       mpz_setbit (result->value.integer, shift + i);
1938
1939   /* Convert to a signed value.  */
1940   convert_mpz_to_signed (result->value.integer, size);
1941
1942   return result;
1943 }
1944
1945
1946 gfc_expr *
1947 gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
1948 {
1949   return simplify_dshift (arg1, arg2, shiftarg, true);
1950 }
1951
1952
1953 gfc_expr *
1954 gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
1955 {
1956   return simplify_dshift (arg1, arg2, shiftarg, false);
1957 }
1958
1959
1960 gfc_expr *
1961 gfc_simplify_erf (gfc_expr *x)
1962 {
1963   gfc_expr *result;
1964
1965   if (x->expr_type != EXPR_CONSTANT)
1966     return NULL;
1967
1968   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1969   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1970
1971   return range_check (result, "ERF");
1972 }
1973
1974
1975 gfc_expr *
1976 gfc_simplify_erfc (gfc_expr *x)
1977 {
1978   gfc_expr *result;
1979
1980   if (x->expr_type != EXPR_CONSTANT)
1981     return NULL;
1982
1983   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1984   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1985
1986   return range_check (result, "ERFC");
1987 }
1988
1989
1990 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */
1991
1992 #define MAX_ITER 200
1993 #define ARG_LIMIT 12
1994
1995 /* Calculate ERFC_SCALED directly by its definition:
1996
1997      ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1998
1999    using a large precision for intermediate results.  This is used for all
2000    but large values of the argument.  */
2001 static void
2002 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2003 {
2004   mp_prec_t prec;
2005   mpfr_t a, b;
2006
2007   prec = mpfr_get_default_prec ();
2008   mpfr_set_default_prec (10 * prec);
2009
2010   mpfr_init (a);
2011   mpfr_init (b);
2012
2013   mpfr_set (a, arg, GFC_RND_MODE);
2014   mpfr_sqr (b, a, GFC_RND_MODE);
2015   mpfr_exp (b, b, GFC_RND_MODE);
2016   mpfr_erfc (a, a, GFC_RND_MODE);
2017   mpfr_mul (a, a, b, GFC_RND_MODE);
2018
2019   mpfr_set (res, a, GFC_RND_MODE);
2020   mpfr_set_default_prec (prec);
2021
2022   mpfr_clear (a);
2023   mpfr_clear (b);
2024 }
2025
2026 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2027
2028     ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2029                      * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2030                                           / (2 * x**2)**n)
2031
2032   This is used for large values of the argument.  Intermediate calculations
2033   are performed with twice the precision.  We don't do a fixed number of
2034   iterations of the sum, but stop when it has converged to the required
2035   precision.  */
2036 static void
2037 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2038 {
2039   mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2040   mpz_t num;
2041   mp_prec_t prec;
2042   unsigned i;
2043
2044   prec = mpfr_get_default_prec ();
2045   mpfr_set_default_prec (2 * prec);
2046
2047   mpfr_init (sum);
2048   mpfr_init (x);
2049   mpfr_init (u);
2050   mpfr_init (v);
2051   mpfr_init (w);
2052   mpz_init (num);
2053
2054   mpfr_init (oldsum);
2055   mpfr_init (sumtrunc);
2056   mpfr_set_prec (oldsum, prec);
2057   mpfr_set_prec (sumtrunc, prec);
2058
2059   mpfr_set (x, arg, GFC_RND_MODE);
2060   mpfr_set_ui (sum, 1, GFC_RND_MODE);
2061   mpz_set_ui (num, 1);
2062
2063   mpfr_set (u, x, GFC_RND_MODE);
2064   mpfr_sqr (u, u, GFC_RND_MODE);
2065   mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2066   mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2067
2068   for (i = 1; i < MAX_ITER; i++)
2069   {
2070     mpfr_set (oldsum, sum, GFC_RND_MODE);
2071
2072     mpz_mul_ui (num, num, 2 * i - 1);
2073     mpz_neg (num, num);
2074
2075     mpfr_set (w, u, GFC_RND_MODE);
2076     mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2077
2078     mpfr_set_z (v, num, GFC_RND_MODE);
2079     mpfr_mul (v, v, w, GFC_RND_MODE);
2080
2081     mpfr_add (sum, sum, v, GFC_RND_MODE);
2082
2083     mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2084     if (mpfr_cmp (sumtrunc, oldsum) == 0)
2085       break;
2086   }
2087
2088   /* We should have converged by now; otherwise, ARG_LIMIT is probably
2089      set too low.  */
2090   gcc_assert (i < MAX_ITER);
2091
2092   /* Divide by x * sqrt(Pi).  */
2093   mpfr_const_pi (u, GFC_RND_MODE);
2094   mpfr_sqrt (u, u, GFC_RND_MODE);
2095   mpfr_mul (u, u, x, GFC_RND_MODE);
2096   mpfr_div (sum, sum, u, GFC_RND_MODE);
2097
2098   mpfr_set (res, sum, GFC_RND_MODE);
2099   mpfr_set_default_prec (prec);
2100
2101   mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2102   mpz_clear (num);
2103 }
2104
2105
2106 gfc_expr *
2107 gfc_simplify_erfc_scaled (gfc_expr *x)
2108 {
2109   gfc_expr *result;
2110
2111   if (x->expr_type != EXPR_CONSTANT)
2112     return NULL;
2113
2114   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2115   if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2116     asympt_erfc_scaled (result->value.real, x->value.real);
2117   else
2118     fullprec_erfc_scaled (result->value.real, x->value.real);
2119
2120   return range_check (result, "ERFC_SCALED");
2121 }
2122
2123 #undef MAX_ITER
2124 #undef ARG_LIMIT
2125
2126
2127 gfc_expr *
2128 gfc_simplify_epsilon (gfc_expr *e)
2129 {
2130   gfc_expr *result;
2131   int i;
2132
2133   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2134
2135   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2136   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2137
2138   return range_check (result, "EPSILON");
2139 }
2140
2141
2142 gfc_expr *
2143 gfc_simplify_exp (gfc_expr *x)
2144 {
2145   gfc_expr *result;
2146
2147   if (x->expr_type != EXPR_CONSTANT)
2148     return NULL;
2149
2150   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2151
2152   switch (x->ts.type)
2153     {
2154       case BT_REAL:
2155         mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2156         break;
2157
2158       case BT_COMPLEX:
2159         gfc_set_model_kind (x->ts.kind);
2160         mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2161         break;
2162
2163       default:
2164         gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2165     }
2166
2167   return range_check (result, "EXP");
2168 }
2169
2170
2171 gfc_expr *
2172 gfc_simplify_exponent (gfc_expr *x)
2173 {
2174   int i;
2175   gfc_expr *result;
2176
2177   if (x->expr_type != EXPR_CONSTANT)
2178     return NULL;
2179
2180   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2181                                   &x->where);
2182
2183   gfc_set_model (x->value.real);
2184
2185   if (mpfr_sgn (x->value.real) == 0)
2186     {
2187       mpz_set_ui (result->value.integer, 0);
2188       return result;
2189     }
2190
2191   i = (int) mpfr_get_exp (x->value.real);
2192   mpz_set_si (result->value.integer, i);
2193
2194   return range_check (result, "EXPONENT");
2195 }
2196
2197
2198 gfc_expr *
2199 gfc_simplify_float (gfc_expr *a)
2200 {
2201   gfc_expr *result;
2202
2203   if (a->expr_type != EXPR_CONSTANT)
2204     return NULL;
2205
2206   if (a->is_boz)
2207     {
2208       if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
2209         return &gfc_bad_expr;
2210
2211       result = gfc_copy_expr (a);
2212     }
2213   else
2214     result = gfc_int2real (a, gfc_default_real_kind);
2215
2216   return range_check (result, "FLOAT");
2217 }
2218
2219
2220 static bool
2221 is_last_ref_vtab (gfc_expr *e)
2222 {
2223   gfc_ref *ref;
2224   gfc_component *comp = NULL;
2225
2226   if (e->expr_type != EXPR_VARIABLE)
2227     return false;
2228
2229   for (ref = e->ref; ref; ref = ref->next)
2230     if (ref->type == REF_COMPONENT)
2231       comp = ref->u.c.component;
2232
2233   if (!e->ref || !comp)
2234     return e->symtree->n.sym->attr.vtab;
2235
2236   if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
2237     return true;
2238
2239   return false;
2240 }
2241
2242
2243 gfc_expr *
2244 gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
2245 {
2246   /* Avoid simplification of resolved symbols.  */
2247   if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
2248     return NULL;
2249
2250   if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
2251     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2252                                  gfc_type_is_extension_of (mold->ts.u.derived,
2253                                                            a->ts.u.derived));
2254   /* Return .false. if the dynamic type can never be the same.  */
2255   if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
2256        && !gfc_type_is_extension_of
2257                         (mold->ts.u.derived->components->ts.u.derived,
2258                          a->ts.u.derived->components->ts.u.derived)
2259        && !gfc_type_is_extension_of
2260                         (a->ts.u.derived->components->ts.u.derived,
2261                          mold->ts.u.derived->components->ts.u.derived))
2262       || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
2263           && !gfc_type_is_extension_of
2264                         (a->ts.u.derived,
2265                          mold->ts.u.derived->components->ts.u.derived)
2266           && !gfc_type_is_extension_of
2267                         (mold->ts.u.derived->components->ts.u.derived,
2268                          a->ts.u.derived))
2269       || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
2270           && !gfc_type_is_extension_of
2271                         (mold->ts.u.derived,
2272                          a->ts.u.derived->components->ts.u.derived)))
2273     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2274
2275   if (mold->ts.type == BT_DERIVED
2276       && gfc_type_is_extension_of (mold->ts.u.derived,
2277                                    a->ts.u.derived->components->ts.u.derived))
2278     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
2279
2280   return NULL;
2281 }
2282
2283
2284 gfc_expr *
2285 gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
2286 {
2287   /* Avoid simplification of resolved symbols.  */
2288   if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
2289     return NULL;
2290
2291   /* Return .false. if the dynamic type can never be the
2292      same.  */
2293   if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
2294       && !gfc_type_compatible (&a->ts, &b->ts)
2295       && !gfc_type_compatible (&b->ts, &a->ts))
2296     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2297
2298   if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
2299      return NULL;
2300
2301   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2302                                gfc_compare_derived_types (a->ts.u.derived,
2303                                                           b->ts.u.derived));
2304 }
2305
2306
2307 gfc_expr *
2308 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
2309 {
2310   gfc_expr *result;
2311   mpfr_t floor;
2312   int kind;
2313
2314   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
2315   if (kind == -1)
2316     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2317
2318   if (e->expr_type != EXPR_CONSTANT)
2319     return NULL;
2320
2321   gfc_set_model_kind (kind);
2322
2323   mpfr_init (floor);
2324   mpfr_floor (floor, e->value.real);
2325
2326   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
2327   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
2328
2329   mpfr_clear (floor);
2330
2331   return range_check (result, "FLOOR");
2332 }
2333
2334
2335 gfc_expr *
2336 gfc_simplify_fraction (gfc_expr *x)
2337 {
2338   gfc_expr *result;
2339   mpfr_t absv, exp, pow2;
2340
2341   if (x->expr_type != EXPR_CONSTANT)
2342     return NULL;
2343
2344   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
2345
2346   if (mpfr_sgn (x->value.real) == 0)
2347     {
2348       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2349       return result;
2350     }
2351
2352   gfc_set_model_kind (x->ts.kind);
2353   mpfr_init (exp);
2354   mpfr_init (absv);
2355   mpfr_init (pow2);
2356
2357   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2358   mpfr_log2 (exp, absv, GFC_RND_MODE);
2359
2360   mpfr_trunc (exp, exp);
2361   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
2362
2363   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2364
2365   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
2366
2367   mpfr_clears (exp, absv, pow2, NULL);
2368
2369   return range_check (result, "FRACTION");
2370 }
2371
2372
2373 gfc_expr *
2374 gfc_simplify_gamma (gfc_expr *x)
2375 {
2376   gfc_expr *result;
2377
2378   if (x->expr_type != EXPR_CONSTANT)
2379     return NULL;
2380
2381   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2382   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2383
2384   return range_check (result, "GAMMA");
2385 }
2386
2387
2388 gfc_expr *
2389 gfc_simplify_huge (gfc_expr *e)
2390 {
2391   gfc_expr *result;
2392   int i;
2393
2394   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2395   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2396
2397   switch (e->ts.type)
2398     {
2399       case BT_INTEGER:
2400         mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2401         break;
2402
2403       case BT_REAL:
2404         mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2405         break;
2406
2407       default:
2408         gcc_unreachable ();
2409     }
2410
2411   return result;
2412 }
2413
2414
2415 gfc_expr *
2416 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2417 {
2418   gfc_expr *result;
2419
2420   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2421     return NULL;
2422
2423   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2424   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2425   return range_check (result, "HYPOT");
2426 }
2427
2428
2429 /* We use the processor's collating sequence, because all
2430    systems that gfortran currently works on are ASCII.  */
2431
2432 gfc_expr *
2433 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2434 {
2435   gfc_expr *result;
2436   gfc_char_t index;
2437   int k;
2438
2439   if (e->expr_type != EXPR_CONSTANT)
2440     return NULL;
2441
2442   if (e->value.character.length != 1)
2443     {
2444       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2445       return &gfc_bad_expr;
2446     }
2447
2448   index = e->value.character.string[0];
2449
2450   if (gfc_option.warn_surprising && index > 127)
2451     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2452                  &e->where);
2453
2454   k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2455   if (k == -1)
2456     return &gfc_bad_expr;
2457
2458   result = gfc_get_int_expr (k, &e->where, index);
2459
2460   return range_check (result, "IACHAR");
2461 }
2462
2463
2464 static gfc_expr *
2465 do_bit_and (gfc_expr *result, gfc_expr *e)
2466 {
2467   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2468   gcc_assert (result->ts.type == BT_INTEGER
2469               && result->expr_type == EXPR_CONSTANT);
2470
2471   mpz_and (result->value.integer, result->value.integer, e->value.integer);
2472   return result;
2473 }
2474
2475
2476 gfc_expr *
2477 gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2478 {
2479   return simplify_transformation (array, dim, mask, -1, do_bit_and);
2480 }
2481
2482
2483 static gfc_expr *
2484 do_bit_ior (gfc_expr *result, gfc_expr *e)
2485 {
2486   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2487   gcc_assert (result->ts.type == BT_INTEGER
2488               && result->expr_type == EXPR_CONSTANT);
2489
2490   mpz_ior (result->value.integer, result->value.integer, e->value.integer);
2491   return result;
2492 }
2493
2494
2495 gfc_expr *
2496 gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2497 {
2498   return simplify_transformation (array, dim, mask, 0, do_bit_ior);
2499 }
2500
2501
2502 gfc_expr *
2503 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2504 {
2505   gfc_expr *result;
2506
2507   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2508     return NULL;
2509
2510   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2511   mpz_and (result->value.integer, x->value.integer, y->value.integer);
2512
2513   return range_check (result, "IAND");
2514 }
2515
2516
2517 gfc_expr *
2518 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2519 {
2520   gfc_expr *result;
2521   int k, pos;
2522
2523   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2524     return NULL;
2525
2526   gfc_extract_int (y, &pos);
2527
2528   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2529
2530   result = gfc_copy_expr (x);
2531
2532   convert_mpz_to_unsigned (result->value.integer,
2533                            gfc_integer_kinds[k].bit_size);
2534
2535   mpz_clrbit (result->value.integer, pos);
2536
2537   convert_mpz_to_signed (result->value.integer,
2538                          gfc_integer_kinds[k].bit_size);
2539
2540   return result;
2541 }
2542
2543
2544 gfc_expr *
2545 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2546 {
2547   gfc_expr *result;
2548   int pos, len;
2549   int i, k, bitsize;
2550   int *bits;
2551
2552   if (x->expr_type != EXPR_CONSTANT
2553       || y->expr_type != EXPR_CONSTANT
2554       || z->expr_type != EXPR_CONSTANT)
2555     return NULL;
2556
2557   gfc_extract_int (y, &pos);
2558   gfc_extract_int (z, &len);
2559
2560   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2561
2562   bitsize = gfc_integer_kinds[k].bit_size;
2563
2564   if (pos + len > bitsize)
2565     {
2566       gfc_error ("Sum of second and third arguments of IBITS exceeds "
2567                  "bit size at %L", &y->where);
2568       return &gfc_bad_expr;
2569     }
2570
2571   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2572   convert_mpz_to_unsigned (result->value.integer,
2573                            gfc_integer_kinds[k].bit_size);
2574
2575   bits = XCNEWVEC (int, bitsize);
2576
2577   for (i = 0; i < bitsize; i++)
2578     bits[i] = 0;
2579
2580   for (i = 0; i < len; i++)
2581     bits[i] = mpz_tstbit (x->value.integer, i + pos);
2582
2583   for (i = 0; i < bitsize; i++)
2584     {
2585       if (bits[i] == 0)
2586         mpz_clrbit (result->value.integer, i);
2587       else if (bits[i] == 1)
2588         mpz_setbit (result->value.integer, i);
2589       else
2590         gfc_internal_error ("IBITS: Bad bit");
2591     }
2592
2593   free (bits);
2594
2595   convert_mpz_to_signed (result->value.integer,
2596                          gfc_integer_kinds[k].bit_size);
2597
2598   return result;
2599 }
2600
2601
2602 gfc_expr *
2603 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2604 {
2605   gfc_expr *result;
2606   int k, pos;
2607
2608   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2609     return NULL;
2610
2611   gfc_extract_int (y, &pos);
2612
2613   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2614
2615   result = gfc_copy_expr (x);
2616
2617   convert_mpz_to_unsigned (result->value.integer,
2618                            gfc_integer_kinds[k].bit_size);
2619
2620   mpz_setbit (result->value.integer, pos);
2621
2622   convert_mpz_to_signed (result->value.integer,
2623                          gfc_integer_kinds[k].bit_size);
2624
2625   return result;
2626 }
2627
2628
2629 gfc_expr *
2630 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2631 {
2632   gfc_expr *result;
2633   gfc_char_t index;
2634   int k;
2635
2636   if (e->expr_type != EXPR_CONSTANT)
2637     return NULL;
2638
2639   if (e->value.character.length != 1)
2640     {
2641       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2642       return &gfc_bad_expr;
2643     }
2644
2645   index = e->value.character.string[0];
2646
2647   k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2648   if (k == -1)
2649     return &gfc_bad_expr;
2650
2651   result = gfc_get_int_expr (k, &e->where, index);
2652
2653   return range_check (result, "ICHAR");
2654 }
2655
2656
2657 gfc_expr *
2658 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2659 {
2660   gfc_expr *result;
2661
2662   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2663     return NULL;
2664
2665   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2666   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2667
2668   return range_check (result, "IEOR");
2669 }
2670
2671
2672 gfc_expr *
2673 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2674 {
2675   gfc_expr *result;
2676   int back, len, lensub;
2677   int i, j, k, count, index = 0, start;
2678
2679   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2680       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
2681     return NULL;
2682
2683   if (b != NULL && b->value.logical != 0)
2684     back = 1;
2685   else
2686     back = 0;
2687
2688   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2689   if (k == -1)
2690     return &gfc_bad_expr;
2691
2692   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2693
2694   len = x->value.character.length;
2695   lensub = y->value.character.length;
2696
2697   if (len < lensub)
2698     {
2699       mpz_set_si (result->value.integer, 0);
2700       return result;
2701     }
2702
2703   if (back == 0)
2704     {
2705       if (lensub == 0)
2706         {
2707           mpz_set_si (result->value.integer, 1);
2708           return result;
2709         }
2710       else if (lensub == 1)
2711         {
2712           for (i = 0; i < len; i++)
2713             {
2714               for (j = 0; j < lensub; j++)
2715                 {
2716                   if (y->value.character.string[j]
2717                       == x->value.character.string[i])
2718                     {
2719                       index = i + 1;
2720                       goto done;
2721                     }
2722                 }
2723             }
2724         }
2725       else
2726         {
2727           for (i = 0; i < len; i++)
2728             {
2729               for (j = 0; j < lensub; j++)
2730                 {
2731                   if (y->value.character.string[j]
2732                       == x->value.character.string[i])
2733                     {
2734                       start = i;
2735                       count = 0;
2736
2737                       for (k = 0; k < lensub; k++)
2738                         {
2739                           if (y->value.character.string[k]
2740                               == x->value.character.string[k + start])
2741                             count++;
2742                         }
2743
2744                       if (count == lensub)
2745                         {
2746                           index = start + 1;
2747                           goto done;
2748                         }
2749                     }
2750                 }
2751             }
2752         }
2753
2754     }
2755   else
2756     {
2757       if (lensub == 0)
2758         {
2759           mpz_set_si (result->value.integer, len + 1);
2760           return result;
2761         }
2762       else if (lensub == 1)
2763         {
2764           for (i = 0; i < len; i++)
2765             {
2766               for (j = 0; j < lensub; j++)
2767                 {
2768                   if (y->value.character.string[j]
2769                       == x->value.character.string[len - i])
2770                     {
2771                       index = len - i + 1;
2772                       goto done;
2773                     }
2774                 }
2775             }
2776         }
2777       else
2778         {
2779           for (i = 0; i < len; i++)
2780             {
2781               for (j = 0; j < lensub; j++)
2782                 {
2783                   if (y->value.character.string[j]
2784                       == x->value.character.string[len - i])
2785                     {
2786                       start = len - i;
2787                       if (start <= len - lensub)
2788                         {
2789                           count = 0;
2790                           for (k = 0; k < lensub; k++)
2791                             if (y->value.character.string[k]
2792                                 == x->value.character.string[k + start])
2793                               count++;
2794
2795                           if (count == lensub)
2796                             {
2797                               index = start + 1;
2798                               goto done;
2799                             }
2800                         }
2801                       else
2802                         {
2803                           continue;
2804                         }
2805                     }
2806                 }
2807             }
2808         }
2809     }
2810
2811 done:
2812   mpz_set_si (result->value.integer, index);
2813   return range_check (result, "INDEX");
2814 }
2815
2816
2817 static gfc_expr *
2818 simplify_intconv (gfc_expr *e, int kind, const char *name)
2819 {
2820   gfc_expr *result = NULL;
2821
2822   if (e->expr_type != EXPR_CONSTANT)
2823     return NULL;
2824
2825   result = gfc_convert_constant (e, BT_INTEGER, kind);
2826   if (result == &gfc_bad_expr)
2827     return &gfc_bad_expr;
2828
2829   return range_check (result, name);
2830 }
2831
2832
2833 gfc_expr *
2834 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2835 {
2836   int kind;
2837
2838   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2839   if (kind == -1)
2840     return &gfc_bad_expr;
2841
2842   return simplify_intconv (e, kind, "INT");
2843 }
2844
2845 gfc_expr *
2846 gfc_simplify_int2 (gfc_expr *e)
2847 {
2848   return simplify_intconv (e, 2, "INT2");
2849 }
2850
2851
2852 gfc_expr *
2853 gfc_simplify_int8 (gfc_expr *e)
2854 {
2855   return simplify_intconv (e, 8, "INT8");
2856 }
2857
2858
2859 gfc_expr *
2860 gfc_simplify_long (gfc_expr *e)
2861 {
2862   return simplify_intconv (e, 4, "LONG");
2863 }
2864
2865
2866 gfc_expr *
2867 gfc_simplify_ifix (gfc_expr *e)
2868 {
2869   gfc_expr *rtrunc, *result;
2870
2871   if (e->expr_type != EXPR_CONSTANT)
2872     return NULL;
2873
2874   rtrunc = gfc_copy_expr (e);
2875   mpfr_trunc (rtrunc->value.real, e->value.real);
2876
2877   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2878                                   &e->where);
2879   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2880
2881   gfc_free_expr (rtrunc);
2882
2883   return range_check (result, "IFIX");
2884 }
2885
2886
2887 gfc_expr *
2888 gfc_simplify_idint (gfc_expr *e)
2889 {
2890   gfc_expr *rtrunc, *result;
2891
2892   if (e->expr_type != EXPR_CONSTANT)
2893     return NULL;
2894
2895   rtrunc = gfc_copy_expr (e);
2896   mpfr_trunc (rtrunc->value.real, e->value.real);
2897
2898   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2899                                   &e->where);
2900   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2901
2902   gfc_free_expr (rtrunc);
2903
2904   return range_check (result, "IDINT");
2905 }
2906
2907
2908 gfc_expr *
2909 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2910 {
2911   gfc_expr *result;
2912
2913   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2914     return NULL;
2915
2916   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2917   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2918
2919   return range_check (result, "IOR");
2920 }
2921
2922
2923 static gfc_expr *
2924 do_bit_xor (gfc_expr *result, gfc_expr *e)
2925 {
2926   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2927   gcc_assert (result->ts.type == BT_INTEGER
2928               && result->expr_type == EXPR_CONSTANT);
2929
2930   mpz_xor (result->value.integer, result->value.integer, e->value.integer);
2931   return result;
2932 }
2933
2934
2935 gfc_expr *
2936 gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2937 {
2938   return simplify_transformation (array, dim, mask, 0, do_bit_xor);
2939 }
2940
2941
2942 gfc_expr *
2943 gfc_simplify_is_iostat_end (gfc_expr *x)
2944 {
2945   if (x->expr_type != EXPR_CONSTANT)
2946     return NULL;
2947
2948   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2949                                mpz_cmp_si (x->value.integer,
2950                                            LIBERROR_END) == 0);
2951 }
2952
2953
2954 gfc_expr *
2955 gfc_simplify_is_iostat_eor (gfc_expr *x)
2956 {
2957   if (x->expr_type != EXPR_CONSTANT)
2958     return NULL;
2959
2960   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2961                                mpz_cmp_si (x->value.integer,
2962                                            LIBERROR_EOR) == 0);
2963 }
2964
2965
2966 gfc_expr *
2967 gfc_simplify_isnan (gfc_expr *x)
2968 {
2969   if (x->expr_type != EXPR_CONSTANT)
2970     return NULL;
2971
2972   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2973                                mpfr_nan_p (x->value.real));
2974 }
2975
2976
2977 /* Performs a shift on its first argument.  Depending on the last
2978    argument, the shift can be arithmetic, i.e. with filling from the
2979    left like in the SHIFTA intrinsic.  */
2980 static gfc_expr *
2981 simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
2982                 bool arithmetic, int direction)
2983 {
2984   gfc_expr *result;
2985   int ashift, *bits, i, k, bitsize, shift;
2986
2987   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2988     return NULL;
2989
2990   gfc_extract_int (s, &shift);
2991
2992   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2993   bitsize = gfc_integer_kinds[k].bit_size;
2994
2995   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2996
2997   if (shift == 0)
2998     {
2999       mpz_set (result->value.integer, e->value.integer);
3000       return result;
3001     }
3002
3003   if (direction > 0 && shift < 0)
3004     {
3005       /* Left shift, as in SHIFTL.  */
3006       gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3007       return &gfc_bad_expr;
3008     }
3009   else if (direction < 0)
3010     {
3011       /* Right shift, as in SHIFTR or SHIFTA.  */
3012       if (shift < 0)
3013         {
3014           gfc_error ("Second argument of %s is negative at %L",
3015                      name, &e->where);
3016           return &gfc_bad_expr;
3017         }
3018
3019       shift = -shift;
3020     }
3021
3022   ashift = (shift >= 0 ? shift : -shift);
3023
3024   if (ashift > bitsize)
3025     {
3026       gfc_error ("Magnitude of second argument of %s exceeds bit size "
3027                  "at %L", name, &e->where);
3028       return &gfc_bad_expr;
3029     }
3030
3031   bits = XCNEWVEC (int, bitsize);
3032
3033   for (i = 0; i < bitsize; i++)
3034     bits[i] = mpz_tstbit (e->value.integer, i);
3035
3036   if (shift > 0)
3037     {
3038       /* Left shift.  */
3039       for (i = 0; i < shift; i++)
3040         mpz_clrbit (result->value.integer, i);
3041
3042       for (i = 0; i < bitsize - shift; i++)
3043         {
3044           if (bits[i] == 0)
3045             mpz_clrbit (result->value.integer, i + shift);
3046           else
3047             mpz_setbit (result->value.integer, i + shift);
3048         }
3049     }
3050   else
3051     {
3052       /* Right shift.  */
3053       if (arithmetic && bits[bitsize - 1])
3054         for (i = bitsize - 1; i >= bitsize - ashift; i--)
3055           mpz_setbit (result->value.integer, i);
3056       else
3057         for (i = bitsize - 1; i >= bitsize - ashift; i--)
3058           mpz_clrbit (result->value.integer, i);
3059
3060       for (i = bitsize - 1; i >= ashift; i--)
3061         {
3062           if (bits[i] == 0)
3063             mpz_clrbit (result->value.integer, i - ashift);
3064           else
3065             mpz_setbit (result->value.integer, i - ashift);
3066         }
3067     }
3068
3069   convert_mpz_to_signed (result->value.integer, bitsize);
3070   free (bits);
3071
3072   return result;
3073 }
3074
3075
3076 gfc_expr *
3077 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3078 {
3079   return simplify_shift (e, s, "ISHFT", false, 0);
3080 }
3081
3082
3083 gfc_expr *
3084 gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3085 {
3086   return simplify_shift (e, s, "LSHIFT", false, 1);
3087 }
3088
3089
3090 gfc_expr *
3091 gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3092 {
3093   return simplify_shift (e, s, "RSHIFT", true, -1);
3094 }
3095
3096
3097 gfc_expr *
3098 gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3099 {
3100   return simplify_shift (e, s, "SHIFTA", true, -1);
3101 }
3102
3103
3104 gfc_expr *
3105 gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3106 {
3107   return simplify_shift (e, s, "SHIFTL", false, 1);
3108 }
3109
3110
3111 gfc_expr *
3112 gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3113 {
3114   return simplify_shift (e, s, "SHIFTR", false, -1);
3115 }
3116
3117
3118 gfc_expr *
3119 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3120 {
3121   gfc_expr *result;
3122   int shift, ashift, isize, ssize, delta, k;
3123   int i, *bits;
3124
3125   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3126     return NULL;
3127
3128   gfc_extract_int (s, &shift);
3129
3130   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3131   isize = gfc_integer_kinds[k].bit_size;
3132
3133   if (sz != NULL)
3134     {
3135       if (sz->expr_type != EXPR_CONSTANT)
3136         return NULL;
3137
3138       gfc_extract_int (sz, &ssize);
3139
3140     }
3141   else
3142     ssize = isize;
3143
3144   if (shift >= 0)
3145     ashift = shift;
3146   else
3147     ashift = -shift;
3148
3149   if (ashift > ssize)
3150     {
3151       if (sz == NULL)
3152         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3153                    "BIT_SIZE of first argument at %L", &s->where);
3154       return &gfc_bad_expr;
3155     }
3156
3157   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3158
3159   mpz_set (result->value.integer, e->value.integer);
3160
3161   if (shift == 0)
3162     return result;
3163
3164   convert_mpz_to_unsigned (result->value.integer, isize);
3165
3166   bits = XCNEWVEC (int, ssize);
3167
3168   for (i = 0; i < ssize; i++)
3169     bits[i] = mpz_tstbit (e->value.integer, i);
3170
3171   delta = ssize - ashift;
3172
3173   if (shift > 0)
3174     {
3175       for (i = 0; i < delta; i++)
3176         {
3177           if (bits[i] == 0)
3178             mpz_clrbit (result->value.integer, i + shift);
3179           else
3180             mpz_setbit (result->value.integer, i + shift);
3181         }
3182
3183       for (i = delta; i < ssize; i++)
3184         {
3185           if (bits[i] == 0)
3186             mpz_clrbit (result->value.integer, i - delta);
3187           else
3188             mpz_setbit (result->value.integer, i - delta);
3189         }
3190     }
3191   else
3192     {
3193       for (i = 0; i < ashift; i++)
3194         {
3195           if (bits[i] == 0)
3196             mpz_clrbit (result->value.integer, i + delta);
3197           else
3198             mpz_setbit (result->value.integer, i + delta);
3199         }
3200
3201       for (i = ashift; i < ssize; i++)
3202         {
3203           if (bits[i] == 0)
3204             mpz_clrbit (result->value.integer, i + shift);
3205           else
3206             mpz_setbit (result->value.integer, i + shift);
3207         }
3208     }
3209
3210   convert_mpz_to_signed (result->value.integer, isize);
3211
3212   free (bits);
3213   return result;
3214 }
3215
3216
3217 gfc_expr *
3218 gfc_simplify_kind (gfc_expr *e)
3219 {
3220   return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
3221 }
3222
3223
3224 static gfc_expr *
3225 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
3226                     gfc_array_spec *as, gfc_ref *ref, bool coarray)
3227 {
3228   gfc_expr *l, *u, *result;
3229   int k;
3230
3231   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3232                 gfc_default_integer_kind);
3233   if (k == -1)
3234     return &gfc_bad_expr;
3235
3236   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3237
3238   /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3239      UBOUND(expr, DIM=n) = SIZE(expr, DIM=n).  */
3240   if (!coarray && array->expr_type != EXPR_VARIABLE)
3241     {
3242       if (upper)
3243         {
3244           gfc_expr* dim = result;
3245           mpz_set_si (dim->value.integer, d);
3246
3247           result = gfc_simplify_size (array, dim, kind);
3248           gfc_free_expr (dim);
3249           if (!result)
3250             goto returnNull;
3251         }
3252       else
3253         mpz_set_si (result->value.integer, 1);
3254
3255       goto done;
3256     }
3257
3258   /* Otherwise, we have a variable expression.  */
3259   gcc_assert (array->expr_type == EXPR_VARIABLE);
3260   gcc_assert (as);
3261
3262   if (gfc_resolve_array_spec (as, 0) == FAILURE)
3263     return NULL;
3264
3265   /* The last dimension of an assumed-size array is special.  */
3266   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
3267       || (coarray && d == as->rank + as->corank
3268           && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
3269     {
3270       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
3271         {
3272           gfc_free_expr (result);
3273           return gfc_copy_expr (as->lower[d-1]);
3274         }
3275
3276       goto returnNull;
3277     }
3278
3279   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3280
3281   /* Then, we need to know the extent of the given dimension.  */
3282   if (coarray || ref->u.ar.type == AR_FULL)
3283     {
3284       l = as->lower[d-1];
3285       u = as->upper[d-1];
3286
3287       if (l->expr_type != EXPR_CONSTANT || u == NULL
3288           || u->expr_type != EXPR_CONSTANT)
3289         goto returnNull;
3290
3291       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
3292         {
3293           /* Zero extent.  */
3294           if (upper)
3295             mpz_set_si (result->value.integer, 0);
3296           else
3297             mpz_set_si (result->value.integer, 1);
3298         }
3299       else
3300         {
3301           /* Nonzero extent.  */
3302           if (upper)
3303             mpz_set (result->value.integer, u->value.integer);
3304           else
3305             mpz_set (result->value.integer, l->value.integer);
3306         }
3307     }
3308   else
3309     {
3310       if (upper)
3311         {
3312           if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
3313               != SUCCESS)
3314             goto returnNull;
3315         }
3316       else
3317         mpz_set_si (result->value.integer, (long int) 1);
3318     }
3319
3320 done:
3321   return range_check (result, upper ? "UBOUND" : "LBOUND");
3322
3323 returnNull:
3324   gfc_free_expr (result);
3325   return NULL;
3326 }
3327
3328
3329 static gfc_expr *
3330 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3331 {
3332   gfc_ref *ref;
3333   gfc_array_spec *as;
3334   int d;
3335
3336   if (array->ts.type == BT_CLASS)
3337     return NULL;
3338
3339   if (array->expr_type != EXPR_VARIABLE)
3340     {
3341       as = NULL;
3342       ref = NULL;
3343       goto done;
3344     }
3345
3346   /* Follow any component references.  */
3347   as = array->symtree->n.sym->as;
3348   for (ref = array->ref; ref; ref = ref->next)
3349     {
3350       switch (ref->type)
3351         {
3352         case REF_ARRAY:
3353           switch (ref->u.ar.type)
3354             {
3355             case AR_ELEMENT:
3356               as = NULL;
3357               continue;
3358
3359             case AR_FULL:
3360               /* We're done because 'as' has already been set in the
3361                  previous iteration.  */
3362               if (!ref->next)
3363                 goto done;
3364
3365             /* Fall through.  */
3366
3367             case AR_UNKNOWN:
3368               return NULL;
3369
3370             case AR_SECTION:
3371               as = ref->u.ar.as;
3372               goto done;
3373             }
3374
3375           gcc_unreachable ();
3376
3377         case REF_COMPONENT:
3378           as = ref->u.c.component->as;
3379           continue;
3380
3381         case REF_SUBSTRING:
3382           continue;
3383         }
3384     }
3385
3386   gcc_unreachable ();
3387
3388  done:
3389
3390   if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
3391              || as->type == AS_ASSUMED_RANK))
3392     return NULL;
3393
3394   if (dim == NULL)
3395     {
3396       /* Multi-dimensional bounds.  */
3397       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3398       gfc_expr *e;
3399       int k;
3400
3401       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
3402       if (upper && as && as->type == AS_ASSUMED_SIZE)
3403         {
3404           /* An error message will be emitted in
3405              check_assumed_size_reference (resolve.c).  */
3406           return &gfc_bad_expr;
3407         }
3408
3409       /* Simplify the bounds for each dimension.  */
3410       for (d = 0; d < array->rank; d++)
3411         {
3412           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3413                                           false);
3414           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3415             {
3416               int j;
3417
3418               for (j = 0; j < d; j++)
3419                 gfc_free_expr (bounds[j]);
3420               return bounds[d];
3421             }
3422         }
3423
3424       /* Allocate the result expression.  */
3425       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3426                     gfc_default_integer_kind);
3427       if (k == -1)
3428         return &gfc_bad_expr;
3429
3430       e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3431
3432       /* The result is a rank 1 array; its size is the rank of the first
3433          argument to {L,U}BOUND.  */
3434       e->rank = 1;
3435       e->shape = gfc_get_shape (1);
3436       mpz_init_set_ui (e->shape[0], array->rank);
3437
3438       /* Create the constructor for this array.  */
3439       for (d = 0; d < array->rank; d++)
3440         gfc_constructor_append_expr (&e->value.constructor,
3441                                      bounds[d], &e->where);
3442
3443       return e;
3444     }
3445   else
3446     {
3447       /* A DIM argument is specified.  */
3448       if (dim->expr_type != EXPR_CONSTANT)
3449         return NULL;
3450
3451       d = mpz_get_si (dim->value.integer);
3452
3453       if ((d < 1 || d > array->rank)
3454           || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3455         {
3456           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3457           return &gfc_bad_expr;
3458         }
3459
3460       if (as && as->type == AS_ASSUMED_RANK)
3461         return NULL;
3462
3463       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3464     }
3465 }
3466
3467
3468 static gfc_expr *
3469 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3470 {
3471   gfc_ref *ref;
3472   gfc_array_spec *as;
3473   int d;
3474
3475   if (array->expr_type != EXPR_VARIABLE)
3476     return NULL;
3477
3478   /* Follow any component references.  */
3479   as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
3480        ? array->ts.u.derived->components->as
3481        : array->symtree->n.sym->as;
3482   for (ref = array->ref; ref; ref = ref->next)
3483     {
3484       switch (ref->type)
3485         {
3486         case REF_ARRAY:
3487           switch (ref->u.ar.type)
3488             {
3489             case AR_ELEMENT:
3490               if (ref->u.ar.as->corank > 0)
3491                 {
3492                   gcc_assert (as == ref->u.ar.as);
3493                   goto done;
3494                 }
3495               as = NULL;
3496               continue;
3497
3498             case AR_FULL:
3499               /* We're done because 'as' has already been set in the
3500                  previous iteration.  */
3501               if (!ref->next)
3502                 goto done;
3503
3504             /* Fall through.  */
3505
3506             case AR_UNKNOWN:
3507               return NULL;
3508
3509             case AR_SECTION:
3510               as = ref->u.ar.as;
3511               goto done;
3512             }
3513
3514           gcc_unreachable ();
3515
3516         case REF_COMPONENT:
3517           as = ref->u.c.component->as;
3518           continue;
3519
3520         case REF_SUBSTRING:
3521           continue;
3522         }
3523     }
3524
3525   if (!as)
3526     gcc_unreachable ();
3527
3528  done:
3529
3530   if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
3531     return NULL;
3532
3533   if (dim == NULL)
3534     {
3535       /* Multi-dimensional cobounds.  */
3536       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3537       gfc_expr *e;
3538       int k;
3539
3540       /* Simplify the cobounds for each dimension.  */
3541       for (d = 0; d < as->corank; d++)
3542         {
3543           bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
3544                                           upper, as, ref, true);
3545           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3546             {
3547               int j;
3548
3549               for (j = 0; j < d; j++)
3550                 gfc_free_expr (bounds[j]);
3551               return bounds[d];
3552             }
3553         }
3554
3555       /* Allocate the result expression.  */
3556       e = gfc_get_expr ();
3557       e->where = array->where;
3558       e->expr_type = EXPR_ARRAY;
3559       e->ts.type = BT_INTEGER;
3560       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3561                     gfc_default_integer_kind);
3562       if (k == -1)
3563         {
3564           gfc_free_expr (e);
3565           return &gfc_bad_expr;
3566         }
3567       e->ts.kind = k;
3568
3569       /* The result is a rank 1 array; its size is the rank of the first
3570          argument to {L,U}COBOUND.  */
3571       e->rank = 1;
3572       e->shape = gfc_get_shape (1);
3573       mpz_init_set_ui (e->shape[0], as->corank);
3574
3575       /* Create the constructor for this array.  */
3576       for (d = 0; d < as->corank; d++)
3577         gfc_constructor_append_expr (&e->value.constructor,
3578                                      bounds[d], &e->where);
3579       return e;
3580     }
3581   else
3582     {
3583       /* A DIM argument is specified.  */
3584       if (dim->expr_type != EXPR_CONSTANT)
3585         return NULL;
3586
3587       d = mpz_get_si (dim->value.integer);
3588
3589       if (d < 1 || d > as->corank)
3590         {
3591           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3592           return &gfc_bad_expr;
3593         }
3594
3595       return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
3596     }
3597 }
3598
3599
3600 gfc_expr *
3601 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3602 {
3603   return simplify_bound (array, dim, kind, 0);
3604 }
3605
3606
3607 gfc_expr *
3608 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3609 {
3610   return simplify_cobound (array, dim, kind, 0);
3611 }
3612
3613 gfc_expr *
3614 gfc_simplify_leadz (gfc_expr *e)
3615 {
3616   unsigned long lz, bs;
3617   int i;
3618
3619   if (e->expr_type != EXPR_CONSTANT)
3620     return NULL;
3621
3622   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3623   bs = gfc_integer_kinds[i].bit_size;
3624   if (mpz_cmp_si (e->value.integer, 0) == 0)
3625     lz = bs;
3626   else if (mpz_cmp_si (e->value.integer, 0) < 0)
3627     lz = 0;
3628   else
3629     lz = bs - mpz_sizeinbase (e->value.integer, 2);
3630
3631   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3632 }
3633
3634
3635 gfc_expr *
3636 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3637 {
3638   gfc_expr *result;
3639   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3640
3641   if (k == -1)
3642     return &gfc_bad_expr;
3643
3644   if (e->expr_type == EXPR_CONSTANT)
3645     {
3646       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3647       mpz_set_si (result->value.integer, e->value.character.length);
3648       return range_check (result, "LEN");
3649     }
3650   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3651            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3652            && e->ts.u.cl->length->ts.type == BT_INTEGER)
3653     {
3654       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3655       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3656       return range_check (result, "LEN");
3657     }
3658   else
3659     return NULL;
3660 }
3661
3662
3663 gfc_expr *
3664 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3665 {
3666   gfc_expr *result;
3667   int count, len, i;
3668   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3669
3670   if (k == -1)
3671     return &gfc_bad_expr;
3672
3673   if (e->expr_type != EXPR_CONSTANT)
3674     return NULL;
3675
3676   len = e->value.character.length;
3677   for (count = 0, i = 1; i <= len; i++)
3678     if (e->value.character.string[len - i] == ' ')
3679       count++;
3680     else
3681       break;
3682
3683   result = gfc_get_int_expr (k, &e->where, len - count);
3684   return range_check (result, "LEN_TRIM");
3685 }
3686
3687 gfc_expr *
3688 gfc_simplify_lgamma (gfc_expr *x)
3689 {
3690   gfc_expr *result;
3691   int sg;
3692
3693   if (x->expr_type != EXPR_CONSTANT)
3694     return NULL;
3695
3696   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3697   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3698
3699   return range_check (result, "LGAMMA");
3700 }
3701
3702
3703 gfc_expr *
3704 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3705 {
3706   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3707     return NULL;
3708
3709   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3710                                gfc_compare_string (a, b) >= 0);
3711 }
3712
3713
3714 gfc_expr *
3715 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3716 {
3717   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3718     return NULL;
3719
3720   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3721                                gfc_compare_string (a, b) > 0);
3722 }
3723
3724
3725 gfc_expr *
3726 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3727 {
3728   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3729     return NULL;
3730
3731   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3732                                gfc_compare_string (a, b) <= 0);
3733 }
3734
3735
3736 gfc_expr *
3737 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3738 {
3739   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3740     return NULL;
3741
3742   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3743                                gfc_compare_string (a, b) < 0);
3744 }
3745
3746
3747 gfc_expr *
3748 gfc_simplify_log (gfc_expr *x)
3749 {
3750   gfc_expr *result;
3751
3752   if (x->expr_type != EXPR_CONSTANT)
3753     return NULL;
3754
3755   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3756
3757   switch (x->ts.type)
3758     {
3759     case BT_REAL:
3760       if (mpfr_sgn (x->value.real) <= 0)
3761         {
3762           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3763                      "to zero", &x->where);
3764           gfc_free_expr (result);
3765           return &gfc_bad_expr;
3766         }
3767
3768       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3769       break;
3770
3771     case BT_COMPLEX:
3772       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3773           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3774         {
3775           gfc_error ("Complex argument of LOG at %L cannot be zero",
3776                      &x->where);
3777           gfc_free_expr (result);
3778           return &gfc_bad_expr;
3779         }
3780
3781       gfc_set_model_kind (x->ts.kind);
3782       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3783       break;
3784
3785     default:
3786       gfc_internal_error ("gfc_simplify_log: bad type");
3787     }
3788
3789   return range_check (result, "LOG");
3790 }
3791
3792
3793 gfc_expr *
3794 gfc_simplify_log10 (gfc_expr *x)
3795 {
3796   gfc_expr *result;
3797
3798   if (x->expr_type != EXPR_CONSTANT)
3799     return NULL;
3800
3801   if (mpfr_sgn (x->value.real) <= 0)
3802     {
3803       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3804                  "to zero", &x->where);
3805       return &gfc_bad_expr;
3806     }
3807
3808   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3809   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3810
3811   return range_check (result, "LOG10");
3812 }
3813
3814
3815 gfc_expr *
3816 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3817 {
3818   int kind;
3819
3820   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3821   if (kind < 0)
3822     return &gfc_bad_expr;
3823
3824   if (e->expr_type != EXPR_CONSTANT)
3825     return NULL;
3826
3827   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3828 }
3829
3830
3831 gfc_expr*
3832 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3833 {
3834   gfc_expr *result;
3835   int row, result_rows, col, result_columns;
3836   int stride_a, offset_a, stride_b, offset_b;
3837
3838   if (!is_constant_array_expr (matrix_a)
3839       || !is_constant_array_expr (matrix_b))
3840     return NULL;
3841
3842   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3843   result = gfc_get_array_expr (matrix_a->ts.type,
3844                                matrix_a->ts.kind,
3845                                &matrix_a->where);
3846
3847   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3848     {
3849       result_rows = 1;
3850       result_columns = mpz_get_si (matrix_b->shape[0]);
3851       stride_a = 1;
3852       stride_b = mpz_get_si (matrix_b->shape[0]);
3853
3854       result->rank = 1;
3855       result->shape = gfc_get_shape (result->rank);
3856       mpz_init_set_si (result->shape[0], result_columns);
3857     }
3858   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3859     {
3860       result_rows = mpz_get_si (matrix_b->shape[0]);
3861       result_columns = 1;
3862       stride_a = mpz_get_si (matrix_a->shape[0]);
3863       stride_b = 1;
3864
3865       result->rank = 1;
3866       result->shape = gfc_get_shape (result->rank);
3867       mpz_init_set_si (result->shape[0], result_rows);
3868     }
3869   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3870     {
3871       result_rows = mpz_get_si (matrix_a->shape[0]);
3872       result_columns = mpz_get_si (matrix_b->shape[1]);
3873       stride_a = mpz_get_si (matrix_a->shape[1]);
3874       stride_b = mpz_get_si (matrix_b->shape[0]);
3875
3876       result->rank = 2;
3877       result->shape = gfc_get_shape (result->rank);
3878       mpz_init_set_si (result->shape[0], result_rows);
3879       mpz_init_set_si (result->shape[1], result_columns);
3880     }
3881   else
3882     gcc_unreachable();
3883
3884   offset_a = offset_b = 0;
3885   for (col = 0; col < result_columns; ++col)
3886     {
3887       offset_a = 0;
3888
3889       for (row = 0; row < result_rows; ++row)
3890         {
3891           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3892                                              matrix_b, 1, offset_b);
3893           gfc_constructor_append_expr (&result->value.constructor,
3894                                        e, NULL);
3895
3896           offset_a += 1;
3897         }
3898
3899       offset_b += stride_b;
3900     }
3901
3902   return result;
3903 }
3904
3905
3906 gfc_expr *
3907 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
3908 {
3909   gfc_expr *result;
3910   int kind, arg, k;
3911   const char *s;
3912
3913   if (i->expr_type != EXPR_CONSTANT)
3914     return NULL;
3915
3916   kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
3917   if (kind == -1)
3918     return &gfc_bad_expr;
3919   k = gfc_validate_kind (BT_INTEGER, kind, false);
3920
3921   s = gfc_extract_int (i, &arg);
3922   gcc_assert (!s);
3923
3924   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3925
3926   /* MASKR(n) = 2^n - 1 */
3927   mpz_set_ui (result->value.integer, 1);
3928   mpz_mul_2exp (result->value.integer, result->value.integer, arg);
3929   mpz_sub_ui (result->value.integer, result->value.integer, 1);
3930
3931   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3932
3933   return result;
3934 }
3935
3936
3937 gfc_expr *
3938 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
3939 {
3940   gfc_expr *result;
3941   int kind, arg, k;
3942   const char *s;
3943   mpz_t z;
3944
3945   if (i->expr_type != EXPR_CONSTANT)
3946     return NULL;
3947
3948   kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
3949   if (kind == -1)
3950     return &gfc_bad_expr;
3951   k = gfc_validate_kind (BT_INTEGER, kind, false);
3952
3953   s = gfc_extract_int (i, &arg);
3954   gcc_assert (!s);
3955
3956   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3957
3958   /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3959   mpz_init_set_ui (z, 1);
3960   mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
3961   mpz_set_ui (result->value.integer, 1);
3962   mpz_mul_2exp (result->value.integer, result->value.integer,
3963                 gfc_integer_kinds[k].bit_size - arg);
3964   mpz_sub (result->value.integer, z, result->value.integer);
3965   mpz_clear (z);
3966
3967   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3968
3969   return result;
3970 }
3971
3972
3973 gfc_expr *
3974 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3975 {
3976   if (tsource->expr_type != EXPR_CONSTANT
3977       || fsource->expr_type != EXPR_CONSTANT
3978       || mask->expr_type != EXPR_CONSTANT)
3979     return NULL;
3980
3981   return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3982 }
3983
3984
3985 gfc_expr *
3986 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
3987 {
3988   mpz_t arg1, arg2, mask;
3989   gfc_expr *result;
3990
3991   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
3992       || mask_expr->expr_type != EXPR_CONSTANT)
3993     return NULL;
3994
3995   result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
3996
3997   /* Convert all argument to unsigned.  */
3998   mpz_init_set (arg1, i->value.integer);
3999   mpz_init_set (arg2, j->value.integer);
4000   mpz_init_set (mask, mask_expr->value.integer);
4001
4002   /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
4003   mpz_and (arg1, arg1, mask);
4004   mpz_com (mask, mask);
4005   mpz_and (arg2, arg2, mask);
4006   mpz_ior (result->value.integer, arg1, arg2);
4007
4008   mpz_clear (arg1);
4009   mpz_clear (arg2);
4010   mpz_clear (mask);
4011
4012   return result;
4013 }
4014
4015
4016 /* Selects between current value and extremum for simplify_min_max
4017    and simplify_minval_maxval.  */
4018 static void
4019 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4020 {
4021   switch (arg->ts.type)
4022     {
4023       case BT_INTEGER:
4024         if (mpz_cmp (arg->value.integer,
4025                         extremum->value.integer) * sign > 0)
4026         mpz_set (extremum->value.integer, arg->value.integer);
4027         break;
4028
4029       case BT_REAL:
4030         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
4031         if (sign > 0)
4032           mpfr_max (extremum->value.real, extremum->value.real,
4033                       arg->value.real, GFC_RND_MODE);
4034         else
4035           mpfr_min (extremum->value.real, extremum->value.real,
4036                       arg->value.real, GFC_RND_MODE);
4037         break;
4038
4039       case BT_CHARACTER:
4040 #define LENGTH(x) ((x)->value.character.length)
4041 #define STRING(x) ((x)->value.character.string)
4042         if (LENGTH(extremum) < LENGTH(arg))
4043           {
4044             gfc_char_t *tmp = STRING(extremum);
4045
4046             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4047             memcpy (STRING(extremum), tmp,
4048                       LENGTH(extremum) * sizeof (gfc_char_t));
4049             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4050                                LENGTH(arg) - LENGTH(extremum));
4051             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
4052             LENGTH(extremum) = LENGTH(arg);
4053             free (tmp);
4054           }
4055
4056         if (gfc_compare_string (arg, extremum) * sign > 0)
4057           {
4058             free (STRING(extremum));
4059             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4060             memcpy (STRING(extremum), STRING(arg),
4061                       LENGTH(arg) * sizeof (gfc_char_t));
4062             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4063                                LENGTH(extremum) - LENGTH(arg));
4064             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
4065           }
4066 #undef LENGTH
4067 #undef STRING
4068         break;
4069
4070       default:
4071         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4072     }
4073 }
4074
4075
4076 /* This function is special since MAX() can take any number of
4077    arguments.  The simplified expression is a rewritten version of the
4078    argument list containing at most one constant element.  Other
4079    constant elements are deleted.  Because the argument list has
4080    already been checked, this function always succeeds.  sign is 1 for
4081    MAX(), -1 for MIN().  */
4082
4083 static gfc_expr *
4084 simplify_min_max (gfc_expr *expr, int sign)
4085 {
4086   gfc_actual_arglist *arg, *last, *extremum;
4087   gfc_intrinsic_sym * specific;
4088
4089   last = NULL;
4090   extremum = NULL;
4091   specific = expr->value.function.isym;
4092
4093   arg = expr->value.function.actual;
4094
4095   for (; arg; last = arg, arg = arg->next)
4096     {
4097       if (arg->expr->expr_type != EXPR_CONSTANT)
4098         continue;
4099
4100       if (extremum == NULL)
4101         {
4102           extremum = arg;
4103           continue;
4104         }
4105
4106       min_max_choose (arg->expr, extremum->expr, sign);
4107
4108       /* Delete the extra constant argument.  */
4109       if (last == NULL)
4110         expr->value.function.actual = arg->next;
4111       else
4112         last->next = arg->next;
4113
4114       arg->next = NULL;
4115       gfc_free_actual_arglist (arg);
4116       arg = last;
4117     }
4118
4119   /* If there is one value left, replace the function call with the
4120      expression.  */
4121   if (expr->value.function.actual->next != NULL)
4122     return NULL;
4123
4124   /* Convert to the correct type and kind.  */
4125   if (expr->ts.type != BT_UNKNOWN)
4126     return gfc_convert_constant (expr->value.function.actual->expr,
4127         expr->ts.type, expr->ts.kind);
4128
4129   if (specific->ts.type != BT_UNKNOWN)
4130     return gfc_convert_constant (expr->value.function.actual->expr,
4131         specific->ts.type, specific->ts.kind);
4132
4133   return gfc_copy_expr (expr->value.function.actual->expr);
4134 }
4135
4136
4137 gfc_expr *
4138 gfc_simplify_min (gfc_expr *e)
4139 {
4140   return simplify_min_max (e, -1);
4141 }
4142
4143
4144 gfc_expr *
4145 gfc_simplify_max (gfc_expr *e)
4146 {
4147   return simplify_min_max (e, 1);
4148 }
4149
4150
4151 /* This is a simplified version of simplify_min_max to provide
4152    simplification of minval and maxval for a vector.  */
4153
4154 static gfc_expr *
4155 simplify_minval_maxval (gfc_expr *expr, int sign)
4156 {
4157   gfc_constructor *c, *extremum;
4158   gfc_intrinsic_sym * specific;
4159
4160   extremum = NULL;
4161   specific = expr->value.function.isym;
4162
4163   for (c = gfc_constructor_first (expr->value.constructor);
4164        c; c = gfc_constructor_next (c))
4165     {
4166       if (c->expr->expr_type != EXPR_CONSTANT)
4167         return NULL;
4168
4169       if (extremum == NULL)
4170         {
4171           extremum = c;
4172           continue;
4173         }
4174
4175       min_max_choose (c->expr, extremum->expr, sign);
4176      }
4177
4178   if (extremum == NULL)
4179     return NULL;
4180
4181   /* Convert to the correct type and kind.  */
4182   if (expr->ts.type != BT_UNKNOWN)
4183     return gfc_convert_constant (extremum->expr,
4184         expr->ts.type, expr->ts.kind);
4185
4186   if (specific->ts.type != BT_UNKNOWN)
4187     return gfc_convert_constant (extremum->expr,
4188         specific->ts.type, specific->ts.kind);
4189
4190   return gfc_copy_expr (extremum->expr);
4191 }
4192
4193
4194 gfc_expr *
4195 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4196 {
4197   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4198     return NULL;
4199
4200   return simplify_minval_maxval (array, -1);
4201 }
4202
4203
4204 gfc_expr *
4205 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4206 {
4207   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4208     return NULL;
4209
4210   return simplify_minval_maxval (array, 1);
4211 }
4212
4213
4214 gfc_expr *
4215 gfc_simplify_maxexponent (gfc_expr *x)
4216 {
4217   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4218   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4219                            gfc_real_kinds[i].max_exponent);
4220 }
4221
4222
4223 gfc_expr *
4224 gfc_simplify_minexponent (gfc_expr *x)
4225 {
4226   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4227   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4228                            gfc_real_kinds[i].min_exponent);
4229 }
4230
4231
4232 gfc_expr *
4233 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4234 {
4235   gfc_expr *result;
4236   int kind;
4237
4238   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4239     return NULL;
4240
4241   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4242   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4243
4244   switch (a->ts.type)
4245     {
4246       case BT_INTEGER:
4247         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4248           {
4249             /* Result is processor-dependent.  */
4250             gfc_error ("Second argument MOD at %L is zero", &a->where);
4251             gfc_free_expr (result);
4252             return &gfc_bad_expr;
4253           }
4254         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4255         break;
4256
4257       case BT_REAL:
4258         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4259           {
4260             /* Result is processor-dependent.  */
4261             gfc_error ("Second argument of MOD at %L is zero", &p->where);
4262             gfc_free_expr (result);
4263             return &gfc_bad_expr;
4264           }
4265
4266         gfc_set_model_kind (kind);
4267         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4268                    GFC_RND_MODE);
4269         break;
4270
4271       default:
4272         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4273     }
4274
4275   return range_check (result, "MOD");
4276 }
4277
4278
4279 gfc_expr *
4280 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4281 {
4282   gfc_expr *result;
4283   int kind;
4284
4285   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4286     return NULL;
4287
4288   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4289   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4290
4291   switch (a->ts.type)
4292     {
4293       case BT_INTEGER:
4294         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4295           {
4296             /* Result is processor-dependent. This processor just opts
4297               to not handle it at all.  */
4298             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4299             gfc_free_expr (result);
4300             return &gfc_bad_expr;
4301           }
4302         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4303
4304         break;
4305
4306       case BT_REAL:
4307         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4308           {
4309             /* Result is processor-dependent.  */
4310             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4311             gfc_free_expr (result);
4312             return &gfc_bad_expr;
4313           }
4314
4315         gfc_set_model_kind (kind);
4316         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4317                    GFC_RND_MODE);
4318         if (mpfr_cmp_ui (result->value.real, 0) != 0)
4319           {
4320             if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
4321               mpfr_add (result->value.real, result->value.real, p->value.real,
4322                         GFC_RND_MODE);
4323           }
4324         else
4325           mpfr_copysign (result->value.real, result->value.real,
4326                          p->value.real, GFC_RND_MODE);
4327         break;
4328
4329       default:
4330         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4331     }
4332
4333   return range_check (result, "MODULO");
4334 }
4335
4336
4337 /* Exists for the sole purpose of consistency with other intrinsics.  */
4338 gfc_expr *
4339 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
4340                      gfc_expr *fp ATTRIBUTE_UNUSED,
4341                      gfc_expr *l  ATTRIBUTE_UNUSED,
4342                      gfc_expr *to ATTRIBUTE_UNUSED,
4343                      gfc_expr *tp ATTRIBUTE_UNUSED)
4344 {
4345   return NULL;
4346 }
4347
4348
4349 gfc_expr *
4350 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4351 {
4352   gfc_expr *result;
4353   mp_exp_t emin, emax;
4354   int kind;
4355
4356   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4357     return NULL;
4358
4359   result = gfc_copy_expr (x);
4360
4361   /* Save current values of emin and emax.  */
4362   emin = mpfr_get_emin ();
4363   emax = mpfr_get_emax ();
4364
4365   /* Set emin and emax for the current model number.  */
4366   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4367   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4368                 mpfr_get_prec(result->value.real) + 1);
4369   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4370   mpfr_check_range (result->value.real, 0, GMP_RNDU);
4371
4372   if (mpfr_sgn (s->value.real) > 0)
4373     {
4374       mpfr_nextabove (result->value.real);
4375       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4376     }
4377   else
4378     {
4379       mpfr_nextbelow (result->value.real);
4380       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4381     }
4382
4383   mpfr_set_emin (emin);
4384   mpfr_set_emax (emax);
4385
4386   /* Only NaN can occur. Do not use range check as it gives an
4387      error for denormal numbers.  */
4388   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
4389     {
4390       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4391       gfc_free_expr (result);
4392       return &gfc_bad_expr;
4393     }
4394
4395   return result;
4396 }
4397
4398
4399 static gfc_expr *
4400 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4401 {
4402   gfc_expr *itrunc, *result;
4403   int kind;
4404
4405   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4406   if (kind == -1)
4407     return &gfc_bad_expr;
4408
4409   if (e->expr_type != EXPR_CONSTANT)
4410     return NULL;
4411
4412   itrunc = gfc_copy_expr (e);
4413   mpfr_round (itrunc->value.real, e->value.real);
4414
4415   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4416   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4417
4418   gfc_free_expr (itrunc);
4419
4420   return range_check (result, name);
4421 }
4422
4423
4424 gfc_expr *
4425 gfc_simplify_new_line (gfc_expr *e)
4426 {
4427   gfc_expr *result;
4428
4429   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4430   result->value.character.string[0] = '\n';
4431
4432   return result;
4433 }
4434
4435
4436 gfc_expr *
4437 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4438 {
4439   return simplify_nint ("NINT", e, k);
4440 }
4441
4442
4443 gfc_expr *
4444 gfc_simplify_idnint (gfc_expr *e)
4445 {
4446   return simplify_nint ("IDNINT", e, NULL);
4447 }
4448
4449
4450 static gfc_expr *
4451 add_squared (gfc_expr *result, gfc_expr *e)
4452 {
4453   mpfr_t tmp;
4454
4455   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4456   gcc_assert (result->ts.type == BT_REAL
4457               && result->expr_type == EXPR_CONSTANT);
4458
4459   gfc_set_model_kind (result->ts.kind);
4460   mpfr_init (tmp);
4461   mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4462   mpfr_add (result->value.real, result->value.real, tmp,
4463             GFC_RND_MODE);
4464   mpfr_clear (tmp);
4465
4466   return result;
4467 }
4468
4469
4470 static gfc_expr *
4471 do_sqrt (gfc_expr *result, gfc_expr *e)
4472 {
4473   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4474   gcc_assert (result->ts.type == BT_REAL
4475               && result->expr_type == EXPR_CONSTANT);
4476
4477   mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4478   mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4479   return result;
4480 }
4481
4482
4483 gfc_expr *
4484 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4485 {
4486   gfc_expr *result;
4487
4488   if (!is_constant_array_expr (e)
4489       || (dim != NULL && !gfc_is_constant_expr (dim)))
4490     return NULL;
4491
4492   result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4493   init_result_expr (result, 0, NULL);
4494
4495   if (!dim || e->rank == 1)
4496     {
4497       result = simplify_transformation_to_scalar (result, e, NULL,
4498                                                   add_squared);
4499       mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4500     }
4501   else
4502     result = simplify_transformation_to_array (result, e, dim, NULL,
4503                                                add_squared, &do_sqrt);
4504
4505   return result;
4506 }
4507
4508
4509 gfc_expr *
4510 gfc_simplify_not (gfc_expr *e)
4511 {
4512   gfc_expr *result;
4513
4514   if (e->expr_type != EXPR_CONSTANT)
4515     return NULL;
4516
4517   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4518   mpz_com (result->value.integer, e->value.integer);
4519
4520   return range_check (result, "NOT");
4521 }
4522
4523
4524 gfc_expr *
4525 gfc_simplify_null (gfc_expr *mold)
4526 {
4527   gfc_expr *result;
4528
4529   if (mold)
4530     {
4531       result = gfc_copy_expr (mold);
4532       result->expr_type = EXPR_NULL;
4533     }
4534   else
4535     result = gfc_get_null_expr (NULL);
4536
4537   return result;
4538 }
4539
4540
4541 gfc_expr *
4542 gfc_simplify_num_images (void)
4543 {
4544   gfc_expr *result;
4545
4546   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4547     {
4548       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4549       return &gfc_bad_expr;
4550     }
4551
4552   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
4553     return NULL;
4554
4555   /* FIXME: gfc_current_locus is wrong.  */
4556   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4557                                   &gfc_current_locus);
4558   mpz_set_si (result->value.integer, 1);
4559   return result;
4560 }
4561
4562
4563 gfc_expr *
4564 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4565 {
4566   gfc_expr *result;
4567   int kind;
4568
4569   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4570     return NULL;
4571
4572   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4573
4574   switch (x->ts.type)
4575     {
4576       case BT_INTEGER:
4577         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4578         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4579         return range_check (result, "OR");
4580
4581       case BT_LOGICAL:
4582         return gfc_get_logical_expr (kind, &x->where,
4583                                      x->value.logical || y->value.logical);
4584       default:
4585         gcc_unreachable();
4586     }
4587 }
4588
4589
4590 gfc_expr *
4591 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4592 {
4593   gfc_expr *result;
4594   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4595
4596   if (!is_constant_array_expr(array)
4597       || !is_constant_array_expr(vector)
4598       || (!gfc_is_constant_expr (mask)
4599           && !is_constant_array_expr(mask)))
4600     return NULL;
4601
4602   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4603   if (array->ts.type == BT_DERIVED)
4604     result->ts.u.derived = array->ts.u.derived;
4605
4606   array_ctor = gfc_constructor_first (array->value.constructor);
4607   vector_ctor = vector
4608                   ? gfc_constructor_first (vector->value.constructor)
4609                   : NULL;
4610
4611   if (mask->expr_type == EXPR_CONSTANT
4612       && mask->value.logical)
4613     {
4614       /* Copy all elements of ARRAY to RESULT.  */
4615       while (array_ctor)
4616         {
4617           gfc_constructor_append_expr (&result->value.constructor,
4618                                        gfc_copy_expr (array_ctor->expr),
4619                                        NULL);
4620
4621           array_ctor = gfc_constructor_next (array_ctor);
4622           vector_ctor = gfc_constructor_next (vector_ctor);
4623         }
4624     }
4625   else if (mask->expr_type == EXPR_ARRAY)
4626     {
4627       /* Copy only those elements of ARRAY to RESULT whose
4628          MASK equals .TRUE..  */
4629       mask_ctor = gfc_constructor_first (mask->value.constructor);
4630       while (mask_ctor)
4631         {
4632           if (mask_ctor->expr->value.logical)
4633             {
4634               gfc_constructor_append_expr (&result->value.constructor,
4635                                            gfc_copy_expr (array_ctor->expr),
4636                                            NULL);
4637               vector_ctor = gfc_constructor_next (vector_ctor);
4638             }
4639
4640           array_ctor = gfc_constructor_next (array_ctor);
4641           mask_ctor = gfc_constructor_next (mask_ctor);
4642         }
4643     }
4644
4645   /* Append any left-over elements from VECTOR to RESULT.  */
4646   while (vector_ctor)
4647     {
4648       gfc_constructor_append_expr (&result->value.constructor,
4649                                    gfc_copy_expr (vector_ctor->expr),
4650                                    NULL);
4651       vector_ctor = gfc_constructor_next (vector_ctor);
4652     }
4653
4654   result->shape = gfc_get_shape (1);
4655   gfc_array_size (result, &result->shape[0]);
4656
4657   if (array->ts.type == BT_CHARACTER)
4658     result->ts.u.cl = array->ts.u.cl;
4659
4660   return result;
4661 }
4662
4663
4664 static gfc_expr *
4665 do_xor (gfc_expr *result, gfc_expr *e)
4666 {
4667   gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
4668   gcc_assert (result->ts.type == BT_LOGICAL
4669               && result->expr_type == EXPR_CONSTANT);
4670
4671   result->value.logical = result->value.logical != e->value.logical;
4672   return result;
4673 }
4674
4675
4676
4677 gfc_expr *
4678 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
4679 {
4680   return simplify_transformation (e, dim, NULL, 0, do_xor);
4681 }
4682
4683
4684 gfc_expr *
4685 gfc_simplify_popcnt (gfc_expr *e)
4686 {
4687   int res, k;
4688   mpz_t x;
4689
4690   if (e->expr_type != EXPR_CONSTANT)
4691     return NULL;
4692
4693   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4694
4695   /* Convert argument to unsigned, then count the '1' bits.  */
4696   mpz_init_set (x, e->value.integer);
4697   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
4698   res = mpz_popcount (x);
4699   mpz_clear (x);
4700
4701   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
4702 }
4703
4704
4705 gfc_expr *
4706 gfc_simplify_poppar (gfc_expr *e)
4707 {
4708   gfc_expr *popcnt;
4709   const char *s;
4710   int i;
4711
4712   if (e->expr_type != EXPR_CONSTANT)
4713     return NULL;
4714
4715   popcnt = gfc_simplify_popcnt (e);
4716   gcc_assert (popcnt);
4717
4718   s = gfc_extract_int (popcnt, &i);
4719   gcc_assert (!s);
4720
4721   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
4722 }
4723
4724
4725 gfc_expr *
4726 gfc_simplify_precision (gfc_expr *e)
4727 {
4728   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4729   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4730                            gfc_real_kinds[i].precision);
4731 }
4732
4733
4734 gfc_expr *
4735 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4736 {
4737   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
4738 }
4739
4740
4741 gfc_expr *
4742 gfc_simplify_radix (gfc_expr *e)
4743 {
4744   int i;
4745   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4746
4747   switch (e->ts.type)
4748     {
4749       case BT_INTEGER:
4750         i = gfc_integer_kinds[i].radix;
4751         break;
4752
4753       case BT_REAL:
4754         i = gfc_real_kinds[i].radix;
4755         break;
4756
4757       default:
4758         gcc_unreachable ();
4759     }
4760
4761   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4762 }
4763
4764
4765 gfc_expr *
4766 gfc_simplify_range (gfc_expr *e)
4767 {
4768   int i;
4769   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4770
4771   switch (e->ts.type)
4772     {
4773       case BT_INTEGER:
4774         i = gfc_integer_kinds[i].range;
4775         break;
4776
4777       case BT_REAL:
4778       case BT_COMPLEX:
4779         i = gfc_real_kinds[i].range;
4780         break;
4781
4782       default:
4783         gcc_unreachable ();
4784     }
4785
4786   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4787 }
4788
4789
4790 gfc_expr *
4791 gfc_simplify_rank (gfc_expr *e)
4792 {
4793   /* Assumed rank.  */
4794   if (e->rank == -1)
4795     return NULL;
4796
4797   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
4798 }
4799
4800
4801 gfc_expr *
4802 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4803 {
4804   gfc_expr *result = NULL;
4805   int kind;
4806
4807   if (e->ts.type == BT_COMPLEX)
4808     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4809   else
4810     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4811
4812   if (kind == -1)
4813     return &gfc_bad_expr;
4814
4815   if (e->expr_type != EXPR_CONSTANT)
4816     return NULL;
4817
4818   if (convert_boz (e, kind) == &gfc_bad_expr)
4819     return &gfc_bad_expr;
4820
4821   result = gfc_convert_constant (e, BT_REAL, kind);
4822   if (result == &gfc_bad_expr)
4823     return &gfc_bad_expr;
4824
4825   return range_check (result, "REAL");
4826 }
4827
4828
4829 gfc_expr *
4830 gfc_simplify_realpart (gfc_expr *e)
4831 {
4832   gfc_expr *result;
4833
4834   if (e->expr_type != EXPR_CONSTANT)
4835     return NULL;
4836
4837   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4838   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4839
4840   return range_check (result, "REALPART");
4841 }
4842
4843 gfc_expr *
4844 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4845 {
4846   gfc_expr *result;
4847   int i, j, len, ncop, nlen;
4848   mpz_t ncopies;
4849   bool have_length = false;
4850
4851   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4852   if (n->expr_type != EXPR_CONSTANT)
4853     return NULL;
4854
4855   /* If NCOPIES is negative, it's an error.  */
4856   if (mpz_sgn (n->value.integer) < 0)
4857     {
4858       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4859                  &n->where);
4860       return &gfc_bad_expr;
4861     }
4862
4863   /* If we don't know the character length, we can do no more.  */
4864   if (e->ts.u.cl && e->ts.u.cl->length
4865         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4866     {
4867       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4868       have_length = true;
4869     }
4870   else if (e->expr_type == EXPR_CONSTANT
4871              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4872     {
4873       len = e->value.character.length;
4874     }
4875   else
4876     return NULL;
4877
4878   /* If the source length is 0, any value of NCOPIES is valid
4879      and everything behaves as if NCOPIES == 0.  */
4880   mpz_init (ncopies);
4881   if (len == 0)
4882     mpz_set_ui (ncopies, 0);
4883   else
4884     mpz_set (ncopies, n->value.integer);
4885
4886   /* Check that NCOPIES isn't too large.  */
4887   if (len)
4888     {
4889       mpz_t max, mlen;
4890       int i;
4891
4892       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4893       mpz_init (max);
4894       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4895
4896       if (have_length)
4897         {
4898           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4899                       e->ts.u.cl->length->value.integer);
4900         }
4901       else
4902         {
4903           mpz_init_set_si (mlen, len);
4904           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4905           mpz_clear (mlen);
4906         }
4907
4908       /* The check itself.  */
4909       if (mpz_cmp (ncopies, max) > 0)
4910         {
4911           mpz_clear (max);
4912           mpz_clear (ncopies);
4913           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4914                      &n->where);
4915           return &gfc_bad_expr;
4916         }
4917
4918       mpz_clear (max);
4919     }
4920   mpz_clear (ncopies);
4921
4922   /* For further simplification, we need the character string to be
4923      constant.  */
4924   if (e->expr_type != EXPR_CONSTANT)
4925     return NULL;
4926
4927   if (len ||
4928       (e->ts.u.cl->length &&
4929        mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4930     {
4931       const char *res = gfc_extract_int (n, &ncop);
4932       gcc_assert (res == NULL);
4933     }
4934   else
4935     ncop = 0;
4936
4937   if (ncop == 0)
4938     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4939
4940   len = e->value.character.length;
4941   nlen = ncop * len;
4942
4943   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4944   for (i = 0; i < ncop; i++)
4945     for (j = 0; j < len; j++)
4946       result->value.character.string[j+i*len]= e->value.character.string[j];
4947
4948   result->value.character.string[nlen] = '\0';  /* For debugger */
4949   return result;
4950 }
4951
4952
4953 /* This one is a bear, but mainly has to do with shuffling elements.  */
4954
4955 gfc_expr *
4956 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4957                       gfc_expr *pad, gfc_expr *order_exp)
4958 {
4959   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4960   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4961   mpz_t index, size;
4962   unsigned long j;
4963   size_t nsource;
4964   gfc_expr *e, *result;
4965
4966   /* Check that argument expression types are OK.  */
4967   if (!is_constant_array_expr (source)
4968       || !is_constant_array_expr (shape_exp)
4969       || !is_constant_array_expr (pad)
4970       || !is_constant_array_expr (order_exp))
4971     return NULL;
4972
4973   /* Proceed with simplification, unpacking the array.  */
4974
4975   mpz_init (index);
4976   rank = 0;
4977
4978   for (;;)
4979     {
4980       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4981       if (e == NULL)
4982         break;
4983
4984       gfc_extract_int (e, &shape[rank]);
4985
4986       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4987       gcc_assert (shape[rank] >= 0);
4988
4989       rank++;
4990     }
4991
4992   gcc_assert (rank > 0);
4993
4994   /* Now unpack the order array if present.  */
4995   if (order_exp == NULL)
4996     {
4997       for (i = 0; i < rank; i++)
4998         order[i] = i;
4999     }
5000   else
5001     {
5002       for (i = 0; i < rank; i++)
5003         x[i] = 0;
5004
5005       for (i = 0; i < rank; i++)
5006         {
5007           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
5008           gcc_assert (e);
5009
5010           gfc_extract_int (e, &order[i]);
5011
5012           gcc_assert (order[i] >= 1 && order[i] <= rank);
5013           order[i]--;
5014           gcc_assert (x[order[i]] == 0);
5015           x[order[i]] = 1;
5016         }
5017     }
5018
5019   /* Count the elements in the source and padding arrays.  */
5020
5021   npad = 0;
5022   if (pad != NULL)
5023     {
5024       gfc_array_size (pad, &size);
5025       npad = mpz_get_ui (size);
5026       mpz_clear (size);
5027     }
5028
5029   gfc_array_size (source, &size);
5030   nsource = mpz_get_ui (size);
5031   mpz_clear (size);
5032
5033   /* If it weren't for that pesky permutation we could just loop
5034      through the source and round out any shortage with pad elements.
5035      But no, someone just had to have the compiler do something the
5036      user should be doing.  */
5037
5038   for (i = 0; i < rank; i++)
5039     x[i] = 0;
5040
5041   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5042                                &source->where);
5043   if (source->ts.type == BT_DERIVED)
5044     result->ts.u.derived = source->ts.u.derived;
5045   result->rank = rank;
5046   result->shape = gfc_get_shape (rank);
5047   for (i = 0; i < rank; i++)
5048     mpz_init_set_ui (result->shape[i], shape[i]);
5049
5050   while (nsource > 0 || npad > 0)
5051     {
5052       /* Figure out which element to extract.  */
5053       mpz_set_ui (index, 0);
5054
5055       for (i = rank - 1; i >= 0; i--)
5056         {
5057           mpz_add_ui (index, index, x[order[i]]);
5058           if (i != 0)
5059             mpz_mul_ui (index, index, shape[order[i - 1]]);
5060         }
5061
5062       if (mpz_cmp_ui (index, INT_MAX) > 0)
5063         gfc_internal_error ("Reshaped array too large at %C");
5064
5065       j = mpz_get_ui (index);
5066
5067       if (j < nsource)
5068         e = gfc_constructor_lookup_expr (source->value.constructor, j);
5069       else
5070         {
5071           gcc_assert (npad > 0);
5072
5073           j = j - nsource;
5074           j = j % npad;
5075           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5076         }
5077       gcc_assert (e);
5078
5079       gfc_constructor_append_expr (&result->value.constructor,
5080                                    gfc_copy_expr (e), &e->where);
5081
5082       /* Calculate the next element.  */
5083       i = 0;
5084
5085 inc:
5086       if (++x[i] < shape[i])
5087         continue;
5088       x[i++] = 0;
5089       if (i < rank)
5090         goto inc;
5091
5092       break;
5093     }
5094
5095   mpz_clear (index);
5096
5097   return result;
5098 }
5099
5100
5101 gfc_expr *
5102 gfc_simplify_rrspacing (gfc_expr *x)
5103 {
5104   gfc_expr *result;
5105   int i;
5106   long int e, p;
5107
5108   if (x->expr_type != EXPR_CONSTANT)
5109     return NULL;
5110
5111   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5112
5113   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5114   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5115
5116   /* Special case x = -0 and 0.  */
5117   if (mpfr_sgn (result->value.real) == 0)
5118     {
5119       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5120       return result;
5121     }
5122
5123   /* | x * 2**(-e) | * 2**p.  */
5124   e = - (long int) mpfr_get_exp (x->value.real);
5125   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5126
5127   p = (long int) gfc_real_kinds[i].digits;
5128   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5129
5130   return range_check (result, "RRSPACING");
5131 }
5132
5133
5134 gfc_expr *
5135 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5136 {
5137   int k, neg_flag, power, exp_range;
5138   mpfr_t scale, radix;
5139   gfc_expr *result;
5140
5141   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5142     return NULL;
5143
5144   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5145
5146   if (mpfr_sgn (x->value.real) == 0)
5147     {
5148       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5149       return result;
5150     }
5151
5152   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5153
5154   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5155
5156   /* This check filters out values of i that would overflow an int.  */
5157   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5158       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5159     {
5160       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5161       gfc_free_expr (result);
5162       return &gfc_bad_expr;
5163     }
5164
5165   /* Compute scale = radix ** power.  */
5166   power = mpz_get_si (i->value.integer);
5167
5168   if (power >= 0)
5169     neg_flag = 0;
5170   else
5171     {
5172       neg_flag = 1;
5173       power = -power;
5174     }
5175
5176   gfc_set_model_kind (x->ts.kind);
5177   mpfr_init (scale);
5178   mpfr_init (radix);
5179   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5180   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5181
5182   if (neg_flag)
5183     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5184   else
5185     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5186
5187   mpfr_clears (scale, radix, NULL);
5188
5189   return range_check (result, "SCALE");
5190 }
5191
5192
5193 /* Variants of strspn and strcspn that operate on wide characters.  */
5194
5195 static size_t
5196 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5197 {
5198   size_t i = 0;
5199   const gfc_char_t *c;
5200
5201   while (s1[i])
5202     {
5203       for (c = s2; *c; c++)
5204         {
5205           if (s1[i] == *c)
5206             break;
5207         }
5208       if (*c == '\0')
5209         break;
5210       i++;
5211     }
5212
5213   return i;
5214 }
5215
5216 static size_t
5217 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5218 {
5219   size_t i = 0;
5220   const gfc_char_t *c;
5221
5222   while (s1[i])
5223     {
5224       for (c = s2; *c; c++)
5225         {
5226           if (s1[i] == *c)
5227             break;
5228         }
5229       if (*c)
5230         break;
5231       i++;
5232     }
5233
5234   return i;
5235 }
5236
5237
5238 gfc_expr *
5239 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5240 {
5241   gfc_expr *result;
5242   int back;
5243   size_t i;
5244   size_t indx, len, lenc;
5245   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5246
5247   if (k == -1)
5248     return &gfc_bad_expr;
5249
5250   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
5251       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
5252     return NULL;
5253
5254   if (b != NULL && b->value.logical != 0)
5255     back = 1;
5256   else
5257     back = 0;
5258
5259   len = e->value.character.length;
5260   lenc = c->value.character.length;
5261
5262   if (len == 0 || lenc == 0)
5263     {
5264       indx = 0;
5265     }
5266   else
5267     {
5268       if (back == 0)
5269         {
5270           indx = wide_strcspn (e->value.character.string,
5271                                c->value.character.string) + 1;
5272           if (indx > len)
5273             indx = 0;
5274         }
5275       else
5276         {
5277           i = 0;
5278           for (indx = len; indx > 0; indx--)
5279             {
5280               for (i = 0; i < lenc; i++)
5281                 {
5282                   if (c->value.character.string[i]
5283                       == e->value.character.string[indx - 1])
5284                     break;
5285                 }
5286               if (i < lenc)
5287                 break;
5288             }
5289         }
5290     }
5291
5292   result = gfc_get_int_expr (k, &e->where, indx);
5293   return range_check (result, "SCAN");
5294 }
5295
5296
5297 gfc_expr *
5298 gfc_simplify_selected_char_kind (gfc_expr *e)
5299 {
5300   int kind;
5301
5302   if (e->expr_type != EXPR_CONSTANT)
5303     return NULL;
5304
5305   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5306       || gfc_compare_with_Cstring (e, "default", false) == 0)
5307     kind = 1;
5308   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5309     kind = 4;
5310   else
5311     kind = -1;
5312
5313   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5314 }
5315
5316
5317 gfc_expr *
5318 gfc_simplify_selected_int_kind (gfc_expr *e)
5319 {
5320   int i, kind, range;
5321
5322   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5323     return NULL;
5324
5325   kind = INT_MAX;
5326
5327   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5328     if (gfc_integer_kinds[i].range >= range
5329         && gfc_integer_kinds[i].kind < kind)
5330       kind = gfc_integer_kinds[i].kind;
5331
5332   if (kind == INT_MAX)
5333     kind = -1;
5334
5335   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5336 }
5337
5338
5339 gfc_expr *
5340 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5341 {
5342   int range, precision, radix, i, kind, found_precision, found_range,
5343       found_radix;
5344   locus *loc = &gfc_current_locus;
5345
5346   if (p == NULL)
5347     precision = 0;
5348   else
5349     {
5350       if (p->expr_type != EXPR_CONSTANT
5351           || gfc_extract_int (p, &precision) != NULL)
5352         return NULL;
5353       loc = &p->where;
5354     }
5355
5356   if (q == NULL)
5357     range = 0;
5358   else
5359     {
5360       if (q->expr_type != EXPR_CONSTANT
5361           || gfc_extract_int (q, &range) != NULL)
5362         return NULL;
5363
5364       if (!loc)
5365         loc = &q->where;
5366     }
5367
5368   if (rdx == NULL)
5369     radix = 0;
5370   else
5371     {
5372       if (rdx->expr_type != EXPR_CONSTANT
5373           || gfc_extract_int (rdx, &radix) != NULL)
5374         return NULL;
5375
5376       if (!loc)
5377         loc = &rdx->where;
5378     }
5379
5380   kind = INT_MAX;
5381   found_precision = 0;
5382   found_range = 0;
5383   found_radix = 0;
5384
5385   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5386     {
5387       if (gfc_real_kinds[i].precision >= precision)
5388         found_precision = 1;
5389
5390       if (gfc_real_kinds[i].range >= range)
5391         found_range = 1;
5392
5393       if (gfc_real_kinds[i].radix >= radix)
5394         found_radix = 1;
5395
5396       if (gfc_real_kinds[i].precision >= precision
5397           && gfc_real_kinds[i].range >= range
5398           && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
5399         kind = gfc_real_kinds[i].kind;
5400     }
5401
5402   if (kind == INT_MAX)
5403     {
5404       if (found_radix && found_range && !found_precision)
5405         kind = -1;
5406       else if (found_radix && found_precision && !found_range)
5407         kind = -2;
5408       else if (found_radix && !found_precision && !found_range)
5409         kind = -3;
5410       else if (found_radix)
5411         kind = -4;
5412       else
5413         kind = -5;
5414     }
5415
5416   return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5417 }
5418
5419
5420 gfc_expr *
5421 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5422 {
5423   gfc_expr *result;
5424   mpfr_t exp, absv, log2, pow2, frac;
5425   unsigned long exp2;
5426
5427   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5428     return NULL;
5429
5430   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5431
5432   if (mpfr_sgn (x->value.real) == 0)
5433     {
5434       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5435       return result;
5436     }
5437
5438   gfc_set_model_kind (x->ts.kind);
5439   mpfr_init (absv);
5440   mpfr_init (log2);
5441   mpfr_init (exp);
5442   mpfr_init (pow2);
5443   mpfr_init (frac);
5444
5445   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5446   mpfr_log2 (log2, absv, GFC_RND_MODE);
5447
5448   mpfr_trunc (log2, log2);
5449   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5450
5451   /* Old exponent value, and fraction.  */
5452   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5453
5454   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5455
5456   /* New exponent.  */
5457   exp2 = (unsigned long) mpz_get_d (i->value.integer);
5458   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5459
5460   mpfr_clears (absv, log2, pow2, frac, NULL);
5461
5462   return range_check (result, "SET_EXPONENT");
5463 }
5464
5465
5466 gfc_expr *
5467 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5468 {
5469   mpz_t shape[GFC_MAX_DIMENSIONS];
5470   gfc_expr *result, *e, *f;
5471   gfc_array_ref *ar;
5472   int n;
5473   gfc_try t;
5474   int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5475
5476   if (source->rank == -1)
5477     return NULL;
5478
5479   result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5480
5481   if (source->rank == 0)
5482     return result;
5483
5484   if (source->expr_type == EXPR_VARIABLE)
5485     {
5486       ar = gfc_find_array_ref (source);
5487       t = gfc_array_ref_shape (ar, shape);
5488     }
5489   else if (source->shape)
5490     {
5491       t = SUCCESS;
5492       for (n = 0; n < source->rank; n++)
5493         {
5494           mpz_init (shape[n]);
5495           mpz_set (shape[n], source->shape[n]);
5496         }
5497     }
5498   else
5499     t = FAILURE;
5500
5501   for (n = 0; n < source->rank; n++)
5502     {
5503       e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5504
5505       if (t == SUCCESS)
5506         {
5507           mpz_set (e->value.integer, shape[n]);
5508           mpz_clear (shape[n]);
5509         }
5510       else
5511         {
5512           mpz_set_ui (e->value.integer, n + 1);
5513
5514           f = gfc_simplify_size (source, e, NULL);
5515           gfc_free_expr (e);
5516           if (f == NULL)
5517             {
5518               gfc_free_expr (result);
5519               return NULL;
5520             }
5521           else
5522             e = f;
5523         }
5524
5525       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5526     }
5527
5528   return result;
5529 }
5530
5531
5532 gfc_expr *
5533 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5534 {
5535   mpz_t size;
5536   gfc_expr *return_value;
5537   int d;
5538   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5539
5540   if (k == -1)
5541     return &gfc_bad_expr;
5542
5543   /* For unary operations, the size of the result is given by the size
5544      of the operand.  For binary ones, it's the size of the first operand
5545      unless it is scalar, then it is the size of the second.  */
5546   if (array->expr_type == EXPR_OP && !array->value.op.uop)
5547     {
5548       gfc_expr* replacement;
5549       gfc_expr* simplified;
5550
5551       switch (array->value.op.op)
5552         {
5553           /* Unary operations.  */
5554           case INTRINSIC_NOT:
5555           case INTRINSIC_UPLUS:
5556           case INTRINSIC_UMINUS:
5557           case INTRINSIC_PARENTHESES:
5558             replacement = array->value.op.op1;
5559             break;
5560
5561           /* Binary operations.  If any one of the operands is scalar, take
5562              the other one's size.  If both of them are arrays, it does not
5563              matter -- try to find one with known shape, if possible.  */
5564           default:
5565             if (array->value.op.op1->rank == 0)
5566               replacement = array->value.op.op2;
5567             else if (array->value.op.op2->rank == 0)
5568               replacement = array->value.op.op1;
5569             else
5570               {
5571                 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5572                 if (simplified)
5573                   return simplified;
5574
5575                 replacement = array->value.op.op2;
5576               }
5577             break;
5578         }
5579
5580       /* Try to reduce it directly if possible.  */
5581       simplified = gfc_simplify_size (replacement, dim, kind);
5582
5583       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5584          simpler than the original one.  */
5585       if (!simplified)
5586         simplified = gfc_build_intrinsic_call ("size", array->where, 3,
5587                                                gfc_copy_expr (replacement),
5588                                                gfc_copy_expr (dim),
5589                                                gfc_copy_expr (kind));
5590
5591       return simplified;
5592     }
5593
5594   if (dim == NULL)
5595     {
5596       if (gfc_array_size (array, &size) == FAILURE)
5597         return NULL;
5598     }
5599   else
5600     {
5601       if (dim->expr_type != EXPR_CONSTANT)
5602         return NULL;
5603
5604       d = mpz_get_ui (dim->value.integer) - 1;
5605       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
5606         return NULL;
5607     }
5608
5609   return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5610   mpz_clear (size);
5611   return return_value;
5612 }
5613
5614
5615 gfc_expr *
5616 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5617 {
5618   gfc_expr *result;
5619
5620   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5621     return NULL;
5622
5623   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5624
5625   switch (x->ts.type)
5626     {
5627       case BT_INTEGER:
5628         mpz_abs (result->value.integer, x->value.integer);
5629         if (mpz_sgn (y->value.integer) < 0)
5630           mpz_neg (result->value.integer, result->value.integer);
5631         break;
5632
5633       case BT_REAL:
5634         if (gfc_option.flag_sign_zero)
5635           mpfr_copysign (result->value.real, x->value.real, y->value.real,
5636                         GFC_RND_MODE);
5637         else
5638           mpfr_setsign (result->value.real, x->value.real,
5639                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5640         break;
5641
5642       default:
5643         gfc_internal_error ("Bad type in gfc_simplify_sign");
5644     }
5645
5646   return result;
5647 }
5648
5649
5650 gfc_expr *
5651 gfc_simplify_sin (gfc_expr *x)
5652 {
5653   gfc_expr *result;
5654
5655   if (x->expr_type != EXPR_CONSTANT)
5656     return NULL;
5657
5658   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5659
5660   switch (x->ts.type)
5661     {
5662       case BT_REAL:
5663         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5664         break;
5665
5666       case BT_COMPLEX:
5667         gfc_set_model (x->value.real);
5668         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5669         break;
5670
5671       default:
5672         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5673     }
5674
5675   return range_check (result, "SIN");
5676 }
5677
5678
5679 gfc_expr *
5680 gfc_simplify_sinh (gfc_expr *x)
5681 {
5682   gfc_expr *result;
5683
5684   if (x->expr_type != EXPR_CONSTANT)
5685     return NULL;
5686
5687   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5688
5689   switch (x->ts.type)
5690     {
5691       case BT_REAL:
5692         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5693         break;
5694
5695       case BT_COMPLEX:
5696         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5697         break;
5698
5699       default:
5700         gcc_unreachable ();
5701     }
5702
5703   return range_check (result, "SINH");
5704 }
5705
5706
5707 /* The argument is always a double precision real that is converted to
5708    single precision.  TODO: Rounding!  */
5709
5710 gfc_expr *
5711 gfc_simplify_sngl (gfc_expr *a)
5712 {
5713   gfc_expr *result;
5714
5715   if (a->expr_type != EXPR_CONSTANT)
5716     return NULL;
5717
5718   result = gfc_real2real (a, gfc_default_real_kind);
5719   return range_check (result, "SNGL");
5720 }
5721
5722
5723 gfc_expr *
5724 gfc_simplify_spacing (gfc_expr *x)
5725 {
5726   gfc_expr *result;
5727   int i;
5728   long int en, ep;
5729
5730   if (x->expr_type != EXPR_CONSTANT)
5731     return NULL;
5732
5733   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5734
5735   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5736
5737   /* Special case x = 0 and -0.  */
5738   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5739   if (mpfr_sgn (result->value.real) == 0)
5740     {
5741       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5742       return result;
5743     }
5744
5745   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5746      are the radix, exponent of x, and precision.  This excludes the
5747      possibility of subnormal numbers.  Fortran 2003 states the result is
5748      b**max(e - p, emin - 1).  */
5749
5750   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5751   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5752   en = en > ep ? en : ep;
5753
5754   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5755   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5756
5757   return range_check (result, "SPACING");
5758 }
5759
5760
5761 gfc_expr *
5762 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5763 {
5764   gfc_expr *result = 0L;
5765   int i, j, dim, ncopies;
5766   mpz_t size;
5767
5768   if ((!gfc_is_constant_expr (source)
5769        && !is_constant_array_expr (source))
5770       || !gfc_is_constant_expr (dim_expr)
5771       || !gfc_is_constant_expr (ncopies_expr))
5772     return NULL;
5773
5774   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5775   gfc_extract_int (dim_expr, &dim);
5776   dim -= 1;   /* zero-base DIM */
5777
5778   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5779   gfc_extract_int (ncopies_expr, &ncopies);
5780   ncopies = MAX (ncopies, 0);
5781
5782   /* Do not allow the array size to exceed the limit for an array
5783      constructor.  */
5784   if (source->expr_type == EXPR_ARRAY)
5785     {
5786       if (gfc_array_size (source, &size) == FAILURE)
5787         gfc_internal_error ("Failure getting length of a constant array.");
5788     }
5789   else
5790     mpz_init_set_ui (size, 1);
5791
5792   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5793     return NULL;
5794
5795   if (source->expr_type == EXPR_CONSTANT)
5796     {
5797       gcc_assert (dim == 0);
5798
5799       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5800                                    &source->where);
5801       if (source->ts.type == BT_DERIVED)
5802         result->ts.u.derived = source->ts.u.derived;
5803       result->rank = 1;
5804       result->shape = gfc_get_shape (result->rank);
5805       mpz_init_set_si (result->shape[0], ncopies);
5806
5807       for (i = 0; i < ncopies; ++i)
5808         gfc_constructor_append_expr (&result->value.constructor,
5809                                      gfc_copy_expr (source), NULL);
5810     }
5811   else if (source->expr_type == EXPR_ARRAY)
5812     {
5813       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5814       gfc_constructor *source_ctor;
5815
5816       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5817       gcc_assert (dim >= 0 && dim <= source->rank);
5818
5819       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5820                                    &source->where);
5821       if (source->ts.type == BT_DERIVED)
5822         result->ts.u.derived = source->ts.u.derived;
5823       result->rank = source->rank + 1;
5824       result->shape = gfc_get_shape (result->rank);
5825
5826       for (i = 0, j = 0; i < result->rank; ++i)
5827         {
5828           if (i != dim)
5829             mpz_init_set (result->shape[i], source->shape[j++]);
5830           else
5831             mpz_init_set_si (result->shape[i], ncopies);
5832
5833           extent[i] = mpz_get_si (result->shape[i]);
5834           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5835         }
5836
5837       offset = 0;
5838       for (source_ctor = gfc_constructor_first (source->value.constructor);
5839            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5840         {
5841           for (i = 0; i < ncopies; ++i)
5842             gfc_constructor_insert_expr (&result->value.constructor,
5843                                          gfc_copy_expr (source_ctor->expr),
5844                                          NULL, offset + i * rstride[dim]);
5845
5846           offset += (dim == 0 ? ncopies : 1);
5847         }
5848     }
5849   else
5850     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5851        Replace NULL with gcc_unreachable() after implementing
5852        gfc_simplify_cshift(). */
5853     return NULL;
5854
5855   if (source->ts.type == BT_CHARACTER)
5856     result->ts.u.cl = source->ts.u.cl;
5857
5858   return result;
5859 }
5860
5861
5862 gfc_expr *
5863 gfc_simplify_sqrt (gfc_expr *e)
5864 {
5865   gfc_expr *result = NULL;
5866
5867   if (e->expr_type != EXPR_CONSTANT)
5868     return NULL;
5869
5870   switch (e->ts.type)
5871     {
5872       case BT_REAL:
5873         if (mpfr_cmp_si (e->value.real, 0) < 0)
5874           {
5875             gfc_error ("Argument of SQRT at %L has a negative value",
5876                        &e->where);
5877             return &gfc_bad_expr;
5878           }
5879         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5880         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5881         break;
5882
5883       case BT_COMPLEX:
5884         gfc_set_model (e->value.real);
5885
5886         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5887         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5888         break;
5889
5890       default:
5891         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5892     }
5893
5894   return range_check (result, "SQRT");
5895 }
5896
5897
5898 gfc_expr *
5899 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5900 {
5901   return simplify_transformation (array, dim, mask, 0, gfc_add);
5902 }
5903
5904
5905 gfc_expr *
5906 gfc_simplify_tan (gfc_expr *x)
5907 {
5908   gfc_expr *result;
5909
5910   if (x->expr_type != EXPR_CONSTANT)
5911     return NULL;
5912
5913   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5914
5915   switch (x->ts.type)
5916     {
5917       case BT_REAL:
5918         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5919         break;
5920
5921       case BT_COMPLEX:
5922         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5923         break;
5924
5925       default:
5926         gcc_unreachable ();
5927     }
5928
5929   return range_check (result, "TAN");
5930 }
5931
5932
5933 gfc_expr *
5934 gfc_simplify_tanh (gfc_expr *x)
5935 {
5936   gfc_expr *result;
5937
5938   if (x->expr_type != EXPR_CONSTANT)
5939     return NULL;
5940
5941   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5942
5943   switch (x->ts.type)
5944     {
5945       case BT_REAL:
5946         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5947         break;
5948
5949       case BT_COMPLEX:
5950         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5951         break;
5952
5953       default:
5954         gcc_unreachable ();
5955     }
5956
5957   return range_check (result, "TANH");
5958 }
5959
5960
5961 gfc_expr *
5962 gfc_simplify_tiny (gfc_expr *e)
5963 {
5964   gfc_expr *result;
5965   int i;
5966
5967   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5968
5969   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5970   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5971
5972   return result;
5973 }
5974
5975
5976 gfc_expr *
5977 gfc_simplify_trailz (gfc_expr *e)
5978 {
5979   unsigned long tz, bs;
5980   int i;
5981
5982   if (e->expr_type != EXPR_CONSTANT)
5983     return NULL;
5984
5985   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5986   bs = gfc_integer_kinds[i].bit_size;
5987   tz = mpz_scan1 (e->value.integer, 0);
5988
5989   return gfc_get_int_expr (gfc_default_integer_kind,
5990                            &e->where, MIN (tz, bs));
5991 }
5992
5993
5994 gfc_expr *
5995 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5996 {
5997   gfc_expr *result;
5998   gfc_expr *mold_element;
5999   size_t source_size;
6000   size_t result_size;
6001   size_t buffer_size;
6002   mpz_t tmp;
6003   unsigned char *buffer;
6004   size_t result_length;
6005
6006
6007   if (!gfc_is_constant_expr (source)
6008         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
6009         || !gfc_is_constant_expr (size))
6010     return NULL;
6011
6012   if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6013                                     &result_size, &result_length) == FAILURE)
6014     return NULL;
6015
6016   /* Calculate the size of the source.  */
6017   if (source->expr_type == EXPR_ARRAY
6018       && gfc_array_size (source, &tmp) == FAILURE)
6019     gfc_internal_error ("Failure getting length of a constant array.");
6020
6021   /* Create an empty new expression with the appropriate characteristics.  */
6022   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6023                                   &source->where);
6024   result->ts = mold->ts;
6025
6026   mold_element = mold->expr_type == EXPR_ARRAY
6027                  ? gfc_constructor_first (mold->value.constructor)->expr
6028                  : mold;
6029
6030   /* Set result character length, if needed.  Note that this needs to be
6031      set even for array expressions, in order to pass this information into
6032      gfc_target_interpret_expr.  */
6033   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6034     result->value.character.length = mold_element->value.character.length;
6035
6036   /* Set the number of elements in the result, and determine its size.  */
6037
6038   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6039     {
6040       result->expr_type = EXPR_ARRAY;
6041       result->rank = 1;
6042       result->shape = gfc_get_shape (1);
6043       mpz_init_set_ui (result->shape[0], result_length);
6044     }
6045   else
6046     result->rank = 0;
6047
6048   /* Allocate the buffer to store the binary version of the source.  */
6049   buffer_size = MAX (source_size, result_size);
6050   buffer = (unsigned char*)alloca (buffer_size);
6051   memset (buffer, 0, buffer_size);
6052
6053   /* Now write source to the buffer.  */
6054   gfc_target_encode_expr (source, buffer, buffer_size);
6055
6056   /* And read the buffer back into the new expression.  */
6057   gfc_target_interpret_expr (buffer, buffer_size, result, false);
6058
6059   return result;
6060 }
6061
6062
6063 gfc_expr *
6064 gfc_simplify_transpose (gfc_expr *matrix)
6065 {
6066   int row, matrix_rows, col, matrix_cols;
6067   gfc_expr *result;
6068
6069   if (!is_constant_array_expr (matrix))
6070     return NULL;
6071
6072   gcc_assert (matrix->rank == 2);
6073
6074   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6075                                &matrix->where);
6076   result->rank = 2;
6077   result->shape = gfc_get_shape (result->rank);
6078   mpz_set (result->shape[0], matrix->shape[1]);
6079   mpz_set (result->shape[1], matrix->shape[0]);
6080
6081   if (matrix->ts.type == BT_CHARACTER)
6082     result->ts.u.cl = matrix->ts.u.cl;
6083   else if (matrix->ts.type == BT_DERIVED)
6084     result->ts.u.derived = matrix->ts.u.derived;
6085
6086   matrix_rows = mpz_get_si (matrix->shape[0]);
6087   matrix_cols = mpz_get_si (matrix->shape[1]);
6088   for (row = 0; row < matrix_rows; ++row)
6089     for (col = 0; col < matrix_cols; ++col)
6090       {
6091         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6092                                                    col * matrix_rows + row);
6093         gfc_constructor_insert_expr (&result->value.constructor,
6094                                      gfc_copy_expr (e), &matrix->where,
6095                                      row * matrix_cols + col);
6096       }
6097
6098   return result;
6099 }
6100
6101
6102 gfc_expr *
6103 gfc_simplify_trim (gfc_expr *e)
6104 {
6105   gfc_expr *result;
6106   int count, i, len, lentrim;
6107
6108   if (e->expr_type != EXPR_CONSTANT)
6109     return NULL;
6110
6111   len = e->value.character.length;
6112   for (count = 0, i = 1; i <= len; ++i)
6113     {
6114       if (e->value.character.string[len - i] == ' ')
6115         count++;
6116       else
6117         break;
6118     }
6119
6120   lentrim = len - count;
6121
6122   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6123   for (i = 0; i < lentrim; i++)
6124     result->value.character.string[i] = e->value.character.string[i];
6125
6126   return result;
6127 }
6128
6129
6130 gfc_expr *
6131 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6132 {
6133   gfc_expr *result;
6134   gfc_ref *ref;
6135   gfc_array_spec *as;
6136   gfc_constructor *sub_cons;
6137   bool first_image;
6138   int d;
6139
6140   if (!is_constant_array_expr (sub))
6141     return NULL;
6142
6143   /* Follow any component references.  */
6144   as = coarray->symtree->n.sym->as;
6145   for (ref = coarray->ref; ref; ref = ref->next)
6146     if (ref->type == REF_COMPONENT)
6147       as = ref->u.ar.as;
6148
6149   if (as->type == AS_DEFERRED)
6150     return NULL;
6151
6152   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6153      the cosubscript addresses the first image.  */
6154
6155   sub_cons = gfc_constructor_first (sub->value.constructor);
6156   first_image = true;
6157
6158   for (d = 1; d <= as->corank; d++)
6159     {
6160       gfc_expr *ca_bound;
6161       int cmp;
6162
6163       gcc_assert (sub_cons != NULL);
6164
6165       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6166                                      NULL, true);
6167       if (ca_bound == NULL)
6168         return NULL;
6169
6170       if (ca_bound == &gfc_bad_expr)
6171         return ca_bound;
6172
6173       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6174
6175       if (cmp == 0)
6176         {
6177           gfc_free_expr (ca_bound);
6178           sub_cons = gfc_constructor_next (sub_cons);
6179           continue;
6180         }
6181
6182       first_image = false;
6183
6184       if (cmp > 0)
6185         {
6186           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6187                      "SUB has %ld and COARRAY lower bound is %ld)",
6188                      &coarray->where, d,
6189                      mpz_get_si (sub_cons->expr->value.integer),
6190                      mpz_get_si (ca_bound->value.integer));
6191           gfc_free_expr (ca_bound);
6192           return &gfc_bad_expr;
6193         }
6194
6195       gfc_free_expr (ca_bound);
6196
6197       /* Check whether upperbound is valid for the multi-images case.  */
6198       if (d < as->corank)
6199         {
6200           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6201                                          NULL, true);
6202           if (ca_bound == &gfc_bad_expr)
6203             return ca_bound;
6204
6205           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6206               && mpz_cmp (ca_bound->value.integer,
6207                           sub_cons->expr->value.integer) < 0)
6208           {
6209             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6210                        "SUB has %ld and COARRAY upper bound is %ld)",
6211                        &coarray->where, d,
6212                        mpz_get_si (sub_cons->expr->value.integer),
6213                        mpz_get_si (ca_bound->value.integer));
6214             gfc_free_expr (ca_bound);
6215             return &gfc_bad_expr;
6216           }
6217
6218           if (ca_bound)
6219             gfc_free_expr (ca_bound);
6220         }
6221
6222       sub_cons = gfc_constructor_next (sub_cons);
6223     }
6224
6225   gcc_assert (sub_cons == NULL);
6226
6227   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
6228     return NULL;
6229
6230   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6231                                   &gfc_current_locus);
6232   if (first_image)
6233     mpz_set_si (result->value.integer, 1);
6234   else
6235     mpz_set_si (result->value.integer, 0);
6236
6237   return result;
6238 }
6239
6240
6241 gfc_expr *
6242 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6243 {
6244   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6245     return NULL;
6246
6247   if (coarray == NULL)
6248     {
6249       gfc_expr *result;
6250       /* FIXME: gfc_current_locus is wrong.  */
6251       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6252                                       &gfc_current_locus);
6253       mpz_set_si (result->value.integer, 1);
6254       return result;
6255     }
6256
6257   /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
6258   return simplify_cobound (coarray, dim, NULL, 0);
6259 }
6260
6261
6262 gfc_expr *
6263 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6264 {
6265   return simplify_bound (array, dim, kind, 1);
6266 }
6267
6268 gfc_expr *
6269 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6270 {
6271   return simplify_cobound (array, dim, kind, 1);
6272 }
6273
6274
6275 gfc_expr *
6276 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6277 {
6278   gfc_expr *result, *e;
6279   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6280
6281   if (!is_constant_array_expr (vector)
6282       || !is_constant_array_expr (mask)
6283       || (!gfc_is_constant_expr (field)
6284           && !is_constant_array_expr(field)))
6285     return NULL;
6286
6287   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6288                                &vector->where);
6289   if (vector->ts.type == BT_DERIVED)
6290     result->ts.u.derived = vector->ts.u.derived;
6291   result->rank = mask->rank;
6292   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6293
6294   if (vector->ts.type == BT_CHARACTER)
6295     result->ts.u.cl = vector->ts.u.cl;
6296
6297   vector_ctor = gfc_constructor_first (vector->value.constructor);
6298   mask_ctor = gfc_constructor_first (mask->value.constructor);
6299   field_ctor
6300     = field->expr_type == EXPR_ARRAY
6301                             ? gfc_constructor_first (field->value.constructor)
6302                             : NULL;
6303
6304   while (mask_ctor)
6305     {
6306       if (mask_ctor->expr->value.logical)
6307         {
6308           gcc_assert (vector_ctor);
6309           e = gfc_copy_expr (vector_ctor->expr);
6310           vector_ctor = gfc_constructor_next (vector_ctor);
6311         }
6312       else if (field->expr_type == EXPR_ARRAY)
6313         e = gfc_copy_expr (field_ctor->expr);
6314       else
6315         e = gfc_copy_expr (field);
6316
6317       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6318
6319       mask_ctor = gfc_constructor_next (mask_ctor);
6320       field_ctor = gfc_constructor_next (field_ctor);
6321     }
6322
6323   return result;
6324 }
6325
6326
6327 gfc_expr *
6328 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6329 {
6330   gfc_expr *result;
6331   int back;
6332   size_t index, len, lenset;
6333   size_t i;
6334   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6335
6336   if (k == -1)
6337     return &gfc_bad_expr;
6338
6339   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
6340       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
6341     return NULL;
6342
6343   if (b != NULL && b->value.logical != 0)
6344     back = 1;
6345   else
6346     back = 0;
6347
6348   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6349
6350   len = s->value.character.length;
6351   lenset = set->value.character.length;
6352
6353   if (len == 0)
6354     {
6355       mpz_set_ui (result->value.integer, 0);
6356       return result;
6357     }
6358
6359   if (back == 0)
6360     {
6361       if (lenset == 0)
6362         {
6363           mpz_set_ui (result->value.integer, 1);
6364           return result;
6365         }
6366
6367       index = wide_strspn (s->value.character.string,
6368                            set->value.character.string) + 1;
6369       if (index > len)
6370         index = 0;
6371
6372     }
6373   else
6374     {
6375       if (lenset == 0)
6376         {
6377           mpz_set_ui (result->value.integer, len);
6378           return result;
6379         }
6380       for (index = len; index > 0; index --)
6381         {
6382           for (i = 0; i < lenset; i++)
6383             {
6384               if (s->value.character.string[index - 1]
6385                   == set->value.character.string[i])
6386                 break;
6387             }
6388           if (i == lenset)
6389             break;
6390         }
6391     }
6392
6393   mpz_set_ui (result->value.integer, index);
6394   return result;
6395 }
6396
6397
6398 gfc_expr *
6399 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6400 {
6401   gfc_expr *result;
6402   int kind;
6403
6404   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6405     return NULL;
6406
6407   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6408
6409   switch (x->ts.type)
6410     {
6411       case BT_INTEGER:
6412         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6413         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6414         return range_check (result, "XOR");
6415
6416       case BT_LOGICAL:
6417         return gfc_get_logical_expr (kind, &x->where,
6418                                      (x->value.logical && !y->value.logical)
6419                                      || (!x->value.logical && y->value.logical));
6420
6421       default:
6422         gcc_unreachable ();
6423     }
6424 }
6425
6426
6427 /****************** Constant simplification *****************/
6428
6429 /* Master function to convert one constant to another.  While this is
6430    used as a simplification function, it requires the destination type
6431    and kind information which is supplied by a special case in
6432    do_simplify().  */
6433
6434 gfc_expr *
6435 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6436 {
6437   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6438   gfc_constructor *c;
6439
6440   switch (e->ts.type)
6441     {
6442     case BT_INTEGER:
6443       switch (type)
6444         {
6445         case BT_INTEGER:
6446           f = gfc_int2int;
6447           break;
6448         case BT_REAL:
6449           f = gfc_int2real;
6450           break;
6451         case BT_COMPLEX:
6452           f = gfc_int2complex;
6453           break;
6454         case BT_LOGICAL:
6455           f = gfc_int2log;
6456           break;
6457         default:
6458           goto oops;
6459         }
6460       break;
6461
6462     case BT_REAL:
6463       switch (type)
6464         {
6465         case BT_INTEGER:
6466           f = gfc_real2int;
6467           break;
6468         case BT_REAL:
6469           f = gfc_real2real;
6470           break;
6471         case BT_COMPLEX:
6472           f = gfc_real2complex;
6473           break;
6474         default:
6475           goto oops;
6476         }
6477       break;
6478
6479     case BT_COMPLEX:
6480       switch (type)
6481         {
6482         case BT_INTEGER:
6483           f = gfc_complex2int;
6484           break;
6485         case BT_REAL:
6486           f = gfc_complex2real;
6487           break;
6488         case BT_COMPLEX:
6489           f = gfc_complex2complex;
6490           break;
6491
6492         default:
6493           goto oops;
6494         }
6495       break;
6496
6497     case BT_LOGICAL:
6498       switch (type)
6499         {
6500         case BT_INTEGER:
6501           f = gfc_log2int;
6502           break;
6503         case BT_LOGICAL:
6504           f = gfc_log2log;
6505           break;
6506         default:
6507           goto oops;
6508         }
6509       break;
6510
6511     case BT_HOLLERITH:
6512       switch (type)
6513         {
6514         case BT_INTEGER:
6515           f = gfc_hollerith2int;
6516           break;
6517
6518         case BT_REAL:
6519           f = gfc_hollerith2real;
6520           break;
6521
6522         case BT_COMPLEX:
6523           f = gfc_hollerith2complex;
6524           break;
6525
6526         case BT_CHARACTER:
6527           f = gfc_hollerith2character;
6528           break;
6529
6530         case BT_LOGICAL:
6531           f = gfc_hollerith2logical;
6532           break;
6533
6534         default:
6535           goto oops;
6536         }
6537       break;
6538
6539     default:
6540     oops:
6541       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6542     }
6543
6544   result = NULL;
6545
6546   switch (e->expr_type)
6547     {
6548     case EXPR_CONSTANT:
6549       result = f (e, kind);
6550       if (result == NULL)
6551         return &gfc_bad_expr;
6552       break;
6553
6554     case EXPR_ARRAY:
6555       if (!gfc_is_constant_expr (e))
6556         break;
6557
6558       result = gfc_get_array_expr (type, kind, &e->where);
6559       result->shape = gfc_copy_shape (e->shape, e->rank);
6560       result->rank = e->rank;
6561
6562       for (c = gfc_constructor_first (e->value.constructor);
6563            c; c = gfc_constructor_next (c))
6564         {
6565           gfc_expr *tmp;
6566           if (c->iterator == NULL)
6567             tmp = f (c->expr, kind);
6568           else
6569             {
6570               g = gfc_convert_constant (c->expr, type, kind);
6571               if (g == &gfc_bad_expr)
6572                 {
6573                   gfc_free_expr (result);
6574                   return g;
6575                 }
6576               tmp = g;
6577             }
6578
6579           if (tmp == NULL)
6580             {
6581               gfc_free_expr (result);
6582               return NULL;
6583             }
6584
6585           gfc_constructor_append_expr (&result->value.constructor,
6586                                        tmp, &c->where);
6587         }
6588
6589       break;
6590
6591     default:
6592       break;
6593     }
6594
6595   return result;
6596 }
6597
6598
6599 /* Function for converting character constants.  */
6600 gfc_expr *
6601 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6602 {
6603   gfc_expr *result;
6604   int i;
6605
6606   if (!gfc_is_constant_expr (e))
6607     return NULL;
6608
6609   if (e->expr_type == EXPR_CONSTANT)
6610     {
6611       /* Simple case of a scalar.  */
6612       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6613       if (result == NULL)
6614         return &gfc_bad_expr;
6615
6616       result->value.character.length = e->value.character.length;
6617       result->value.character.string
6618         = gfc_get_wide_string (e->value.character.length + 1);
6619       memcpy (result->value.character.string, e->value.character.string,
6620               (e->value.character.length + 1) * sizeof (gfc_char_t));
6621
6622       /* Check we only have values representable in the destination kind.  */
6623       for (i = 0; i < result->value.character.length; i++)
6624         if (!gfc_check_character_range (result->value.character.string[i],
6625                                         kind))
6626           {
6627             gfc_error ("Character '%s' in string at %L cannot be converted "
6628                        "into character kind %d",
6629                        gfc_print_wide_char (result->value.character.string[i]),
6630                        &e->where, kind);
6631             return &gfc_bad_expr;
6632           }
6633
6634       return result;
6635     }
6636   else if (e->expr_type == EXPR_ARRAY)
6637     {
6638       /* For an array constructor, we convert each constructor element.  */
6639       gfc_constructor *c;
6640
6641       result = gfc_get_array_expr (type, kind, &e->where);
6642       result->shape = gfc_copy_shape (e->shape, e->rank);
6643       result->rank = e->rank;
6644       result->ts.u.cl = e->ts.u.cl;
6645
6646       for (c = gfc_constructor_first (e->value.constructor);
6647            c; c = gfc_constructor_next (c))
6648         {
6649           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6650           if (tmp == &gfc_bad_expr)
6651             {
6652               gfc_free_expr (result);
6653               return &gfc_bad_expr;
6654             }
6655
6656           if (tmp == NULL)
6657             {
6658               gfc_free_expr (result);
6659               return NULL;
6660             }
6661
6662           gfc_constructor_append_expr (&result->value.constructor,
6663                                        tmp, &c->where);
6664         }
6665
6666       return result;
6667     }
6668   else
6669     return NULL;
6670 }
6671
6672
6673 gfc_expr *
6674 gfc_simplify_compiler_options (void)
6675 {
6676   char *str;
6677   gfc_expr *result;
6678
6679   str = gfc_get_option_string ();
6680   result = gfc_get_character_expr (gfc_default_character_kind,
6681                                    &gfc_current_locus, str, strlen (str));
6682   free (str);
6683   return result;
6684 }
6685
6686
6687 gfc_expr *
6688 gfc_simplify_compiler_version (void)
6689 {
6690   char *buffer;
6691   size_t len;
6692
6693   len = strlen ("GCC version ") + strlen (version_string);
6694   buffer = XALLOCAVEC (char, len + 1);
6695   snprintf (buffer, len + 1, "GCC version %s", version_string);
6696   return gfc_get_character_expr (gfc_default_character_kind,
6697                                 &gfc_current_locus, buffer, len);
6698 }