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->expr_type != EXPR_VARIABLE)
3330     {
3331       as = NULL;
3332       ref = NULL;
3333       goto done;
3334     }
3335
3336   /* Follow any component references.  */
3337   as = array->symtree->n.sym->as;
3338   for (ref = array->ref; ref; ref = ref->next)
3339     {
3340       switch (ref->type)
3341         {
3342         case REF_ARRAY:
3343           switch (ref->u.ar.type)
3344             {
3345             case AR_ELEMENT:
3346               as = NULL;
3347               continue;
3348
3349             case AR_FULL:
3350               /* We're done because 'as' has already been set in the
3351                  previous iteration.  */
3352               if (!ref->next)
3353                 goto done;
3354
3355             /* Fall through.  */
3356
3357             case AR_UNKNOWN:
3358               return NULL;
3359
3360             case AR_SECTION:
3361               as = ref->u.ar.as;
3362               goto done;
3363             }
3364
3365           gcc_unreachable ();
3366
3367         case REF_COMPONENT:
3368           as = ref->u.c.component->as;
3369           continue;
3370
3371         case REF_SUBSTRING:
3372           continue;
3373         }
3374     }
3375
3376   gcc_unreachable ();
3377
3378  done:
3379
3380   if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
3381     return NULL;
3382
3383   if (dim == NULL)
3384     {
3385       /* Multi-dimensional bounds.  */
3386       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3387       gfc_expr *e;
3388       int k;
3389
3390       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
3391       if (upper && as && as->type == AS_ASSUMED_SIZE)
3392         {
3393           /* An error message will be emitted in
3394              check_assumed_size_reference (resolve.c).  */
3395           return &gfc_bad_expr;
3396         }
3397
3398       /* Simplify the bounds for each dimension.  */
3399       for (d = 0; d < array->rank; d++)
3400         {
3401           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3402                                           false);
3403           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3404             {
3405               int j;
3406
3407               for (j = 0; j < d; j++)
3408                 gfc_free_expr (bounds[j]);
3409               return bounds[d];
3410             }
3411         }
3412
3413       /* Allocate the result expression.  */
3414       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3415                     gfc_default_integer_kind);
3416       if (k == -1)
3417         return &gfc_bad_expr;
3418
3419       e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3420
3421       /* The result is a rank 1 array; its size is the rank of the first
3422          argument to {L,U}BOUND.  */
3423       e->rank = 1;
3424       e->shape = gfc_get_shape (1);
3425       mpz_init_set_ui (e->shape[0], array->rank);
3426
3427       /* Create the constructor for this array.  */
3428       for (d = 0; d < array->rank; d++)
3429         gfc_constructor_append_expr (&e->value.constructor,
3430                                      bounds[d], &e->where);
3431
3432       return e;
3433     }
3434   else
3435     {
3436       /* A DIM argument is specified.  */
3437       if (dim->expr_type != EXPR_CONSTANT)
3438         return NULL;
3439
3440       d = mpz_get_si (dim->value.integer);
3441
3442       if (d < 1 || d > array->rank
3443           || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3444         {
3445           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3446           return &gfc_bad_expr;
3447         }
3448
3449       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3450     }
3451 }
3452
3453
3454 static gfc_expr *
3455 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3456 {
3457   gfc_ref *ref;
3458   gfc_array_spec *as;
3459   int d;
3460
3461   if (array->expr_type != EXPR_VARIABLE)
3462     return NULL;
3463
3464   /* Follow any component references.  */
3465   as = array->symtree->n.sym->as;
3466   for (ref = array->ref; ref; ref = ref->next)
3467     {
3468       switch (ref->type)
3469         {
3470         case REF_ARRAY:
3471           switch (ref->u.ar.type)
3472             {
3473             case AR_ELEMENT:
3474               if (ref->u.ar.as->corank > 0)
3475                 {
3476                   gcc_assert (as == ref->u.ar.as);
3477                   goto done;
3478                 }
3479               as = NULL;
3480               continue;
3481
3482             case AR_FULL:
3483               /* We're done because 'as' has already been set in the
3484                  previous iteration.  */
3485               if (!ref->next)
3486                 goto done;
3487
3488             /* Fall through.  */
3489
3490             case AR_UNKNOWN:
3491               return NULL;
3492
3493             case AR_SECTION:
3494               as = ref->u.ar.as;
3495               goto done;
3496             }
3497
3498           gcc_unreachable ();
3499
3500         case REF_COMPONENT:
3501           as = ref->u.c.component->as;
3502           continue;
3503
3504         case REF_SUBSTRING:
3505           continue;
3506         }
3507     }
3508
3509   gcc_unreachable ();
3510
3511  done:
3512
3513   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3514     return NULL;
3515
3516   if (dim == NULL)
3517     {
3518       /* Multi-dimensional cobounds.  */
3519       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3520       gfc_expr *e;
3521       int k;
3522
3523       /* Simplify the cobounds for each dimension.  */
3524       for (d = 0; d < as->corank; d++)
3525         {
3526           bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
3527                                           upper, as, ref, true);
3528           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3529             {
3530               int j;
3531
3532               for (j = 0; j < d; j++)
3533                 gfc_free_expr (bounds[j]);
3534               return bounds[d];
3535             }
3536         }
3537
3538       /* Allocate the result expression.  */
3539       e = gfc_get_expr ();
3540       e->where = array->where;
3541       e->expr_type = EXPR_ARRAY;
3542       e->ts.type = BT_INTEGER;
3543       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3544                     gfc_default_integer_kind);
3545       if (k == -1)
3546         {
3547           gfc_free_expr (e);
3548           return &gfc_bad_expr;
3549         }
3550       e->ts.kind = k;
3551
3552       /* The result is a rank 1 array; its size is the rank of the first
3553          argument to {L,U}COBOUND.  */
3554       e->rank = 1;
3555       e->shape = gfc_get_shape (1);
3556       mpz_init_set_ui (e->shape[0], as->corank);
3557
3558       /* Create the constructor for this array.  */
3559       for (d = 0; d < as->corank; d++)
3560         gfc_constructor_append_expr (&e->value.constructor,
3561                                      bounds[d], &e->where);
3562       return e;
3563     }
3564   else
3565     {
3566       /* A DIM argument is specified.  */
3567       if (dim->expr_type != EXPR_CONSTANT)
3568         return NULL;
3569
3570       d = mpz_get_si (dim->value.integer);
3571
3572       if (d < 1 || d > as->corank)
3573         {
3574           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3575           return &gfc_bad_expr;
3576         }
3577
3578       return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3579     }
3580 }
3581
3582
3583 gfc_expr *
3584 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3585 {
3586   return simplify_bound (array, dim, kind, 0);
3587 }
3588
3589
3590 gfc_expr *
3591 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3592 {
3593   return simplify_cobound (array, dim, kind, 0);
3594 }
3595
3596 gfc_expr *
3597 gfc_simplify_leadz (gfc_expr *e)
3598 {
3599   unsigned long lz, bs;
3600   int i;
3601
3602   if (e->expr_type != EXPR_CONSTANT)
3603     return NULL;
3604
3605   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3606   bs = gfc_integer_kinds[i].bit_size;
3607   if (mpz_cmp_si (e->value.integer, 0) == 0)
3608     lz = bs;
3609   else if (mpz_cmp_si (e->value.integer, 0) < 0)
3610     lz = 0;
3611   else
3612     lz = bs - mpz_sizeinbase (e->value.integer, 2);
3613
3614   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3615 }
3616
3617
3618 gfc_expr *
3619 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3620 {
3621   gfc_expr *result;
3622   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3623
3624   if (k == -1)
3625     return &gfc_bad_expr;
3626
3627   if (e->expr_type == EXPR_CONSTANT)
3628     {
3629       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3630       mpz_set_si (result->value.integer, e->value.character.length);
3631       return range_check (result, "LEN");
3632     }
3633   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3634            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3635            && e->ts.u.cl->length->ts.type == BT_INTEGER)
3636     {
3637       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3638       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3639       return range_check (result, "LEN");
3640     }
3641   else
3642     return NULL;
3643 }
3644
3645
3646 gfc_expr *
3647 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3648 {
3649   gfc_expr *result;
3650   int count, len, i;
3651   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3652
3653   if (k == -1)
3654     return &gfc_bad_expr;
3655
3656   if (e->expr_type != EXPR_CONSTANT)
3657     return NULL;
3658
3659   len = e->value.character.length;
3660   for (count = 0, i = 1; i <= len; i++)
3661     if (e->value.character.string[len - i] == ' ')
3662       count++;
3663     else
3664       break;
3665
3666   result = gfc_get_int_expr (k, &e->where, len - count);
3667   return range_check (result, "LEN_TRIM");
3668 }
3669
3670 gfc_expr *
3671 gfc_simplify_lgamma (gfc_expr *x)
3672 {
3673   gfc_expr *result;
3674   int sg;
3675
3676   if (x->expr_type != EXPR_CONSTANT)
3677     return NULL;
3678
3679   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3680   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3681
3682   return range_check (result, "LGAMMA");
3683 }
3684
3685
3686 gfc_expr *
3687 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3688 {
3689   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3690     return NULL;
3691
3692   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3693                                gfc_compare_string (a, b) >= 0);
3694 }
3695
3696
3697 gfc_expr *
3698 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3699 {
3700   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3701     return NULL;
3702
3703   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3704                                gfc_compare_string (a, b) > 0);
3705 }
3706
3707
3708 gfc_expr *
3709 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3710 {
3711   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3712     return NULL;
3713
3714   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3715                                gfc_compare_string (a, b) <= 0);
3716 }
3717
3718
3719 gfc_expr *
3720 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3721 {
3722   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3723     return NULL;
3724
3725   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3726                                gfc_compare_string (a, b) < 0);
3727 }
3728
3729
3730 gfc_expr *
3731 gfc_simplify_log (gfc_expr *x)
3732 {
3733   gfc_expr *result;
3734
3735   if (x->expr_type != EXPR_CONSTANT)
3736     return NULL;
3737
3738   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3739
3740   switch (x->ts.type)
3741     {
3742     case BT_REAL:
3743       if (mpfr_sgn (x->value.real) <= 0)
3744         {
3745           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3746                      "to zero", &x->where);
3747           gfc_free_expr (result);
3748           return &gfc_bad_expr;
3749         }
3750
3751       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3752       break;
3753
3754     case BT_COMPLEX:
3755       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3756           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3757         {
3758           gfc_error ("Complex argument of LOG at %L cannot be zero",
3759                      &x->where);
3760           gfc_free_expr (result);
3761           return &gfc_bad_expr;
3762         }
3763
3764       gfc_set_model_kind (x->ts.kind);
3765       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3766       break;
3767
3768     default:
3769       gfc_internal_error ("gfc_simplify_log: bad type");
3770     }
3771
3772   return range_check (result, "LOG");
3773 }
3774
3775
3776 gfc_expr *
3777 gfc_simplify_log10 (gfc_expr *x)
3778 {
3779   gfc_expr *result;
3780
3781   if (x->expr_type != EXPR_CONSTANT)
3782     return NULL;
3783
3784   if (mpfr_sgn (x->value.real) <= 0)
3785     {
3786       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3787                  "to zero", &x->where);
3788       return &gfc_bad_expr;
3789     }
3790
3791   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3792   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3793
3794   return range_check (result, "LOG10");
3795 }
3796
3797
3798 gfc_expr *
3799 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3800 {
3801   int kind;
3802
3803   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3804   if (kind < 0)
3805     return &gfc_bad_expr;
3806
3807   if (e->expr_type != EXPR_CONSTANT)
3808     return NULL;
3809
3810   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3811 }
3812
3813
3814 gfc_expr*
3815 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3816 {
3817   gfc_expr *result;
3818   int row, result_rows, col, result_columns;
3819   int stride_a, offset_a, stride_b, offset_b;
3820
3821   if (!is_constant_array_expr (matrix_a)
3822       || !is_constant_array_expr (matrix_b))
3823     return NULL;
3824
3825   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3826   result = gfc_get_array_expr (matrix_a->ts.type,
3827                                matrix_a->ts.kind,
3828                                &matrix_a->where);
3829
3830   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3831     {
3832       result_rows = 1;
3833       result_columns = mpz_get_si (matrix_b->shape[0]);
3834       stride_a = 1;
3835       stride_b = mpz_get_si (matrix_b->shape[0]);
3836
3837       result->rank = 1;
3838       result->shape = gfc_get_shape (result->rank);
3839       mpz_init_set_si (result->shape[0], result_columns);
3840     }
3841   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3842     {
3843       result_rows = mpz_get_si (matrix_b->shape[0]);
3844       result_columns = 1;
3845       stride_a = mpz_get_si (matrix_a->shape[0]);
3846       stride_b = 1;
3847
3848       result->rank = 1;
3849       result->shape = gfc_get_shape (result->rank);
3850       mpz_init_set_si (result->shape[0], result_rows);
3851     }
3852   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3853     {
3854       result_rows = mpz_get_si (matrix_a->shape[0]);
3855       result_columns = mpz_get_si (matrix_b->shape[1]);
3856       stride_a = mpz_get_si (matrix_a->shape[1]);
3857       stride_b = mpz_get_si (matrix_b->shape[0]);
3858
3859       result->rank = 2;
3860       result->shape = gfc_get_shape (result->rank);
3861       mpz_init_set_si (result->shape[0], result_rows);
3862       mpz_init_set_si (result->shape[1], result_columns);
3863     }
3864   else
3865     gcc_unreachable();
3866
3867   offset_a = offset_b = 0;
3868   for (col = 0; col < result_columns; ++col)
3869     {
3870       offset_a = 0;
3871
3872       for (row = 0; row < result_rows; ++row)
3873         {
3874           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3875                                              matrix_b, 1, offset_b);
3876           gfc_constructor_append_expr (&result->value.constructor,
3877                                        e, NULL);
3878
3879           offset_a += 1;
3880         }
3881
3882       offset_b += stride_b;
3883     }
3884
3885   return result;
3886 }
3887
3888
3889 gfc_expr *
3890 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
3891 {
3892   gfc_expr *result;
3893   int kind, arg, k;
3894   const char *s;
3895
3896   if (i->expr_type != EXPR_CONSTANT)
3897     return NULL;
3898
3899   kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
3900   if (kind == -1)
3901     return &gfc_bad_expr;
3902   k = gfc_validate_kind (BT_INTEGER, kind, false);
3903
3904   s = gfc_extract_int (i, &arg);
3905   gcc_assert (!s);
3906
3907   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3908
3909   /* MASKR(n) = 2^n - 1 */
3910   mpz_set_ui (result->value.integer, 1);
3911   mpz_mul_2exp (result->value.integer, result->value.integer, arg);
3912   mpz_sub_ui (result->value.integer, result->value.integer, 1);
3913
3914   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3915
3916   return result;
3917 }
3918
3919
3920 gfc_expr *
3921 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
3922 {
3923   gfc_expr *result;
3924   int kind, arg, k;
3925   const char *s;
3926   mpz_t z;
3927
3928   if (i->expr_type != EXPR_CONSTANT)
3929     return NULL;
3930
3931   kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
3932   if (kind == -1)
3933     return &gfc_bad_expr;
3934   k = gfc_validate_kind (BT_INTEGER, kind, false);
3935
3936   s = gfc_extract_int (i, &arg);
3937   gcc_assert (!s);
3938
3939   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3940
3941   /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3942   mpz_init_set_ui (z, 1);
3943   mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
3944   mpz_set_ui (result->value.integer, 1);
3945   mpz_mul_2exp (result->value.integer, result->value.integer,
3946                 gfc_integer_kinds[k].bit_size - arg);
3947   mpz_sub (result->value.integer, z, result->value.integer);
3948   mpz_clear (z);
3949
3950   convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3951
3952   return result;
3953 }
3954
3955
3956 gfc_expr *
3957 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3958 {
3959   if (tsource->expr_type != EXPR_CONSTANT
3960       || fsource->expr_type != EXPR_CONSTANT
3961       || mask->expr_type != EXPR_CONSTANT)
3962     return NULL;
3963
3964   return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3965 }
3966
3967
3968 gfc_expr *
3969 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
3970 {
3971   mpz_t arg1, arg2, mask;
3972   gfc_expr *result;
3973
3974   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
3975       || mask_expr->expr_type != EXPR_CONSTANT)
3976     return NULL;
3977
3978   result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
3979
3980   /* Convert all argument to unsigned.  */
3981   mpz_init_set (arg1, i->value.integer);
3982   mpz_init_set (arg2, j->value.integer);
3983   mpz_init_set (mask, mask_expr->value.integer);
3984
3985   /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
3986   mpz_and (arg1, arg1, mask);
3987   mpz_com (mask, mask);
3988   mpz_and (arg2, arg2, mask);
3989   mpz_ior (result->value.integer, arg1, arg2);
3990
3991   mpz_clear (arg1);
3992   mpz_clear (arg2);
3993   mpz_clear (mask);
3994
3995   return result;
3996 }
3997
3998
3999 /* Selects between current value and extremum for simplify_min_max
4000    and simplify_minval_maxval.  */
4001 static void
4002 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4003 {
4004   switch (arg->ts.type)
4005     {
4006       case BT_INTEGER:
4007         if (mpz_cmp (arg->value.integer,
4008                         extremum->value.integer) * sign > 0)
4009         mpz_set (extremum->value.integer, arg->value.integer);
4010         break;
4011
4012       case BT_REAL:
4013         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
4014         if (sign > 0)
4015           mpfr_max (extremum->value.real, extremum->value.real,
4016                       arg->value.real, GFC_RND_MODE);
4017         else
4018           mpfr_min (extremum->value.real, extremum->value.real,
4019                       arg->value.real, GFC_RND_MODE);
4020         break;
4021
4022       case BT_CHARACTER:
4023 #define LENGTH(x) ((x)->value.character.length)
4024 #define STRING(x) ((x)->value.character.string)
4025         if (LENGTH(extremum) < LENGTH(arg))
4026           {
4027             gfc_char_t *tmp = STRING(extremum);
4028
4029             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4030             memcpy (STRING(extremum), tmp,
4031                       LENGTH(extremum) * sizeof (gfc_char_t));
4032             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4033                                LENGTH(arg) - LENGTH(extremum));
4034             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
4035             LENGTH(extremum) = LENGTH(arg);
4036             free (tmp);
4037           }
4038
4039         if (gfc_compare_string (arg, extremum) * sign > 0)
4040           {
4041             free (STRING(extremum));
4042             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4043             memcpy (STRING(extremum), STRING(arg),
4044                       LENGTH(arg) * sizeof (gfc_char_t));
4045             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4046                                LENGTH(extremum) - LENGTH(arg));
4047             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
4048           }
4049 #undef LENGTH
4050 #undef STRING
4051         break;
4052
4053       default:
4054         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4055     }
4056 }
4057
4058
4059 /* This function is special since MAX() can take any number of
4060    arguments.  The simplified expression is a rewritten version of the
4061    argument list containing at most one constant element.  Other
4062    constant elements are deleted.  Because the argument list has
4063    already been checked, this function always succeeds.  sign is 1 for
4064    MAX(), -1 for MIN().  */
4065
4066 static gfc_expr *
4067 simplify_min_max (gfc_expr *expr, int sign)
4068 {
4069   gfc_actual_arglist *arg, *last, *extremum;
4070   gfc_intrinsic_sym * specific;
4071
4072   last = NULL;
4073   extremum = NULL;
4074   specific = expr->value.function.isym;
4075
4076   arg = expr->value.function.actual;
4077
4078   for (; arg; last = arg, arg = arg->next)
4079     {
4080       if (arg->expr->expr_type != EXPR_CONSTANT)
4081         continue;
4082
4083       if (extremum == NULL)
4084         {
4085           extremum = arg;
4086           continue;
4087         }
4088
4089       min_max_choose (arg->expr, extremum->expr, sign);
4090
4091       /* Delete the extra constant argument.  */
4092       if (last == NULL)
4093         expr->value.function.actual = arg->next;
4094       else
4095         last->next = arg->next;
4096
4097       arg->next = NULL;
4098       gfc_free_actual_arglist (arg);
4099       arg = last;
4100     }
4101
4102   /* If there is one value left, replace the function call with the
4103      expression.  */
4104   if (expr->value.function.actual->next != NULL)
4105     return NULL;
4106
4107   /* Convert to the correct type and kind.  */
4108   if (expr->ts.type != BT_UNKNOWN)
4109     return gfc_convert_constant (expr->value.function.actual->expr,
4110         expr->ts.type, expr->ts.kind);
4111
4112   if (specific->ts.type != BT_UNKNOWN)
4113     return gfc_convert_constant (expr->value.function.actual->expr,
4114         specific->ts.type, specific->ts.kind);
4115
4116   return gfc_copy_expr (expr->value.function.actual->expr);
4117 }
4118
4119
4120 gfc_expr *
4121 gfc_simplify_min (gfc_expr *e)
4122 {
4123   return simplify_min_max (e, -1);
4124 }
4125
4126
4127 gfc_expr *
4128 gfc_simplify_max (gfc_expr *e)
4129 {
4130   return simplify_min_max (e, 1);
4131 }
4132
4133
4134 /* This is a simplified version of simplify_min_max to provide
4135    simplification of minval and maxval for a vector.  */
4136
4137 static gfc_expr *
4138 simplify_minval_maxval (gfc_expr *expr, int sign)
4139 {
4140   gfc_constructor *c, *extremum;
4141   gfc_intrinsic_sym * specific;
4142
4143   extremum = NULL;
4144   specific = expr->value.function.isym;
4145
4146   for (c = gfc_constructor_first (expr->value.constructor);
4147        c; c = gfc_constructor_next (c))
4148     {
4149       if (c->expr->expr_type != EXPR_CONSTANT)
4150         return NULL;
4151
4152       if (extremum == NULL)
4153         {
4154           extremum = c;
4155           continue;
4156         }
4157
4158       min_max_choose (c->expr, extremum->expr, sign);
4159      }
4160
4161   if (extremum == NULL)
4162     return NULL;
4163
4164   /* Convert to the correct type and kind.  */
4165   if (expr->ts.type != BT_UNKNOWN)
4166     return gfc_convert_constant (extremum->expr,
4167         expr->ts.type, expr->ts.kind);
4168
4169   if (specific->ts.type != BT_UNKNOWN)
4170     return gfc_convert_constant (extremum->expr,
4171         specific->ts.type, specific->ts.kind);
4172
4173   return gfc_copy_expr (extremum->expr);
4174 }
4175
4176
4177 gfc_expr *
4178 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4179 {
4180   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4181     return NULL;
4182
4183   return simplify_minval_maxval (array, -1);
4184 }
4185
4186
4187 gfc_expr *
4188 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4189 {
4190   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4191     return NULL;
4192
4193   return simplify_minval_maxval (array, 1);
4194 }
4195
4196
4197 gfc_expr *
4198 gfc_simplify_maxexponent (gfc_expr *x)
4199 {
4200   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4201   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4202                            gfc_real_kinds[i].max_exponent);
4203 }
4204
4205
4206 gfc_expr *
4207 gfc_simplify_minexponent (gfc_expr *x)
4208 {
4209   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4210   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4211                            gfc_real_kinds[i].min_exponent);
4212 }
4213
4214
4215 gfc_expr *
4216 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4217 {
4218   gfc_expr *result;
4219   mpfr_t tmp;
4220   int kind;
4221
4222   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4223     return NULL;
4224
4225   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4226   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4227
4228   switch (a->ts.type)
4229     {
4230       case BT_INTEGER:
4231         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4232           {
4233             /* Result is processor-dependent.  */
4234             gfc_error ("Second argument MOD at %L is zero", &a->where);
4235             gfc_free_expr (result);
4236             return &gfc_bad_expr;
4237           }
4238         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4239         break;
4240
4241       case BT_REAL:
4242         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4243           {
4244             /* Result is processor-dependent.  */
4245             gfc_error ("Second argument of MOD at %L is zero", &p->where);
4246             gfc_free_expr (result);
4247             return &gfc_bad_expr;
4248           }
4249
4250         gfc_set_model_kind (kind);
4251         mpfr_init (tmp);
4252         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
4253         mpfr_trunc (tmp, tmp);
4254         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
4255         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
4256         mpfr_clear (tmp);
4257         break;
4258
4259       default:
4260         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4261     }
4262
4263   return range_check (result, "MOD");
4264 }
4265
4266
4267 gfc_expr *
4268 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4269 {
4270   gfc_expr *result;
4271   mpfr_t tmp;
4272   int kind;
4273
4274   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4275     return NULL;
4276
4277   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4278   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4279
4280   switch (a->ts.type)
4281     {
4282       case BT_INTEGER:
4283         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4284           {
4285             /* Result is processor-dependent. This processor just opts
4286               to not handle it at all.  */
4287             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4288             gfc_free_expr (result);
4289             return &gfc_bad_expr;
4290           }
4291         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4292
4293         break;
4294
4295       case BT_REAL:
4296         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4297           {
4298             /* Result is processor-dependent.  */
4299             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4300             gfc_free_expr (result);
4301             return &gfc_bad_expr;
4302           }
4303
4304         gfc_set_model_kind (kind);
4305         mpfr_init (tmp);
4306         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
4307         mpfr_floor (tmp, tmp);
4308         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
4309         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
4310         mpfr_clear (tmp);
4311         break;
4312
4313       default:
4314         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4315     }
4316
4317   return range_check (result, "MODULO");
4318 }
4319
4320
4321 /* Exists for the sole purpose of consistency with other intrinsics.  */
4322 gfc_expr *
4323 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
4324                      gfc_expr *fp ATTRIBUTE_UNUSED,
4325                      gfc_expr *l  ATTRIBUTE_UNUSED,
4326                      gfc_expr *to ATTRIBUTE_UNUSED,
4327                      gfc_expr *tp ATTRIBUTE_UNUSED)
4328 {
4329   return NULL;
4330 }
4331
4332
4333 gfc_expr *
4334 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4335 {
4336   gfc_expr *result;
4337   mp_exp_t emin, emax;
4338   int kind;
4339
4340   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4341     return NULL;
4342
4343   result = gfc_copy_expr (x);
4344
4345   /* Save current values of emin and emax.  */
4346   emin = mpfr_get_emin ();
4347   emax = mpfr_get_emax ();
4348
4349   /* Set emin and emax for the current model number.  */
4350   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4351   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4352                 mpfr_get_prec(result->value.real) + 1);
4353   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4354   mpfr_check_range (result->value.real, 0, GMP_RNDU);
4355
4356   if (mpfr_sgn (s->value.real) > 0)
4357     {
4358       mpfr_nextabove (result->value.real);
4359       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4360     }
4361   else
4362     {
4363       mpfr_nextbelow (result->value.real);
4364       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4365     }
4366
4367   mpfr_set_emin (emin);
4368   mpfr_set_emax (emax);
4369
4370   /* Only NaN can occur. Do not use range check as it gives an
4371      error for denormal numbers.  */
4372   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
4373     {
4374       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4375       gfc_free_expr (result);
4376       return &gfc_bad_expr;
4377     }
4378
4379   return result;
4380 }
4381
4382
4383 static gfc_expr *
4384 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4385 {
4386   gfc_expr *itrunc, *result;
4387   int kind;
4388
4389   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4390   if (kind == -1)
4391     return &gfc_bad_expr;
4392
4393   if (e->expr_type != EXPR_CONSTANT)
4394     return NULL;
4395
4396   itrunc = gfc_copy_expr (e);
4397   mpfr_round (itrunc->value.real, e->value.real);
4398
4399   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4400   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4401
4402   gfc_free_expr (itrunc);
4403
4404   return range_check (result, name);
4405 }
4406
4407
4408 gfc_expr *
4409 gfc_simplify_new_line (gfc_expr *e)
4410 {
4411   gfc_expr *result;
4412
4413   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4414   result->value.character.string[0] = '\n';
4415
4416   return result;
4417 }
4418
4419
4420 gfc_expr *
4421 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4422 {
4423   return simplify_nint ("NINT", e, k);
4424 }
4425
4426
4427 gfc_expr *
4428 gfc_simplify_idnint (gfc_expr *e)
4429 {
4430   return simplify_nint ("IDNINT", e, NULL);
4431 }
4432
4433
4434 static gfc_expr *
4435 add_squared (gfc_expr *result, gfc_expr *e)
4436 {
4437   mpfr_t tmp;
4438
4439   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4440   gcc_assert (result->ts.type == BT_REAL
4441               && result->expr_type == EXPR_CONSTANT);
4442
4443   gfc_set_model_kind (result->ts.kind);
4444   mpfr_init (tmp);
4445   mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4446   mpfr_add (result->value.real, result->value.real, tmp,
4447             GFC_RND_MODE);
4448   mpfr_clear (tmp);
4449
4450   return result;
4451 }
4452
4453
4454 static gfc_expr *
4455 do_sqrt (gfc_expr *result, gfc_expr *e)
4456 {
4457   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4458   gcc_assert (result->ts.type == BT_REAL
4459               && result->expr_type == EXPR_CONSTANT);
4460
4461   mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4462   mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4463   return result;
4464 }
4465
4466
4467 gfc_expr *
4468 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4469 {
4470   gfc_expr *result;
4471
4472   if (!is_constant_array_expr (e)
4473       || (dim != NULL && !gfc_is_constant_expr (dim)))
4474     return NULL;
4475
4476   result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4477   init_result_expr (result, 0, NULL);
4478
4479   if (!dim || e->rank == 1)
4480     {
4481       result = simplify_transformation_to_scalar (result, e, NULL,
4482                                                   add_squared);
4483       mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4484     }
4485   else
4486     result = simplify_transformation_to_array (result, e, dim, NULL,
4487                                                add_squared, &do_sqrt);
4488
4489   return result;
4490 }
4491
4492
4493 gfc_expr *
4494 gfc_simplify_not (gfc_expr *e)
4495 {
4496   gfc_expr *result;
4497
4498   if (e->expr_type != EXPR_CONSTANT)
4499     return NULL;
4500
4501   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4502   mpz_com (result->value.integer, e->value.integer);
4503
4504   return range_check (result, "NOT");
4505 }
4506
4507
4508 gfc_expr *
4509 gfc_simplify_null (gfc_expr *mold)
4510 {
4511   gfc_expr *result;
4512
4513   if (mold)
4514     {
4515       result = gfc_copy_expr (mold);
4516       result->expr_type = EXPR_NULL;
4517     }
4518   else
4519     result = gfc_get_null_expr (NULL);
4520
4521   return result;
4522 }
4523
4524
4525 gfc_expr *
4526 gfc_simplify_num_images (void)
4527 {
4528   gfc_expr *result;
4529
4530   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4531     {
4532       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4533       return &gfc_bad_expr;
4534     }
4535
4536   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
4537     return NULL;
4538
4539   /* FIXME: gfc_current_locus is wrong.  */
4540   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4541                                   &gfc_current_locus);
4542   mpz_set_si (result->value.integer, 1);
4543   return result;
4544 }
4545
4546
4547 gfc_expr *
4548 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4549 {
4550   gfc_expr *result;
4551   int kind;
4552
4553   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4554     return NULL;
4555
4556   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4557
4558   switch (x->ts.type)
4559     {
4560       case BT_INTEGER:
4561         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4562         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4563         return range_check (result, "OR");
4564
4565       case BT_LOGICAL:
4566         return gfc_get_logical_expr (kind, &x->where,
4567                                      x->value.logical || y->value.logical);
4568       default:
4569         gcc_unreachable();
4570     }
4571 }
4572
4573
4574 gfc_expr *
4575 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4576 {
4577   gfc_expr *result;
4578   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4579
4580   if (!is_constant_array_expr(array)
4581       || !is_constant_array_expr(vector)
4582       || (!gfc_is_constant_expr (mask)
4583           && !is_constant_array_expr(mask)))
4584     return NULL;
4585
4586   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4587   if (array->ts.type == BT_DERIVED)
4588     result->ts.u.derived = array->ts.u.derived;
4589
4590   array_ctor = gfc_constructor_first (array->value.constructor);
4591   vector_ctor = vector
4592                   ? gfc_constructor_first (vector->value.constructor)
4593                   : NULL;
4594
4595   if (mask->expr_type == EXPR_CONSTANT
4596       && mask->value.logical)
4597     {
4598       /* Copy all elements of ARRAY to RESULT.  */
4599       while (array_ctor)
4600         {
4601           gfc_constructor_append_expr (&result->value.constructor,
4602                                        gfc_copy_expr (array_ctor->expr),
4603                                        NULL);
4604
4605           array_ctor = gfc_constructor_next (array_ctor);
4606           vector_ctor = gfc_constructor_next (vector_ctor);
4607         }
4608     }
4609   else if (mask->expr_type == EXPR_ARRAY)
4610     {
4611       /* Copy only those elements of ARRAY to RESULT whose
4612          MASK equals .TRUE..  */
4613       mask_ctor = gfc_constructor_first (mask->value.constructor);
4614       while (mask_ctor)
4615         {
4616           if (mask_ctor->expr->value.logical)
4617             {
4618               gfc_constructor_append_expr (&result->value.constructor,
4619                                            gfc_copy_expr (array_ctor->expr),
4620                                            NULL);
4621               vector_ctor = gfc_constructor_next (vector_ctor);
4622             }
4623
4624           array_ctor = gfc_constructor_next (array_ctor);
4625           mask_ctor = gfc_constructor_next (mask_ctor);
4626         }
4627     }
4628
4629   /* Append any left-over elements from VECTOR to RESULT.  */
4630   while (vector_ctor)
4631     {
4632       gfc_constructor_append_expr (&result->value.constructor,
4633                                    gfc_copy_expr (vector_ctor->expr),
4634                                    NULL);
4635       vector_ctor = gfc_constructor_next (vector_ctor);
4636     }
4637
4638   result->shape = gfc_get_shape (1);
4639   gfc_array_size (result, &result->shape[0]);
4640
4641   if (array->ts.type == BT_CHARACTER)
4642     result->ts.u.cl = array->ts.u.cl;
4643
4644   return result;
4645 }
4646
4647
4648 static gfc_expr *
4649 do_xor (gfc_expr *result, gfc_expr *e)
4650 {
4651   gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
4652   gcc_assert (result->ts.type == BT_LOGICAL
4653               && result->expr_type == EXPR_CONSTANT);
4654
4655   result->value.logical = result->value.logical != e->value.logical;
4656   return result;
4657 }
4658
4659
4660
4661 gfc_expr *
4662 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
4663 {
4664   return simplify_transformation (e, dim, NULL, 0, do_xor);
4665 }
4666
4667
4668 gfc_expr *
4669 gfc_simplify_popcnt (gfc_expr *e)
4670 {
4671   int res, k;
4672   mpz_t x;
4673
4674   if (e->expr_type != EXPR_CONSTANT)
4675     return NULL;
4676
4677   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4678
4679   /* Convert argument to unsigned, then count the '1' bits.  */
4680   mpz_init_set (x, e->value.integer);
4681   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
4682   res = mpz_popcount (x);
4683   mpz_clear (x);
4684
4685   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
4686 }
4687
4688
4689 gfc_expr *
4690 gfc_simplify_poppar (gfc_expr *e)
4691 {
4692   gfc_expr *popcnt;
4693   const char *s;
4694   int i;
4695
4696   if (e->expr_type != EXPR_CONSTANT)
4697     return NULL;
4698
4699   popcnt = gfc_simplify_popcnt (e);
4700   gcc_assert (popcnt);
4701
4702   s = gfc_extract_int (popcnt, &i);
4703   gcc_assert (!s);
4704
4705   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
4706 }
4707
4708
4709 gfc_expr *
4710 gfc_simplify_precision (gfc_expr *e)
4711 {
4712   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4713   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4714                            gfc_real_kinds[i].precision);
4715 }
4716
4717
4718 gfc_expr *
4719 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4720 {
4721   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
4722 }
4723
4724
4725 gfc_expr *
4726 gfc_simplify_radix (gfc_expr *e)
4727 {
4728   int i;
4729   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4730
4731   switch (e->ts.type)
4732     {
4733       case BT_INTEGER:
4734         i = gfc_integer_kinds[i].radix;
4735         break;
4736
4737       case BT_REAL:
4738         i = gfc_real_kinds[i].radix;
4739         break;
4740
4741       default:
4742         gcc_unreachable ();
4743     }
4744
4745   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4746 }
4747
4748
4749 gfc_expr *
4750 gfc_simplify_range (gfc_expr *e)
4751 {
4752   int i;
4753   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4754
4755   switch (e->ts.type)
4756     {
4757       case BT_INTEGER:
4758         i = gfc_integer_kinds[i].range;
4759         break;
4760
4761       case BT_REAL:
4762       case BT_COMPLEX:
4763         i = gfc_real_kinds[i].range;
4764         break;
4765
4766       default:
4767         gcc_unreachable ();
4768     }
4769
4770   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4771 }
4772
4773
4774 gfc_expr *
4775 gfc_simplify_rank (gfc_expr *e)
4776 {
4777   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
4778 }
4779
4780
4781 gfc_expr *
4782 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4783 {
4784   gfc_expr *result = NULL;
4785   int kind;
4786
4787   if (e->ts.type == BT_COMPLEX)
4788     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4789   else
4790     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4791
4792   if (kind == -1)
4793     return &gfc_bad_expr;
4794
4795   if (e->expr_type != EXPR_CONSTANT)
4796     return NULL;
4797
4798   if (convert_boz (e, kind) == &gfc_bad_expr)
4799     return &gfc_bad_expr;
4800
4801   result = gfc_convert_constant (e, BT_REAL, kind);
4802   if (result == &gfc_bad_expr)
4803     return &gfc_bad_expr;
4804
4805   return range_check (result, "REAL");
4806 }
4807
4808
4809 gfc_expr *
4810 gfc_simplify_realpart (gfc_expr *e)
4811 {
4812   gfc_expr *result;
4813
4814   if (e->expr_type != EXPR_CONSTANT)
4815     return NULL;
4816
4817   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4818   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4819
4820   return range_check (result, "REALPART");
4821 }
4822
4823 gfc_expr *
4824 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4825 {
4826   gfc_expr *result;
4827   int i, j, len, ncop, nlen;
4828   mpz_t ncopies;
4829   bool have_length = false;
4830
4831   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4832   if (n->expr_type != EXPR_CONSTANT)
4833     return NULL;
4834
4835   /* If NCOPIES is negative, it's an error.  */
4836   if (mpz_sgn (n->value.integer) < 0)
4837     {
4838       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4839                  &n->where);
4840       return &gfc_bad_expr;
4841     }
4842
4843   /* If we don't know the character length, we can do no more.  */
4844   if (e->ts.u.cl && e->ts.u.cl->length
4845         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4846     {
4847       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4848       have_length = true;
4849     }
4850   else if (e->expr_type == EXPR_CONSTANT
4851              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4852     {
4853       len = e->value.character.length;
4854     }
4855   else
4856     return NULL;
4857
4858   /* If the source length is 0, any value of NCOPIES is valid
4859      and everything behaves as if NCOPIES == 0.  */
4860   mpz_init (ncopies);
4861   if (len == 0)
4862     mpz_set_ui (ncopies, 0);
4863   else
4864     mpz_set (ncopies, n->value.integer);
4865
4866   /* Check that NCOPIES isn't too large.  */
4867   if (len)
4868     {
4869       mpz_t max, mlen;
4870       int i;
4871
4872       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4873       mpz_init (max);
4874       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4875
4876       if (have_length)
4877         {
4878           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4879                       e->ts.u.cl->length->value.integer);
4880         }
4881       else
4882         {
4883           mpz_init_set_si (mlen, len);
4884           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4885           mpz_clear (mlen);
4886         }
4887
4888       /* The check itself.  */
4889       if (mpz_cmp (ncopies, max) > 0)
4890         {
4891           mpz_clear (max);
4892           mpz_clear (ncopies);
4893           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4894                      &n->where);
4895           return &gfc_bad_expr;
4896         }
4897
4898       mpz_clear (max);
4899     }
4900   mpz_clear (ncopies);
4901
4902   /* For further simplification, we need the character string to be
4903      constant.  */
4904   if (e->expr_type != EXPR_CONSTANT)
4905     return NULL;
4906
4907   if (len ||
4908       (e->ts.u.cl->length &&
4909        mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4910     {
4911       const char *res = gfc_extract_int (n, &ncop);
4912       gcc_assert (res == NULL);
4913     }
4914   else
4915     ncop = 0;
4916
4917   len = e->value.character.length;
4918   nlen = ncop * len;
4919
4920   result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4921
4922   if (ncop == 0)
4923     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4924
4925   len = e->value.character.length;
4926   nlen = ncop * len;
4927
4928   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4929   for (i = 0; i < ncop; i++)
4930     for (j = 0; j < len; j++)
4931       result->value.character.string[j+i*len]= e->value.character.string[j];
4932
4933   result->value.character.string[nlen] = '\0';  /* For debugger */
4934   return result;
4935 }
4936
4937
4938 /* This one is a bear, but mainly has to do with shuffling elements.  */
4939
4940 gfc_expr *
4941 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4942                       gfc_expr *pad, gfc_expr *order_exp)
4943 {
4944   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4945   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4946   mpz_t index, size;
4947   unsigned long j;
4948   size_t nsource;
4949   gfc_expr *e, *result;
4950
4951   /* Check that argument expression types are OK.  */
4952   if (!is_constant_array_expr (source)
4953       || !is_constant_array_expr (shape_exp)
4954       || !is_constant_array_expr (pad)
4955       || !is_constant_array_expr (order_exp))
4956     return NULL;
4957
4958   /* Proceed with simplification, unpacking the array.  */
4959
4960   mpz_init (index);
4961   rank = 0;
4962
4963   for (;;)
4964     {
4965       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4966       if (e == NULL)
4967         break;
4968
4969       gfc_extract_int (e, &shape[rank]);
4970
4971       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4972       gcc_assert (shape[rank] >= 0);
4973
4974       rank++;
4975     }
4976
4977   gcc_assert (rank > 0);
4978
4979   /* Now unpack the order array if present.  */
4980   if (order_exp == NULL)
4981     {
4982       for (i = 0; i < rank; i++)
4983         order[i] = i;
4984     }
4985   else
4986     {
4987       for (i = 0; i < rank; i++)
4988         x[i] = 0;
4989
4990       for (i = 0; i < rank; i++)
4991         {
4992           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4993           gcc_assert (e);
4994
4995           gfc_extract_int (e, &order[i]);
4996
4997           gcc_assert (order[i] >= 1 && order[i] <= rank);
4998           order[i]--;
4999           gcc_assert (x[order[i]] == 0);
5000           x[order[i]] = 1;
5001         }
5002     }
5003
5004   /* Count the elements in the source and padding arrays.  */
5005
5006   npad = 0;
5007   if (pad != NULL)
5008     {
5009       gfc_array_size (pad, &size);
5010       npad = mpz_get_ui (size);
5011       mpz_clear (size);
5012     }
5013
5014   gfc_array_size (source, &size);
5015   nsource = mpz_get_ui (size);
5016   mpz_clear (size);
5017
5018   /* If it weren't for that pesky permutation we could just loop
5019      through the source and round out any shortage with pad elements.
5020      But no, someone just had to have the compiler do something the
5021      user should be doing.  */
5022
5023   for (i = 0; i < rank; i++)
5024     x[i] = 0;
5025
5026   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5027                                &source->where);
5028   if (source->ts.type == BT_DERIVED)
5029     result->ts.u.derived = source->ts.u.derived;
5030   result->rank = rank;
5031   result->shape = gfc_get_shape (rank);
5032   for (i = 0; i < rank; i++)
5033     mpz_init_set_ui (result->shape[i], shape[i]);
5034
5035   while (nsource > 0 || npad > 0)
5036     {
5037       /* Figure out which element to extract.  */
5038       mpz_set_ui (index, 0);
5039
5040       for (i = rank - 1; i >= 0; i--)
5041         {
5042           mpz_add_ui (index, index, x[order[i]]);
5043           if (i != 0)
5044             mpz_mul_ui (index, index, shape[order[i - 1]]);
5045         }
5046
5047       if (mpz_cmp_ui (index, INT_MAX) > 0)
5048         gfc_internal_error ("Reshaped array too large at %C");
5049
5050       j = mpz_get_ui (index);
5051
5052       if (j < nsource)
5053         e = gfc_constructor_lookup_expr (source->value.constructor, j);
5054       else
5055         {
5056           gcc_assert (npad > 0);
5057
5058           j = j - nsource;
5059           j = j % npad;
5060           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5061         }
5062       gcc_assert (e);
5063
5064       gfc_constructor_append_expr (&result->value.constructor,
5065                                    gfc_copy_expr (e), &e->where);
5066
5067       /* Calculate the next element.  */
5068       i = 0;
5069
5070 inc:
5071       if (++x[i] < shape[i])
5072         continue;
5073       x[i++] = 0;
5074       if (i < rank)
5075         goto inc;
5076
5077       break;
5078     }
5079
5080   mpz_clear (index);
5081
5082   return result;
5083 }
5084
5085
5086 gfc_expr *
5087 gfc_simplify_rrspacing (gfc_expr *x)
5088 {
5089   gfc_expr *result;
5090   int i;
5091   long int e, p;
5092
5093   if (x->expr_type != EXPR_CONSTANT)
5094     return NULL;
5095
5096   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5097
5098   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5099   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5100
5101   /* Special case x = -0 and 0.  */
5102   if (mpfr_sgn (result->value.real) == 0)
5103     {
5104       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5105       return result;
5106     }
5107
5108   /* | x * 2**(-e) | * 2**p.  */
5109   e = - (long int) mpfr_get_exp (x->value.real);
5110   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5111
5112   p = (long int) gfc_real_kinds[i].digits;
5113   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5114
5115   return range_check (result, "RRSPACING");
5116 }
5117
5118
5119 gfc_expr *
5120 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5121 {
5122   int k, neg_flag, power, exp_range;
5123   mpfr_t scale, radix;
5124   gfc_expr *result;
5125
5126   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5127     return NULL;
5128
5129   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5130
5131   if (mpfr_sgn (x->value.real) == 0)
5132     {
5133       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5134       return result;
5135     }
5136
5137   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5138
5139   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5140
5141   /* This check filters out values of i that would overflow an int.  */
5142   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5143       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5144     {
5145       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5146       gfc_free_expr (result);
5147       return &gfc_bad_expr;
5148     }
5149
5150   /* Compute scale = radix ** power.  */
5151   power = mpz_get_si (i->value.integer);
5152
5153   if (power >= 0)
5154     neg_flag = 0;
5155   else
5156     {
5157       neg_flag = 1;
5158       power = -power;
5159     }
5160
5161   gfc_set_model_kind (x->ts.kind);
5162   mpfr_init (scale);
5163   mpfr_init (radix);
5164   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5165   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5166
5167   if (neg_flag)
5168     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5169   else
5170     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5171
5172   mpfr_clears (scale, radix, NULL);
5173
5174   return range_check (result, "SCALE");
5175 }
5176
5177
5178 /* Variants of strspn and strcspn that operate on wide characters.  */
5179
5180 static size_t
5181 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5182 {
5183   size_t i = 0;
5184   const gfc_char_t *c;
5185
5186   while (s1[i])
5187     {
5188       for (c = s2; *c; c++)
5189         {
5190           if (s1[i] == *c)
5191             break;
5192         }
5193       if (*c == '\0')
5194         break;
5195       i++;
5196     }
5197
5198   return i;
5199 }
5200
5201 static size_t
5202 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5203 {
5204   size_t i = 0;
5205   const gfc_char_t *c;
5206
5207   while (s1[i])
5208     {
5209       for (c = s2; *c; c++)
5210         {
5211           if (s1[i] == *c)
5212             break;
5213         }
5214       if (*c)
5215         break;
5216       i++;
5217     }
5218
5219   return i;
5220 }
5221
5222
5223 gfc_expr *
5224 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5225 {
5226   gfc_expr *result;
5227   int back;
5228   size_t i;
5229   size_t indx, len, lenc;
5230   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5231
5232   if (k == -1)
5233     return &gfc_bad_expr;
5234
5235   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
5236     return NULL;
5237
5238   if (b != NULL && b->value.logical != 0)
5239     back = 1;
5240   else
5241     back = 0;
5242
5243   len = e->value.character.length;
5244   lenc = c->value.character.length;
5245
5246   if (len == 0 || lenc == 0)
5247     {
5248       indx = 0;
5249     }
5250   else
5251     {
5252       if (back == 0)
5253         {
5254           indx = wide_strcspn (e->value.character.string,
5255                                c->value.character.string) + 1;
5256           if (indx > len)
5257             indx = 0;
5258         }
5259       else
5260         {
5261           i = 0;
5262           for (indx = len; indx > 0; indx--)
5263             {
5264               for (i = 0; i < lenc; i++)
5265                 {
5266                   if (c->value.character.string[i]
5267                       == e->value.character.string[indx - 1])
5268                     break;
5269                 }
5270               if (i < lenc)
5271                 break;
5272             }
5273         }
5274     }
5275
5276   result = gfc_get_int_expr (k, &e->where, indx);
5277   return range_check (result, "SCAN");
5278 }
5279
5280
5281 gfc_expr *
5282 gfc_simplify_selected_char_kind (gfc_expr *e)
5283 {
5284   int kind;
5285
5286   if (e->expr_type != EXPR_CONSTANT)
5287     return NULL;
5288
5289   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5290       || gfc_compare_with_Cstring (e, "default", false) == 0)
5291     kind = 1;
5292   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5293     kind = 4;
5294   else
5295     kind = -1;
5296
5297   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5298 }
5299
5300
5301 gfc_expr *
5302 gfc_simplify_selected_int_kind (gfc_expr *e)
5303 {
5304   int i, kind, range;
5305
5306   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5307     return NULL;
5308
5309   kind = INT_MAX;
5310
5311   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5312     if (gfc_integer_kinds[i].range >= range
5313         && gfc_integer_kinds[i].kind < kind)
5314       kind = gfc_integer_kinds[i].kind;
5315
5316   if (kind == INT_MAX)
5317     kind = -1;
5318
5319   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5320 }
5321
5322
5323 gfc_expr *
5324 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5325 {
5326   int range, precision, radix, i, kind, found_precision, found_range,
5327       found_radix;
5328   locus *loc = &gfc_current_locus;
5329
5330   if (p == NULL)
5331     precision = 0;
5332   else
5333     {
5334       if (p->expr_type != EXPR_CONSTANT
5335           || gfc_extract_int (p, &precision) != NULL)
5336         return NULL;
5337       loc = &p->where;
5338     }
5339
5340   if (q == NULL)
5341     range = 0;
5342   else
5343     {
5344       if (q->expr_type != EXPR_CONSTANT
5345           || gfc_extract_int (q, &range) != NULL)
5346         return NULL;
5347
5348       if (!loc)
5349         loc = &q->where;
5350     }
5351
5352   if (rdx == NULL)
5353     radix = 0;
5354   else
5355     {
5356       if (rdx->expr_type != EXPR_CONSTANT
5357           || gfc_extract_int (rdx, &radix) != NULL)
5358         return NULL;
5359
5360       if (!loc)
5361         loc = &rdx->where;
5362     }
5363
5364   kind = INT_MAX;
5365   found_precision = 0;
5366   found_range = 0;
5367   found_radix = 0;
5368
5369   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5370     {
5371       if (gfc_real_kinds[i].precision >= precision)
5372         found_precision = 1;
5373
5374       if (gfc_real_kinds[i].range >= range)
5375         found_range = 1;
5376
5377       if (gfc_real_kinds[i].radix >= radix)
5378         found_radix = 1;
5379
5380       if (gfc_real_kinds[i].precision >= precision
5381           && gfc_real_kinds[i].range >= range
5382           && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
5383         kind = gfc_real_kinds[i].kind;
5384     }
5385
5386   if (kind == INT_MAX)
5387     {
5388       if (found_radix && found_range && !found_precision)
5389         kind = -1;
5390       else if (found_radix && found_precision && !found_range)
5391         kind = -2;
5392       else if (found_radix && !found_precision && !found_range)
5393         kind = -3;
5394       else if (found_radix)
5395         kind = -4;
5396       else
5397         kind = -5;
5398     }
5399
5400   return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5401 }
5402
5403
5404 gfc_expr *
5405 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5406 {
5407   gfc_expr *result;
5408   mpfr_t exp, absv, log2, pow2, frac;
5409   unsigned long exp2;
5410
5411   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5412     return NULL;
5413
5414   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5415
5416   if (mpfr_sgn (x->value.real) == 0)
5417     {
5418       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5419       return result;
5420     }
5421
5422   gfc_set_model_kind (x->ts.kind);
5423   mpfr_init (absv);
5424   mpfr_init (log2);
5425   mpfr_init (exp);
5426   mpfr_init (pow2);
5427   mpfr_init (frac);
5428
5429   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5430   mpfr_log2 (log2, absv, GFC_RND_MODE);
5431
5432   mpfr_trunc (log2, log2);
5433   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5434
5435   /* Old exponent value, and fraction.  */
5436   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5437
5438   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5439
5440   /* New exponent.  */
5441   exp2 = (unsigned long) mpz_get_d (i->value.integer);
5442   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5443
5444   mpfr_clears (absv, log2, pow2, frac, NULL);
5445
5446   return range_check (result, "SET_EXPONENT");
5447 }
5448
5449
5450 gfc_expr *
5451 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5452 {
5453   mpz_t shape[GFC_MAX_DIMENSIONS];
5454   gfc_expr *result, *e, *f;
5455   gfc_array_ref *ar;
5456   int n;
5457   gfc_try t;
5458   int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5459
5460   result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5461
5462   if (source->rank == 0)
5463     return result;
5464
5465   if (source->expr_type == EXPR_VARIABLE)
5466     {
5467       ar = gfc_find_array_ref (source);
5468       t = gfc_array_ref_shape (ar, shape);
5469     }
5470   else if (source->shape)
5471     {
5472       t = SUCCESS;
5473       for (n = 0; n < source->rank; n++)
5474         {
5475           mpz_init (shape[n]);
5476           mpz_set (shape[n], source->shape[n]);
5477         }
5478     }
5479   else
5480     t = FAILURE;
5481
5482   for (n = 0; n < source->rank; n++)
5483     {
5484       e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5485
5486       if (t == SUCCESS)
5487         {
5488           mpz_set (e->value.integer, shape[n]);
5489           mpz_clear (shape[n]);
5490         }
5491       else
5492         {
5493           mpz_set_ui (e->value.integer, n + 1);
5494
5495           f = gfc_simplify_size (source, e, NULL);
5496           gfc_free_expr (e);
5497           if (f == NULL)
5498             {
5499               gfc_free_expr (result);
5500               return NULL;
5501             }
5502           else
5503             e = f;
5504         }
5505
5506       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5507     }
5508
5509   return result;
5510 }
5511
5512
5513 gfc_expr *
5514 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5515 {
5516   mpz_t size;
5517   gfc_expr *return_value;
5518   int d;
5519   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5520
5521   if (k == -1)
5522     return &gfc_bad_expr;
5523
5524   /* For unary operations, the size of the result is given by the size
5525      of the operand.  For binary ones, it's the size of the first operand
5526      unless it is scalar, then it is the size of the second.  */
5527   if (array->expr_type == EXPR_OP && !array->value.op.uop)
5528     {
5529       gfc_expr* replacement;
5530       gfc_expr* simplified;
5531
5532       switch (array->value.op.op)
5533         {
5534           /* Unary operations.  */
5535           case INTRINSIC_NOT:
5536           case INTRINSIC_UPLUS:
5537           case INTRINSIC_UMINUS:
5538             replacement = array->value.op.op1;
5539             break;
5540
5541           /* Binary operations.  If any one of the operands is scalar, take
5542              the other one's size.  If both of them are arrays, it does not
5543              matter -- try to find one with known shape, if possible.  */
5544           default:
5545             if (array->value.op.op1->rank == 0)
5546               replacement = array->value.op.op2;
5547             else if (array->value.op.op2->rank == 0)
5548               replacement = array->value.op.op1;
5549             else
5550               {
5551                 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5552                 if (simplified)
5553                   return simplified;
5554
5555                 replacement = array->value.op.op2;
5556               }
5557             break;
5558         }
5559
5560       /* Try to reduce it directly if possible.  */
5561       simplified = gfc_simplify_size (replacement, dim, kind);
5562
5563       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5564          simpler than the original one.  */
5565       if (!simplified)
5566         simplified = gfc_build_intrinsic_call ("size", array->where, 3,
5567                                                gfc_copy_expr (replacement),
5568                                                gfc_copy_expr (dim),
5569                                                gfc_copy_expr (kind));
5570
5571       return simplified;
5572     }
5573
5574   if (dim == NULL)
5575     {
5576       if (gfc_array_size (array, &size) == FAILURE)
5577         return NULL;
5578     }
5579   else
5580     {
5581       if (dim->expr_type != EXPR_CONSTANT)
5582         return NULL;
5583
5584       d = mpz_get_ui (dim->value.integer) - 1;
5585       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
5586         return NULL;
5587     }
5588
5589   return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5590   mpz_clear (size);
5591   return return_value;
5592 }
5593
5594
5595 gfc_expr *
5596 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5597 {
5598   gfc_expr *result;
5599
5600   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5601     return NULL;
5602
5603   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5604
5605   switch (x->ts.type)
5606     {
5607       case BT_INTEGER:
5608         mpz_abs (result->value.integer, x->value.integer);
5609         if (mpz_sgn (y->value.integer) < 0)
5610           mpz_neg (result->value.integer, result->value.integer);
5611         break;
5612
5613       case BT_REAL:
5614         if (gfc_option.flag_sign_zero)
5615           mpfr_copysign (result->value.real, x->value.real, y->value.real,
5616                         GFC_RND_MODE);
5617         else
5618           mpfr_setsign (result->value.real, x->value.real,
5619                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5620         break;
5621
5622       default:
5623         gfc_internal_error ("Bad type in gfc_simplify_sign");
5624     }
5625
5626   return result;
5627 }
5628
5629
5630 gfc_expr *
5631 gfc_simplify_sin (gfc_expr *x)
5632 {
5633   gfc_expr *result;
5634
5635   if (x->expr_type != EXPR_CONSTANT)
5636     return NULL;
5637
5638   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5639
5640   switch (x->ts.type)
5641     {
5642       case BT_REAL:
5643         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5644         break;
5645
5646       case BT_COMPLEX:
5647         gfc_set_model (x->value.real);
5648         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5649         break;
5650
5651       default:
5652         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5653     }
5654
5655   return range_check (result, "SIN");
5656 }
5657
5658
5659 gfc_expr *
5660 gfc_simplify_sinh (gfc_expr *x)
5661 {
5662   gfc_expr *result;
5663
5664   if (x->expr_type != EXPR_CONSTANT)
5665     return NULL;
5666
5667   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5668
5669   switch (x->ts.type)
5670     {
5671       case BT_REAL:
5672         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5673         break;
5674
5675       case BT_COMPLEX:
5676         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5677         break;
5678
5679       default:
5680         gcc_unreachable ();
5681     }
5682
5683   return range_check (result, "SINH");
5684 }
5685
5686
5687 /* The argument is always a double precision real that is converted to
5688    single precision.  TODO: Rounding!  */
5689
5690 gfc_expr *
5691 gfc_simplify_sngl (gfc_expr *a)
5692 {
5693   gfc_expr *result;
5694
5695   if (a->expr_type != EXPR_CONSTANT)
5696     return NULL;
5697
5698   result = gfc_real2real (a, gfc_default_real_kind);
5699   return range_check (result, "SNGL");
5700 }
5701
5702
5703 gfc_expr *
5704 gfc_simplify_spacing (gfc_expr *x)
5705 {
5706   gfc_expr *result;
5707   int i;
5708   long int en, ep;
5709
5710   if (x->expr_type != EXPR_CONSTANT)
5711     return NULL;
5712
5713   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5714
5715   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5716
5717   /* Special case x = 0 and -0.  */
5718   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5719   if (mpfr_sgn (result->value.real) == 0)
5720     {
5721       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5722       return result;
5723     }
5724
5725   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5726      are the radix, exponent of x, and precision.  This excludes the
5727      possibility of subnormal numbers.  Fortran 2003 states the result is
5728      b**max(e - p, emin - 1).  */
5729
5730   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5731   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5732   en = en > ep ? en : ep;
5733
5734   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5735   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5736
5737   return range_check (result, "SPACING");
5738 }
5739
5740
5741 gfc_expr *
5742 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5743 {
5744   gfc_expr *result = 0L;
5745   int i, j, dim, ncopies;
5746   mpz_t size;
5747
5748   if ((!gfc_is_constant_expr (source)
5749        && !is_constant_array_expr (source))
5750       || !gfc_is_constant_expr (dim_expr)
5751       || !gfc_is_constant_expr (ncopies_expr))
5752     return NULL;
5753
5754   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5755   gfc_extract_int (dim_expr, &dim);
5756   dim -= 1;   /* zero-base DIM */
5757
5758   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5759   gfc_extract_int (ncopies_expr, &ncopies);
5760   ncopies = MAX (ncopies, 0);
5761
5762   /* Do not allow the array size to exceed the limit for an array
5763      constructor.  */
5764   if (source->expr_type == EXPR_ARRAY)
5765     {
5766       if (gfc_array_size (source, &size) == FAILURE)
5767         gfc_internal_error ("Failure getting length of a constant array.");
5768     }
5769   else
5770     mpz_init_set_ui (size, 1);
5771
5772   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5773     return NULL;
5774
5775   if (source->expr_type == EXPR_CONSTANT)
5776     {
5777       gcc_assert (dim == 0);
5778
5779       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5780                                    &source->where);
5781       if (source->ts.type == BT_DERIVED)
5782         result->ts.u.derived = source->ts.u.derived;
5783       result->rank = 1;
5784       result->shape = gfc_get_shape (result->rank);
5785       mpz_init_set_si (result->shape[0], ncopies);
5786
5787       for (i = 0; i < ncopies; ++i)
5788         gfc_constructor_append_expr (&result->value.constructor,
5789                                      gfc_copy_expr (source), NULL);
5790     }
5791   else if (source->expr_type == EXPR_ARRAY)
5792     {
5793       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5794       gfc_constructor *source_ctor;
5795
5796       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5797       gcc_assert (dim >= 0 && dim <= source->rank);
5798
5799       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5800                                    &source->where);
5801       if (source->ts.type == BT_DERIVED)
5802         result->ts.u.derived = source->ts.u.derived;
5803       result->rank = source->rank + 1;
5804       result->shape = gfc_get_shape (result->rank);
5805
5806       for (i = 0, j = 0; i < result->rank; ++i)
5807         {
5808           if (i != dim)
5809             mpz_init_set (result->shape[i], source->shape[j++]);
5810           else
5811             mpz_init_set_si (result->shape[i], ncopies);
5812
5813           extent[i] = mpz_get_si (result->shape[i]);
5814           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5815         }
5816
5817       offset = 0;
5818       for (source_ctor = gfc_constructor_first (source->value.constructor);
5819            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5820         {
5821           for (i = 0; i < ncopies; ++i)
5822             gfc_constructor_insert_expr (&result->value.constructor,
5823                                          gfc_copy_expr (source_ctor->expr),
5824                                          NULL, offset + i * rstride[dim]);
5825
5826           offset += (dim == 0 ? ncopies : 1);
5827         }
5828     }
5829   else
5830     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5831        Replace NULL with gcc_unreachable() after implementing
5832        gfc_simplify_cshift(). */
5833     return NULL;
5834
5835   if (source->ts.type == BT_CHARACTER)
5836     result->ts.u.cl = source->ts.u.cl;
5837
5838   return result;
5839 }
5840
5841
5842 gfc_expr *
5843 gfc_simplify_sqrt (gfc_expr *e)
5844 {
5845   gfc_expr *result = NULL;
5846
5847   if (e->expr_type != EXPR_CONSTANT)
5848     return NULL;
5849
5850   switch (e->ts.type)
5851     {
5852       case BT_REAL:
5853         if (mpfr_cmp_si (e->value.real, 0) < 0)
5854           {
5855             gfc_error ("Argument of SQRT at %L has a negative value",
5856                        &e->where);
5857             return &gfc_bad_expr;
5858           }
5859         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5860         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5861         break;
5862
5863       case BT_COMPLEX:
5864         gfc_set_model (e->value.real);
5865
5866         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5867         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5868         break;
5869
5870       default:
5871         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5872     }
5873
5874   return range_check (result, "SQRT");
5875 }
5876
5877
5878 gfc_expr *
5879 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5880 {
5881   return simplify_transformation (array, dim, mask, 0, gfc_add);
5882 }
5883
5884
5885 gfc_expr *
5886 gfc_simplify_tan (gfc_expr *x)
5887 {
5888   gfc_expr *result;
5889
5890   if (x->expr_type != EXPR_CONSTANT)
5891     return NULL;
5892
5893   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5894
5895   switch (x->ts.type)
5896     {
5897       case BT_REAL:
5898         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5899         break;
5900
5901       case BT_COMPLEX:
5902         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5903         break;
5904
5905       default:
5906         gcc_unreachable ();
5907     }
5908
5909   return range_check (result, "TAN");
5910 }
5911
5912
5913 gfc_expr *
5914 gfc_simplify_tanh (gfc_expr *x)
5915 {
5916   gfc_expr *result;
5917
5918   if (x->expr_type != EXPR_CONSTANT)
5919     return NULL;
5920
5921   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5922
5923   switch (x->ts.type)
5924     {
5925       case BT_REAL:
5926         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5927         break;
5928
5929       case BT_COMPLEX:
5930         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5931         break;
5932
5933       default:
5934         gcc_unreachable ();
5935     }
5936
5937   return range_check (result, "TANH");
5938 }
5939
5940
5941 gfc_expr *
5942 gfc_simplify_tiny (gfc_expr *e)
5943 {
5944   gfc_expr *result;
5945   int i;
5946
5947   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5948
5949   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5950   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5951
5952   return result;
5953 }
5954
5955
5956 gfc_expr *
5957 gfc_simplify_trailz (gfc_expr *e)
5958 {
5959   unsigned long tz, bs;
5960   int i;
5961
5962   if (e->expr_type != EXPR_CONSTANT)
5963     return NULL;
5964
5965   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5966   bs = gfc_integer_kinds[i].bit_size;
5967   tz = mpz_scan1 (e->value.integer, 0);
5968
5969   return gfc_get_int_expr (gfc_default_integer_kind,
5970                            &e->where, MIN (tz, bs));
5971 }
5972
5973
5974 gfc_expr *
5975 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5976 {
5977   gfc_expr *result;
5978   gfc_expr *mold_element;
5979   size_t source_size;
5980   size_t result_size;
5981   size_t buffer_size;
5982   mpz_t tmp;
5983   unsigned char *buffer;
5984   size_t result_length;
5985
5986
5987   if (!gfc_is_constant_expr (source)
5988         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5989         || !gfc_is_constant_expr (size))
5990     return NULL;
5991
5992   if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
5993                                     &result_size, &result_length) == FAILURE)
5994     return NULL;
5995
5996   /* Calculate the size of the source.  */
5997   if (source->expr_type == EXPR_ARRAY
5998       && gfc_array_size (source, &tmp) == FAILURE)
5999     gfc_internal_error ("Failure getting length of a constant array.");
6000
6001   /* Create an empty new expression with the appropriate characteristics.  */
6002   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6003                                   &source->where);
6004   result->ts = mold->ts;
6005
6006   mold_element = mold->expr_type == EXPR_ARRAY
6007                  ? gfc_constructor_first (mold->value.constructor)->expr
6008                  : mold;
6009
6010   /* Set result character length, if needed.  Note that this needs to be
6011      set even for array expressions, in order to pass this information into
6012      gfc_target_interpret_expr.  */
6013   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6014     result->value.character.length = mold_element->value.character.length;
6015
6016   /* Set the number of elements in the result, and determine its size.  */
6017
6018   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6019     {
6020       result->expr_type = EXPR_ARRAY;
6021       result->rank = 1;
6022       result->shape = gfc_get_shape (1);
6023       mpz_init_set_ui (result->shape[0], result_length);
6024     }
6025   else
6026     result->rank = 0;
6027
6028   /* Allocate the buffer to store the binary version of the source.  */
6029   buffer_size = MAX (source_size, result_size);
6030   buffer = (unsigned char*)alloca (buffer_size);
6031   memset (buffer, 0, buffer_size);
6032
6033   /* Now write source to the buffer.  */
6034   gfc_target_encode_expr (source, buffer, buffer_size);
6035
6036   /* And read the buffer back into the new expression.  */
6037   gfc_target_interpret_expr (buffer, buffer_size, result, false);
6038
6039   return result;
6040 }
6041
6042
6043 gfc_expr *
6044 gfc_simplify_transpose (gfc_expr *matrix)
6045 {
6046   int row, matrix_rows, col, matrix_cols;
6047   gfc_expr *result;
6048
6049   if (!is_constant_array_expr (matrix))
6050     return NULL;
6051
6052   gcc_assert (matrix->rank == 2);
6053
6054   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6055                                &matrix->where);
6056   result->rank = 2;
6057   result->shape = gfc_get_shape (result->rank);
6058   mpz_set (result->shape[0], matrix->shape[1]);
6059   mpz_set (result->shape[1], matrix->shape[0]);
6060
6061   if (matrix->ts.type == BT_CHARACTER)
6062     result->ts.u.cl = matrix->ts.u.cl;
6063   else if (matrix->ts.type == BT_DERIVED)
6064     result->ts.u.derived = matrix->ts.u.derived;
6065
6066   matrix_rows = mpz_get_si (matrix->shape[0]);
6067   matrix_cols = mpz_get_si (matrix->shape[1]);
6068   for (row = 0; row < matrix_rows; ++row)
6069     for (col = 0; col < matrix_cols; ++col)
6070       {
6071         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6072                                                    col * matrix_rows + row);
6073         gfc_constructor_insert_expr (&result->value.constructor,
6074                                      gfc_copy_expr (e), &matrix->where,
6075                                      row * matrix_cols + col);
6076       }
6077
6078   return result;
6079 }
6080
6081
6082 gfc_expr *
6083 gfc_simplify_trim (gfc_expr *e)
6084 {
6085   gfc_expr *result;
6086   int count, i, len, lentrim;
6087
6088   if (e->expr_type != EXPR_CONSTANT)
6089     return NULL;
6090
6091   len = e->value.character.length;
6092   for (count = 0, i = 1; i <= len; ++i)
6093     {
6094       if (e->value.character.string[len - i] == ' ')
6095         count++;
6096       else
6097         break;
6098     }
6099
6100   lentrim = len - count;
6101
6102   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6103   for (i = 0; i < lentrim; i++)
6104     result->value.character.string[i] = e->value.character.string[i];
6105
6106   return result;
6107 }
6108
6109
6110 gfc_expr *
6111 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6112 {
6113   gfc_expr *result;
6114   gfc_ref *ref;
6115   gfc_array_spec *as;
6116   gfc_constructor *sub_cons;
6117   bool first_image;
6118   int d;
6119
6120   if (!is_constant_array_expr (sub))
6121     return NULL;
6122
6123   /* Follow any component references.  */
6124   as = coarray->symtree->n.sym->as;
6125   for (ref = coarray->ref; ref; ref = ref->next)
6126     if (ref->type == REF_COMPONENT)
6127       as = ref->u.ar.as;
6128
6129   if (as->type == AS_DEFERRED)
6130     return NULL;
6131
6132   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6133      the cosubscript addresses the first image.  */
6134
6135   sub_cons = gfc_constructor_first (sub->value.constructor);
6136   first_image = true;
6137
6138   for (d = 1; d <= as->corank; d++)
6139     {
6140       gfc_expr *ca_bound;
6141       int cmp;
6142
6143       gcc_assert (sub_cons != NULL);
6144
6145       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6146                                      NULL, true);
6147       if (ca_bound == NULL)
6148         return NULL;
6149
6150       if (ca_bound == &gfc_bad_expr)
6151         return ca_bound;
6152
6153       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6154
6155       if (cmp == 0)
6156         {
6157           gfc_free_expr (ca_bound);
6158           sub_cons = gfc_constructor_next (sub_cons);
6159           continue;
6160         }
6161
6162       first_image = false;
6163
6164       if (cmp > 0)
6165         {
6166           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6167                      "SUB has %ld and COARRAY lower bound is %ld)",
6168                      &coarray->where, d,
6169                      mpz_get_si (sub_cons->expr->value.integer),
6170                      mpz_get_si (ca_bound->value.integer));
6171           gfc_free_expr (ca_bound);
6172           return &gfc_bad_expr;
6173         }
6174
6175       gfc_free_expr (ca_bound);
6176
6177       /* Check whether upperbound is valid for the multi-images case.  */
6178       if (d < as->corank)
6179         {
6180           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6181                                          NULL, true);
6182           if (ca_bound == &gfc_bad_expr)
6183             return ca_bound;
6184
6185           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6186               && mpz_cmp (ca_bound->value.integer,
6187                           sub_cons->expr->value.integer) < 0)
6188           {
6189             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6190                        "SUB has %ld and COARRAY upper bound is %ld)",
6191                        &coarray->where, d,
6192                        mpz_get_si (sub_cons->expr->value.integer),
6193                        mpz_get_si (ca_bound->value.integer));
6194             gfc_free_expr (ca_bound);
6195             return &gfc_bad_expr;
6196           }
6197
6198           if (ca_bound)
6199             gfc_free_expr (ca_bound);
6200         }
6201
6202       sub_cons = gfc_constructor_next (sub_cons);
6203     }
6204
6205   gcc_assert (sub_cons == NULL);
6206
6207   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
6208     return NULL;
6209
6210   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6211                                   &gfc_current_locus);
6212   if (first_image)
6213     mpz_set_si (result->value.integer, 1);
6214   else
6215     mpz_set_si (result->value.integer, 0);
6216
6217   return result;
6218 }
6219
6220
6221 gfc_expr *
6222 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6223 {
6224   gfc_ref *ref;
6225   gfc_array_spec *as;
6226   int d;
6227
6228   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6229     return NULL;
6230
6231   if (coarray == NULL)
6232     {
6233       gfc_expr *result;
6234       /* FIXME: gfc_current_locus is wrong.  */
6235       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6236                                       &gfc_current_locus);
6237       mpz_set_si (result->value.integer, 1);
6238       return result;
6239     }
6240
6241   gcc_assert (coarray->expr_type == EXPR_VARIABLE);
6242
6243   /* Follow any component references.  */
6244   as = coarray->symtree->n.sym->as;
6245   for (ref = coarray->ref; ref; ref = ref->next)
6246     if (ref->type == REF_COMPONENT)
6247       as = ref->u.ar.as;
6248
6249   if (as->type == AS_DEFERRED)
6250     return NULL;
6251
6252   if (dim == NULL)
6253     {
6254       /* Multi-dimensional bounds.  */
6255       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
6256       gfc_expr *e;
6257
6258       /* Simplify the bounds for each dimension.  */
6259       for (d = 0; d < as->corank; d++)
6260         {
6261           bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
6262                                           as, NULL, true);
6263           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
6264             {
6265               int j;
6266
6267               for (j = 0; j < d; j++)
6268                 gfc_free_expr (bounds[j]);
6269
6270               return bounds[d];
6271             }
6272         }
6273
6274       /* Allocate the result expression.  */
6275       e = gfc_get_expr ();
6276       e->where = coarray->where;
6277       e->expr_type = EXPR_ARRAY;
6278       e->ts.type = BT_INTEGER;
6279       e->ts.kind = gfc_default_integer_kind;
6280
6281       e->rank = 1;
6282       e->shape = gfc_get_shape (1);
6283       mpz_init_set_ui (e->shape[0], as->corank);
6284
6285       /* Create the constructor for this array.  */
6286       for (d = 0; d < as->corank; d++)
6287         gfc_constructor_append_expr (&e->value.constructor,
6288                                      bounds[d], &e->where);
6289
6290       return e;
6291     }
6292   else
6293     {
6294       /* A DIM argument is specified.  */
6295       if (dim->expr_type != EXPR_CONSTANT)
6296         return NULL;
6297
6298       d = mpz_get_si (dim->value.integer);
6299
6300       if (d < 1 || d > as->corank)
6301         {
6302           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
6303           return &gfc_bad_expr;
6304         }
6305
6306       return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
6307                                  true);
6308    }
6309 }
6310
6311
6312 gfc_expr *
6313 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6314 {
6315   return simplify_bound (array, dim, kind, 1);
6316 }
6317
6318 gfc_expr *
6319 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6320 {
6321   return simplify_cobound (array, dim, kind, 1);
6322 }
6323
6324
6325 gfc_expr *
6326 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6327 {
6328   gfc_expr *result, *e;
6329   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6330
6331   if (!is_constant_array_expr (vector)
6332       || !is_constant_array_expr (mask)
6333       || (!gfc_is_constant_expr (field)
6334           && !is_constant_array_expr(field)))
6335     return NULL;
6336
6337   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6338                                &vector->where);
6339   if (vector->ts.type == BT_DERIVED)
6340     result->ts.u.derived = vector->ts.u.derived;
6341   result->rank = mask->rank;
6342   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6343
6344   if (vector->ts.type == BT_CHARACTER)
6345     result->ts.u.cl = vector->ts.u.cl;
6346
6347   vector_ctor = gfc_constructor_first (vector->value.constructor);
6348   mask_ctor = gfc_constructor_first (mask->value.constructor);
6349   field_ctor
6350     = field->expr_type == EXPR_ARRAY
6351                             ? gfc_constructor_first (field->value.constructor)
6352                             : NULL;
6353
6354   while (mask_ctor)
6355     {
6356       if (mask_ctor->expr->value.logical)
6357         {
6358           gcc_assert (vector_ctor);
6359           e = gfc_copy_expr (vector_ctor->expr);
6360           vector_ctor = gfc_constructor_next (vector_ctor);
6361         }
6362       else if (field->expr_type == EXPR_ARRAY)
6363         e = gfc_copy_expr (field_ctor->expr);
6364       else
6365         e = gfc_copy_expr (field);
6366
6367       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6368
6369       mask_ctor = gfc_constructor_next (mask_ctor);
6370       field_ctor = gfc_constructor_next (field_ctor);
6371     }
6372
6373   return result;
6374 }
6375
6376
6377 gfc_expr *
6378 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6379 {
6380   gfc_expr *result;
6381   int back;
6382   size_t index, len, lenset;
6383   size_t i;
6384   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6385
6386   if (k == -1)
6387     return &gfc_bad_expr;
6388
6389   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
6390     return NULL;
6391
6392   if (b != NULL && b->value.logical != 0)
6393     back = 1;
6394   else
6395     back = 0;
6396
6397   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6398
6399   len = s->value.character.length;
6400   lenset = set->value.character.length;
6401
6402   if (len == 0)
6403     {
6404       mpz_set_ui (result->value.integer, 0);
6405       return result;
6406     }
6407
6408   if (back == 0)
6409     {
6410       if (lenset == 0)
6411         {
6412           mpz_set_ui (result->value.integer, 1);
6413           return result;
6414         }
6415
6416       index = wide_strspn (s->value.character.string,
6417                            set->value.character.string) + 1;
6418       if (index > len)
6419         index = 0;
6420
6421     }
6422   else
6423     {
6424       if (lenset == 0)
6425         {
6426           mpz_set_ui (result->value.integer, len);
6427           return result;
6428         }
6429       for (index = len; index > 0; index --)
6430         {
6431           for (i = 0; i < lenset; i++)
6432             {
6433               if (s->value.character.string[index - 1]
6434                   == set->value.character.string[i])
6435                 break;
6436             }
6437           if (i == lenset)
6438             break;
6439         }
6440     }
6441
6442   mpz_set_ui (result->value.integer, index);
6443   return result;
6444 }
6445
6446
6447 gfc_expr *
6448 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6449 {
6450   gfc_expr *result;
6451   int kind;
6452
6453   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6454     return NULL;
6455
6456   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6457
6458   switch (x->ts.type)
6459     {
6460       case BT_INTEGER:
6461         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6462         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6463         return range_check (result, "XOR");
6464
6465       case BT_LOGICAL:
6466         return gfc_get_logical_expr (kind, &x->where,
6467                                      (x->value.logical && !y->value.logical)
6468                                      || (!x->value.logical && y->value.logical));
6469
6470       default:
6471         gcc_unreachable ();
6472     }
6473 }
6474
6475
6476 /****************** Constant simplification *****************/
6477
6478 /* Master function to convert one constant to another.  While this is
6479    used as a simplification function, it requires the destination type
6480    and kind information which is supplied by a special case in
6481    do_simplify().  */
6482
6483 gfc_expr *
6484 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6485 {
6486   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6487   gfc_constructor *c;
6488
6489   switch (e->ts.type)
6490     {
6491     case BT_INTEGER:
6492       switch (type)
6493         {
6494         case BT_INTEGER:
6495           f = gfc_int2int;
6496           break;
6497         case BT_REAL:
6498           f = gfc_int2real;
6499           break;
6500         case BT_COMPLEX:
6501           f = gfc_int2complex;
6502           break;
6503         case BT_LOGICAL:
6504           f = gfc_int2log;
6505           break;
6506         default:
6507           goto oops;
6508         }
6509       break;
6510
6511     case BT_REAL:
6512       switch (type)
6513         {
6514         case BT_INTEGER:
6515           f = gfc_real2int;
6516           break;
6517         case BT_REAL:
6518           f = gfc_real2real;
6519           break;
6520         case BT_COMPLEX:
6521           f = gfc_real2complex;
6522           break;
6523         default:
6524           goto oops;
6525         }
6526       break;
6527
6528     case BT_COMPLEX:
6529       switch (type)
6530         {
6531         case BT_INTEGER:
6532           f = gfc_complex2int;
6533           break;
6534         case BT_REAL:
6535           f = gfc_complex2real;
6536           break;
6537         case BT_COMPLEX:
6538           f = gfc_complex2complex;
6539           break;
6540
6541         default:
6542           goto oops;
6543         }
6544       break;
6545
6546     case BT_LOGICAL:
6547       switch (type)
6548         {
6549         case BT_INTEGER:
6550           f = gfc_log2int;
6551           break;
6552         case BT_LOGICAL:
6553           f = gfc_log2log;
6554           break;
6555         default:
6556           goto oops;
6557         }
6558       break;
6559
6560     case BT_HOLLERITH:
6561       switch (type)
6562         {
6563         case BT_INTEGER:
6564           f = gfc_hollerith2int;
6565           break;
6566
6567         case BT_REAL:
6568           f = gfc_hollerith2real;
6569           break;
6570
6571         case BT_COMPLEX:
6572           f = gfc_hollerith2complex;
6573           break;
6574
6575         case BT_CHARACTER:
6576           f = gfc_hollerith2character;
6577           break;
6578
6579         case BT_LOGICAL:
6580           f = gfc_hollerith2logical;
6581           break;
6582
6583         default:
6584           goto oops;
6585         }
6586       break;
6587
6588     default:
6589     oops:
6590       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6591     }
6592
6593   result = NULL;
6594
6595   switch (e->expr_type)
6596     {
6597     case EXPR_CONSTANT:
6598       result = f (e, kind);
6599       if (result == NULL)
6600         return &gfc_bad_expr;
6601       break;
6602
6603     case EXPR_ARRAY:
6604       if (!gfc_is_constant_expr (e))
6605         break;
6606
6607       result = gfc_get_array_expr (type, kind, &e->where);
6608       result->shape = gfc_copy_shape (e->shape, e->rank);
6609       result->rank = e->rank;
6610
6611       for (c = gfc_constructor_first (e->value.constructor);
6612            c; c = gfc_constructor_next (c))
6613         {
6614           gfc_expr *tmp;
6615           if (c->iterator == NULL)
6616             tmp = f (c->expr, kind);
6617           else
6618             {
6619               g = gfc_convert_constant (c->expr, type, kind);
6620               if (g == &gfc_bad_expr)
6621                 {
6622                   gfc_free_expr (result);
6623                   return g;
6624                 }
6625               tmp = g;
6626             }
6627
6628           if (tmp == NULL)
6629             {
6630               gfc_free_expr (result);
6631               return NULL;
6632             }
6633
6634           gfc_constructor_append_expr (&result->value.constructor,
6635                                        tmp, &c->where);
6636         }
6637
6638       break;
6639
6640     default:
6641       break;
6642     }
6643
6644   return result;
6645 }
6646
6647
6648 /* Function for converting character constants.  */
6649 gfc_expr *
6650 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6651 {
6652   gfc_expr *result;
6653   int i;
6654
6655   if (!gfc_is_constant_expr (e))
6656     return NULL;
6657
6658   if (e->expr_type == EXPR_CONSTANT)
6659     {
6660       /* Simple case of a scalar.  */
6661       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6662       if (result == NULL)
6663         return &gfc_bad_expr;
6664
6665       result->value.character.length = e->value.character.length;
6666       result->value.character.string
6667         = gfc_get_wide_string (e->value.character.length + 1);
6668       memcpy (result->value.character.string, e->value.character.string,
6669               (e->value.character.length + 1) * sizeof (gfc_char_t));
6670
6671       /* Check we only have values representable in the destination kind.  */
6672       for (i = 0; i < result->value.character.length; i++)
6673         if (!gfc_check_character_range (result->value.character.string[i],
6674                                         kind))
6675           {
6676             gfc_error ("Character '%s' in string at %L cannot be converted "
6677                        "into character kind %d",
6678                        gfc_print_wide_char (result->value.character.string[i]),
6679                        &e->where, kind);
6680             return &gfc_bad_expr;
6681           }
6682
6683       return result;
6684     }
6685   else if (e->expr_type == EXPR_ARRAY)
6686     {
6687       /* For an array constructor, we convert each constructor element.  */
6688       gfc_constructor *c;
6689
6690       result = gfc_get_array_expr (type, kind, &e->where);
6691       result->shape = gfc_copy_shape (e->shape, e->rank);
6692       result->rank = e->rank;
6693       result->ts.u.cl = e->ts.u.cl;
6694
6695       for (c = gfc_constructor_first (e->value.constructor);
6696            c; c = gfc_constructor_next (c))
6697         {
6698           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6699           if (tmp == &gfc_bad_expr)
6700             {
6701               gfc_free_expr (result);
6702               return &gfc_bad_expr;
6703             }
6704
6705           if (tmp == NULL)
6706             {
6707               gfc_free_expr (result);
6708               return NULL;
6709             }
6710
6711           gfc_constructor_append_expr (&result->value.constructor,
6712                                        tmp, &c->where);
6713         }
6714
6715       return result;
6716     }
6717   else
6718     return NULL;
6719 }
6720
6721
6722 gfc_expr *
6723 gfc_simplify_compiler_options (void)
6724 {
6725   char *str;
6726   gfc_expr *result;
6727
6728   str = gfc_get_option_string ();
6729   result = gfc_get_character_expr (gfc_default_character_kind,
6730                                    &gfc_current_locus, str, strlen (str));
6731   free (str);
6732   return result;
6733 }
6734
6735
6736 gfc_expr *
6737 gfc_simplify_compiler_version (void)
6738 {
6739   char *buffer;
6740   size_t len;
6741
6742   len = strlen ("GCC version ") + strlen (version_string);
6743   buffer = XALLOCAVEC (char, len + 1);
6744   snprintf (buffer, len + 1, "GCC version %s", version_string);
6745   return gfc_get_character_expr (gfc_default_character_kind,
6746                                 &gfc_current_locus, buffer, len);
6747 }