gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000-2013 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught & Katherine Holcomb
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "coretypes.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "arith.h"
  27 #include "intrinsic.h"
  28 #include "target-memory.h"
  29 #include "constructor.h"
  30 #include "tm.h"         /* For BITS_PER_UNIT.  */
  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
2255   if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
2256     return NULL;
2257
2258   /* Return .false. if the dynamic type can never be the same.  */
2259   if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
2260        && !gfc_type_is_extension_of
2261                         (mold->ts.u.derived->components->ts.u.derived,
2262                          a->ts.u.derived->components->ts.u.derived)
2263        && !gfc_type_is_extension_of
2264                         (a->ts.u.derived->components->ts.u.derived,
2265                          mold->ts.u.derived->components->ts.u.derived))
2266       || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
2267           && !gfc_type_is_extension_of
2268                         (a->ts.u.derived,
2269                          mold->ts.u.derived->components->ts.u.derived)
2270           && !gfc_type_is_extension_of
2271                         (mold->ts.u.derived->components->ts.u.derived,
2272                          a->ts.u.derived))
2273       || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
2274           && !gfc_type_is_extension_of
2275                         (mold->ts.u.derived,
2276                          a->ts.u.derived->components->ts.u.derived)))
2277     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2278
2279   if (mold->ts.type == BT_DERIVED
2280       && gfc_type_is_extension_of (mold->ts.u.derived,
2281                                    a->ts.u.derived->components->ts.u.derived))
2282     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
2283
2284   return NULL;
2285 }
2286
2287
2288 gfc_expr *
2289 gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
2290 {
2291   /* Avoid simplification of resolved symbols.  */
2292   if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
2293     return NULL;
2294
2295   /* Return .false. if the dynamic type can never be the
2296      same.  */
2297   if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
2298       && !gfc_type_compatible (&a->ts, &b->ts)
2299       && !gfc_type_compatible (&b->ts, &a->ts))
2300     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2301
2302   if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
2303      return NULL;
2304
2305   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2306                                gfc_compare_derived_types (a->ts.u.derived,
2307                                                           b->ts.u.derived));
2308 }
2309
2310
2311 gfc_expr *
2312 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
2313 {
2314   gfc_expr *result;
2315   mpfr_t floor;
2316   int kind;
2317
2318   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
2319   if (kind == -1)
2320     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2321
2322   if (e->expr_type != EXPR_CONSTANT)
2323     return NULL;
2324
2325   gfc_set_model_kind (kind);
2326
2327   mpfr_init (floor);
2328   mpfr_floor (floor, e->value.real);
2329
2330   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
2331   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
2332
2333   mpfr_clear (floor);
2334
2335   return range_check (result, "FLOOR");
2336 }
2337
2338
2339 gfc_expr *
2340 gfc_simplify_fraction (gfc_expr *x)
2341 {
2342   gfc_expr *result;
2343   mpfr_t absv, exp, pow2;
2344
2345   if (x->expr_type != EXPR_CONSTANT)
2346     return NULL;
2347
2348   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
2349
2350   if (mpfr_sgn (x->value.real) == 0)
2351     {
2352       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2353       return result;
2354     }
2355
2356   gfc_set_model_kind (x->ts.kind);
2357   mpfr_init (exp);
2358   mpfr_init (absv);
2359   mpfr_init (pow2);
2360
2361   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2362   mpfr_log2 (exp, absv, GFC_RND_MODE);
2363
2364   mpfr_trunc (exp, exp);
2365   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
2366
2367   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2368
2369   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
2370
2371   mpfr_clears (exp, absv, pow2, NULL);
2372
2373   return range_check (result, "FRACTION");
2374 }
2375
2376
2377 gfc_expr *
2378 gfc_simplify_gamma (gfc_expr *x)
2379 {
2380   gfc_expr *result;
2381
2382   if (x->expr_type != EXPR_CONSTANT)
2383     return NULL;
2384
2385   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2386   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2387
2388   return range_check (result, "GAMMA");
2389 }
2390
2391
2392 gfc_expr *
2393 gfc_simplify_huge (gfc_expr *e)
2394 {
2395   gfc_expr *result;
2396   int i;
2397
2398   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2399   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2400
2401   switch (e->ts.type)
2402     {
2403       case BT_INTEGER:
2404         mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2405         break;
2406
2407       case BT_REAL:
2408         mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2409         break;
2410
2411       default:
2412         gcc_unreachable ();
2413     }
2414
2415   return result;
2416 }
2417
2418
2419 gfc_expr *
2420 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2421 {
2422   gfc_expr *result;
2423
2424   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2425     return NULL;
2426
2427   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2428   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2429   return range_check (result, "HYPOT");
2430 }
2431
2432
2433 /* We use the processor's collating sequence, because all
2434    systems that gfortran currently works on are ASCII.  */
2435
2436 gfc_expr *
2437 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2438 {
2439   gfc_expr *result;
2440   gfc_char_t index;
2441   int k;
2442
2443   if (e->expr_type != EXPR_CONSTANT)
2444     return NULL;
2445
2446   if (e->value.character.length != 1)
2447     {
2448       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2449       return &gfc_bad_expr;
2450     }
2451
2452   index = e->value.character.string[0];
2453
2454   if (gfc_option.warn_surprising && index > 127)
2455     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2456                  &e->where);
2457
2458   k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2459   if (k == -1)
2460     return &gfc_bad_expr;
2461
2462   result = gfc_get_int_expr (k, &e->where, index);
2463
2464   return range_check (result, "IACHAR");
2465 }
2466
2467
2468 static gfc_expr *
2469 do_bit_and (gfc_expr *result, gfc_expr *e)
2470 {
2471   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2472   gcc_assert (result->ts.type == BT_INTEGER
2473               && result->expr_type == EXPR_CONSTANT);
2474
2475   mpz_and (result->value.integer, result->value.integer, e->value.integer);
2476   return result;
2477 }
2478
2479
2480 gfc_expr *
2481 gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2482 {
2483   return simplify_transformation (array, dim, mask, -1, do_bit_and);
2484 }
2485
2486
2487 static gfc_expr *
2488 do_bit_ior (gfc_expr *result, gfc_expr *e)
2489 {
2490   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2491   gcc_assert (result->ts.type == BT_INTEGER
2492               && result->expr_type == EXPR_CONSTANT);
2493
2494   mpz_ior (result->value.integer, result->value.integer, e->value.integer);
2495   return result;
2496 }
2497
2498
2499 gfc_expr *
2500 gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2501 {
2502   return simplify_transformation (array, dim, mask, 0, do_bit_ior);
2503 }
2504
2505
2506 gfc_expr *
2507 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2508 {
2509   gfc_expr *result;
2510
2511   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2512     return NULL;
2513
2514   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2515   mpz_and (result->value.integer, x->value.integer, y->value.integer);
2516
2517   return range_check (result, "IAND");
2518 }
2519
2520
2521 gfc_expr *
2522 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2523 {
2524   gfc_expr *result;
2525   int k, pos;
2526
2527   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2528     return NULL;
2529
2530   gfc_extract_int (y, &pos);
2531
2532   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2533
2534   result = gfc_copy_expr (x);
2535
2536   convert_mpz_to_unsigned (result->value.integer,
2537                            gfc_integer_kinds[k].bit_size);
2538
2539   mpz_clrbit (result->value.integer, pos);
2540
2541   convert_mpz_to_signed (result->value.integer,
2542                          gfc_integer_kinds[k].bit_size);
2543
2544   return result;
2545 }
2546
2547
2548 gfc_expr *
2549 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2550 {
2551   gfc_expr *result;
2552   int pos, len;
2553   int i, k, bitsize;
2554   int *bits;
2555
2556   if (x->expr_type != EXPR_CONSTANT
2557       || y->expr_type != EXPR_CONSTANT
2558       || z->expr_type != EXPR_CONSTANT)
2559     return NULL;
2560
2561   gfc_extract_int (y, &pos);
2562   gfc_extract_int (z, &len);
2563
2564   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2565
2566   bitsize = gfc_integer_kinds[k].bit_size;
2567
2568   if (pos + len > bitsize)
2569     {
2570       gfc_error ("Sum of second and third arguments of IBITS exceeds "
2571                  "bit size at %L", &y->where);
2572       return &gfc_bad_expr;
2573     }
2574
2575   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2576   convert_mpz_to_unsigned (result->value.integer,
2577                            gfc_integer_kinds[k].bit_size);
2578
2579   bits = XCNEWVEC (int, bitsize);
2580
2581   for (i = 0; i < bitsize; i++)
2582     bits[i] = 0;
2583
2584   for (i = 0; i < len; i++)
2585     bits[i] = mpz_tstbit (x->value.integer, i + pos);
2586
2587   for (i = 0; i < bitsize; i++)
2588     {
2589       if (bits[i] == 0)
2590         mpz_clrbit (result->value.integer, i);
2591       else if (bits[i] == 1)
2592         mpz_setbit (result->value.integer, i);
2593       else
2594         gfc_internal_error ("IBITS: Bad bit");
2595     }
2596
2597   free (bits);
2598
2599   convert_mpz_to_signed (result->value.integer,
2600                          gfc_integer_kinds[k].bit_size);
2601
2602   return result;
2603 }
2604
2605
2606 gfc_expr *
2607 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2608 {
2609   gfc_expr *result;
2610   int k, pos;
2611
2612   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2613     return NULL;
2614
2615   gfc_extract_int (y, &pos);
2616
2617   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2618
2619   result = gfc_copy_expr (x);
2620
2621   convert_mpz_to_unsigned (result->value.integer,
2622                            gfc_integer_kinds[k].bit_size);
2623
2624   mpz_setbit (result->value.integer, pos);
2625
2626   convert_mpz_to_signed (result->value.integer,
2627                          gfc_integer_kinds[k].bit_size);
2628
2629   return result;
2630 }
2631
2632
2633 gfc_expr *
2634 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2635 {
2636   gfc_expr *result;
2637   gfc_char_t index;
2638   int k;
2639
2640   if (e->expr_type != EXPR_CONSTANT)
2641     return NULL;
2642
2643   if (e->value.character.length != 1)
2644     {
2645       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2646       return &gfc_bad_expr;
2647     }
2648
2649   index = e->value.character.string[0];
2650
2651   k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2652   if (k == -1)
2653     return &gfc_bad_expr;
2654
2655   result = gfc_get_int_expr (k, &e->where, index);
2656
2657   return range_check (result, "ICHAR");
2658 }
2659
2660
2661 gfc_expr *
2662 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2663 {
2664   gfc_expr *result;
2665
2666   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2667     return NULL;
2668
2669   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2670   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2671
2672   return range_check (result, "IEOR");
2673 }
2674
2675
2676 gfc_expr *
2677 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2678 {
2679   gfc_expr *result;
2680   int back, len, lensub;
2681   int i, j, k, count, index = 0, start;
2682
2683   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2684       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
2685     return NULL;
2686
2687   if (b != NULL && b->value.logical != 0)
2688     back = 1;
2689   else
2690     back = 0;
2691
2692   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2693   if (k == -1)
2694     return &gfc_bad_expr;
2695
2696   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2697
2698   len = x->value.character.length;
2699   lensub = y->value.character.length;
2700
2701   if (len < lensub)
2702     {
2703       mpz_set_si (result->value.integer, 0);
2704       return result;
2705     }
2706
2707   if (back == 0)
2708     {
2709       if (lensub == 0)
2710         {
2711           mpz_set_si (result->value.integer, 1);
2712           return result;
2713         }
2714       else if (lensub == 1)
2715         {
2716           for (i = 0; i < len; i++)
2717             {
2718               for (j = 0; j < lensub; j++)
2719                 {
2720                   if (y->value.character.string[j]
2721                       == x->value.character.string[i])
2722                     {
2723                       index = i + 1;
2724                       goto done;
2725                     }
2726                 }
2727             }
2728         }
2729       else
2730         {
2731           for (i = 0; i < len; i++)
2732             {
2733               for (j = 0; j < lensub; j++)
2734                 {
2735                   if (y->value.character.string[j]
2736                       == x->value.character.string[i])
2737                     {
2738                       start = i;
2739                       count = 0;
2740
2741                       for (k = 0; k < lensub; k++)
2742                         {
2743                           if (y->value.character.string[k]
2744                               == x->value.character.string[k + start])
2745                             count++;
2746                         }
2747
2748                       if (count == lensub)
2749                         {
2750                           index = start + 1;
2751                           goto done;
2752                         }
2753                     }
2754                 }
2755             }
2756         }
2757
2758     }
2759   else
2760     {
2761       if (lensub == 0)
2762         {
2763           mpz_set_si (result->value.integer, len + 1);
2764           return result;
2765         }
2766       else if (lensub == 1)
2767         {
2768           for (i = 0; i < len; i++)
2769             {
2770               for (j = 0; j < lensub; j++)
2771                 {
2772                   if (y->value.character.string[j]
2773                       == x->value.character.string[len - i])
2774                     {
2775                       index = len - i + 1;
2776                       goto done;
2777                     }
2778                 }
2779             }
2780         }
2781       else
2782         {
2783           for (i = 0; i < len; i++)
2784             {
2785               for (j = 0; j < lensub; j++)
2786                 {
2787                   if (y->value.character.string[j]
2788                       == x->value.character.string[len - i])
2789                     {
2790                       start = len - i;
2791                       if (start <= len - lensub)
2792                         {
2793                           count = 0;
2794                           for (k = 0; k < lensub; k++)
2795                             if (y->value.character.string[k]
2796                                 == x->value.character.string[k + start])
2797                               count++;
2798
2799                           if (count == lensub)
2800                             {
2801                               index = start + 1;
2802                               goto done;
2803                             }
2804                         }
2805                       else
2806                         {
2807                           continue;
2808                         }
2809                     }
2810                 }
2811             }
2812         }
2813     }
2814
2815 done:
2816   mpz_set_si (result->value.integer, index);
2817   return range_check (result, "INDEX");
2818 }
2819
2820
2821 static gfc_expr *
2822 simplify_intconv (gfc_expr *e, int kind, const char *name)
2823 {
2824   gfc_expr *result = NULL;
2825
2826   if (e->expr_type != EXPR_CONSTANT)
2827     return NULL;
2828
2829   result = gfc_convert_constant (e, BT_INTEGER, kind);
2830   if (result == &gfc_bad_expr)
2831     return &gfc_bad_expr;
2832
2833   return range_check (result, name);
2834 }
2835
2836
2837 gfc_expr *
2838 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2839 {
2840   int kind;
2841
2842   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2843   if (kind == -1)
2844     return &gfc_bad_expr;
2845
2846   return simplify_intconv (e, kind, "INT");
2847 }
2848
2849 gfc_expr *
2850 gfc_simplify_int2 (gfc_expr *e)
2851 {
2852   return simplify_intconv (e, 2, "INT2");
2853 }
2854
2855
2856 gfc_expr *
2857 gfc_simplify_int8 (gfc_expr *e)
2858 {
2859   return simplify_intconv (e, 8, "INT8");
2860 }
2861
2862
2863 gfc_expr *
2864 gfc_simplify_long (gfc_expr *e)
2865 {
2866   return simplify_intconv (e, 4, "LONG");
2867 }
2868
2869
2870 gfc_expr *
2871 gfc_simplify_ifix (gfc_expr *e)
2872 {
2873   gfc_expr *rtrunc, *result;
2874
2875   if (e->expr_type != EXPR_CONSTANT)
2876     return NULL;
2877
2878   rtrunc = gfc_copy_expr (e);
2879   mpfr_trunc (rtrunc->value.real, e->value.real);
2880
2881   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2882                                   &e->where);
2883   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2884
2885   gfc_free_expr (rtrunc);
2886
2887   return range_check (result, "IFIX");
2888 }
2889
2890
2891 gfc_expr *
2892 gfc_simplify_idint (gfc_expr *e)
2893 {
2894   gfc_expr *rtrunc, *result;
2895
2896   if (e->expr_type != EXPR_CONSTANT)
2897     return NULL;
2898
2899   rtrunc = gfc_copy_expr (e);
2900   mpfr_trunc (rtrunc->value.real, e->value.real);
2901
2902   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2903                                   &e->where);
2904   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2905
2906   gfc_free_expr (rtrunc);
2907
2908   return range_check (result, "IDINT");
2909 }
2910
2911
2912 gfc_expr *
2913 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2914 {
2915   gfc_expr *result;
2916
2917   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2918     return NULL;
2919
2920   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2921   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2922
2923   return range_check (result, "IOR");
2924 }
2925
2926
2927 static gfc_expr *
2928 do_bit_xor (gfc_expr *result, gfc_expr *e)
2929 {
2930   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2931   gcc_assert (result->ts.type == BT_INTEGER
2932               && result->expr_type == EXPR_CONSTANT);
2933
2934   mpz_xor (result->value.integer, result->value.integer, e->value.integer);
2935   return result;
2936 }
2937
2938
2939 gfc_expr *
2940 gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2941 {
2942   return simplify_transformation (array, dim, mask, 0, do_bit_xor);
2943 }
2944
2945
2946 gfc_expr *
2947 gfc_simplify_is_iostat_end (gfc_expr *x)
2948 {
2949   if (x->expr_type != EXPR_CONSTANT)
2950     return NULL;
2951
2952   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2953                                mpz_cmp_si (x->value.integer,
2954                                            LIBERROR_END) == 0);
2955 }
2956
2957
2958 gfc_expr *
2959 gfc_simplify_is_iostat_eor (gfc_expr *x)
2960 {
2961   if (x->expr_type != EXPR_CONSTANT)
2962     return NULL;
2963
2964   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2965                                mpz_cmp_si (x->value.integer,
2966                                            LIBERROR_EOR) == 0);
2967 }
2968
2969
2970 gfc_expr *
2971 gfc_simplify_isnan (gfc_expr *x)
2972 {
2973   if (x->expr_type != EXPR_CONSTANT)
2974     return NULL;
2975
2976   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2977                                mpfr_nan_p (x->value.real));
2978 }
2979
2980
2981 /* Performs a shift on its first argument.  Depending on the last
2982    argument, the shift can be arithmetic, i.e. with filling from the
2983    left like in the SHIFTA intrinsic.  */
2984 static gfc_expr *
2985 simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
2986                 bool arithmetic, int direction)
2987 {
2988   gfc_expr *result;
2989   int ashift, *bits, i, k, bitsize, shift;
2990
2991   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2992     return NULL;
2993
2994   gfc_extract_int (s, &shift);
2995
2996   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2997   bitsize = gfc_integer_kinds[k].bit_size;
2998
2999   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3000
3001   if (shift == 0)
3002     {
3003       mpz_set (result->value.integer, e->value.integer);
3004       return result;
3005     }
3006
3007   if (direction > 0 && shift < 0)
3008     {
3009       /* Left shift, as in SHIFTL.  */
3010       gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3011       return &gfc_bad_expr;
3012     }
3013   else if (direction < 0)
3014     {
3015       /* Right shift, as in SHIFTR or SHIFTA.  */
3016       if (shift < 0)
3017         {
3018           gfc_error ("Second argument of %s is negative at %L",
3019                      name, &e->where);
3020           return &gfc_bad_expr;
3021         }
3022
3023       shift = -shift;
3024     }
3025
3026   ashift = (shift >= 0 ? shift : -shift);
3027
3028   if (ashift > bitsize)
3029     {
3030       gfc_error ("Magnitude of second argument of %s exceeds bit size "
3031                  "at %L", name, &e->where);
3032       return &gfc_bad_expr;
3033     }
3034
3035   bits = XCNEWVEC (int, bitsize);
3036
3037   for (i = 0; i < bitsize; i++)
3038     bits[i] = mpz_tstbit (e->value.integer, i);
3039
3040   if (shift > 0)
3041     {
3042       /* Left shift.  */
3043       for (i = 0; i < shift; i++)
3044         mpz_clrbit (result->value.integer, i);
3045
3046       for (i = 0; i < bitsize - shift; i++)
3047         {
3048           if (bits[i] == 0)
3049             mpz_clrbit (result->value.integer, i + shift);
3050           else
3051             mpz_setbit (result->value.integer, i + shift);
3052         }
3053     }
3054   else
3055     {
3056       /* Right shift.  */
3057       if (arithmetic && bits[bitsize - 1])
3058         for (i = bitsize - 1; i >= bitsize - ashift; i--)
3059           mpz_setbit (result->value.integer, i);
3060       else
3061         for (i = bitsize - 1; i >= bitsize - ashift; i--)
3062           mpz_clrbit (result->value.integer, i);
3063
3064       for (i = bitsize - 1; i >= ashift; i--)
3065         {
3066           if (bits[i] == 0)
3067             mpz_clrbit (result->value.integer, i - ashift);
3068           else
3069             mpz_setbit (result->value.integer, i - ashift);
3070         }
3071     }
3072
3073   convert_mpz_to_signed (result->value.integer, bitsize);
3074   free (bits);
3075
3076   return result;
3077 }
3078
3079
3080 gfc_expr *
3081 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3082 {
3083   return simplify_shift (e, s, "ISHFT", false, 0);
3084 }
3085
3086
3087 gfc_expr *
3088 gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3089 {
3090   return simplify_shift (e, s, "LSHIFT", false, 1);
3091 }
3092
3093
3094 gfc_expr *
3095 gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3096 {
3097   return simplify_shift (e, s, "RSHIFT", true, -1);
3098 }
3099
3100
3101 gfc_expr *
3102 gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3103 {
3104   return simplify_shift (e, s, "SHIFTA", true, -1);
3105 }
3106
3107
3108 gfc_expr *
3109 gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3110 {
3111   return simplify_shift (e, s, "SHIFTL", false, 1);
3112 }
3113
3114
3115 gfc_expr *
3116 gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3117 {
3118   return simplify_shift (e, s, "SHIFTR", false, -1);
3119 }
3120
3121
3122 gfc_expr *
3123 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3124 {
3125   gfc_expr *result;
3126   int shift, ashift, isize, ssize, delta, k;
3127   int i, *bits;
3128
3129   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3130     return NULL;
3131
3132   gfc_extract_int (s, &shift);
3133
3134   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3135   isize = gfc_integer_kinds[k].bit_size;
3136
3137   if (sz != NULL)
3138     {
3139       if (sz->expr_type != EXPR_CONSTANT)
3140         return NULL;
3141
3142       gfc_extract_int (sz, &ssize);
3143
3144     }
3145   else
3146     ssize = isize;
3147
3148   if (shift >= 0)
3149     ashift = shift;
3150   else
3151     ashift = -shift;
3152
3153   if (ashift > ssize)
3154     {
3155       if (sz == NULL)
3156         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3157                    "BIT_SIZE of first argument at %L", &s->where);
3158       return &gfc_bad_expr;
3159     }
3160
3161   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3162
3163   mpz_set (result->value.integer, e->value.integer);
3164
3165   if (shift == 0)
3166     return result;
3167
3168   convert_mpz_to_unsigned (result->value.integer, isize);
3169
3170   bits = XCNEWVEC (int, ssize);
3171
3172   for (i = 0; i < ssize; i++)
3173     bits[i] = mpz_tstbit (e->value.integer, i);
3174
3175   delta = ssize - ashift;
3176
3177   if (shift > 0)
3178     {
3179       for (i = 0; i < delta; i++)
3180         {
3181           if (bits[i] == 0)
3182             mpz_clrbit (result->value.integer, i + shift);
3183           else
3184             mpz_setbit (result->value.integer, i + shift);
3185         }
3186
3187       for (i = delta; i < ssize; i++)
3188         {
3189           if (bits[i] == 0)
3190             mpz_clrbit (result->value.integer, i - delta);
3191           else
3192             mpz_setbit (result->value.integer, i - delta);
3193         }
3194     }
3195   else
3196     {
3197       for (i = 0; i < ashift; i++)
3198         {
3199           if (bits[i] == 0)
3200             mpz_clrbit (result->value.integer, i + delta);
3201           else
3202             mpz_setbit (result->value.integer, i + delta);
3203         }
3204
3205       for (i = ashift; i < ssize; i++)
3206         {
3207           if (bits[i] == 0)
3208             mpz_clrbit (result->value.integer, i + shift);
3209           else
3210             mpz_setbit (result->value.integer, i + shift);
3211         }
3212     }
3213
3214   convert_mpz_to_signed (result->value.integer, isize);
3215
3216   free (bits);
3217   return result;
3218 }
3219
3220
3221 gfc_expr *
3222 gfc_simplify_kind (gfc_expr *e)
3223 {
3224   return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
3225 }
3226
3227
3228 static gfc_expr *
3229 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
3230                     gfc_array_spec *as, gfc_ref *ref, bool coarray)
3231 {
3232   gfc_expr *l, *u, *result;
3233   int k;
3234
3235   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3236                 gfc_default_integer_kind);
3237   if (k == -1)
3238     return &gfc_bad_expr;
3239
3240   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3241
3242   /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3243      UBOUND(expr, DIM=n) = SIZE(expr, DIM=n).  */
3244   if (!coarray && array->expr_type != EXPR_VARIABLE)
3245     {
3246       if (upper)
3247         {
3248           gfc_expr* dim = result;
3249           mpz_set_si (dim->value.integer, d);
3250
3251           result = gfc_simplify_size (array, dim, kind);
3252           gfc_free_expr (dim);
3253           if (!result)
3254             goto returnNull;
3255         }
3256       else
3257         mpz_set_si (result->value.integer, 1);
3258
3259       goto done;
3260     }
3261
3262   /* Otherwise, we have a variable expression.  */
3263   gcc_assert (array->expr_type == EXPR_VARIABLE);
3264   gcc_assert (as);
3265
3266   if (!gfc_resolve_array_spec (as, 0))
3267     return NULL;
3268
3269   /* The last dimension of an assumed-size array is special.  */
3270   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
3271       || (coarray && d == as->rank + as->corank
3272           && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
3273     {
3274       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
3275         {
3276           gfc_free_expr (result);
3277           return gfc_copy_expr (as->lower[d-1]);
3278         }
3279
3280       goto returnNull;
3281     }
3282
3283   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3284
3285   /* Then, we need to know the extent of the given dimension.  */
3286   if (coarray || ref->u.ar.type == AR_FULL)
3287     {
3288       l = as->lower[d-1];
3289       u = as->upper[d-1];
3290
3291       if (l->expr_type != EXPR_CONSTANT || u == NULL
3292           || u->expr_type != EXPR_CONSTANT)
3293         goto returnNull;
3294
3295       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
3296         {
3297           /* Zero extent.  */
3298           if (upper)
3299             mpz_set_si (result->value.integer, 0);
3300           else
3301             mpz_set_si (result->value.integer, 1);
3302         }
3303       else
3304         {
3305           /* Nonzero extent.  */
3306           if (upper)
3307             mpz_set (result->value.integer, u->value.integer);
3308           else
3309             mpz_set (result->value.integer, l->value.integer);
3310         }
3311     }
3312   else
3313     {
3314       if (upper)
3315         {
3316           if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
3317             goto returnNull;
3318         }
3319       else
3320         mpz_set_si (result->value.integer, (long int) 1);
3321     }
3322
3323 done:
3324   return range_check (result, upper ? "UBOUND" : "LBOUND");
3325
3326 returnNull:
3327   gfc_free_expr (result);
3328   return NULL;
3329 }
3330
3331
3332 static gfc_expr *
3333 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3334 {
3335   gfc_ref *ref;
3336   gfc_array_spec *as;
3337   int d;
3338
3339   if (array->ts.type == BT_CLASS)
3340     return NULL;
3341
3342   if (array->expr_type != EXPR_VARIABLE)
3343     {
3344       as = NULL;
3345       ref = NULL;
3346       goto done;
3347     }
3348
3349   /* Follow any component references.  */
3350   as = array->symtree->n.sym->as;
3351   for (ref = array->ref; ref; ref = ref->next)
3352     {
3353       switch (ref->type)
3354         {
3355         case REF_ARRAY:
3356           switch (ref->u.ar.type)
3357             {
3358             case AR_ELEMENT:
3359               as = NULL;
3360               continue;
3361
3362             case AR_FULL:
3363               /* We're done because 'as' has already been set in the
3364                  previous iteration.  */
3365               if (!ref->next)
3366                 goto done;
3367
3368             /* Fall through.  */
3369
3370             case AR_UNKNOWN:
3371               return NULL;
3372
3373             case AR_SECTION:
3374               as = ref->u.ar.as;
3375               goto done;
3376             }
3377
3378           gcc_unreachable ();
3379
3380         case REF_COMPONENT:
3381           as = ref->u.c.component->as;
3382           continue;
3383
3384         case REF_SUBSTRING:
3385           continue;
3386         }
3387     }
3388
3389   gcc_unreachable ();
3390
3391  done:
3392
3393   if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
3394              || as->type == AS_ASSUMED_RANK))
3395     return NULL;
3396
3397   if (dim == NULL)
3398     {
3399       /* Multi-dimensional bounds.  */
3400       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3401       gfc_expr *e;
3402       int k;
3403
3404       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
3405       if (upper && as && as->type == AS_ASSUMED_SIZE)
3406         {
3407           /* An error message will be emitted in
3408              check_assumed_size_reference (resolve.c).  */
3409           return &gfc_bad_expr;
3410         }
3411
3412       /* Simplify the bounds for each dimension.  */
3413       for (d = 0; d < array->rank; d++)
3414         {
3415           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3416                                           false);
3417           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3418             {
3419               int j;
3420
3421               for (j = 0; j < d; j++)
3422                 gfc_free_expr (bounds[j]);
3423               return bounds[d];
3424             }
3425         }
3426
3427       /* Allocate the result expression.  */
3428       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3429                     gfc_default_integer_kind);
3430       if (k == -1)
3431         return &gfc_bad_expr;
3432
3433       e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3434
3435       /* The result is a rank 1 array; its size is the rank of the first
3436          argument to {L,U}BOUND.  */
3437       e->rank = 1;
3438       e->shape = gfc_get_shape (1);
3439       mpz_init_set_ui (e->shape[0], array->rank);
3440
3441       /* Create the constructor for this array.  */
3442       for (d = 0; d < array->rank; d++)
3443         gfc_constructor_append_expr (&e->value.constructor,
3444                                      bounds[d], &e->where);
3445
3446       return e;
3447     }
3448   else
3449     {
3450       /* A DIM argument is specified.  */
3451       if (dim->expr_type != EXPR_CONSTANT)
3452         return NULL;
3453
3454       d = mpz_get_si (dim->value.integer);
3455
3456       if ((d < 1 || d > array->rank)
3457           || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3458         {
3459           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3460           return &gfc_bad_expr;
3461         }
3462
3463       if (as && as->type == AS_ASSUMED_RANK)
3464         return NULL;
3465
3466       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3467     }
3468 }
3469
3470
3471 static gfc_expr *
3472 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3473 {
3474   gfc_ref *ref;
3475   gfc_array_spec *as;
3476   int d;
3477
3478   if (array->expr_type != EXPR_VARIABLE)
3479     return NULL;
3480
3481   /* Follow any component references.  */
3482   as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
3483        ? array->ts.u.derived->components->as
3484        : array->symtree->n.sym->as;
3485   for (ref = array->ref; ref; ref = ref->next)
3486     {
3487       switch (ref->type)
3488         {
3489         case REF_ARRAY:
3490           switch (ref->u.ar.type)
3491             {
3492             case AR_ELEMENT:
3493               if (ref->u.ar.as->corank > 0)
3494                 {
3495                   gcc_assert (as == ref->u.ar.as);
3496                   goto done;
3497                 }
3498               as = NULL;
3499               continue;
3500
3501             case AR_FULL:
3502               /* We're done because 'as' has already been set in the
3503                  previous iteration.  */
3504               if (!ref->next)
3505                 goto done;
3506
3507             /* Fall through.  */
3508
3509             case AR_UNKNOWN:
3510               return NULL;
3511
3512             case AR_SECTION:
3513               as = ref->u.ar.as;
3514               goto done;
3515             }
3516
3517           gcc_unreachable ();
3518
3519         case REF_COMPONENT:
3520           as = ref->u.c.component->as;
3521           continue;
3522
3523         case REF_SUBSTRING:
3524           continue;
3525         }
3526     }
3527
3528   if (!as)
3529     gcc_unreachable ();
3530
3531  done:
3532
3533   if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
3534     return NULL;
3535
3536   if (dim == NULL)
3537     {
3538       /* Multi-dimensional cobounds.  */
3539       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3540       gfc_expr *e;
3541       int k;
3542
3543       /* Simplify the cobounds for each dimension.  */
3544       for (d = 0; d < as->corank; d++)
3545         {
3546           bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
3547                                           upper, as, ref, true);
3548           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3549             {
3550               int j;
3551
3552               for (j = 0; j < d; j++)
3553                 gfc_free_expr (bounds[j]);
3554               return bounds[d];
3555             }
3556         }
3557
3558       /* Allocate the result expression.  */
3559       e = gfc_get_expr ();
3560       e->where = array->where;
3561       e->expr_type = EXPR_ARRAY;
3562       e->ts.type = BT_INTEGER;
3563       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3564                     gfc_default_integer_kind);
3565       if (k == -1)
3566         {
3567           gfc_free_expr (e);
3568           return &gfc_bad_expr;
3569         }
3570       e->ts.kind = k;
3571
3572       /* The result is a rank 1 array; its size is the rank of the first
3573          argument to {L,U}COBOUND.  */
3574       e->rank = 1;
3575       e->shape = gfc_get_shape (1);
3576       mpz_init_set_ui (e->shape[0], as->corank);
3577
3578       /* Create the constructor for this array.  */
3579       for (d = 0; d < as->corank; d++)
3580         gfc_constructor_append_expr (&e->value.constructor,
3581                                      bounds[d], &e->where);
3582       return e;
3583     }
3584   else
3585     {
3586       /* A DIM argument is specified.  */
3587       if (dim->expr_type != EXPR_CONSTANT)
3588         return NULL;
3589
3590       d = mpz_get_si (dim->value.integer);
3591
3592       if (d < 1 || d > as->corank)
3593         {
3594           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3595           return &gfc_bad_expr;
3596         }
3597
3598       return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
3599     }
3600 }
3601
3602
3603 gfc_expr *
3604 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3605 {
3606   return simplify_bound (array, dim, kind, 0);
3607 }
3608
3609
3610 gfc_expr *
3611 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3612 {
3613   return simplify_cobound (array, dim, kind, 0);
3614 }
3615
3616 gfc_expr *
3617 gfc_simplify_leadz (gfc_expr *e)
3618 {
3619   unsigned long lz, bs;
3620   int i;
3621
3622   if (e->expr_type != EXPR_CONSTANT)
3623     return NULL;
3624
3625   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3626   bs = gfc_integer_kinds[i].bit_size;
3627   if (mpz_cmp_si (e->value.integer, 0) == 0)
3628     lz = bs;
3629   else if (mpz_cmp_si (e->value.integer, 0) < 0)
3630     lz = 0;
3631   else
3632     lz = bs - mpz_sizeinbase (e->value.integer, 2);
3633
3634   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3635 }
3636
3637
3638 gfc_expr *
3639 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3640 {
3641   gfc_expr *result;
3642   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3643
3644   if (k == -1)
3645     return &gfc_bad_expr;
3646
3647   if (e->expr_type == EXPR_CONSTANT)
3648     {
3649       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3650       mpz_set_si (result->value.integer, e->value.character.length);
3651       return range_check (result, "LEN");
3652     }
3653   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3654            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3655            && e->ts.u.cl->length->ts.type == BT_INTEGER)
3656     {
3657       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3658       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3659       return range_check (result, "LEN");
3660     }
3661   else
3662     return NULL;
3663 }
3664
3665
3666 gfc_expr *
3667 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3668 {
3669   gfc_expr *result;
3670   int count, len, i;
3671   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3672
3673   if (k == -1)
3674     return &gfc_bad_expr;
3675
3676   if (e->expr_type != EXPR_CONSTANT)
3677     return NULL;
3678
3679   len = e->value.character.length;
3680   for (count = 0, i = 1; i <= len; i++)
3681     if (e->value.character.string[len - i] == ' ')
3682       count++;
3683     else
3684       break;
3685
3686   result = gfc_get_int_expr (k, &e->where, len - count);
3687   return range_check (result, "LEN_TRIM");
3688 }
3689
3690 gfc_expr *
3691 gfc_simplify_lgamma (gfc_expr *x)
3692 {
3693   gfc_expr *result;
3694   int sg;
3695
3696   if (x->expr_type != EXPR_CONSTANT)
3697     return NULL;
3698
3699   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3700   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3701
3702   return range_check (result, "LGAMMA");
3703 }
3704
3705
3706 gfc_expr *
3707 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3708 {
3709   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3710     return NULL;
3711
3712   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3713                                gfc_compare_string (a, b) >= 0);
3714 }
3715
3716
3717 gfc_expr *
3718 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3719 {
3720   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3721     return NULL;
3722
3723   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3724                                gfc_compare_string (a, b) > 0);
3725 }
3726
3727
3728 gfc_expr *
3729 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3730 {
3731   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3732     return NULL;
3733
3734   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3735                                gfc_compare_string (a, b) <= 0);
3736 }
3737
3738
3739 gfc_expr *
3740 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3741 {
3742   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3743     return NULL;
3744
3745   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3746                                gfc_compare_string (a, b) < 0);
3747 }
3748
3749
3750 gfc_expr *
3751 gfc_simplify_log (gfc_expr *x)
3752 {
3753   gfc_expr *result;
3754
3755   if (x->expr_type != EXPR_CONSTANT)
3756     return NULL;
3757
3758   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3759
3760   switch (x->ts.type)
3761     {
3762     case BT_REAL:
3763       if (mpfr_sgn (x->value.real) <= 0)
3764         {
3765           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3766                      "to zero", &x->where);
3767           gfc_free_expr (result);
3768           return &gfc_bad_expr;
3769         }
3770
3771       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3772       break;
3773
3774     case BT_COMPLEX:
3775       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3776           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3777         {
3778           gfc_error ("Complex argument of LOG at %L cannot be zero",
3779                      &x->where);
3780           gfc_free_expr (result);
3781           return &gfc_bad_expr;
3782         }
3783
3784       gfc_set_model_kind (x->ts.kind);
3785       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3786       break;
3787
3788     default:
3789       gfc_internal_error ("gfc_simplify_log: bad type");
3790     }
3791
3792   return range_check (result, "LOG");
3793 }
3794
3795
3796 gfc_expr *
3797 gfc_simplify_log10 (gfc_expr *x)
3798 {
3799   gfc_expr *result;
3800
3801   if (x->expr_type != EXPR_CONSTANT)
3802     return NULL;
3803
3804   if (mpfr_sgn (x->value.real) <= 0)
3805     {
3806       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3807                  "to zero", &x->where);
3808       return &gfc_bad_expr;
3809     }
3810
3811   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3812   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3813
3814   return range_check (result, "LOG10");
3815 }
3816
3817
3818 gfc_expr *
3819 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3820 {
3821   int kind;
3822
3823   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3824   if (kind < 0)
3825     return &gfc_bad_expr;
3826
3827   if (e->expr_type != EXPR_CONSTANT)
3828     return NULL;
3829
3830   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3831 }
3832
3833
3834 gfc_expr*
3835 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3836 {
3837   gfc_expr *result;
3838   int row, result_rows, col, result_columns;
3839   int stride_a, offset_a, stride_b, offset_b;
3840
3841   if (!is_constant_array_expr (matrix_a)
3842       || !is_constant_array_expr (matrix_b))
3843     return NULL;
3844
3845   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3846   result = gfc_get_array_expr (matrix_a->ts.type,
3847                                matrix_a->ts.kind,
3848                                &matrix_a->where);
3849
3850   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3851     {
3852       result_rows = 1;
3853       result_columns = mpz_get_si (matrix_b->shape[1]);
3854       stride_a = 1;
3855       stride_b = mpz_get_si (matrix_b->shape[0]);
3856
3857       result->rank = 1;
3858       result->shape = gfc_get_shape (result->rank);
3859       mpz_init_set_si (result->shape[0], result_columns);
3860     }
3861   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3862     {
3863       result_rows = mpz_get_si (matrix_a->shape[0]);
3864       result_columns = 1;
3865       stride_a = mpz_get_si (matrix_a->shape[0]);
3866       stride_b = 1;
3867
3868       result->rank = 1;
3869       result->shape = gfc_get_shape (result->rank);
3870       mpz_init_set_si (result->shape[0], result_rows);
3871     }
3872   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3873     {
3874       result_rows = mpz_get_si (matrix_a->shape[0]);
3875       result_columns = mpz_get_si (matrix_b->shape[1]);
3876       stride_a = mpz_get_si (matrix_a->shape[0]);
3877       stride_b = mpz_get_si (matrix_b->shape[0]);
3878
3879       result->rank = 2;
3880       result->shape = gfc_get_shape (result->rank);
3881       mpz_init_set_si (result->shape[0], result_rows);
3882       mpz_init_set_si (result->shape[1], result_columns);
3883     }
3884   else
3885     gcc_unreachable();
3886
3887   offset_a = offset_b = 0;
3888   for (col = 0; col < result_columns; ++col)
3889     {
3890       offset_a = 0;
3891
3892       for (row = 0; row < result_rows; ++row)
3893         {
3894           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3895                                              matrix_b, 1, offset_b);
3896           gfc_constructor_append_expr (&result->value.constructor,
3897                                        e, NULL);
3898
3899           offset_a += 1;
3900         }
3901
3902       offset_b += stride_b;
3903     }
3904
3905   return result;
3906 }
3907
3908
3909 gfc_expr *
3910 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
3911 {
3912   gfc_expr *result;
3913   int kind, arg, k;
3914   const char *s;
3915
3916   if (i->expr_type != EXPR_CONSTANT)
3917     return NULL;
3918
3919   kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
3920   if (kind == -1)
3921     return &gfc_bad_expr;
3922   k = gfc_validate_kind (BT_INTEGER, kind, false);
3923
3924   s = gfc_extract_int (i, &arg);
3925   gcc_assert (!s);
3926
3927   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3928
3929   /* MASKR(n) = 2^n - 1 */
3930   mpz_set_ui (result->value.integer, 1);
3931   mpz_mul_2exp (result->value.integer, result->value.integer, arg);
3932   mpz_sub_ui (result->value.integer, result->value.integer, 1);
3933
3934   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3935
3936   return result;
3937 }
3938
3939
3940 gfc_expr *
3941 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
3942 {
3943   gfc_expr *result;
3944   int kind, arg, k;
3945   const char *s;
3946   mpz_t z;
3947
3948   if (i->expr_type != EXPR_CONSTANT)
3949     return NULL;
3950
3951   kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
3952   if (kind == -1)
3953     return &gfc_bad_expr;
3954   k = gfc_validate_kind (BT_INTEGER, kind, false);
3955
3956   s = gfc_extract_int (i, &arg);
3957   gcc_assert (!s);
3958
3959   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3960
3961   /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3962   mpz_init_set_ui (z, 1);
3963   mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
3964   mpz_set_ui (result->value.integer, 1);
3965   mpz_mul_2exp (result->value.integer, result->value.integer,
3966                 gfc_integer_kinds[k].bit_size - arg);
3967   mpz_sub (result->value.integer, z, result->value.integer);
3968   mpz_clear (z);
3969
3970   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3971
3972   return result;
3973 }
3974
3975
3976 gfc_expr *
3977 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3978 {
3979   gfc_expr * result;
3980   gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
3981
3982   if (mask->expr_type == EXPR_CONSTANT)
3983     return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
3984                                                ? tsource : fsource));
3985
3986   if (!mask->rank || !is_constant_array_expr (mask)
3987       || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
3988     return NULL;
3989
3990   result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
3991                                &tsource->where);
3992   if (tsource->ts.type == BT_DERIVED)
3993     result->ts.u.derived = tsource->ts.u.derived;
3994   else if (tsource->ts.type == BT_CHARACTER)
3995     result->ts.u.cl = tsource->ts.u.cl;
3996
3997   tsource_ctor = gfc_constructor_first (tsource->value.constructor);
3998   fsource_ctor = gfc_constructor_first (fsource->value.constructor);
3999   mask_ctor = gfc_constructor_first (mask->value.constructor);
4000
4001   while (mask_ctor)
4002     {
4003       if (mask_ctor->expr->value.logical)
4004         gfc_constructor_append_expr (&result->value.constructor,
4005                                      gfc_copy_expr (tsource_ctor->expr),
4006                                      NULL);
4007       else
4008         gfc_constructor_append_expr (&result->value.constructor,
4009                                      gfc_copy_expr (fsource_ctor->expr),
4010                                      NULL);
4011       tsource_ctor = gfc_constructor_next (tsource_ctor);
4012       fsource_ctor = gfc_constructor_next (fsource_ctor);
4013       mask_ctor = gfc_constructor_next (mask_ctor);
4014     }
4015
4016   result->shape = gfc_get_shape (1);
4017   gfc_array_size (result, &result->shape[0]);
4018
4019   return result;
4020 }
4021
4022
4023 gfc_expr *
4024 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4025 {
4026   mpz_t arg1, arg2, mask;
4027   gfc_expr *result;
4028
4029   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4030       || mask_expr->expr_type != EXPR_CONSTANT)
4031     return NULL;
4032
4033   result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4034
4035   /* Convert all argument to unsigned.  */
4036   mpz_init_set (arg1, i->value.integer);
4037   mpz_init_set (arg2, j->value.integer);
4038   mpz_init_set (mask, mask_expr->value.integer);
4039
4040   /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
4041   mpz_and (arg1, arg1, mask);
4042   mpz_com (mask, mask);
4043   mpz_and (arg2, arg2, mask);
4044   mpz_ior (result->value.integer, arg1, arg2);
4045
4046   mpz_clear (arg1);
4047   mpz_clear (arg2);
4048   mpz_clear (mask);
4049
4050   return result;
4051 }
4052
4053
4054 /* Selects between current value and extremum for simplify_min_max
4055    and simplify_minval_maxval.  */
4056 static void
4057 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4058 {
4059   switch (arg->ts.type)
4060     {
4061       case BT_INTEGER:
4062         if (mpz_cmp (arg->value.integer,
4063                         extremum->value.integer) * sign > 0)
4064         mpz_set (extremum->value.integer, arg->value.integer);
4065         break;
4066
4067       case BT_REAL:
4068         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
4069         if (sign > 0)
4070           mpfr_max (extremum->value.real, extremum->value.real,
4071                       arg->value.real, GFC_RND_MODE);
4072         else
4073           mpfr_min (extremum->value.real, extremum->value.real,
4074                       arg->value.real, GFC_RND_MODE);
4075         break;
4076
4077       case BT_CHARACTER:
4078 #define LENGTH(x) ((x)->value.character.length)
4079 #define STRING(x) ((x)->value.character.string)
4080         if (LENGTH (extremum) < LENGTH(arg))
4081           {
4082             gfc_char_t *tmp = STRING(extremum);
4083
4084             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4085             memcpy (STRING(extremum), tmp,
4086                       LENGTH(extremum) * sizeof (gfc_char_t));
4087             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4088                                LENGTH(arg) - LENGTH(extremum));
4089             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
4090             LENGTH(extremum) = LENGTH(arg);
4091             free (tmp);
4092           }
4093
4094         if (gfc_compare_string (arg, extremum) * sign > 0)
4095           {
4096             free (STRING(extremum));
4097             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4098             memcpy (STRING(extremum), STRING(arg),
4099                       LENGTH(arg) * sizeof (gfc_char_t));
4100             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4101                                LENGTH(extremum) - LENGTH(arg));
4102             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
4103           }
4104 #undef LENGTH
4105 #undef STRING
4106         break;
4107
4108       default:
4109         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4110     }
4111 }
4112
4113
4114 /* This function is special since MAX() can take any number of
4115    arguments.  The simplified expression is a rewritten version of the
4116    argument list containing at most one constant element.  Other
4117    constant elements are deleted.  Because the argument list has
4118    already been checked, this function always succeeds.  sign is 1 for
4119    MAX(), -1 for MIN().  */
4120
4121 static gfc_expr *
4122 simplify_min_max (gfc_expr *expr, int sign)
4123 {
4124   gfc_actual_arglist *arg, *last, *extremum;
4125   gfc_intrinsic_sym * specific;
4126
4127   last = NULL;
4128   extremum = NULL;
4129   specific = expr->value.function.isym;
4130
4131   arg = expr->value.function.actual;
4132
4133   for (; arg; last = arg, arg = arg->next)
4134     {
4135       if (arg->expr->expr_type != EXPR_CONSTANT)
4136         continue;
4137
4138       if (extremum == NULL)
4139         {
4140           extremum = arg;
4141           continue;
4142         }
4143
4144       min_max_choose (arg->expr, extremum->expr, sign);
4145
4146       /* Delete the extra constant argument.  */
4147       last->next = arg->next;
4148
4149       arg->next = NULL;
4150       gfc_free_actual_arglist (arg);
4151       arg = last;
4152     }
4153
4154   /* If there is one value left, replace the function call with the
4155      expression.  */
4156   if (expr->value.function.actual->next != NULL)
4157     return NULL;
4158
4159   /* Convert to the correct type and kind.  */
4160   if (expr->ts.type != BT_UNKNOWN)
4161     return gfc_convert_constant (expr->value.function.actual->expr,
4162         expr->ts.type, expr->ts.kind);
4163
4164   if (specific->ts.type != BT_UNKNOWN)
4165     return gfc_convert_constant (expr->value.function.actual->expr,
4166         specific->ts.type, specific->ts.kind);
4167
4168   return gfc_copy_expr (expr->value.function.actual->expr);
4169 }
4170
4171
4172 gfc_expr *
4173 gfc_simplify_min (gfc_expr *e)
4174 {
4175   return simplify_min_max (e, -1);
4176 }
4177
4178
4179 gfc_expr *
4180 gfc_simplify_max (gfc_expr *e)
4181 {
4182   return simplify_min_max (e, 1);
4183 }
4184
4185
4186 /* This is a simplified version of simplify_min_max to provide
4187    simplification of minval and maxval for a vector.  */
4188
4189 static gfc_expr *
4190 simplify_minval_maxval (gfc_expr *expr, int sign)
4191 {
4192   gfc_constructor *c, *extremum;
4193   gfc_intrinsic_sym * specific;
4194
4195   extremum = NULL;
4196   specific = expr->value.function.isym;
4197
4198   for (c = gfc_constructor_first (expr->value.constructor);
4199        c; c = gfc_constructor_next (c))
4200     {
4201       if (c->expr->expr_type != EXPR_CONSTANT)
4202         return NULL;
4203
4204       if (extremum == NULL)
4205         {
4206           extremum = c;
4207           continue;
4208         }
4209
4210       min_max_choose (c->expr, extremum->expr, sign);
4211      }
4212
4213   if (extremum == NULL)
4214     return NULL;
4215
4216   /* Convert to the correct type and kind.  */
4217   if (expr->ts.type != BT_UNKNOWN)
4218     return gfc_convert_constant (extremum->expr,
4219         expr->ts.type, expr->ts.kind);
4220
4221   if (specific->ts.type != BT_UNKNOWN)
4222     return gfc_convert_constant (extremum->expr,
4223         specific->ts.type, specific->ts.kind);
4224
4225   return gfc_copy_expr (extremum->expr);
4226 }
4227
4228
4229 gfc_expr *
4230 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4231 {
4232   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4233     return NULL;
4234
4235   return simplify_minval_maxval (array, -1);
4236 }
4237
4238
4239 gfc_expr *
4240 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4241 {
4242   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4243     return NULL;
4244
4245   return simplify_minval_maxval (array, 1);
4246 }
4247
4248
4249 gfc_expr *
4250 gfc_simplify_maxexponent (gfc_expr *x)
4251 {
4252   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4253   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4254                            gfc_real_kinds[i].max_exponent);
4255 }
4256
4257
4258 gfc_expr *
4259 gfc_simplify_minexponent (gfc_expr *x)
4260 {
4261   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4262   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4263                            gfc_real_kinds[i].min_exponent);
4264 }
4265
4266
4267 gfc_expr *
4268 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4269 {
4270   gfc_expr *result;
4271   int kind;
4272
4273   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4274     return NULL;
4275
4276   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4277   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4278
4279   switch (a->ts.type)
4280     {
4281       case BT_INTEGER:
4282         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4283           {
4284             /* Result is processor-dependent.  */
4285             gfc_error ("Second argument MOD at %L is zero", &a->where);
4286             gfc_free_expr (result);
4287             return &gfc_bad_expr;
4288           }
4289         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4290         break;
4291
4292       case BT_REAL:
4293         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4294           {
4295             /* Result is processor-dependent.  */
4296             gfc_error ("Second argument of MOD at %L is zero", &p->where);
4297             gfc_free_expr (result);
4298             return &gfc_bad_expr;
4299           }
4300
4301         gfc_set_model_kind (kind);
4302         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4303                    GFC_RND_MODE);
4304         break;
4305
4306       default:
4307         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4308     }
4309
4310   return range_check (result, "MOD");
4311 }
4312
4313
4314 gfc_expr *
4315 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4316 {
4317   gfc_expr *result;
4318   int kind;
4319
4320   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4321     return NULL;
4322
4323   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4324   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4325
4326   switch (a->ts.type)
4327     {
4328       case BT_INTEGER:
4329         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4330           {
4331             /* Result is processor-dependent. This processor just opts
4332               to not handle it at all.  */
4333             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4334             gfc_free_expr (result);
4335             return &gfc_bad_expr;
4336           }
4337         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4338
4339         break;
4340
4341       case BT_REAL:
4342         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4343           {
4344             /* Result is processor-dependent.  */
4345             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4346             gfc_free_expr (result);
4347             return &gfc_bad_expr;
4348           }
4349
4350         gfc_set_model_kind (kind);
4351         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4352                    GFC_RND_MODE);
4353         if (mpfr_cmp_ui (result->value.real, 0) != 0)
4354           {
4355             if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
4356               mpfr_add (result->value.real, result->value.real, p->value.real,
4357                         GFC_RND_MODE);
4358           }
4359         else
4360           mpfr_copysign (result->value.real, result->value.real,
4361                          p->value.real, GFC_RND_MODE);
4362         break;
4363
4364       default:
4365         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4366     }
4367
4368   return range_check (result, "MODULO");
4369 }
4370
4371
4372 /* Exists for the sole purpose of consistency with other intrinsics.  */
4373 gfc_expr *
4374 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
4375                      gfc_expr *fp ATTRIBUTE_UNUSED,
4376                      gfc_expr *l  ATTRIBUTE_UNUSED,
4377                      gfc_expr *to ATTRIBUTE_UNUSED,
4378                      gfc_expr *tp ATTRIBUTE_UNUSED)
4379 {
4380   return NULL;
4381 }
4382
4383
4384 gfc_expr *
4385 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4386 {
4387   gfc_expr *result;
4388   mp_exp_t emin, emax;
4389   int kind;
4390
4391   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4392     return NULL;
4393
4394   result = gfc_copy_expr (x);
4395
4396   /* Save current values of emin and emax.  */
4397   emin = mpfr_get_emin ();
4398   emax = mpfr_get_emax ();
4399
4400   /* Set emin and emax for the current model number.  */
4401   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4402   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4403                 mpfr_get_prec(result->value.real) + 1);
4404   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4405   mpfr_check_range (result->value.real, 0, GMP_RNDU);
4406
4407   if (mpfr_sgn (s->value.real) > 0)
4408     {
4409       mpfr_nextabove (result->value.real);
4410       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4411     }
4412   else
4413     {
4414       mpfr_nextbelow (result->value.real);
4415       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4416     }
4417
4418   mpfr_set_emin (emin);
4419   mpfr_set_emax (emax);
4420
4421   /* Only NaN can occur. Do not use range check as it gives an
4422      error for denormal numbers.  */
4423   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
4424     {
4425       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4426       gfc_free_expr (result);
4427       return &gfc_bad_expr;
4428     }
4429
4430   return result;
4431 }
4432
4433
4434 static gfc_expr *
4435 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4436 {
4437   gfc_expr *itrunc, *result;
4438   int kind;
4439
4440   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4441   if (kind == -1)
4442     return &gfc_bad_expr;
4443
4444   if (e->expr_type != EXPR_CONSTANT)
4445     return NULL;
4446
4447   itrunc = gfc_copy_expr (e);
4448   mpfr_round (itrunc->value.real, e->value.real);
4449
4450   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4451   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4452
4453   gfc_free_expr (itrunc);
4454
4455   return range_check (result, name);
4456 }
4457
4458
4459 gfc_expr *
4460 gfc_simplify_new_line (gfc_expr *e)
4461 {
4462   gfc_expr *result;
4463
4464   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4465   result->value.character.string[0] = '\n';
4466
4467   return result;
4468 }
4469
4470
4471 gfc_expr *
4472 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4473 {
4474   return simplify_nint ("NINT", e, k);
4475 }
4476
4477
4478 gfc_expr *
4479 gfc_simplify_idnint (gfc_expr *e)
4480 {
4481   return simplify_nint ("IDNINT", e, NULL);
4482 }
4483
4484
4485 static gfc_expr *
4486 add_squared (gfc_expr *result, gfc_expr *e)
4487 {
4488   mpfr_t tmp;
4489
4490   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4491   gcc_assert (result->ts.type == BT_REAL
4492               && result->expr_type == EXPR_CONSTANT);
4493
4494   gfc_set_model_kind (result->ts.kind);
4495   mpfr_init (tmp);
4496   mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4497   mpfr_add (result->value.real, result->value.real, tmp,
4498             GFC_RND_MODE);
4499   mpfr_clear (tmp);
4500
4501   return result;
4502 }
4503
4504
4505 static gfc_expr *
4506 do_sqrt (gfc_expr *result, gfc_expr *e)
4507 {
4508   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4509   gcc_assert (result->ts.type == BT_REAL
4510               && result->expr_type == EXPR_CONSTANT);
4511
4512   mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4513   mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4514   return result;
4515 }
4516
4517
4518 gfc_expr *
4519 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4520 {
4521   gfc_expr *result;
4522
4523   if (!is_constant_array_expr (e)
4524       || (dim != NULL && !gfc_is_constant_expr (dim)))
4525     return NULL;
4526
4527   result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4528   init_result_expr (result, 0, NULL);
4529
4530   if (!dim || e->rank == 1)
4531     {
4532       result = simplify_transformation_to_scalar (result, e, NULL,
4533                                                   add_squared);
4534       mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4535     }
4536   else
4537     result = simplify_transformation_to_array (result, e, dim, NULL,
4538                                                add_squared, &do_sqrt);
4539
4540   return result;
4541 }
4542
4543
4544 gfc_expr *
4545 gfc_simplify_not (gfc_expr *e)
4546 {
4547   gfc_expr *result;
4548
4549   if (e->expr_type != EXPR_CONSTANT)
4550     return NULL;
4551
4552   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4553   mpz_com (result->value.integer, e->value.integer);
4554
4555   return range_check (result, "NOT");
4556 }
4557
4558
4559 gfc_expr *
4560 gfc_simplify_null (gfc_expr *mold)
4561 {
4562   gfc_expr *result;
4563
4564   if (mold)
4565     {
4566       result = gfc_copy_expr (mold);
4567       result->expr_type = EXPR_NULL;
4568     }
4569   else
4570     result = gfc_get_null_expr (NULL);
4571
4572   return result;
4573 }
4574
4575
4576 gfc_expr *
4577 gfc_simplify_num_images (void)
4578 {
4579   gfc_expr *result;
4580
4581   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4582     {
4583       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4584       return &gfc_bad_expr;
4585     }
4586
4587   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
4588     return NULL;
4589
4590   /* FIXME: gfc_current_locus is wrong.  */
4591   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4592                                   &gfc_current_locus);
4593   mpz_set_si (result->value.integer, 1);
4594   return result;
4595 }
4596
4597
4598 gfc_expr *
4599 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4600 {
4601   gfc_expr *result;
4602   int kind;
4603
4604   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4605     return NULL;
4606
4607   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4608
4609   switch (x->ts.type)
4610     {
4611       case BT_INTEGER:
4612         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4613         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4614         return range_check (result, "OR");
4615
4616       case BT_LOGICAL:
4617         return gfc_get_logical_expr (kind, &x->where,
4618                                      x->value.logical || y->value.logical);
4619       default:
4620         gcc_unreachable();
4621     }
4622 }
4623
4624
4625 gfc_expr *
4626 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4627 {
4628   gfc_expr *result;
4629   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4630
4631   if (!is_constant_array_expr (array)
4632       || !is_constant_array_expr (vector)
4633       || (!gfc_is_constant_expr (mask)
4634           && !is_constant_array_expr (mask)))
4635     return NULL;
4636
4637   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4638   if (array->ts.type == BT_DERIVED)
4639     result->ts.u.derived = array->ts.u.derived;
4640
4641   array_ctor = gfc_constructor_first (array->value.constructor);
4642   vector_ctor = vector
4643                   ? gfc_constructor_first (vector->value.constructor)
4644                   : NULL;
4645
4646   if (mask->expr_type == EXPR_CONSTANT
4647       && mask->value.logical)
4648     {
4649       /* Copy all elements of ARRAY to RESULT.  */
4650       while (array_ctor)
4651         {
4652           gfc_constructor_append_expr (&result->value.constructor,
4653                                        gfc_copy_expr (array_ctor->expr),
4654                                        NULL);
4655
4656           array_ctor = gfc_constructor_next (array_ctor);
4657           vector_ctor = gfc_constructor_next (vector_ctor);
4658         }
4659     }
4660   else if (mask->expr_type == EXPR_ARRAY)
4661     {
4662       /* Copy only those elements of ARRAY to RESULT whose
4663          MASK equals .TRUE..  */
4664       mask_ctor = gfc_constructor_first (mask->value.constructor);
4665       while (mask_ctor)
4666         {
4667           if (mask_ctor->expr->value.logical)
4668             {
4669               gfc_constructor_append_expr (&result->value.constructor,
4670                                            gfc_copy_expr (array_ctor->expr),
4671                                            NULL);
4672               vector_ctor = gfc_constructor_next (vector_ctor);
4673             }
4674
4675           array_ctor = gfc_constructor_next (array_ctor);
4676           mask_ctor = gfc_constructor_next (mask_ctor);
4677         }
4678     }
4679
4680   /* Append any left-over elements from VECTOR to RESULT.  */
4681   while (vector_ctor)
4682     {
4683       gfc_constructor_append_expr (&result->value.constructor,
4684                                    gfc_copy_expr (vector_ctor->expr),
4685                                    NULL);
4686       vector_ctor = gfc_constructor_next (vector_ctor);
4687     }
4688
4689   result->shape = gfc_get_shape (1);
4690   gfc_array_size (result, &result->shape[0]);
4691
4692   if (array->ts.type == BT_CHARACTER)
4693     result->ts.u.cl = array->ts.u.cl;
4694
4695   return result;
4696 }
4697
4698
4699 static gfc_expr *
4700 do_xor (gfc_expr *result, gfc_expr *e)
4701 {
4702   gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
4703   gcc_assert (result->ts.type == BT_LOGICAL
4704               && result->expr_type == EXPR_CONSTANT);
4705
4706   result->value.logical = result->value.logical != e->value.logical;
4707   return result;
4708 }
4709
4710
4711
4712 gfc_expr *
4713 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
4714 {
4715   return simplify_transformation (e, dim, NULL, 0, do_xor);
4716 }
4717
4718
4719 gfc_expr *
4720 gfc_simplify_popcnt (gfc_expr *e)
4721 {
4722   int res, k;
4723   mpz_t x;
4724
4725   if (e->expr_type != EXPR_CONSTANT)
4726     return NULL;
4727
4728   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4729
4730   /* Convert argument to unsigned, then count the '1' bits.  */
4731   mpz_init_set (x, e->value.integer);
4732   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
4733   res = mpz_popcount (x);
4734   mpz_clear (x);
4735
4736   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
4737 }
4738
4739
4740 gfc_expr *
4741 gfc_simplify_poppar (gfc_expr *e)
4742 {
4743   gfc_expr *popcnt;
4744   const char *s;
4745   int i;
4746
4747   if (e->expr_type != EXPR_CONSTANT)
4748     return NULL;
4749
4750   popcnt = gfc_simplify_popcnt (e);
4751   gcc_assert (popcnt);
4752
4753   s = gfc_extract_int (popcnt, &i);
4754   gcc_assert (!s);
4755
4756   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
4757 }
4758
4759
4760 gfc_expr *
4761 gfc_simplify_precision (gfc_expr *e)
4762 {
4763   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4764   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4765                            gfc_real_kinds[i].precision);
4766 }
4767
4768
4769 gfc_expr *
4770 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4771 {
4772   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
4773 }
4774
4775
4776 gfc_expr *
4777 gfc_simplify_radix (gfc_expr *e)
4778 {
4779   int i;
4780   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4781
4782   switch (e->ts.type)
4783     {
4784       case BT_INTEGER:
4785         i = gfc_integer_kinds[i].radix;
4786         break;
4787
4788       case BT_REAL:
4789         i = gfc_real_kinds[i].radix;
4790         break;
4791
4792       default:
4793         gcc_unreachable ();
4794     }
4795
4796   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4797 }
4798
4799
4800 gfc_expr *
4801 gfc_simplify_range (gfc_expr *e)
4802 {
4803   int i;
4804   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4805
4806   switch (e->ts.type)
4807     {
4808       case BT_INTEGER:
4809         i = gfc_integer_kinds[i].range;
4810         break;
4811
4812       case BT_REAL:
4813       case BT_COMPLEX:
4814         i = gfc_real_kinds[i].range;
4815         break;
4816
4817       default:
4818         gcc_unreachable ();
4819     }
4820
4821   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4822 }
4823
4824
4825 gfc_expr *
4826 gfc_simplify_rank (gfc_expr *e)
4827 {
4828   /* Assumed rank.  */
4829   if (e->rank == -1)
4830     return NULL;
4831
4832   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
4833 }
4834
4835
4836 gfc_expr *
4837 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4838 {
4839   gfc_expr *result = NULL;
4840   int kind;
4841
4842   if (e->ts.type == BT_COMPLEX)
4843     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4844   else
4845     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4846
4847   if (kind == -1)
4848     return &gfc_bad_expr;
4849
4850   if (e->expr_type != EXPR_CONSTANT)
4851     return NULL;
4852
4853   if (convert_boz (e, kind) == &gfc_bad_expr)
4854     return &gfc_bad_expr;
4855
4856   result = gfc_convert_constant (e, BT_REAL, kind);
4857   if (result == &gfc_bad_expr)
4858     return &gfc_bad_expr;
4859
4860   return range_check (result, "REAL");
4861 }
4862
4863
4864 gfc_expr *
4865 gfc_simplify_realpart (gfc_expr *e)
4866 {
4867   gfc_expr *result;
4868
4869   if (e->expr_type != EXPR_CONSTANT)
4870     return NULL;
4871
4872   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4873   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4874
4875   return range_check (result, "REALPART");
4876 }
4877
4878 gfc_expr *
4879 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4880 {
4881   gfc_expr *result;
4882   int i, j, len, ncop, nlen;
4883   mpz_t ncopies;
4884   bool have_length = false;
4885
4886   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4887   if (n->expr_type != EXPR_CONSTANT)
4888     return NULL;
4889
4890   /* If NCOPIES is negative, it's an error.  */
4891   if (mpz_sgn (n->value.integer) < 0)
4892     {
4893       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4894                  &n->where);
4895       return &gfc_bad_expr;
4896     }
4897
4898   /* If we don't know the character length, we can do no more.  */
4899   if (e->ts.u.cl && e->ts.u.cl->length
4900         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4901     {
4902       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4903       have_length = true;
4904     }
4905   else if (e->expr_type == EXPR_CONSTANT
4906              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4907     {
4908       len = e->value.character.length;
4909     }
4910   else
4911     return NULL;
4912
4913   /* If the source length is 0, any value of NCOPIES is valid
4914      and everything behaves as if NCOPIES == 0.  */
4915   mpz_init (ncopies);
4916   if (len == 0)
4917     mpz_set_ui (ncopies, 0);
4918   else
4919     mpz_set (ncopies, n->value.integer);
4920
4921   /* Check that NCOPIES isn't too large.  */
4922   if (len)
4923     {
4924       mpz_t max, mlen;
4925       int i;
4926
4927       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4928       mpz_init (max);
4929       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4930
4931       if (have_length)
4932         {
4933           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4934                       e->ts.u.cl->length->value.integer);
4935         }
4936       else
4937         {
4938           mpz_init_set_si (mlen, len);
4939           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4940           mpz_clear (mlen);
4941         }
4942
4943       /* The check itself.  */
4944       if (mpz_cmp (ncopies, max) > 0)
4945         {
4946           mpz_clear (max);
4947           mpz_clear (ncopies);
4948           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4949                      &n->where);
4950           return &gfc_bad_expr;
4951         }
4952
4953       mpz_clear (max);
4954     }
4955   mpz_clear (ncopies);
4956
4957   /* For further simplification, we need the character string to be
4958      constant.  */
4959   if (e->expr_type != EXPR_CONSTANT)
4960     return NULL;
4961
4962   if (len ||
4963       (e->ts.u.cl->length &&
4964        mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4965     {
4966       const char *res = gfc_extract_int (n, &ncop);
4967       gcc_assert (res == NULL);
4968     }
4969   else
4970     ncop = 0;
4971
4972   if (ncop == 0)
4973     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4974
4975   len = e->value.character.length;
4976   nlen = ncop * len;
4977
4978   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4979   for (i = 0; i < ncop; i++)
4980     for (j = 0; j < len; j++)
4981       result->value.character.string[j+i*len]= e->value.character.string[j];
4982
4983   result->value.character.string[nlen] = '\0';  /* For debugger */
4984   return result;
4985 }
4986
4987
4988 /* This one is a bear, but mainly has to do with shuffling elements.  */
4989
4990 gfc_expr *
4991 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4992                       gfc_expr *pad, gfc_expr *order_exp)
4993 {
4994   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4995   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4996   mpz_t index, size;
4997   unsigned long j;
4998   size_t nsource;
4999   gfc_expr *e, *result;
5000
5001   /* Check that argument expression types are OK.  */
5002   if (!is_constant_array_expr (source)
5003       || !is_constant_array_expr (shape_exp)
5004       || !is_constant_array_expr (pad)
5005       || !is_constant_array_expr (order_exp))
5006     return NULL;
5007
5008   /* Proceed with simplification, unpacking the array.  */
5009
5010   mpz_init (index);
5011   rank = 0;
5012
5013   for (;;)
5014     {
5015       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
5016       if (e == NULL)
5017         break;
5018
5019       gfc_extract_int (e, &shape[rank]);
5020
5021       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
5022       gcc_assert (shape[rank] >= 0);
5023
5024       rank++;
5025     }
5026
5027   gcc_assert (rank > 0);
5028
5029   /* Now unpack the order array if present.  */
5030   if (order_exp == NULL)
5031     {
5032       for (i = 0; i < rank; i++)
5033         order[i] = i;
5034     }
5035   else
5036     {
5037       for (i = 0; i < rank; i++)
5038         x[i] = 0;
5039
5040       for (i = 0; i < rank; i++)
5041         {
5042           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
5043           gcc_assert (e);
5044
5045           gfc_extract_int (e, &order[i]);
5046
5047           gcc_assert (order[i] >= 1 && order[i] <= rank);
5048           order[i]--;
5049           gcc_assert (x[order[i]] == 0);
5050           x[order[i]] = 1;
5051         }
5052     }
5053
5054   /* Count the elements in the source and padding arrays.  */
5055
5056   npad = 0;
5057   if (pad != NULL)
5058     {
5059       gfc_array_size (pad, &size);
5060       npad = mpz_get_ui (size);
5061       mpz_clear (size);
5062     }
5063
5064   gfc_array_size (source, &size);
5065   nsource = mpz_get_ui (size);
5066   mpz_clear (size);
5067
5068   /* If it weren't for that pesky permutation we could just loop
5069      through the source and round out any shortage with pad elements.
5070      But no, someone just had to have the compiler do something the
5071      user should be doing.  */
5072
5073   for (i = 0; i < rank; i++)
5074     x[i] = 0;
5075
5076   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5077                                &source->where);
5078   if (source->ts.type == BT_DERIVED)
5079     result->ts.u.derived = source->ts.u.derived;
5080   result->rank = rank;
5081   result->shape = gfc_get_shape (rank);
5082   for (i = 0; i < rank; i++)
5083     mpz_init_set_ui (result->shape[i], shape[i]);
5084
5085   while (nsource > 0 || npad > 0)
5086     {
5087       /* Figure out which element to extract.  */
5088       mpz_set_ui (index, 0);
5089
5090       for (i = rank - 1; i >= 0; i--)
5091         {
5092           mpz_add_ui (index, index, x[order[i]]);
5093           if (i != 0)
5094             mpz_mul_ui (index, index, shape[order[i - 1]]);
5095         }
5096
5097       if (mpz_cmp_ui (index, INT_MAX) > 0)
5098         gfc_internal_error ("Reshaped array too large at %C");
5099
5100       j = mpz_get_ui (index);
5101
5102       if (j < nsource)
5103         e = gfc_constructor_lookup_expr (source->value.constructor, j);
5104       else
5105         {
5106           gcc_assert (npad > 0);
5107
5108           j = j - nsource;
5109           j = j % npad;
5110           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5111         }
5112       gcc_assert (e);
5113
5114       gfc_constructor_append_expr (&result->value.constructor,
5115                                    gfc_copy_expr (e), &e->where);
5116
5117       /* Calculate the next element.  */
5118       i = 0;
5119
5120 inc:
5121       if (++x[i] < shape[i])
5122         continue;
5123       x[i++] = 0;
5124       if (i < rank)
5125         goto inc;
5126
5127       break;
5128     }
5129
5130   mpz_clear (index);
5131
5132   return result;
5133 }
5134
5135
5136 gfc_expr *
5137 gfc_simplify_rrspacing (gfc_expr *x)
5138 {
5139   gfc_expr *result;
5140   int i;
5141   long int e, p;
5142
5143   if (x->expr_type != EXPR_CONSTANT)
5144     return NULL;
5145
5146   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5147
5148   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5149   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5150
5151   /* Special case x = -0 and 0.  */
5152   if (mpfr_sgn (result->value.real) == 0)
5153     {
5154       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5155       return result;
5156     }
5157
5158   /* | x * 2**(-e) | * 2**p.  */
5159   e = - (long int) mpfr_get_exp (x->value.real);
5160   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5161
5162   p = (long int) gfc_real_kinds[i].digits;
5163   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5164
5165   return range_check (result, "RRSPACING");
5166 }
5167
5168
5169 gfc_expr *
5170 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5171 {
5172   int k, neg_flag, power, exp_range;
5173   mpfr_t scale, radix;
5174   gfc_expr *result;
5175
5176   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5177     return NULL;
5178
5179   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5180
5181   if (mpfr_sgn (x->value.real) == 0)
5182     {
5183       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5184       return result;
5185     }
5186
5187   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5188
5189   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5190
5191   /* This check filters out values of i that would overflow an int.  */
5192   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5193       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5194     {
5195       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5196       gfc_free_expr (result);
5197       return &gfc_bad_expr;
5198     }
5199
5200   /* Compute scale = radix ** power.  */
5201   power = mpz_get_si (i->value.integer);
5202
5203   if (power >= 0)
5204     neg_flag = 0;
5205   else
5206     {
5207       neg_flag = 1;
5208       power = -power;
5209     }
5210
5211   gfc_set_model_kind (x->ts.kind);
5212   mpfr_init (scale);
5213   mpfr_init (radix);
5214   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5215   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5216
5217   if (neg_flag)
5218     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5219   else
5220     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5221
5222   mpfr_clears (scale, radix, NULL);
5223
5224   return range_check (result, "SCALE");
5225 }
5226
5227
5228 /* Variants of strspn and strcspn that operate on wide characters.  */
5229
5230 static size_t
5231 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5232 {
5233   size_t i = 0;
5234   const gfc_char_t *c;
5235
5236   while (s1[i])
5237     {
5238       for (c = s2; *c; c++)
5239         {
5240           if (s1[i] == *c)
5241             break;
5242         }
5243       if (*c == '\0')
5244         break;
5245       i++;
5246     }
5247
5248   return i;
5249 }
5250
5251 static size_t
5252 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5253 {
5254   size_t i = 0;
5255   const gfc_char_t *c;
5256
5257   while (s1[i])
5258     {
5259       for (c = s2; *c; c++)
5260         {
5261           if (s1[i] == *c)
5262             break;
5263         }
5264       if (*c)
5265         break;
5266       i++;
5267     }
5268
5269   return i;
5270 }
5271
5272
5273 gfc_expr *
5274 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5275 {
5276   gfc_expr *result;
5277   int back;
5278   size_t i;
5279   size_t indx, len, lenc;
5280   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5281
5282   if (k == -1)
5283     return &gfc_bad_expr;
5284
5285   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
5286       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
5287     return NULL;
5288
5289   if (b != NULL && b->value.logical != 0)
5290     back = 1;
5291   else
5292     back = 0;
5293
5294   len = e->value.character.length;
5295   lenc = c->value.character.length;
5296
5297   if (len == 0 || lenc == 0)
5298     {
5299       indx = 0;
5300     }
5301   else
5302     {
5303       if (back == 0)
5304         {
5305           indx = wide_strcspn (e->value.character.string,
5306                                c->value.character.string) + 1;
5307           if (indx > len)
5308             indx = 0;
5309         }
5310       else
5311         {
5312           i = 0;
5313           for (indx = len; indx > 0; indx--)
5314             {
5315               for (i = 0; i < lenc; i++)
5316                 {
5317                   if (c->value.character.string[i]
5318                       == e->value.character.string[indx - 1])
5319                     break;
5320                 }
5321               if (i < lenc)
5322                 break;
5323             }
5324         }
5325     }
5326
5327   result = gfc_get_int_expr (k, &e->where, indx);
5328   return range_check (result, "SCAN");
5329 }
5330
5331
5332 gfc_expr *
5333 gfc_simplify_selected_char_kind (gfc_expr *e)
5334 {
5335   int kind;
5336
5337   if (e->expr_type != EXPR_CONSTANT)
5338     return NULL;
5339
5340   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5341       || gfc_compare_with_Cstring (e, "default", false) == 0)
5342     kind = 1;
5343   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5344     kind = 4;
5345   else
5346     kind = -1;
5347
5348   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5349 }
5350
5351
5352 gfc_expr *
5353 gfc_simplify_selected_int_kind (gfc_expr *e)
5354 {
5355   int i, kind, range;
5356
5357   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5358     return NULL;
5359
5360   kind = INT_MAX;
5361
5362   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5363     if (gfc_integer_kinds[i].range >= range
5364         && gfc_integer_kinds[i].kind < kind)
5365       kind = gfc_integer_kinds[i].kind;
5366
5367   if (kind == INT_MAX)
5368     kind = -1;
5369
5370   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5371 }
5372
5373
5374 gfc_expr *
5375 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5376 {
5377   int range, precision, radix, i, kind, found_precision, found_range,
5378       found_radix;
5379   locus *loc = &gfc_current_locus;
5380
5381   if (p == NULL)
5382     precision = 0;
5383   else
5384     {
5385       if (p->expr_type != EXPR_CONSTANT
5386           || gfc_extract_int (p, &precision) != NULL)
5387         return NULL;
5388       loc = &p->where;
5389     }
5390
5391   if (q == NULL)
5392     range = 0;
5393   else
5394     {
5395       if (q->expr_type != EXPR_CONSTANT
5396           || gfc_extract_int (q, &range) != NULL)
5397         return NULL;
5398
5399       if (!loc)
5400         loc = &q->where;
5401     }
5402
5403   if (rdx == NULL)
5404     radix = 0;
5405   else
5406     {
5407       if (rdx->expr_type != EXPR_CONSTANT
5408           || gfc_extract_int (rdx, &radix) != NULL)
5409         return NULL;
5410
5411       if (!loc)
5412         loc = &rdx->where;
5413     }
5414
5415   kind = INT_MAX;
5416   found_precision = 0;
5417   found_range = 0;
5418   found_radix = 0;
5419
5420   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5421     {
5422       if (gfc_real_kinds[i].precision >= precision)
5423         found_precision = 1;
5424
5425       if (gfc_real_kinds[i].range >= range)
5426         found_range = 1;
5427
5428       if (gfc_real_kinds[i].radix >= radix)
5429         found_radix = 1;
5430
5431       if (gfc_real_kinds[i].precision >= precision
5432           && gfc_real_kinds[i].range >= range
5433           && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
5434         kind = gfc_real_kinds[i].kind;
5435     }
5436
5437   if (kind == INT_MAX)
5438     {
5439       if (found_radix && found_range && !found_precision)
5440         kind = -1;
5441       else if (found_radix && found_precision && !found_range)
5442         kind = -2;
5443       else if (found_radix && !found_precision && !found_range)
5444         kind = -3;
5445       else if (found_radix)
5446         kind = -4;
5447       else
5448         kind = -5;
5449     }
5450
5451   return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5452 }
5453
5454
5455 gfc_expr *
5456 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5457 {
5458   gfc_expr *result;
5459   mpfr_t exp, absv, log2, pow2, frac;
5460   unsigned long exp2;
5461
5462   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5463     return NULL;
5464
5465   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5466
5467   if (mpfr_sgn (x->value.real) == 0)
5468     {
5469       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5470       return result;
5471     }
5472
5473   gfc_set_model_kind (x->ts.kind);
5474   mpfr_init (absv);
5475   mpfr_init (log2);
5476   mpfr_init (exp);
5477   mpfr_init (pow2);
5478   mpfr_init (frac);
5479
5480   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5481   mpfr_log2 (log2, absv, GFC_RND_MODE);
5482
5483   mpfr_trunc (log2, log2);
5484   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5485
5486   /* Old exponent value, and fraction.  */
5487   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5488
5489   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5490
5491   /* New exponent.  */
5492   exp2 = (unsigned long) mpz_get_d (i->value.integer);
5493   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5494
5495   mpfr_clears (absv, log2, pow2, frac, NULL);
5496
5497   return range_check (result, "SET_EXPONENT");
5498 }
5499
5500
5501 gfc_expr *
5502 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5503 {
5504   mpz_t shape[GFC_MAX_DIMENSIONS];
5505   gfc_expr *result, *e, *f;
5506   gfc_array_ref *ar;
5507   int n;
5508   bool t;
5509   int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5510
5511   if (source->rank == -1)
5512     return NULL;
5513
5514   result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5515
5516   if (source->rank == 0)
5517     return result;
5518
5519   if (source->expr_type == EXPR_VARIABLE)
5520     {
5521       ar = gfc_find_array_ref (source);
5522       t = gfc_array_ref_shape (ar, shape);
5523     }
5524   else if (source->shape)
5525     {
5526       t = true;
5527       for (n = 0; n < source->rank; n++)
5528         {
5529           mpz_init (shape[n]);
5530           mpz_set (shape[n], source->shape[n]);
5531         }
5532     }
5533   else
5534     t = false;
5535
5536   for (n = 0; n < source->rank; n++)
5537     {
5538       e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5539
5540       if (t)
5541         {
5542           mpz_set (e->value.integer, shape[n]);
5543           mpz_clear (shape[n]);
5544         }
5545       else
5546         {
5547           mpz_set_ui (e->value.integer, n + 1);
5548
5549           f = gfc_simplify_size (source, e, NULL);
5550           gfc_free_expr (e);
5551           if (f == NULL)
5552             {
5553               gfc_free_expr (result);
5554               return NULL;
5555             }
5556           else
5557             e = f;
5558         }
5559
5560       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5561     }
5562
5563   return result;
5564 }
5565
5566
5567 gfc_expr *
5568 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5569 {
5570   mpz_t size;
5571   gfc_expr *return_value;
5572   int d;
5573   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5574
5575   if (k == -1)
5576     return &gfc_bad_expr;
5577
5578   /* For unary operations, the size of the result is given by the size
5579      of the operand.  For binary ones, it's the size of the first operand
5580      unless it is scalar, then it is the size of the second.  */
5581   if (array->expr_type == EXPR_OP && !array->value.op.uop)
5582     {
5583       gfc_expr* replacement;
5584       gfc_expr* simplified;
5585
5586       switch (array->value.op.op)
5587         {
5588           /* Unary operations.  */
5589           case INTRINSIC_NOT:
5590           case INTRINSIC_UPLUS:
5591           case INTRINSIC_UMINUS:
5592           case INTRINSIC_PARENTHESES:
5593             replacement = array->value.op.op1;
5594             break;
5595
5596           /* Binary operations.  If any one of the operands is scalar, take
5597              the other one's size.  If both of them are arrays, it does not
5598              matter -- try to find one with known shape, if possible.  */
5599           default:
5600             if (array->value.op.op1->rank == 0)
5601               replacement = array->value.op.op2;
5602             else if (array->value.op.op2->rank == 0)
5603               replacement = array->value.op.op1;
5604             else
5605               {
5606                 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5607                 if (simplified)
5608                   return simplified;
5609
5610                 replacement = array->value.op.op2;
5611               }
5612             break;
5613         }
5614
5615       /* Try to reduce it directly if possible.  */
5616       simplified = gfc_simplify_size (replacement, dim, kind);
5617
5618       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5619          simpler than the original one.  */
5620       if (!simplified)
5621         simplified = gfc_build_intrinsic_call (gfc_current_ns,
5622                                                GFC_ISYM_SIZE, "size",
5623                                                array->where, 3,
5624                                                gfc_copy_expr (replacement),
5625                                                gfc_copy_expr (dim),
5626                                                gfc_copy_expr (kind));
5627
5628       return simplified;
5629     }
5630
5631   if (dim == NULL)
5632     {
5633       if (!gfc_array_size (array, &size))
5634         return NULL;
5635     }
5636   else
5637     {
5638       if (dim->expr_type != EXPR_CONSTANT)
5639         return NULL;
5640
5641       d = mpz_get_ui (dim->value.integer) - 1;
5642       if (!gfc_array_dimen_size (array, d, &size))
5643         return NULL;
5644     }
5645
5646   return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5647   mpz_clear (size);
5648   return return_value;
5649 }
5650
5651
5652 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5653    multiplied by the array size.  */
5654
5655 gfc_expr *
5656 gfc_simplify_sizeof (gfc_expr *x)
5657 {
5658   gfc_expr *result = NULL;
5659   mpz_t array_size;
5660
5661   if (x->ts.type == BT_CLASS || x->ts.deferred)
5662     return NULL;
5663
5664   if (x->ts.type == BT_CHARACTER
5665       && (!x->ts.u.cl || !x->ts.u.cl->length
5666           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
5667     return NULL;
5668
5669   if (x->rank && x->expr_type != EXPR_ARRAY
5670       && !gfc_array_size (x, &array_size))
5671     return NULL;
5672
5673   result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5674                                   &x->where);
5675   mpz_set_si (result->value.integer, gfc_target_expr_size (x));
5676
5677   /* gfc_target_expr_size already takes the array size for array constructors
5678      into account.  */
5679   if (x->rank && x->expr_type != EXPR_ARRAY)
5680     {
5681       mpz_mul (result->value.integer, result->value.integer, array_size);
5682       mpz_clear (array_size);
5683     }
5684
5685   return result;
5686 }
5687
5688
5689 /* STORAGE_SIZE returns the size in bits of a single array element.  */
5690
5691 gfc_expr *
5692 gfc_simplify_storage_size (gfc_expr *x,
5693                            gfc_expr *kind)
5694 {
5695   gfc_expr *result = NULL;
5696   int k;
5697   size_t elt_size;
5698
5699   if (x->ts.type == BT_CLASS || x->ts.deferred)
5700     return NULL;
5701
5702   if (x->ts.type == BT_CHARACTER
5703       && (!x->ts.u.cl || !x->ts.u.cl->length
5704           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
5705     return NULL;
5706
5707   k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
5708   if (k == -1)
5709     return &gfc_bad_expr;
5710
5711   if (x->expr_type == EXPR_ARRAY)
5712     {
5713       gfc_constructor *c = gfc_constructor_first (x->value.constructor);
5714       elt_size = gfc_target_expr_size (c->expr);
5715     }
5716   else
5717     elt_size = gfc_target_expr_size (x);
5718
5719   result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5720                                   &x->where);
5721   mpz_set_si (result->value.integer, elt_size);
5722
5723   mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
5724   return result;
5725 }
5726
5727
5728 gfc_expr *
5729 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5730 {
5731   gfc_expr *result;
5732
5733   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5734     return NULL;
5735
5736   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5737
5738   switch (x->ts.type)
5739     {
5740       case BT_INTEGER:
5741         mpz_abs (result->value.integer, x->value.integer);
5742         if (mpz_sgn (y->value.integer) < 0)
5743           mpz_neg (result->value.integer, result->value.integer);
5744         break;
5745
5746       case BT_REAL:
5747         if (gfc_option.flag_sign_zero)
5748           mpfr_copysign (result->value.real, x->value.real, y->value.real,
5749                         GFC_RND_MODE);
5750         else
5751           mpfr_setsign (result->value.real, x->value.real,
5752                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5753         break;
5754
5755       default:
5756         gfc_internal_error ("Bad type in gfc_simplify_sign");
5757     }
5758
5759   return result;
5760 }
5761
5762
5763 gfc_expr *
5764 gfc_simplify_sin (gfc_expr *x)
5765 {
5766   gfc_expr *result;
5767
5768   if (x->expr_type != EXPR_CONSTANT)
5769     return NULL;
5770
5771   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5772
5773   switch (x->ts.type)
5774     {
5775       case BT_REAL:
5776         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5777         break;
5778
5779       case BT_COMPLEX:
5780         gfc_set_model (x->value.real);
5781         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5782         break;
5783
5784       default:
5785         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5786     }
5787
5788   return range_check (result, "SIN");
5789 }
5790
5791
5792 gfc_expr *
5793 gfc_simplify_sinh (gfc_expr *x)
5794 {
5795   gfc_expr *result;
5796
5797   if (x->expr_type != EXPR_CONSTANT)
5798     return NULL;
5799
5800   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5801
5802   switch (x->ts.type)
5803     {
5804       case BT_REAL:
5805         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5806         break;
5807
5808       case BT_COMPLEX:
5809         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5810         break;
5811
5812       default:
5813         gcc_unreachable ();
5814     }
5815
5816   return range_check (result, "SINH");
5817 }
5818
5819
5820 /* The argument is always a double precision real that is converted to
5821    single precision.  TODO: Rounding!  */
5822
5823 gfc_expr *
5824 gfc_simplify_sngl (gfc_expr *a)
5825 {
5826   gfc_expr *result;
5827
5828   if (a->expr_type != EXPR_CONSTANT)
5829     return NULL;
5830
5831   result = gfc_real2real (a, gfc_default_real_kind);
5832   return range_check (result, "SNGL");
5833 }
5834
5835
5836 gfc_expr *
5837 gfc_simplify_spacing (gfc_expr *x)
5838 {
5839   gfc_expr *result;
5840   int i;
5841   long int en, ep;
5842
5843   if (x->expr_type != EXPR_CONSTANT)
5844     return NULL;
5845
5846   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5847
5848   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5849
5850   /* Special case x = 0 and -0.  */
5851   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5852   if (mpfr_sgn (result->value.real) == 0)
5853     {
5854       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5855       return result;
5856     }
5857
5858   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5859      are the radix, exponent of x, and precision.  This excludes the
5860      possibility of subnormal numbers.  Fortran 2003 states the result is
5861      b**max(e - p, emin - 1).  */
5862
5863   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5864   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5865   en = en > ep ? en : ep;
5866
5867   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5868   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5869
5870   return range_check (result, "SPACING");
5871 }
5872
5873
5874 gfc_expr *
5875 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5876 {
5877   gfc_expr *result = 0L;
5878   int i, j, dim, ncopies;
5879   mpz_t size;
5880
5881   if ((!gfc_is_constant_expr (source)
5882        && !is_constant_array_expr (source))
5883       || !gfc_is_constant_expr (dim_expr)
5884       || !gfc_is_constant_expr (ncopies_expr))
5885     return NULL;
5886
5887   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5888   gfc_extract_int (dim_expr, &dim);
5889   dim -= 1;   /* zero-base DIM */
5890
5891   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5892   gfc_extract_int (ncopies_expr, &ncopies);
5893   ncopies = MAX (ncopies, 0);
5894
5895   /* Do not allow the array size to exceed the limit for an array
5896      constructor.  */
5897   if (source->expr_type == EXPR_ARRAY)
5898     {
5899       if (!gfc_array_size (source, &size))
5900         gfc_internal_error ("Failure getting length of a constant array.");
5901     }
5902   else
5903     mpz_init_set_ui (size, 1);
5904
5905   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5906     return NULL;
5907
5908   if (source->expr_type == EXPR_CONSTANT)
5909     {
5910       gcc_assert (dim == 0);
5911
5912       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5913                                    &source->where);
5914       if (source->ts.type == BT_DERIVED)
5915         result->ts.u.derived = source->ts.u.derived;
5916       result->rank = 1;
5917       result->shape = gfc_get_shape (result->rank);
5918       mpz_init_set_si (result->shape[0], ncopies);
5919
5920       for (i = 0; i < ncopies; ++i)
5921         gfc_constructor_append_expr (&result->value.constructor,
5922                                      gfc_copy_expr (source), NULL);
5923     }
5924   else if (source->expr_type == EXPR_ARRAY)
5925     {
5926       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5927       gfc_constructor *source_ctor;
5928
5929       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5930       gcc_assert (dim >= 0 && dim <= source->rank);
5931
5932       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5933                                    &source->where);
5934       if (source->ts.type == BT_DERIVED)
5935         result->ts.u.derived = source->ts.u.derived;
5936       result->rank = source->rank + 1;
5937       result->shape = gfc_get_shape (result->rank);
5938
5939       for (i = 0, j = 0; i < result->rank; ++i)
5940         {
5941           if (i != dim)
5942             mpz_init_set (result->shape[i], source->shape[j++]);
5943           else
5944             mpz_init_set_si (result->shape[i], ncopies);
5945
5946           extent[i] = mpz_get_si (result->shape[i]);
5947           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5948         }
5949
5950       offset = 0;
5951       for (source_ctor = gfc_constructor_first (source->value.constructor);
5952            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5953         {
5954           for (i = 0; i < ncopies; ++i)
5955             gfc_constructor_insert_expr (&result->value.constructor,
5956                                          gfc_copy_expr (source_ctor->expr),
5957                                          NULL, offset + i * rstride[dim]);
5958
5959           offset += (dim == 0 ? ncopies : 1);
5960         }
5961     }
5962   else
5963     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5964        Replace NULL with gcc_unreachable() after implementing
5965        gfc_simplify_cshift(). */
5966     return NULL;
5967
5968   if (source->ts.type == BT_CHARACTER)
5969     result->ts.u.cl = source->ts.u.cl;
5970
5971   return result;
5972 }
5973
5974
5975 gfc_expr *
5976 gfc_simplify_sqrt (gfc_expr *e)
5977 {
5978   gfc_expr *result = NULL;
5979
5980   if (e->expr_type != EXPR_CONSTANT)
5981     return NULL;
5982
5983   switch (e->ts.type)
5984     {
5985       case BT_REAL:
5986         if (mpfr_cmp_si (e->value.real, 0) < 0)
5987           {
5988             gfc_error ("Argument of SQRT at %L has a negative value",
5989                        &e->where);
5990             return &gfc_bad_expr;
5991           }
5992         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5993         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5994         break;
5995
5996       case BT_COMPLEX:
5997         gfc_set_model (e->value.real);
5998
5999         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6000         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
6001         break;
6002
6003       default:
6004         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
6005     }
6006
6007   return range_check (result, "SQRT");
6008 }
6009
6010
6011 gfc_expr *
6012 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6013 {
6014   return simplify_transformation (array, dim, mask, 0, gfc_add);
6015 }
6016
6017
6018 gfc_expr *
6019 gfc_simplify_tan (gfc_expr *x)
6020 {
6021   gfc_expr *result;
6022
6023   if (x->expr_type != EXPR_CONSTANT)
6024     return NULL;
6025
6026   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6027
6028   switch (x->ts.type)
6029     {
6030       case BT_REAL:
6031         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
6032         break;
6033
6034       case BT_COMPLEX:
6035         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6036         break;
6037
6038       default:
6039         gcc_unreachable ();
6040     }
6041
6042   return range_check (result, "TAN");
6043 }
6044
6045
6046 gfc_expr *
6047 gfc_simplify_tanh (gfc_expr *x)
6048 {
6049   gfc_expr *result;
6050
6051   if (x->expr_type != EXPR_CONSTANT)
6052     return NULL;
6053
6054   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6055
6056   switch (x->ts.type)
6057     {
6058       case BT_REAL:
6059         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
6060         break;
6061
6062       case BT_COMPLEX:
6063         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6064         break;
6065
6066       default:
6067         gcc_unreachable ();
6068     }
6069
6070   return range_check (result, "TANH");
6071 }
6072
6073
6074 gfc_expr *
6075 gfc_simplify_tiny (gfc_expr *e)
6076 {
6077   gfc_expr *result;
6078   int i;
6079
6080   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
6081
6082   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6083   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6084
6085   return result;
6086 }
6087
6088
6089 gfc_expr *
6090 gfc_simplify_trailz (gfc_expr *e)
6091 {
6092   unsigned long tz, bs;
6093   int i;
6094
6095   if (e->expr_type != EXPR_CONSTANT)
6096     return NULL;
6097
6098   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6099   bs = gfc_integer_kinds[i].bit_size;
6100   tz = mpz_scan1 (e->value.integer, 0);
6101
6102   return gfc_get_int_expr (gfc_default_integer_kind,
6103                            &e->where, MIN (tz, bs));
6104 }
6105
6106
6107 gfc_expr *
6108 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6109 {
6110   gfc_expr *result;
6111   gfc_expr *mold_element;
6112   size_t source_size;
6113   size_t result_size;
6114   size_t buffer_size;
6115   mpz_t tmp;
6116   unsigned char *buffer;
6117   size_t result_length;
6118
6119
6120   if (!gfc_is_constant_expr (source)
6121         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
6122         || !gfc_is_constant_expr (size))
6123     return NULL;
6124
6125   if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6126                                      &result_size, &result_length))
6127     return NULL;
6128
6129   /* Calculate the size of the source.  */
6130   if (source->expr_type == EXPR_ARRAY
6131       && !gfc_array_size (source, &tmp))
6132     gfc_internal_error ("Failure getting length of a constant array.");
6133
6134   /* Create an empty new expression with the appropriate characteristics.  */
6135   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6136                                   &source->where);
6137   result->ts = mold->ts;
6138
6139   mold_element = mold->expr_type == EXPR_ARRAY
6140                  ? gfc_constructor_first (mold->value.constructor)->expr
6141                  : mold;
6142
6143   /* Set result character length, if needed.  Note that this needs to be
6144      set even for array expressions, in order to pass this information into
6145      gfc_target_interpret_expr.  */
6146   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6147     result->value.character.length = mold_element->value.character.length;
6148
6149   /* Set the number of elements in the result, and determine its size.  */
6150
6151   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6152     {
6153       result->expr_type = EXPR_ARRAY;
6154       result->rank = 1;
6155       result->shape = gfc_get_shape (1);
6156       mpz_init_set_ui (result->shape[0], result_length);
6157     }
6158   else
6159     result->rank = 0;
6160
6161   /* Allocate the buffer to store the binary version of the source.  */
6162   buffer_size = MAX (source_size, result_size);
6163   buffer = (unsigned char*)alloca (buffer_size);
6164   memset (buffer, 0, buffer_size);
6165
6166   /* Now write source to the buffer.  */
6167   gfc_target_encode_expr (source, buffer, buffer_size);
6168
6169   /* And read the buffer back into the new expression.  */
6170   gfc_target_interpret_expr (buffer, buffer_size, result, false);
6171
6172   return result;
6173 }
6174
6175
6176 gfc_expr *
6177 gfc_simplify_transpose (gfc_expr *matrix)
6178 {
6179   int row, matrix_rows, col, matrix_cols;
6180   gfc_expr *result;
6181
6182   if (!is_constant_array_expr (matrix))
6183     return NULL;
6184
6185   gcc_assert (matrix->rank == 2);
6186
6187   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6188                                &matrix->where);
6189   result->rank = 2;
6190   result->shape = gfc_get_shape (result->rank);
6191   mpz_set (result->shape[0], matrix->shape[1]);
6192   mpz_set (result->shape[1], matrix->shape[0]);
6193
6194   if (matrix->ts.type == BT_CHARACTER)
6195     result->ts.u.cl = matrix->ts.u.cl;
6196   else if (matrix->ts.type == BT_DERIVED)
6197     result->ts.u.derived = matrix->ts.u.derived;
6198
6199   matrix_rows = mpz_get_si (matrix->shape[0]);
6200   matrix_cols = mpz_get_si (matrix->shape[1]);
6201   for (row = 0; row < matrix_rows; ++row)
6202     for (col = 0; col < matrix_cols; ++col)
6203       {
6204         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6205                                                    col * matrix_rows + row);
6206         gfc_constructor_insert_expr (&result->value.constructor,
6207                                      gfc_copy_expr (e), &matrix->where,
6208                                      row * matrix_cols + col);
6209       }
6210
6211   return result;
6212 }
6213
6214
6215 gfc_expr *
6216 gfc_simplify_trim (gfc_expr *e)
6217 {
6218   gfc_expr *result;
6219   int count, i, len, lentrim;
6220
6221   if (e->expr_type != EXPR_CONSTANT)
6222     return NULL;
6223
6224   len = e->value.character.length;
6225   for (count = 0, i = 1; i <= len; ++i)
6226     {
6227       if (e->value.character.string[len - i] == ' ')
6228         count++;
6229       else
6230         break;
6231     }
6232
6233   lentrim = len - count;
6234
6235   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6236   for (i = 0; i < lentrim; i++)
6237     result->value.character.string[i] = e->value.character.string[i];
6238
6239   return result;
6240 }
6241
6242
6243 gfc_expr *
6244 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6245 {
6246   gfc_expr *result;
6247   gfc_ref *ref;
6248   gfc_array_spec *as;
6249   gfc_constructor *sub_cons;
6250   bool first_image;
6251   int d;
6252
6253   if (!is_constant_array_expr (sub))
6254     return NULL;
6255
6256   /* Follow any component references.  */
6257   as = coarray->symtree->n.sym->as;
6258   for (ref = coarray->ref; ref; ref = ref->next)
6259     if (ref->type == REF_COMPONENT)
6260       as = ref->u.ar.as;
6261
6262   if (as->type == AS_DEFERRED)
6263     return NULL;
6264
6265   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6266      the cosubscript addresses the first image.  */
6267
6268   sub_cons = gfc_constructor_first (sub->value.constructor);
6269   first_image = true;
6270
6271   for (d = 1; d <= as->corank; d++)
6272     {
6273       gfc_expr *ca_bound;
6274       int cmp;
6275
6276       gcc_assert (sub_cons != NULL);
6277
6278       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6279                                      NULL, true);
6280       if (ca_bound == NULL)
6281         return NULL;
6282
6283       if (ca_bound == &gfc_bad_expr)
6284         return ca_bound;
6285
6286       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6287
6288       if (cmp == 0)
6289         {
6290           gfc_free_expr (ca_bound);
6291           sub_cons = gfc_constructor_next (sub_cons);
6292           continue;
6293         }
6294
6295       first_image = false;
6296
6297       if (cmp > 0)
6298         {
6299           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6300                      "SUB has %ld and COARRAY lower bound is %ld)",
6301                      &coarray->where, d,
6302                      mpz_get_si (sub_cons->expr->value.integer),
6303                      mpz_get_si (ca_bound->value.integer));
6304           gfc_free_expr (ca_bound);
6305           return &gfc_bad_expr;
6306         }
6307
6308       gfc_free_expr (ca_bound);
6309
6310       /* Check whether upperbound is valid for the multi-images case.  */
6311       if (d < as->corank)
6312         {
6313           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6314                                          NULL, true);
6315           if (ca_bound == &gfc_bad_expr)
6316             return ca_bound;
6317
6318           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6319               && mpz_cmp (ca_bound->value.integer,
6320                           sub_cons->expr->value.integer) < 0)
6321           {
6322             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6323                        "SUB has %ld and COARRAY upper bound is %ld)",
6324                        &coarray->where, d,
6325                        mpz_get_si (sub_cons->expr->value.integer),
6326                        mpz_get_si (ca_bound->value.integer));
6327             gfc_free_expr (ca_bound);
6328             return &gfc_bad_expr;
6329           }
6330
6331           if (ca_bound)
6332             gfc_free_expr (ca_bound);
6333         }
6334
6335       sub_cons = gfc_constructor_next (sub_cons);
6336     }
6337
6338   gcc_assert (sub_cons == NULL);
6339
6340   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
6341     return NULL;
6342
6343   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6344                                   &gfc_current_locus);
6345   if (first_image)
6346     mpz_set_si (result->value.integer, 1);
6347   else
6348     mpz_set_si (result->value.integer, 0);
6349
6350   return result;
6351 }
6352
6353
6354 gfc_expr *
6355 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6356 {
6357   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6358     return NULL;
6359
6360   if (coarray == NULL)
6361     {
6362       gfc_expr *result;
6363       /* FIXME: gfc_current_locus is wrong.  */
6364       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6365                                       &gfc_current_locus);
6366       mpz_set_si (result->value.integer, 1);
6367       return result;
6368     }
6369
6370   /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
6371   return simplify_cobound (coarray, dim, NULL, 0);
6372 }
6373
6374
6375 gfc_expr *
6376 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6377 {
6378   return simplify_bound (array, dim, kind, 1);
6379 }
6380
6381 gfc_expr *
6382 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6383 {
6384   return simplify_cobound (array, dim, kind, 1);
6385 }
6386
6387
6388 gfc_expr *
6389 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6390 {
6391   gfc_expr *result, *e;
6392   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6393
6394   if (!is_constant_array_expr (vector)
6395       || !is_constant_array_expr (mask)
6396       || (!gfc_is_constant_expr (field)
6397           && !is_constant_array_expr (field)))
6398     return NULL;
6399
6400   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6401                                &vector->where);
6402   if (vector->ts.type == BT_DERIVED)
6403     result->ts.u.derived = vector->ts.u.derived;
6404   result->rank = mask->rank;
6405   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6406
6407   if (vector->ts.type == BT_CHARACTER)
6408     result->ts.u.cl = vector->ts.u.cl;
6409
6410   vector_ctor = gfc_constructor_first (vector->value.constructor);
6411   mask_ctor = gfc_constructor_first (mask->value.constructor);
6412   field_ctor
6413     = field->expr_type == EXPR_ARRAY
6414                             ? gfc_constructor_first (field->value.constructor)
6415                             : NULL;
6416
6417   while (mask_ctor)
6418     {
6419       if (mask_ctor->expr->value.logical)
6420         {
6421           gcc_assert (vector_ctor);
6422           e = gfc_copy_expr (vector_ctor->expr);
6423           vector_ctor = gfc_constructor_next (vector_ctor);
6424         }
6425       else if (field->expr_type == EXPR_ARRAY)
6426         e = gfc_copy_expr (field_ctor->expr);
6427       else
6428         e = gfc_copy_expr (field);
6429
6430       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6431
6432       mask_ctor = gfc_constructor_next (mask_ctor);
6433       field_ctor = gfc_constructor_next (field_ctor);
6434     }
6435
6436   return result;
6437 }
6438
6439
6440 gfc_expr *
6441 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6442 {
6443   gfc_expr *result;
6444   int back;
6445   size_t index, len, lenset;
6446   size_t i;
6447   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6448
6449   if (k == -1)
6450     return &gfc_bad_expr;
6451
6452   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
6453       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
6454     return NULL;
6455
6456   if (b != NULL && b->value.logical != 0)
6457     back = 1;
6458   else
6459     back = 0;
6460
6461   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6462
6463   len = s->value.character.length;
6464   lenset = set->value.character.length;
6465
6466   if (len == 0)
6467     {
6468       mpz_set_ui (result->value.integer, 0);
6469       return result;
6470     }
6471
6472   if (back == 0)
6473     {
6474       if (lenset == 0)
6475         {
6476           mpz_set_ui (result->value.integer, 1);
6477           return result;
6478         }
6479
6480       index = wide_strspn (s->value.character.string,
6481                            set->value.character.string) + 1;
6482       if (index > len)
6483         index = 0;
6484
6485     }
6486   else
6487     {
6488       if (lenset == 0)
6489         {
6490           mpz_set_ui (result->value.integer, len);
6491           return result;
6492         }
6493       for (index = len; index > 0; index --)
6494         {
6495           for (i = 0; i < lenset; i++)
6496             {
6497               if (s->value.character.string[index - 1]
6498                   == set->value.character.string[i])
6499                 break;
6500             }
6501           if (i == lenset)
6502             break;
6503         }
6504     }
6505
6506   mpz_set_ui (result->value.integer, index);
6507   return result;
6508 }
6509
6510
6511 gfc_expr *
6512 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6513 {
6514   gfc_expr *result;
6515   int kind;
6516
6517   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6518     return NULL;
6519
6520   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6521
6522   switch (x->ts.type)
6523     {
6524       case BT_INTEGER:
6525         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6526         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6527         return range_check (result, "XOR");
6528
6529       case BT_LOGICAL:
6530         return gfc_get_logical_expr (kind, &x->where,
6531                                      (x->value.logical && !y->value.logical)
6532                                      || (!x->value.logical && y->value.logical));
6533
6534       default:
6535         gcc_unreachable ();
6536     }
6537 }
6538
6539
6540 /****************** Constant simplification *****************/
6541
6542 /* Master function to convert one constant to another.  While this is
6543    used as a simplification function, it requires the destination type
6544    and kind information which is supplied by a special case in
6545    do_simplify().  */
6546
6547 gfc_expr *
6548 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6549 {
6550   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6551   gfc_constructor *c;
6552
6553   switch (e->ts.type)
6554     {
6555     case BT_INTEGER:
6556       switch (type)
6557         {
6558         case BT_INTEGER:
6559           f = gfc_int2int;
6560           break;
6561         case BT_REAL:
6562           f = gfc_int2real;
6563           break;
6564         case BT_COMPLEX:
6565           f = gfc_int2complex;
6566           break;
6567         case BT_LOGICAL:
6568           f = gfc_int2log;
6569           break;
6570         default:
6571           goto oops;
6572         }
6573       break;
6574
6575     case BT_REAL:
6576       switch (type)
6577         {
6578         case BT_INTEGER:
6579           f = gfc_real2int;
6580           break;
6581         case BT_REAL:
6582           f = gfc_real2real;
6583           break;
6584         case BT_COMPLEX:
6585           f = gfc_real2complex;
6586           break;
6587         default:
6588           goto oops;
6589         }
6590       break;
6591
6592     case BT_COMPLEX:
6593       switch (type)
6594         {
6595         case BT_INTEGER:
6596           f = gfc_complex2int;
6597           break;
6598         case BT_REAL:
6599           f = gfc_complex2real;
6600           break;
6601         case BT_COMPLEX:
6602           f = gfc_complex2complex;
6603           break;
6604
6605         default:
6606           goto oops;
6607         }
6608       break;
6609
6610     case BT_LOGICAL:
6611       switch (type)
6612         {
6613         case BT_INTEGER:
6614           f = gfc_log2int;
6615           break;
6616         case BT_LOGICAL:
6617           f = gfc_log2log;
6618           break;
6619         default:
6620           goto oops;
6621         }
6622       break;
6623
6624     case BT_HOLLERITH:
6625       switch (type)
6626         {
6627         case BT_INTEGER:
6628           f = gfc_hollerith2int;
6629           break;
6630
6631         case BT_REAL:
6632           f = gfc_hollerith2real;
6633           break;
6634
6635         case BT_COMPLEX:
6636           f = gfc_hollerith2complex;
6637           break;
6638
6639         case BT_CHARACTER:
6640           f = gfc_hollerith2character;
6641           break;
6642
6643         case BT_LOGICAL:
6644           f = gfc_hollerith2logical;
6645           break;
6646
6647         default:
6648           goto oops;
6649         }
6650       break;
6651
6652     default:
6653     oops:
6654       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6655     }
6656
6657   result = NULL;
6658
6659   switch (e->expr_type)
6660     {
6661     case EXPR_CONSTANT:
6662       result = f (e, kind);
6663       if (result == NULL)
6664         return &gfc_bad_expr;
6665       break;
6666
6667     case EXPR_ARRAY:
6668       if (!gfc_is_constant_expr (e))
6669         break;
6670
6671       result = gfc_get_array_expr (type, kind, &e->where);
6672       result->shape = gfc_copy_shape (e->shape, e->rank);
6673       result->rank = e->rank;
6674
6675       for (c = gfc_constructor_first (e->value.constructor);
6676            c; c = gfc_constructor_next (c))
6677         {
6678           gfc_expr *tmp;
6679           if (c->iterator == NULL)
6680             tmp = f (c->expr, kind);
6681           else
6682             {
6683               g = gfc_convert_constant (c->expr, type, kind);
6684               if (g == &gfc_bad_expr)
6685                 {
6686                   gfc_free_expr (result);
6687                   return g;
6688                 }
6689               tmp = g;
6690             }
6691
6692           if (tmp == NULL)
6693             {
6694               gfc_free_expr (result);
6695               return NULL;
6696             }
6697
6698           gfc_constructor_append_expr (&result->value.constructor,
6699                                        tmp, &c->where);
6700         }
6701
6702       break;
6703
6704     default:
6705       break;
6706     }
6707
6708   return result;
6709 }
6710
6711
6712 /* Function for converting character constants.  */
6713 gfc_expr *
6714 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6715 {
6716   gfc_expr *result;
6717   int i;
6718
6719   if (!gfc_is_constant_expr (e))
6720     return NULL;
6721
6722   if (e->expr_type == EXPR_CONSTANT)
6723     {
6724       /* Simple case of a scalar.  */
6725       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6726       if (result == NULL)
6727         return &gfc_bad_expr;
6728
6729       result->value.character.length = e->value.character.length;
6730       result->value.character.string
6731         = gfc_get_wide_string (e->value.character.length + 1);
6732       memcpy (result->value.character.string, e->value.character.string,
6733               (e->value.character.length + 1) * sizeof (gfc_char_t));
6734
6735       /* Check we only have values representable in the destination kind.  */
6736       for (i = 0; i < result->value.character.length; i++)
6737         if (!gfc_check_character_range (result->value.character.string[i],
6738                                         kind))
6739           {
6740             gfc_error ("Character '%s' in string at %L cannot be converted "
6741                        "into character kind %d",
6742                        gfc_print_wide_char (result->value.character.string[i]),
6743                        &e->where, kind);
6744             return &gfc_bad_expr;
6745           }
6746
6747       return result;
6748     }
6749   else if (e->expr_type == EXPR_ARRAY)
6750     {
6751       /* For an array constructor, we convert each constructor element.  */
6752       gfc_constructor *c;
6753
6754       result = gfc_get_array_expr (type, kind, &e->where);
6755       result->shape = gfc_copy_shape (e->shape, e->rank);
6756       result->rank = e->rank;
6757       result->ts.u.cl = e->ts.u.cl;
6758
6759       for (c = gfc_constructor_first (e->value.constructor);
6760            c; c = gfc_constructor_next (c))
6761         {
6762           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6763           if (tmp == &gfc_bad_expr)
6764             {
6765               gfc_free_expr (result);
6766               return &gfc_bad_expr;
6767             }
6768
6769           if (tmp == NULL)
6770             {
6771               gfc_free_expr (result);
6772               return NULL;
6773             }
6774
6775           gfc_constructor_append_expr (&result->value.constructor,
6776                                        tmp, &c->where);
6777         }
6778
6779       return result;
6780     }
6781   else
6782     return NULL;
6783 }
6784
6785
6786 gfc_expr *
6787 gfc_simplify_compiler_options (void)
6788 {
6789   char *str;
6790   gfc_expr *result;
6791
6792   str = gfc_get_option_string ();
6793   result = gfc_get_character_expr (gfc_default_character_kind,
6794                                    &gfc_current_locus, str, strlen (str));
6795   free (str);
6796   return result;
6797 }
6798
6799
6800 gfc_expr *
6801 gfc_simplify_compiler_version (void)
6802 {
6803   char *buffer;
6804   size_t len;
6805
6806   len = strlen ("GCC version ") + strlen (version_string);
6807   buffer = XALLOCAVEC (char, len + 1);
6808   snprintf (buffer, len + 1, "GCC version %s", version_string);
6809   return gfc_get_character_expr (gfc_default_character_kind,
6810                                 &gfc_current_locus, buffer, len);
6811 }