gcc/fortran/simplify.c

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