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           case INTRINSIC_PARENTHESES:
5545             replacement = array->value.op.op1;
5546             break;
5547
5548           /* Binary operations.  If any one of the operands is scalar, take
5549              the other one's size.  If both of them are arrays, it does not
5550              matter -- try to find one with known shape, if possible.  */
5551           default:
5552             if (array->value.op.op1->rank == 0)
5553               replacement = array->value.op.op2;
5554             else if (array->value.op.op2->rank == 0)
5555               replacement = array->value.op.op1;
5556             else
5557               {
5558                 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5559                 if (simplified)
5560                   return simplified;
5561
5562                 replacement = array->value.op.op2;
5563               }
5564             break;
5565         }
5566
5567       /* Try to reduce it directly if possible.  */
5568       simplified = gfc_simplify_size (replacement, dim, kind);
5569
5570       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5571          simpler than the original one.  */
5572       if (!simplified)
5573         simplified = gfc_build_intrinsic_call ("size", array->where, 3,
5574                                                gfc_copy_expr (replacement),
5575                                                gfc_copy_expr (dim),
5576                                                gfc_copy_expr (kind));
5577
5578       return simplified;
5579     }
5580
5581   if (dim == NULL)
5582     {
5583       if (gfc_array_size (array, &size) == FAILURE)
5584         return NULL;
5585     }
5586   else
5587     {
5588       if (dim->expr_type != EXPR_CONSTANT)
5589         return NULL;
5590
5591       d = mpz_get_ui (dim->value.integer) - 1;
5592       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
5593         return NULL;
5594     }
5595
5596   return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5597   mpz_clear (size);
5598   return return_value;
5599 }
5600
5601
5602 gfc_expr *
5603 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5604 {
5605   gfc_expr *result;
5606
5607   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5608     return NULL;
5609
5610   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5611
5612   switch (x->ts.type)
5613     {
5614       case BT_INTEGER:
5615         mpz_abs (result->value.integer, x->value.integer);
5616         if (mpz_sgn (y->value.integer) < 0)
5617           mpz_neg (result->value.integer, result->value.integer);
5618         break;
5619
5620       case BT_REAL:
5621         if (gfc_option.flag_sign_zero)
5622           mpfr_copysign (result->value.real, x->value.real, y->value.real,
5623                         GFC_RND_MODE);
5624         else
5625           mpfr_setsign (result->value.real, x->value.real,
5626                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5627         break;
5628
5629       default:
5630         gfc_internal_error ("Bad type in gfc_simplify_sign");
5631     }
5632
5633   return result;
5634 }
5635
5636
5637 gfc_expr *
5638 gfc_simplify_sin (gfc_expr *x)
5639 {
5640   gfc_expr *result;
5641
5642   if (x->expr_type != EXPR_CONSTANT)
5643     return NULL;
5644
5645   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5646
5647   switch (x->ts.type)
5648     {
5649       case BT_REAL:
5650         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5651         break;
5652
5653       case BT_COMPLEX:
5654         gfc_set_model (x->value.real);
5655         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5656         break;
5657
5658       default:
5659         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5660     }
5661
5662   return range_check (result, "SIN");
5663 }
5664
5665
5666 gfc_expr *
5667 gfc_simplify_sinh (gfc_expr *x)
5668 {
5669   gfc_expr *result;
5670
5671   if (x->expr_type != EXPR_CONSTANT)
5672     return NULL;
5673
5674   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5675
5676   switch (x->ts.type)
5677     {
5678       case BT_REAL:
5679         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5680         break;
5681
5682       case BT_COMPLEX:
5683         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5684         break;
5685
5686       default:
5687         gcc_unreachable ();
5688     }
5689
5690   return range_check (result, "SINH");
5691 }
5692
5693
5694 /* The argument is always a double precision real that is converted to
5695    single precision.  TODO: Rounding!  */
5696
5697 gfc_expr *
5698 gfc_simplify_sngl (gfc_expr *a)
5699 {
5700   gfc_expr *result;
5701
5702   if (a->expr_type != EXPR_CONSTANT)
5703     return NULL;
5704
5705   result = gfc_real2real (a, gfc_default_real_kind);
5706   return range_check (result, "SNGL");
5707 }
5708
5709
5710 gfc_expr *
5711 gfc_simplify_spacing (gfc_expr *x)
5712 {
5713   gfc_expr *result;
5714   int i;
5715   long int en, ep;
5716
5717   if (x->expr_type != EXPR_CONSTANT)
5718     return NULL;
5719
5720   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5721
5722   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5723
5724   /* Special case x = 0 and -0.  */
5725   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5726   if (mpfr_sgn (result->value.real) == 0)
5727     {
5728       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5729       return result;
5730     }
5731
5732   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5733      are the radix, exponent of x, and precision.  This excludes the
5734      possibility of subnormal numbers.  Fortran 2003 states the result is
5735      b**max(e - p, emin - 1).  */
5736
5737   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5738   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5739   en = en > ep ? en : ep;
5740
5741   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5742   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5743
5744   return range_check (result, "SPACING");
5745 }
5746
5747
5748 gfc_expr *
5749 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5750 {
5751   gfc_expr *result = 0L;
5752   int i, j, dim, ncopies;
5753   mpz_t size;
5754
5755   if ((!gfc_is_constant_expr (source)
5756        && !is_constant_array_expr (source))
5757       || !gfc_is_constant_expr (dim_expr)
5758       || !gfc_is_constant_expr (ncopies_expr))
5759     return NULL;
5760
5761   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5762   gfc_extract_int (dim_expr, &dim);
5763   dim -= 1;   /* zero-base DIM */
5764
5765   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5766   gfc_extract_int (ncopies_expr, &ncopies);
5767   ncopies = MAX (ncopies, 0);
5768
5769   /* Do not allow the array size to exceed the limit for an array
5770      constructor.  */
5771   if (source->expr_type == EXPR_ARRAY)
5772     {
5773       if (gfc_array_size (source, &size) == FAILURE)
5774         gfc_internal_error ("Failure getting length of a constant array.");
5775     }
5776   else
5777     mpz_init_set_ui (size, 1);
5778
5779   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5780     return NULL;
5781
5782   if (source->expr_type == EXPR_CONSTANT)
5783     {
5784       gcc_assert (dim == 0);
5785
5786       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5787                                    &source->where);
5788       if (source->ts.type == BT_DERIVED)
5789         result->ts.u.derived = source->ts.u.derived;
5790       result->rank = 1;
5791       result->shape = gfc_get_shape (result->rank);
5792       mpz_init_set_si (result->shape[0], ncopies);
5793
5794       for (i = 0; i < ncopies; ++i)
5795         gfc_constructor_append_expr (&result->value.constructor,
5796                                      gfc_copy_expr (source), NULL);
5797     }
5798   else if (source->expr_type == EXPR_ARRAY)
5799     {
5800       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5801       gfc_constructor *source_ctor;
5802
5803       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5804       gcc_assert (dim >= 0 && dim <= source->rank);
5805
5806       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5807                                    &source->where);
5808       if (source->ts.type == BT_DERIVED)
5809         result->ts.u.derived = source->ts.u.derived;
5810       result->rank = source->rank + 1;
5811       result->shape = gfc_get_shape (result->rank);
5812
5813       for (i = 0, j = 0; i < result->rank; ++i)
5814         {
5815           if (i != dim)
5816             mpz_init_set (result->shape[i], source->shape[j++]);
5817           else
5818             mpz_init_set_si (result->shape[i], ncopies);
5819
5820           extent[i] = mpz_get_si (result->shape[i]);
5821           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5822         }
5823
5824       offset = 0;
5825       for (source_ctor = gfc_constructor_first (source->value.constructor);
5826            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5827         {
5828           for (i = 0; i < ncopies; ++i)
5829             gfc_constructor_insert_expr (&result->value.constructor,
5830                                          gfc_copy_expr (source_ctor->expr),
5831                                          NULL, offset + i * rstride[dim]);
5832
5833           offset += (dim == 0 ? ncopies : 1);
5834         }
5835     }
5836   else
5837     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5838        Replace NULL with gcc_unreachable() after implementing
5839        gfc_simplify_cshift(). */
5840     return NULL;
5841
5842   if (source->ts.type == BT_CHARACTER)
5843     result->ts.u.cl = source->ts.u.cl;
5844
5845   return result;
5846 }
5847
5848
5849 gfc_expr *
5850 gfc_simplify_sqrt (gfc_expr *e)
5851 {
5852   gfc_expr *result = NULL;
5853
5854   if (e->expr_type != EXPR_CONSTANT)
5855     return NULL;
5856
5857   switch (e->ts.type)
5858     {
5859       case BT_REAL:
5860         if (mpfr_cmp_si (e->value.real, 0) < 0)
5861           {
5862             gfc_error ("Argument of SQRT at %L has a negative value",
5863                        &e->where);
5864             return &gfc_bad_expr;
5865           }
5866         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5867         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5868         break;
5869
5870       case BT_COMPLEX:
5871         gfc_set_model (e->value.real);
5872
5873         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5874         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5875         break;
5876
5877       default:
5878         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5879     }
5880
5881   return range_check (result, "SQRT");
5882 }
5883
5884
5885 gfc_expr *
5886 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5887 {
5888   return simplify_transformation (array, dim, mask, 0, gfc_add);
5889 }
5890
5891
5892 gfc_expr *
5893 gfc_simplify_tan (gfc_expr *x)
5894 {
5895   gfc_expr *result;
5896
5897   if (x->expr_type != EXPR_CONSTANT)
5898     return NULL;
5899
5900   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5901
5902   switch (x->ts.type)
5903     {
5904       case BT_REAL:
5905         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5906         break;
5907
5908       case BT_COMPLEX:
5909         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5910         break;
5911
5912       default:
5913         gcc_unreachable ();
5914     }
5915
5916   return range_check (result, "TAN");
5917 }
5918
5919
5920 gfc_expr *
5921 gfc_simplify_tanh (gfc_expr *x)
5922 {
5923   gfc_expr *result;
5924
5925   if (x->expr_type != EXPR_CONSTANT)
5926     return NULL;
5927
5928   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5929
5930   switch (x->ts.type)
5931     {
5932       case BT_REAL:
5933         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5934         break;
5935
5936       case BT_COMPLEX:
5937         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5938         break;
5939
5940       default:
5941         gcc_unreachable ();
5942     }
5943
5944   return range_check (result, "TANH");
5945 }
5946
5947
5948 gfc_expr *
5949 gfc_simplify_tiny (gfc_expr *e)
5950 {
5951   gfc_expr *result;
5952   int i;
5953
5954   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5955
5956   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5957   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5958
5959   return result;
5960 }
5961
5962
5963 gfc_expr *
5964 gfc_simplify_trailz (gfc_expr *e)
5965 {
5966   unsigned long tz, bs;
5967   int i;
5968
5969   if (e->expr_type != EXPR_CONSTANT)
5970     return NULL;
5971
5972   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5973   bs = gfc_integer_kinds[i].bit_size;
5974   tz = mpz_scan1 (e->value.integer, 0);
5975
5976   return gfc_get_int_expr (gfc_default_integer_kind,
5977                            &e->where, MIN (tz, bs));
5978 }
5979
5980
5981 gfc_expr *
5982 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5983 {
5984   gfc_expr *result;
5985   gfc_expr *mold_element;
5986   size_t source_size;
5987   size_t result_size;
5988   size_t buffer_size;
5989   mpz_t tmp;
5990   unsigned char *buffer;
5991   size_t result_length;
5992
5993
5994   if (!gfc_is_constant_expr (source)
5995         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5996         || !gfc_is_constant_expr (size))
5997     return NULL;
5998
5999   if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6000                                     &result_size, &result_length) == FAILURE)
6001     return NULL;
6002
6003   /* Calculate the size of the source.  */
6004   if (source->expr_type == EXPR_ARRAY
6005       && gfc_array_size (source, &tmp) == FAILURE)
6006     gfc_internal_error ("Failure getting length of a constant array.");
6007
6008   /* Create an empty new expression with the appropriate characteristics.  */
6009   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6010                                   &source->where);
6011   result->ts = mold->ts;
6012
6013   mold_element = mold->expr_type == EXPR_ARRAY
6014                  ? gfc_constructor_first (mold->value.constructor)->expr
6015                  : mold;
6016
6017   /* Set result character length, if needed.  Note that this needs to be
6018      set even for array expressions, in order to pass this information into
6019      gfc_target_interpret_expr.  */
6020   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6021     result->value.character.length = mold_element->value.character.length;
6022
6023   /* Set the number of elements in the result, and determine its size.  */
6024
6025   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6026     {
6027       result->expr_type = EXPR_ARRAY;
6028       result->rank = 1;
6029       result->shape = gfc_get_shape (1);
6030       mpz_init_set_ui (result->shape[0], result_length);
6031     }
6032   else
6033     result->rank = 0;
6034
6035   /* Allocate the buffer to store the binary version of the source.  */
6036   buffer_size = MAX (source_size, result_size);
6037   buffer = (unsigned char*)alloca (buffer_size);
6038   memset (buffer, 0, buffer_size);
6039
6040   /* Now write source to the buffer.  */
6041   gfc_target_encode_expr (source, buffer, buffer_size);
6042
6043   /* And read the buffer back into the new expression.  */
6044   gfc_target_interpret_expr (buffer, buffer_size, result, false);
6045
6046   return result;
6047 }
6048
6049
6050 gfc_expr *
6051 gfc_simplify_transpose (gfc_expr *matrix)
6052 {
6053   int row, matrix_rows, col, matrix_cols;
6054   gfc_expr *result;
6055
6056   if (!is_constant_array_expr (matrix))
6057     return NULL;
6058
6059   gcc_assert (matrix->rank == 2);
6060
6061   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6062                                &matrix->where);
6063   result->rank = 2;
6064   result->shape = gfc_get_shape (result->rank);
6065   mpz_set (result->shape[0], matrix->shape[1]);
6066   mpz_set (result->shape[1], matrix->shape[0]);
6067
6068   if (matrix->ts.type == BT_CHARACTER)
6069     result->ts.u.cl = matrix->ts.u.cl;
6070   else if (matrix->ts.type == BT_DERIVED)
6071     result->ts.u.derived = matrix->ts.u.derived;
6072
6073   matrix_rows = mpz_get_si (matrix->shape[0]);
6074   matrix_cols = mpz_get_si (matrix->shape[1]);
6075   for (row = 0; row < matrix_rows; ++row)
6076     for (col = 0; col < matrix_cols; ++col)
6077       {
6078         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6079                                                    col * matrix_rows + row);
6080         gfc_constructor_insert_expr (&result->value.constructor,
6081                                      gfc_copy_expr (e), &matrix->where,
6082                                      row * matrix_cols + col);
6083       }
6084
6085   return result;
6086 }
6087
6088
6089 gfc_expr *
6090 gfc_simplify_trim (gfc_expr *e)
6091 {
6092   gfc_expr *result;
6093   int count, i, len, lentrim;
6094
6095   if (e->expr_type != EXPR_CONSTANT)
6096     return NULL;
6097
6098   len = e->value.character.length;
6099   for (count = 0, i = 1; i <= len; ++i)
6100     {
6101       if (e->value.character.string[len - i] == ' ')
6102         count++;
6103       else
6104         break;
6105     }
6106
6107   lentrim = len - count;
6108
6109   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6110   for (i = 0; i < lentrim; i++)
6111     result->value.character.string[i] = e->value.character.string[i];
6112
6113   return result;
6114 }
6115
6116
6117 gfc_expr *
6118 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6119 {
6120   gfc_expr *result;
6121   gfc_ref *ref;
6122   gfc_array_spec *as;
6123   gfc_constructor *sub_cons;
6124   bool first_image;
6125   int d;
6126
6127   if (!is_constant_array_expr (sub))
6128     return NULL;
6129
6130   /* Follow any component references.  */
6131   as = coarray->symtree->n.sym->as;
6132   for (ref = coarray->ref; ref; ref = ref->next)
6133     if (ref->type == REF_COMPONENT)
6134       as = ref->u.ar.as;
6135
6136   if (as->type == AS_DEFERRED)
6137     return NULL;
6138
6139   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6140      the cosubscript addresses the first image.  */
6141
6142   sub_cons = gfc_constructor_first (sub->value.constructor);
6143   first_image = true;
6144
6145   for (d = 1; d <= as->corank; d++)
6146     {
6147       gfc_expr *ca_bound;
6148       int cmp;
6149
6150       gcc_assert (sub_cons != NULL);
6151
6152       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6153                                      NULL, true);
6154       if (ca_bound == NULL)
6155         return NULL;
6156
6157       if (ca_bound == &gfc_bad_expr)
6158         return ca_bound;
6159
6160       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6161
6162       if (cmp == 0)
6163         {
6164           gfc_free_expr (ca_bound);
6165           sub_cons = gfc_constructor_next (sub_cons);
6166           continue;
6167         }
6168
6169       first_image = false;
6170
6171       if (cmp > 0)
6172         {
6173           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6174                      "SUB has %ld and COARRAY lower bound is %ld)",
6175                      &coarray->where, d,
6176                      mpz_get_si (sub_cons->expr->value.integer),
6177                      mpz_get_si (ca_bound->value.integer));
6178           gfc_free_expr (ca_bound);
6179           return &gfc_bad_expr;
6180         }
6181
6182       gfc_free_expr (ca_bound);
6183
6184       /* Check whether upperbound is valid for the multi-images case.  */
6185       if (d < as->corank)
6186         {
6187           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6188                                          NULL, true);
6189           if (ca_bound == &gfc_bad_expr)
6190             return ca_bound;
6191
6192           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6193               && mpz_cmp (ca_bound->value.integer,
6194                           sub_cons->expr->value.integer) < 0)
6195           {
6196             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6197                        "SUB has %ld and COARRAY upper bound is %ld)",
6198                        &coarray->where, d,
6199                        mpz_get_si (sub_cons->expr->value.integer),
6200                        mpz_get_si (ca_bound->value.integer));
6201             gfc_free_expr (ca_bound);
6202             return &gfc_bad_expr;
6203           }
6204
6205           if (ca_bound)
6206             gfc_free_expr (ca_bound);
6207         }
6208
6209       sub_cons = gfc_constructor_next (sub_cons);
6210     }
6211
6212   gcc_assert (sub_cons == NULL);
6213
6214   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
6215     return NULL;
6216
6217   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6218                                   &gfc_current_locus);
6219   if (first_image)
6220     mpz_set_si (result->value.integer, 1);
6221   else
6222     mpz_set_si (result->value.integer, 0);
6223
6224   return result;
6225 }
6226
6227
6228 gfc_expr *
6229 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6230 {
6231   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6232     return NULL;
6233
6234   if (coarray == NULL)
6235     {
6236       gfc_expr *result;
6237       /* FIXME: gfc_current_locus is wrong.  */
6238       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6239                                       &gfc_current_locus);
6240       mpz_set_si (result->value.integer, 1);
6241       return result;
6242     }
6243
6244   /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
6245   return simplify_cobound (coarray, dim, NULL, 0);
6246 }
6247
6248
6249 gfc_expr *
6250 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6251 {
6252   return simplify_bound (array, dim, kind, 1);
6253 }
6254
6255 gfc_expr *
6256 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6257 {
6258   return simplify_cobound (array, dim, kind, 1);
6259 }
6260
6261
6262 gfc_expr *
6263 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6264 {
6265   gfc_expr *result, *e;
6266   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6267
6268   if (!is_constant_array_expr (vector)
6269       || !is_constant_array_expr (mask)
6270       || (!gfc_is_constant_expr (field)
6271           && !is_constant_array_expr(field)))
6272     return NULL;
6273
6274   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6275                                &vector->where);
6276   if (vector->ts.type == BT_DERIVED)
6277     result->ts.u.derived = vector->ts.u.derived;
6278   result->rank = mask->rank;
6279   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6280
6281   if (vector->ts.type == BT_CHARACTER)
6282     result->ts.u.cl = vector->ts.u.cl;
6283
6284   vector_ctor = gfc_constructor_first (vector->value.constructor);
6285   mask_ctor = gfc_constructor_first (mask->value.constructor);
6286   field_ctor
6287     = field->expr_type == EXPR_ARRAY
6288                             ? gfc_constructor_first (field->value.constructor)
6289                             : NULL;
6290
6291   while (mask_ctor)
6292     {
6293       if (mask_ctor->expr->value.logical)
6294         {
6295           gcc_assert (vector_ctor);
6296           e = gfc_copy_expr (vector_ctor->expr);
6297           vector_ctor = gfc_constructor_next (vector_ctor);
6298         }
6299       else if (field->expr_type == EXPR_ARRAY)
6300         e = gfc_copy_expr (field_ctor->expr);
6301       else
6302         e = gfc_copy_expr (field);
6303
6304       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6305
6306       mask_ctor = gfc_constructor_next (mask_ctor);
6307       field_ctor = gfc_constructor_next (field_ctor);
6308     }
6309
6310   return result;
6311 }
6312
6313
6314 gfc_expr *
6315 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6316 {
6317   gfc_expr *result;
6318   int back;
6319   size_t index, len, lenset;
6320   size_t i;
6321   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6322
6323   if (k == -1)
6324     return &gfc_bad_expr;
6325
6326   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
6327     return NULL;
6328
6329   if (b != NULL && b->value.logical != 0)
6330     back = 1;
6331   else
6332     back = 0;
6333
6334   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6335
6336   len = s->value.character.length;
6337   lenset = set->value.character.length;
6338
6339   if (len == 0)
6340     {
6341       mpz_set_ui (result->value.integer, 0);
6342       return result;
6343     }
6344
6345   if (back == 0)
6346     {
6347       if (lenset == 0)
6348         {
6349           mpz_set_ui (result->value.integer, 1);
6350           return result;
6351         }
6352
6353       index = wide_strspn (s->value.character.string,
6354                            set->value.character.string) + 1;
6355       if (index > len)
6356         index = 0;
6357
6358     }
6359   else
6360     {
6361       if (lenset == 0)
6362         {
6363           mpz_set_ui (result->value.integer, len);
6364           return result;
6365         }
6366       for (index = len; index > 0; index --)
6367         {
6368           for (i = 0; i < lenset; i++)
6369             {
6370               if (s->value.character.string[index - 1]
6371                   == set->value.character.string[i])
6372                 break;
6373             }
6374           if (i == lenset)
6375             break;
6376         }
6377     }
6378
6379   mpz_set_ui (result->value.integer, index);
6380   return result;
6381 }
6382
6383
6384 gfc_expr *
6385 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6386 {
6387   gfc_expr *result;
6388   int kind;
6389
6390   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6391     return NULL;
6392
6393   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6394
6395   switch (x->ts.type)
6396     {
6397       case BT_INTEGER:
6398         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6399         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6400         return range_check (result, "XOR");
6401
6402       case BT_LOGICAL:
6403         return gfc_get_logical_expr (kind, &x->where,
6404                                      (x->value.logical && !y->value.logical)
6405                                      || (!x->value.logical && y->value.logical));
6406
6407       default:
6408         gcc_unreachable ();
6409     }
6410 }
6411
6412
6413 /****************** Constant simplification *****************/
6414
6415 /* Master function to convert one constant to another.  While this is
6416    used as a simplification function, it requires the destination type
6417    and kind information which is supplied by a special case in
6418    do_simplify().  */
6419
6420 gfc_expr *
6421 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6422 {
6423   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6424   gfc_constructor *c;
6425
6426   switch (e->ts.type)
6427     {
6428     case BT_INTEGER:
6429       switch (type)
6430         {
6431         case BT_INTEGER:
6432           f = gfc_int2int;
6433           break;
6434         case BT_REAL:
6435           f = gfc_int2real;
6436           break;
6437         case BT_COMPLEX:
6438           f = gfc_int2complex;
6439           break;
6440         case BT_LOGICAL:
6441           f = gfc_int2log;
6442           break;
6443         default:
6444           goto oops;
6445         }
6446       break;
6447
6448     case BT_REAL:
6449       switch (type)
6450         {
6451         case BT_INTEGER:
6452           f = gfc_real2int;
6453           break;
6454         case BT_REAL:
6455           f = gfc_real2real;
6456           break;
6457         case BT_COMPLEX:
6458           f = gfc_real2complex;
6459           break;
6460         default:
6461           goto oops;
6462         }
6463       break;
6464
6465     case BT_COMPLEX:
6466       switch (type)
6467         {
6468         case BT_INTEGER:
6469           f = gfc_complex2int;
6470           break;
6471         case BT_REAL:
6472           f = gfc_complex2real;
6473           break;
6474         case BT_COMPLEX:
6475           f = gfc_complex2complex;
6476           break;
6477
6478         default:
6479           goto oops;
6480         }
6481       break;
6482
6483     case BT_LOGICAL:
6484       switch (type)
6485         {
6486         case BT_INTEGER:
6487           f = gfc_log2int;
6488           break;
6489         case BT_LOGICAL:
6490           f = gfc_log2log;
6491           break;
6492         default:
6493           goto oops;
6494         }
6495       break;
6496
6497     case BT_HOLLERITH:
6498       switch (type)
6499         {
6500         case BT_INTEGER:
6501           f = gfc_hollerith2int;
6502           break;
6503
6504         case BT_REAL:
6505           f = gfc_hollerith2real;
6506           break;
6507
6508         case BT_COMPLEX:
6509           f = gfc_hollerith2complex;
6510           break;
6511
6512         case BT_CHARACTER:
6513           f = gfc_hollerith2character;
6514           break;
6515
6516         case BT_LOGICAL:
6517           f = gfc_hollerith2logical;
6518           break;
6519
6520         default:
6521           goto oops;
6522         }
6523       break;
6524
6525     default:
6526     oops:
6527       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6528     }
6529
6530   result = NULL;
6531
6532   switch (e->expr_type)
6533     {
6534     case EXPR_CONSTANT:
6535       result = f (e, kind);
6536       if (result == NULL)
6537         return &gfc_bad_expr;
6538       break;
6539
6540     case EXPR_ARRAY:
6541       if (!gfc_is_constant_expr (e))
6542         break;
6543
6544       result = gfc_get_array_expr (type, kind, &e->where);
6545       result->shape = gfc_copy_shape (e->shape, e->rank);
6546       result->rank = e->rank;
6547
6548       for (c = gfc_constructor_first (e->value.constructor);
6549            c; c = gfc_constructor_next (c))
6550         {
6551           gfc_expr *tmp;
6552           if (c->iterator == NULL)
6553             tmp = f (c->expr, kind);
6554           else
6555             {
6556               g = gfc_convert_constant (c->expr, type, kind);
6557               if (g == &gfc_bad_expr)
6558                 {
6559                   gfc_free_expr (result);
6560                   return g;
6561                 }
6562               tmp = g;
6563             }
6564
6565           if (tmp == NULL)
6566             {
6567               gfc_free_expr (result);
6568               return NULL;
6569             }
6570
6571           gfc_constructor_append_expr (&result->value.constructor,
6572                                        tmp, &c->where);
6573         }
6574
6575       break;
6576
6577     default:
6578       break;
6579     }
6580
6581   return result;
6582 }
6583
6584
6585 /* Function for converting character constants.  */
6586 gfc_expr *
6587 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6588 {
6589   gfc_expr *result;
6590   int i;
6591
6592   if (!gfc_is_constant_expr (e))
6593     return NULL;
6594
6595   if (e->expr_type == EXPR_CONSTANT)
6596     {
6597       /* Simple case of a scalar.  */
6598       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6599       if (result == NULL)
6600         return &gfc_bad_expr;
6601
6602       result->value.character.length = e->value.character.length;
6603       result->value.character.string
6604         = gfc_get_wide_string (e->value.character.length + 1);
6605       memcpy (result->value.character.string, e->value.character.string,
6606               (e->value.character.length + 1) * sizeof (gfc_char_t));
6607
6608       /* Check we only have values representable in the destination kind.  */
6609       for (i = 0; i < result->value.character.length; i++)
6610         if (!gfc_check_character_range (result->value.character.string[i],
6611                                         kind))
6612           {
6613             gfc_error ("Character '%s' in string at %L cannot be converted "
6614                        "into character kind %d",
6615                        gfc_print_wide_char (result->value.character.string[i]),
6616                        &e->where, kind);
6617             return &gfc_bad_expr;
6618           }
6619
6620       return result;
6621     }
6622   else if (e->expr_type == EXPR_ARRAY)
6623     {
6624       /* For an array constructor, we convert each constructor element.  */
6625       gfc_constructor *c;
6626
6627       result = gfc_get_array_expr (type, kind, &e->where);
6628       result->shape = gfc_copy_shape (e->shape, e->rank);
6629       result->rank = e->rank;
6630       result->ts.u.cl = e->ts.u.cl;
6631
6632       for (c = gfc_constructor_first (e->value.constructor);
6633            c; c = gfc_constructor_next (c))
6634         {
6635           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6636           if (tmp == &gfc_bad_expr)
6637             {
6638               gfc_free_expr (result);
6639               return &gfc_bad_expr;
6640             }
6641
6642           if (tmp == NULL)
6643             {
6644               gfc_free_expr (result);
6645               return NULL;
6646             }
6647
6648           gfc_constructor_append_expr (&result->value.constructor,
6649                                        tmp, &c->where);
6650         }
6651
6652       return result;
6653     }
6654   else
6655     return NULL;
6656 }
6657
6658
6659 gfc_expr *
6660 gfc_simplify_compiler_options (void)
6661 {
6662   char *str;
6663   gfc_expr *result;
6664
6665   str = gfc_get_option_string ();
6666   result = gfc_get_character_expr (gfc_default_character_kind,
6667                                    &gfc_current_locus, str, strlen (str));
6668   free (str);
6669   return result;
6670 }
6671
6672
6673 gfc_expr *
6674 gfc_simplify_compiler_version (void)
6675 {
6676   char *buffer;
6677   size_t len;
6678
6679   len = strlen ("GCC version ") + strlen (version_string);
6680   buffer = XALLOCAVEC (char, len + 1);
6681   snprintf (buffer, len + 1, "GCC version %s", version_string);
6682   return gfc_get_character_expr (gfc_default_character_kind,
6683                                 &gfc_current_locus, buffer, len);
6684 }