gcc/fortran/simplify.c

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