gcc/fortran/simplify.c

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