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