gcc/fortran/simplify.c

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