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