gcc/fortran/simplify.c

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