gcc/fortran/simplify.c

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