gcc/fortran/simplify.c

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