gcc/fortran/simplify.c

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