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               as = NULL;
2940               continue;
2941
2942             case AR_FULL:
2943               /* We're done because 'as' has already been set in the
2944                  previous iteration.  */
2945               if (!ref->next)
2946                 goto done;
2947
2948             /* Fall through.  */
2949
2950             case AR_UNKNOWN:
2951               return NULL;
2952
2953             case AR_SECTION:
2954               as = ref->u.ar.as;
2955               goto done;
2956             }
2957
2958           gcc_unreachable ();
2959
2960         case REF_COMPONENT:
2961           as = ref->u.c.component->as;
2962           continue;
2963
2964         case REF_SUBSTRING:
2965           continue;
2966         }
2967     }
2968
2969   gcc_unreachable ();
2970
2971  done:
2972
2973   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2974     return NULL;
2975
2976   if (dim == NULL)
2977     {
2978       /* Multi-dimensional cobounds.  */
2979       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2980       gfc_expr *e;
2981       int k;
2982
2983       /* Simplify the cobounds for each dimension.  */
2984       for (d = 0; d < as->corank; d++)
2985         {
2986           bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
2987                                           upper, as, ref, true);
2988           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2989             {
2990               int j;
2991
2992               for (j = 0; j < d; j++)
2993                 gfc_free_expr (bounds[j]);
2994               return bounds[d];
2995             }
2996         }
2997
2998       /* Allocate the result expression.  */
2999       e = gfc_get_expr ();
3000       e->where = array->where;
3001       e->expr_type = EXPR_ARRAY;
3002       e->ts.type = BT_INTEGER;
3003       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3004                     gfc_default_integer_kind);
3005       if (k == -1)
3006         {
3007           gfc_free_expr (e);
3008           return &gfc_bad_expr;
3009         }
3010       e->ts.kind = k;
3011
3012       /* The result is a rank 1 array; its size is the rank of the first
3013          argument to {L,U}COBOUND.  */
3014       e->rank = 1;
3015       e->shape = gfc_get_shape (1);
3016       mpz_init_set_ui (e->shape[0], as->corank);
3017
3018       /* Create the constructor for this array.  */
3019       for (d = 0; d < as->corank; d++)
3020         gfc_constructor_append_expr (&e->value.constructor,
3021                                      bounds[d], &e->where);
3022       return e;
3023     }
3024   else
3025     {
3026       /* A DIM argument is specified.  */
3027       if (dim->expr_type != EXPR_CONSTANT)
3028         return NULL;
3029
3030       d = mpz_get_si (dim->value.integer);
3031
3032       if (d < 1 || d > as->corank)
3033         {
3034           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3035           return &gfc_bad_expr;
3036         }
3037
3038       return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3039     }
3040 }
3041
3042
3043 gfc_expr *
3044 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3045 {
3046   return simplify_bound (array, dim, kind, 0);
3047 }
3048
3049
3050 gfc_expr *
3051 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3052 {
3053   gfc_expr *e;
3054   /* return simplify_cobound (array, dim, kind, 0);*/
3055
3056   e = simplify_cobound (array, dim, kind, 0);
3057   if (e != NULL)
3058     return e;
3059
3060   gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3061              "cobounds at %L", &array->where);
3062   return &gfc_bad_expr;
3063 }
3064
3065 gfc_expr *
3066 gfc_simplify_leadz (gfc_expr *e)
3067 {
3068   unsigned long lz, bs;
3069   int i;
3070
3071   if (array->expr_type != EXPR_VARIABLE)
3072     return NULL;
3073
3074   /* Follow any component references.  */
3075   as = array->symtree->n.sym->as;
3076   for (ref = array->ref; ref; ref = ref->next)
3077     {
3078       switch (ref->type)
3079         {
3080         case REF_ARRAY:
3081           switch (ref->u.ar.type)
3082             {
3083             case AR_ELEMENT:
3084               if (ref->next == NULL)
3085                 {
3086                   gcc_assert (ref->u.ar.as->corank > 0
3087                               && ref->u.ar.as->rank == 0);
3088                   as = ref->u.ar.as;
3089                   goto done;
3090                 }
3091               as = NULL;
3092               continue;
3093
3094   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3095 }
3096
3097             case AR_UNKNOWN:
3098               return NULL;
3099
3100             case AR_SECTION:
3101               as = ref->u.ar.as;
3102               goto done;
3103             }
3104
3105           gcc_unreachable ();
3106
3107   if (e->expr_type == EXPR_CONSTANT)
3108     {
3109       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3110       mpz_set_si (result->value.integer, e->value.character.length);
3111       return range_check (result, "LEN");
3112     }
3113   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3114            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3115            && e->ts.u.cl->length->ts.type == BT_INTEGER)
3116     {
3117       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3118       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3119       return range_check (result, "LEN");
3120     }
3121   else
3122     return NULL;
3123 }
3124
3125
3126 gfc_expr *
3127 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3128 {
3129   gfc_expr *result;
3130   int count, len, i;
3131   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3132
3133  done:
3134
3135   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3136     return NULL;
3137
3138   len = e->value.character.length;
3139   for (count = 0, i = 1; i <= len; i++)
3140     if (e->value.character.string[len - i] == ' ')
3141       count++;
3142     else
3143       break;
3144
3145   result = gfc_get_int_expr (k, &e->where, len - count);
3146   return range_check (result, "LEN_TRIM");
3147 }
3148
3149 gfc_expr *
3150 gfc_simplify_lgamma (gfc_expr *x)
3151 {
3152   gfc_expr *result;
3153   int sg;
3154
3155   if (x->expr_type != EXPR_CONSTANT)
3156     return NULL;
3157
3158   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3159   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3160
3161   return range_check (result, "LGAMMA");
3162 }
3163
3164
3165 gfc_expr *
3166 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3167 {
3168   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3169     return NULL;
3170
3171   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3172                                gfc_compare_string (a, b) >= 0);
3173 }
3174
3175
3176 gfc_expr *
3177 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3178 {
3179   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3180     return NULL;
3181
3182   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3183                                gfc_compare_string (a, b) > 0);
3184 }
3185
3186
3187 gfc_expr *
3188 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3189 {
3190   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3191     return NULL;
3192
3193   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3194                                gfc_compare_string (a, b) <= 0);
3195 }
3196
3197
3198 gfc_expr *
3199 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3200 {
3201   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3202     return NULL;
3203
3204   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3205                                gfc_compare_string (a, b) < 0);
3206 }
3207
3208
3209 gfc_expr *
3210 gfc_simplify_log (gfc_expr *x)
3211 {
3212   gfc_expr *result;
3213
3214   if (x->expr_type != EXPR_CONSTANT)
3215     return NULL;
3216
3217   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3218
3219   switch (x->ts.type)
3220     {
3221     case BT_REAL:
3222       if (mpfr_sgn (x->value.real) <= 0)
3223         {
3224           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3225                      "to zero", &x->where);
3226           gfc_free_expr (result);
3227           return &gfc_bad_expr;
3228         }
3229
3230       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3231       break;
3232
3233     case BT_COMPLEX:
3234       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3235           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3236         {
3237           gfc_error ("Complex argument of LOG at %L cannot be zero",
3238                      &x->where);
3239           gfc_free_expr (result);
3240           return &gfc_bad_expr;
3241         }
3242
3243       gfc_set_model_kind (x->ts.kind);
3244       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3245       break;
3246
3247     default:
3248       gfc_internal_error ("gfc_simplify_log: bad type");
3249     }
3250
3251   return range_check (result, "LOG");
3252 }
3253
3254
3255 gfc_expr *
3256 gfc_simplify_log10 (gfc_expr *x)
3257 {
3258   gfc_expr *result;
3259
3260   if (x->expr_type != EXPR_CONSTANT)
3261     return NULL;
3262
3263   if (mpfr_sgn (x->value.real) <= 0)
3264     {
3265       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3266                  "to zero", &x->where);
3267       return &gfc_bad_expr;
3268     }
3269
3270   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3271   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3272
3273   return range_check (result, "LOG10");
3274 }
3275
3276
3277 gfc_expr *
3278 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3279 {
3280   int kind;
3281
3282   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3283   if (kind < 0)
3284     return &gfc_bad_expr;
3285
3286   if (e->expr_type != EXPR_CONSTANT)
3287     return NULL;
3288
3289   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3290 }
3291
3292
3293 gfc_expr*
3294 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3295 {
3296   gfc_expr *result;
3297   int row, result_rows, col, result_columns;
3298   int stride_a, offset_a, stride_b, offset_b;
3299
3300   if (!is_constant_array_expr (matrix_a)
3301       || !is_constant_array_expr (matrix_b))
3302     return NULL;
3303
3304   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3305   result = gfc_get_array_expr (matrix_a->ts.type,
3306                                matrix_a->ts.kind,
3307                                &matrix_a->where);
3308
3309   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3310     {
3311       result_rows = 1;
3312       result_columns = mpz_get_si (matrix_b->shape[0]);
3313       stride_a = 1;
3314       stride_b = mpz_get_si (matrix_b->shape[0]);
3315
3316       result->rank = 1;
3317       result->shape = gfc_get_shape (result->rank);
3318       mpz_init_set_si (result->shape[0], result_columns);
3319     }
3320   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3321     {
3322       result_rows = mpz_get_si (matrix_b->shape[0]);
3323       result_columns = 1;
3324       stride_a = mpz_get_si (matrix_a->shape[0]);
3325       stride_b = 1;
3326
3327       result->rank = 1;
3328       result->shape = gfc_get_shape (result->rank);
3329       mpz_init_set_si (result->shape[0], result_rows);
3330     }
3331   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3332     {
3333       result_rows = mpz_get_si (matrix_a->shape[0]);
3334       result_columns = mpz_get_si (matrix_b->shape[1]);
3335       stride_a = mpz_get_si (matrix_a->shape[1]);
3336       stride_b = mpz_get_si (matrix_b->shape[0]);
3337
3338       result->rank = 2;
3339       result->shape = gfc_get_shape (result->rank);
3340       mpz_init_set_si (result->shape[0], result_rows);
3341       mpz_init_set_si (result->shape[1], result_columns);
3342     }
3343   else
3344     gcc_unreachable();
3345
3346   offset_a = offset_b = 0;
3347   for (col = 0; col < result_columns; ++col)
3348     {
3349       offset_a = 0;
3350
3351       for (row = 0; row < result_rows; ++row)
3352         {
3353           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3354                                              matrix_b, 1, offset_b);
3355           gfc_constructor_append_expr (&result->value.constructor,
3356                                        e, NULL);
3357
3358           offset_a += 1;
3359         }
3360
3361       offset_b += stride_b;
3362     }
3363
3364   return result;
3365 }
3366
3367
3368 gfc_expr *
3369 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3370 {
3371   if (tsource->expr_type != EXPR_CONSTANT
3372       || fsource->expr_type != EXPR_CONSTANT
3373       || mask->expr_type != EXPR_CONSTANT)
3374     return NULL;
3375
3376   return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3377 }
3378
3379
3380 /* Selects bewteen current value and extremum for simplify_min_max
3381    and simplify_minval_maxval.  */
3382 static void
3383 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3384 {
3385   switch (arg->ts.type)
3386     {
3387       case BT_INTEGER:
3388         if (mpz_cmp (arg->value.integer,
3389                         extremum->value.integer) * sign > 0)
3390         mpz_set (extremum->value.integer, arg->value.integer);
3391         break;
3392
3393       case BT_REAL:
3394         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
3395         if (sign > 0)
3396           mpfr_max (extremum->value.real, extremum->value.real,
3397                       arg->value.real, GFC_RND_MODE);
3398         else
3399           mpfr_min (extremum->value.real, extremum->value.real,
3400                       arg->value.real, GFC_RND_MODE);
3401         break;
3402
3403       case BT_CHARACTER:
3404 #define LENGTH(x) ((x)->value.character.length)
3405 #define STRING(x) ((x)->value.character.string)
3406         if (LENGTH(extremum) < LENGTH(arg))
3407           {
3408             gfc_char_t *tmp = STRING(extremum);
3409
3410             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3411             memcpy (STRING(extremum), tmp,
3412                       LENGTH(extremum) * sizeof (gfc_char_t));
3413             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3414                                LENGTH(arg) - LENGTH(extremum));
3415             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
3416             LENGTH(extremum) = LENGTH(arg);
3417             gfc_free (tmp);
3418           }
3419
3420         if (gfc_compare_string (arg, extremum) * sign > 0)
3421           {
3422             gfc_free (STRING(extremum));
3423             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3424             memcpy (STRING(extremum), STRING(arg),
3425                       LENGTH(arg) * sizeof (gfc_char_t));
3426             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3427                                LENGTH(extremum) - LENGTH(arg));
3428             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
3429           }
3430 #undef LENGTH
3431 #undef STRING
3432         break;
3433
3434       default:
3435         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3436     }
3437 }
3438
3439
3440 /* This function is special since MAX() can take any number of
3441    arguments.  The simplified expression is a rewritten version of the
3442    argument list containing at most one constant element.  Other
3443    constant elements are deleted.  Because the argument list has
3444    already been checked, this function always succeeds.  sign is 1 for
3445    MAX(), -1 for MIN().  */
3446
3447 static gfc_expr *
3448 simplify_min_max (gfc_expr *expr, int sign)
3449 {
3450   gfc_actual_arglist *arg, *last, *extremum;
3451   gfc_intrinsic_sym * specific;
3452
3453   last = NULL;
3454   extremum = NULL;
3455   specific = expr->value.function.isym;
3456
3457   arg = expr->value.function.actual;
3458
3459   for (; arg; last = arg, arg = arg->next)
3460     {
3461       if (arg->expr->expr_type != EXPR_CONSTANT)
3462         continue;
3463
3464       if (extremum == NULL)
3465         {
3466           extremum = arg;
3467           continue;
3468         }
3469
3470       min_max_choose (arg->expr, extremum->expr, sign);
3471
3472       /* Delete the extra constant argument.  */
3473       if (last == NULL)
3474         expr->value.function.actual = arg->next;
3475       else
3476         last->next = arg->next;
3477
3478       arg->next = NULL;
3479       gfc_free_actual_arglist (arg);
3480       arg = last;
3481     }
3482
3483   /* If there is one value left, replace the function call with the
3484      expression.  */
3485   if (expr->value.function.actual->next != NULL)
3486     return NULL;
3487
3488   /* Convert to the correct type and kind.  */
3489   if (expr->ts.type != BT_UNKNOWN)
3490     return gfc_convert_constant (expr->value.function.actual->expr,
3491         expr->ts.type, expr->ts.kind);
3492
3493   if (specific->ts.type != BT_UNKNOWN)
3494     return gfc_convert_constant (expr->value.function.actual->expr,
3495         specific->ts.type, specific->ts.kind);
3496
3497   return gfc_copy_expr (expr->value.function.actual->expr);
3498 }
3499
3500
3501 gfc_expr *
3502 gfc_simplify_min (gfc_expr *e)
3503 {
3504   return simplify_min_max (e, -1);
3505 }
3506
3507
3508 gfc_expr *
3509 gfc_simplify_max (gfc_expr *e)
3510 {
3511   return simplify_min_max (e, 1);
3512 }
3513
3514
3515 /* This is a simplified version of simplify_min_max to provide
3516    simplification of minval and maxval for a vector.  */
3517
3518 static gfc_expr *
3519 simplify_minval_maxval (gfc_expr *expr, int sign)
3520 {
3521   gfc_constructor *c, *extremum;
3522   gfc_intrinsic_sym * specific;
3523
3524   extremum = NULL;
3525   specific = expr->value.function.isym;
3526
3527   for (c = gfc_constructor_first (expr->value.constructor);
3528        c; c = gfc_constructor_next (c))
3529     {
3530       if (c->expr->expr_type != EXPR_CONSTANT)
3531         return NULL;
3532
3533       if (extremum == NULL)
3534         {
3535           extremum = c;
3536           continue;
3537         }
3538
3539       min_max_choose (c->expr, extremum->expr, sign);
3540      }
3541
3542   if (extremum == NULL)
3543     return NULL;
3544
3545   /* Convert to the correct type and kind.  */
3546   if (expr->ts.type != BT_UNKNOWN)
3547     return gfc_convert_constant (extremum->expr,
3548         expr->ts.type, expr->ts.kind);
3549
3550   if (specific->ts.type != BT_UNKNOWN)
3551     return gfc_convert_constant (extremum->expr,
3552         specific->ts.type, specific->ts.kind);
3553
3554   return gfc_copy_expr (extremum->expr);
3555 }
3556
3557
3558 gfc_expr *
3559 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3560 {
3561   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3562     return NULL;
3563
3564   return simplify_minval_maxval (array, -1);
3565 }
3566
3567
3568 gfc_expr *
3569 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3570 {
3571   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3572     return NULL;
3573
3574   return simplify_minval_maxval (array, 1);
3575 }
3576
3577
3578 gfc_expr *
3579 gfc_simplify_maxexponent (gfc_expr *x)
3580 {
3581   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3582   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3583                            gfc_real_kinds[i].max_exponent);
3584 }
3585
3586
3587 gfc_expr *
3588 gfc_simplify_minexponent (gfc_expr *x)
3589 {
3590   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3591   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3592                            gfc_real_kinds[i].min_exponent);
3593 }
3594
3595
3596 gfc_expr *
3597 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3598 {
3599   gfc_expr *result;
3600   mpfr_t tmp;
3601   int kind;
3602
3603   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3604     return NULL;
3605
3606   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3607   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3608
3609   switch (a->ts.type)
3610     {
3611       case BT_INTEGER:
3612         if (mpz_cmp_ui (p->value.integer, 0) == 0)
3613           {
3614             /* Result is processor-dependent.  */
3615             gfc_error ("Second argument MOD at %L is zero", &a->where);
3616             gfc_free_expr (result);
3617             return &gfc_bad_expr;
3618           }
3619         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3620         break;
3621
3622       case BT_REAL:
3623         if (mpfr_cmp_ui (p->value.real, 0) == 0)
3624           {
3625             /* Result is processor-dependent.  */
3626             gfc_error ("Second argument of MOD at %L is zero", &p->where);
3627             gfc_free_expr (result);
3628             return &gfc_bad_expr;
3629           }
3630
3631         gfc_set_model_kind (kind);
3632         mpfr_init (tmp);
3633         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3634         mpfr_trunc (tmp, tmp);
3635         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3636         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3637         mpfr_clear (tmp);
3638         break;
3639
3640       default:
3641         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3642     }
3643
3644   return range_check (result, "MOD");
3645 }
3646
3647
3648 gfc_expr *
3649 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3650 {
3651   gfc_expr *result;
3652   mpfr_t tmp;
3653   int kind;
3654
3655   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3656     return NULL;
3657
3658   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3659   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3660
3661   switch (a->ts.type)
3662     {
3663       case BT_INTEGER:
3664         if (mpz_cmp_ui (p->value.integer, 0) == 0)
3665           {
3666             /* Result is processor-dependent. This processor just opts
3667               to not handle it at all.  */
3668             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3669             gfc_free_expr (result);
3670             return &gfc_bad_expr;
3671           }
3672         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3673
3674         break;
3675
3676       case BT_REAL:
3677         if (mpfr_cmp_ui (p->value.real, 0) == 0)
3678           {
3679             /* Result is processor-dependent.  */
3680             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3681             gfc_free_expr (result);
3682             return &gfc_bad_expr;
3683           }
3684
3685         gfc_set_model_kind (kind);
3686         mpfr_init (tmp);
3687         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3688         mpfr_floor (tmp, tmp);
3689         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3690         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3691         mpfr_clear (tmp);
3692         break;
3693
3694       default:
3695         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3696     }
3697
3698   return range_check (result, "MODULO");
3699 }
3700
3701
3702 /* Exists for the sole purpose of consistency with other intrinsics.  */
3703 gfc_expr *
3704 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
3705                      gfc_expr *fp ATTRIBUTE_UNUSED,
3706                      gfc_expr *l  ATTRIBUTE_UNUSED,
3707                      gfc_expr *to ATTRIBUTE_UNUSED,
3708                      gfc_expr *tp ATTRIBUTE_UNUSED)
3709 {
3710   return NULL;
3711 }
3712
3713
3714 gfc_expr *
3715 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3716 {
3717   gfc_expr *result;
3718   mp_exp_t emin, emax;
3719   int kind;
3720
3721   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3722     return NULL;
3723
3724   if (mpfr_sgn (s->value.real) == 0)
3725     {
3726       gfc_error ("Second argument of NEAREST at %L shall not be zero",
3727                  &s->where);
3728       return &gfc_bad_expr;
3729     }
3730
3731   result = gfc_copy_expr (x);
3732
3733   /* Save current values of emin and emax.  */
3734   emin = mpfr_get_emin ();
3735   emax = mpfr_get_emax ();
3736
3737   /* Set emin and emax for the current model number.  */
3738   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3739   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3740                 mpfr_get_prec(result->value.real) + 1);
3741   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3742   mpfr_check_range (result->value.real, 0, GMP_RNDU);
3743
3744   if (mpfr_sgn (s->value.real) > 0)
3745     {
3746       mpfr_nextabove (result->value.real);
3747       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3748     }
3749   else
3750     {
3751       mpfr_nextbelow (result->value.real);
3752       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3753     }
3754
3755   mpfr_set_emin (emin);
3756   mpfr_set_emax (emax);
3757
3758   /* Only NaN can occur. Do not use range check as it gives an
3759      error for denormal numbers.  */
3760   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3761     {
3762       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3763       gfc_free_expr (result);
3764       return &gfc_bad_expr;
3765     }
3766
3767   return result;
3768 }
3769
3770
3771 static gfc_expr *
3772 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3773 {
3774   gfc_expr *itrunc, *result;
3775   int kind;
3776
3777   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3778   if (kind == -1)
3779     return &gfc_bad_expr;
3780
3781   if (e->expr_type != EXPR_CONSTANT)
3782     return NULL;
3783
3784   itrunc = gfc_copy_expr (e);
3785   mpfr_round (itrunc->value.real, e->value.real);
3786
3787   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3788   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3789
3790   gfc_free_expr (itrunc);
3791
3792   return range_check (result, name);
3793 }
3794
3795
3796 gfc_expr *
3797 gfc_simplify_new_line (gfc_expr *e)
3798 {
3799   gfc_expr *result;
3800
3801   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
3802   result->value.character.string[0] = '\n';
3803
3804   return result;
3805 }
3806
3807
3808 gfc_expr *
3809 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3810 {
3811   return simplify_nint ("NINT", e, k);
3812 }
3813
3814
3815 gfc_expr *
3816 gfc_simplify_idnint (gfc_expr *e)
3817 {
3818   return simplify_nint ("IDNINT", e, NULL);
3819 }
3820
3821
3822 gfc_expr *
3823 gfc_simplify_not (gfc_expr *e)
3824 {
3825   gfc_expr *result;
3826
3827   if (e->expr_type != EXPR_CONSTANT)
3828     return NULL;
3829
3830   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3831   mpz_com (result->value.integer, e->value.integer);
3832
3833   return range_check (result, "NOT");
3834 }
3835
3836
3837 gfc_expr *
3838 gfc_simplify_null (gfc_expr *mold)
3839 {
3840   gfc_expr *result;
3841
3842   if (mold)
3843     {
3844       result = gfc_copy_expr (mold);
3845       result->expr_type = EXPR_NULL;
3846     }
3847   else
3848     result = gfc_get_null_expr (NULL);
3849
3850   return result;
3851 }
3852
3853
3854 gfc_expr *
3855 gfc_simplify_num_images (void)
3856 {
3857   gfc_expr *result;
3858
3859   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3860     {
3861       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3862       return &gfc_bad_expr;
3863     }
3864
3865   /* FIXME: gfc_current_locus is wrong.  */
3866   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3867                                   &gfc_current_locus);
3868   mpz_set_si (result->value.integer, 1);
3869   return result;
3870 }
3871
3872
3873 gfc_expr *
3874 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3875 {
3876   gfc_expr *result;
3877   int kind;
3878
3879   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3880     return NULL;
3881
3882   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3883
3884   switch (x->ts.type)
3885     {
3886       case BT_INTEGER:
3887         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3888         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3889         return range_check (result, "OR");
3890
3891       case BT_LOGICAL:
3892         return gfc_get_logical_expr (kind, &x->where,
3893                                      x->value.logical || y->value.logical);
3894       default:
3895         gcc_unreachable();
3896     }
3897 }
3898
3899
3900 gfc_expr *
3901 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3902 {
3903   gfc_expr *result;
3904   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3905
3906   if (!is_constant_array_expr(array)
3907       || !is_constant_array_expr(vector)
3908       || (!gfc_is_constant_expr (mask)
3909           && !is_constant_array_expr(mask)))
3910     return NULL;
3911
3912   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3913
3914   array_ctor = gfc_constructor_first (array->value.constructor);
3915   vector_ctor = vector
3916                   ? gfc_constructor_first (vector->value.constructor)
3917                   : NULL;
3918
3919   if (mask->expr_type == EXPR_CONSTANT
3920       && mask->value.logical)
3921     {
3922       /* Copy all elements of ARRAY to RESULT.  */
3923       while (array_ctor)
3924         {
3925           gfc_constructor_append_expr (&result->value.constructor,
3926                                        gfc_copy_expr (array_ctor->expr),
3927                                        NULL);
3928
3929           array_ctor = gfc_constructor_next (array_ctor);
3930           vector_ctor = gfc_constructor_next (vector_ctor);
3931         }
3932     }
3933   else if (mask->expr_type == EXPR_ARRAY)
3934     {
3935       /* Copy only those elements of ARRAY to RESULT whose
3936          MASK equals .TRUE..  */
3937       mask_ctor = gfc_constructor_first (mask->value.constructor);
3938       while (mask_ctor)
3939         {
3940           if (mask_ctor->expr->value.logical)
3941             {
3942               gfc_constructor_append_expr (&result->value.constructor,
3943                                            gfc_copy_expr (array_ctor->expr),
3944                                            NULL);
3945               vector_ctor = gfc_constructor_next (vector_ctor);
3946             }
3947
3948           array_ctor = gfc_constructor_next (array_ctor);
3949           mask_ctor = gfc_constructor_next (mask_ctor);
3950         }
3951     }
3952
3953   /* Append any left-over elements from VECTOR to RESULT.  */
3954   while (vector_ctor)
3955     {
3956       gfc_constructor_append_expr (&result->value.constructor,
3957                                    gfc_copy_expr (vector_ctor->expr),
3958                                    NULL);
3959       vector_ctor = gfc_constructor_next (vector_ctor);
3960     }
3961
3962   result->shape = gfc_get_shape (1);
3963   gfc_array_size (result, &result->shape[0]);
3964
3965   if (array->ts.type == BT_CHARACTER)
3966     result->ts.u.cl = array->ts.u.cl;
3967
3968   return result;
3969 }
3970
3971
3972 gfc_expr *
3973 gfc_simplify_precision (gfc_expr *e)
3974 {
3975   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3976   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3977                            gfc_real_kinds[i].precision);
3978 }
3979
3980
3981 gfc_expr *
3982 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3983 {
3984   gfc_expr *result;
3985
3986   if (!is_constant_array_expr (array)
3987       || !gfc_is_constant_expr (dim))
3988     return NULL;
3989
3990   if (mask
3991       && !is_constant_array_expr (mask)
3992       && mask->expr_type != EXPR_CONSTANT)
3993     return NULL;
3994
3995   result = transformational_result (array, dim, array->ts.type,
3996                                     array->ts.kind, &array->where);
3997   init_result_expr (result, 1, NULL);
3998
3999   return !dim || array->rank == 1 ?
4000     simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
4001     simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4002 }
4003
4004
4005 gfc_expr *
4006 gfc_simplify_radix (gfc_expr *e)
4007 {
4008   int i;
4009   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4010
4011   switch (e->ts.type)
4012     {
4013       case BT_INTEGER:
4014         i = gfc_integer_kinds[i].radix;
4015         break;
4016
4017       case BT_REAL:
4018         i = gfc_real_kinds[i].radix;
4019         break;
4020
4021       default:
4022         gcc_unreachable ();
4023     }
4024
4025   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4026 }
4027
4028
4029 gfc_expr *
4030 gfc_simplify_range (gfc_expr *e)
4031 {
4032   int i;
4033   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4034
4035   switch (e->ts.type)
4036     {
4037       case BT_INTEGER:
4038         i = gfc_integer_kinds[i].range;
4039         break;
4040
4041       case BT_REAL:
4042       case BT_COMPLEX:
4043         i = gfc_real_kinds[i].range;
4044         break;
4045
4046       default:
4047         gcc_unreachable ();
4048     }
4049
4050   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4051 }
4052
4053
4054 gfc_expr *
4055 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4056 {
4057   gfc_expr *result = NULL;
4058   int kind;
4059
4060   if (e->ts.type == BT_COMPLEX)
4061     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4062   else
4063     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4064
4065   if (kind == -1)
4066     return &gfc_bad_expr;
4067
4068   if (e->expr_type != EXPR_CONSTANT)
4069     return NULL;
4070
4071   if (convert_boz (e, kind) == &gfc_bad_expr)
4072     return &gfc_bad_expr;
4073
4074   result = gfc_convert_constant (e, BT_REAL, kind);
4075   if (result == &gfc_bad_expr)
4076     return &gfc_bad_expr;
4077
4078   return range_check (result, "REAL");
4079 }
4080
4081
4082 gfc_expr *
4083 gfc_simplify_realpart (gfc_expr *e)
4084 {
4085   gfc_expr *result;
4086
4087   if (e->expr_type != EXPR_CONSTANT)
4088     return NULL;
4089
4090   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4091   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4092
4093   return range_check (result, "REALPART");
4094 }
4095
4096 gfc_expr *
4097 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4098 {
4099   gfc_expr *result;
4100   int i, j, len, ncop, nlen;
4101   mpz_t ncopies;
4102   bool have_length = false;
4103
4104   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4105   if (n->expr_type != EXPR_CONSTANT)
4106     return NULL;
4107
4108   /* If NCOPIES is negative, it's an error.  */
4109   if (mpz_sgn (n->value.integer) < 0)
4110     {
4111       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4112                  &n->where);
4113       return &gfc_bad_expr;
4114     }
4115
4116   /* If we don't know the character length, we can do no more.  */
4117   if (e->ts.u.cl && e->ts.u.cl->length
4118         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4119     {
4120       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4121       have_length = true;
4122     }
4123   else if (e->expr_type == EXPR_CONSTANT
4124              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4125     {
4126       len = e->value.character.length;
4127     }
4128   else
4129     return NULL;
4130
4131   /* If the source length is 0, any value of NCOPIES is valid
4132      and everything behaves as if NCOPIES == 0.  */
4133   mpz_init (ncopies);
4134   if (len == 0)
4135     mpz_set_ui (ncopies, 0);
4136   else
4137     mpz_set (ncopies, n->value.integer);
4138
4139   /* Check that NCOPIES isn't too large.  */
4140   if (len)
4141     {
4142       mpz_t max, mlen;
4143       int i;
4144
4145       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4146       mpz_init (max);
4147       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4148
4149       if (have_length)
4150         {
4151           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4152                       e->ts.u.cl->length->value.integer);
4153         }
4154       else
4155         {
4156           mpz_init_set_si (mlen, len);
4157           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4158           mpz_clear (mlen);
4159         }
4160
4161       /* The check itself.  */
4162       if (mpz_cmp (ncopies, max) > 0)
4163         {
4164           mpz_clear (max);
4165           mpz_clear (ncopies);
4166           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4167                      &n->where);
4168           return &gfc_bad_expr;
4169         }
4170
4171       mpz_clear (max);
4172     }
4173   mpz_clear (ncopies);
4174
4175   /* For further simplification, we need the character string to be
4176      constant.  */
4177   if (e->expr_type != EXPR_CONSTANT)
4178     return NULL;
4179
4180   if (len ||
4181       (e->ts.u.cl->length &&
4182        mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4183     {
4184       const char *res = gfc_extract_int (n, &ncop);
4185       gcc_assert (res == NULL);
4186     }
4187   else
4188     ncop = 0;
4189
4190   len = e->value.character.length;
4191   nlen = ncop * len;
4192
4193   result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4194
4195   if (ncop == 0)
4196     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4197
4198   len = e->value.character.length;
4199   nlen = ncop * len;
4200
4201   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4202   for (i = 0; i < ncop; i++)
4203     for (j = 0; j < len; j++)
4204       result->value.character.string[j+i*len]= e->value.character.string[j];
4205
4206   result->value.character.string[nlen] = '\0';  /* For debugger */
4207   return result;
4208 }
4209
4210
4211 /* This one is a bear, but mainly has to do with shuffling elements.  */
4212
4213 gfc_expr *
4214 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4215                       gfc_expr *pad, gfc_expr *order_exp)
4216 {
4217   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4218   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4219   mpz_t index, size;
4220   unsigned long j;
4221   size_t nsource;
4222   gfc_expr *e, *result;
4223
4224   /* Check that argument expression types are OK.  */
4225   if (!is_constant_array_expr (source)
4226       || !is_constant_array_expr (shape_exp)
4227       || !is_constant_array_expr (pad)
4228       || !is_constant_array_expr (order_exp))
4229     return NULL;
4230
4231   /* Proceed with simplification, unpacking the array.  */
4232
4233   mpz_init (index);
4234   rank = 0;
4235
4236   for (;;)
4237     {
4238       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4239       if (e == NULL)
4240         break;
4241
4242       gfc_extract_int (e, &shape[rank]);
4243
4244       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4245       gcc_assert (shape[rank] >= 0);
4246
4247       rank++;
4248     }
4249
4250   gcc_assert (rank > 0);
4251
4252   /* Now unpack the order array if present.  */
4253   if (order_exp == NULL)
4254     {
4255       for (i = 0; i < rank; i++)
4256         order[i] = i;
4257     }
4258   else
4259     {
4260       for (i = 0; i < rank; i++)
4261         x[i] = 0;
4262
4263       for (i = 0; i < rank; i++)
4264         {
4265           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4266           gcc_assert (e);
4267
4268           gfc_extract_int (e, &order[i]);
4269
4270           gcc_assert (order[i] >= 1 && order[i] <= rank);
4271           order[i]--;
4272           gcc_assert (x[order[i]] == 0);
4273           x[order[i]] = 1;
4274         }
4275     }
4276
4277   /* Count the elements in the source and padding arrays.  */
4278
4279   npad = 0;
4280   if (pad != NULL)
4281     {
4282       gfc_array_size (pad, &size);
4283       npad = mpz_get_ui (size);
4284       mpz_clear (size);
4285     }
4286
4287   gfc_array_size (source, &size);
4288   nsource = mpz_get_ui (size);
4289   mpz_clear (size);
4290
4291   /* If it weren't for that pesky permutation we could just loop
4292      through the source and round out any shortage with pad elements.
4293      But no, someone just had to have the compiler do something the
4294      user should be doing.  */
4295
4296   for (i = 0; i < rank; i++)
4297     x[i] = 0;
4298
4299   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4300                                &source->where);
4301   result->rank = rank;
4302   result->shape = gfc_get_shape (rank);
4303   for (i = 0; i < rank; i++)
4304     mpz_init_set_ui (result->shape[i], shape[i]);
4305
4306   while (nsource > 0 || npad > 0)
4307     {
4308       /* Figure out which element to extract.  */
4309       mpz_set_ui (index, 0);
4310
4311       for (i = rank - 1; i >= 0; i--)
4312         {
4313           mpz_add_ui (index, index, x[order[i]]);
4314           if (i != 0)
4315             mpz_mul_ui (index, index, shape[order[i - 1]]);
4316         }
4317
4318       if (mpz_cmp_ui (index, INT_MAX) > 0)
4319         gfc_internal_error ("Reshaped array too large at %C");
4320
4321       j = mpz_get_ui (index);
4322
4323       if (j < nsource)
4324         e = gfc_constructor_lookup_expr (source->value.constructor, j);
4325       else
4326         {
4327           gcc_assert (npad > 0);
4328
4329           j = j - nsource;
4330           j = j % npad;
4331           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4332         }
4333       gcc_assert (e);
4334
4335       gfc_constructor_append_expr (&result->value.constructor,
4336                                    gfc_copy_expr (e), &e->where);
4337
4338       /* Calculate the next element.  */
4339       i = 0;
4340
4341 inc:
4342       if (++x[i] < shape[i])
4343         continue;
4344       x[i++] = 0;
4345       if (i < rank)
4346         goto inc;
4347
4348       break;
4349     }
4350
4351   mpz_clear (index);
4352
4353   return result;
4354 }
4355
4356
4357 gfc_expr *
4358 gfc_simplify_rrspacing (gfc_expr *x)
4359 {
4360   gfc_expr *result;
4361   int i;
4362   long int e, p;
4363
4364   if (x->expr_type != EXPR_CONSTANT)
4365     return NULL;
4366
4367   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4368
4369   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4370   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4371
4372   /* Special case x = -0 and 0.  */
4373   if (mpfr_sgn (result->value.real) == 0)
4374     {
4375       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4376       return result;
4377     }
4378
4379   /* | x * 2**(-e) | * 2**p.  */
4380   e = - (long int) mpfr_get_exp (x->value.real);
4381   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4382
4383   p = (long int) gfc_real_kinds[i].digits;
4384   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4385
4386   return range_check (result, "RRSPACING");
4387 }
4388
4389
4390 gfc_expr *
4391 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4392 {
4393   int k, neg_flag, power, exp_range;
4394   mpfr_t scale, radix;
4395   gfc_expr *result;
4396
4397   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4398     return NULL;
4399
4400   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4401
4402   if (mpfr_sgn (x->value.real) == 0)
4403     {
4404       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4405       return result;
4406     }
4407
4408   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4409
4410   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4411
4412   /* This check filters out values of i that would overflow an int.  */
4413   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4414       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4415     {
4416       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4417       gfc_free_expr (result);
4418       return &gfc_bad_expr;
4419     }
4420
4421   /* Compute scale = radix ** power.  */
4422   power = mpz_get_si (i->value.integer);
4423
4424   if (power >= 0)
4425     neg_flag = 0;
4426   else
4427     {
4428       neg_flag = 1;
4429       power = -power;
4430     }
4431
4432   gfc_set_model_kind (x->ts.kind);
4433   mpfr_init (scale);
4434   mpfr_init (radix);
4435   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4436   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4437
4438   if (neg_flag)
4439     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4440   else
4441     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4442
4443   mpfr_clears (scale, radix, NULL);
4444
4445   return range_check (result, "SCALE");
4446 }
4447
4448
4449 /* Variants of strspn and strcspn that operate on wide characters.  */
4450
4451 static size_t
4452 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4453 {
4454   size_t i = 0;
4455   const gfc_char_t *c;
4456
4457   while (s1[i])
4458     {
4459       for (c = s2; *c; c++)
4460         {
4461           if (s1[i] == *c)
4462             break;
4463         }
4464       if (*c == '\0')
4465         break;
4466       i++;
4467     }
4468
4469   return i;
4470 }
4471
4472 static size_t
4473 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4474 {
4475   size_t i = 0;
4476   const gfc_char_t *c;
4477
4478   while (s1[i])
4479     {
4480       for (c = s2; *c; c++)
4481         {
4482           if (s1[i] == *c)
4483             break;
4484         }
4485       if (*c)
4486         break;
4487       i++;
4488     }
4489
4490   return i;
4491 }
4492
4493
4494 gfc_expr *
4495 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4496 {
4497   gfc_expr *result;
4498   int back;
4499   size_t i;
4500   size_t indx, len, lenc;
4501   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4502
4503   if (k == -1)
4504     return &gfc_bad_expr;
4505
4506   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4507     return NULL;
4508
4509   if (b != NULL && b->value.logical != 0)
4510     back = 1;
4511   else
4512     back = 0;
4513
4514   len = e->value.character.length;
4515   lenc = c->value.character.length;
4516
4517   if (len == 0 || lenc == 0)
4518     {
4519       indx = 0;
4520     }
4521   else
4522     {
4523       if (back == 0)
4524         {
4525           indx = wide_strcspn (e->value.character.string,
4526                                c->value.character.string) + 1;
4527           if (indx > len)
4528             indx = 0;
4529         }
4530       else
4531         {
4532           i = 0;
4533           for (indx = len; indx > 0; indx--)
4534             {
4535               for (i = 0; i < lenc; i++)
4536                 {
4537                   if (c->value.character.string[i]
4538                       == e->value.character.string[indx - 1])
4539                     break;
4540                 }
4541               if (i < lenc)
4542                 break;
4543             }
4544         }
4545     }
4546
4547   result = gfc_get_int_expr (k, &e->where, indx);
4548   return range_check (result, "SCAN");
4549 }
4550
4551
4552 gfc_expr *
4553 gfc_simplify_selected_char_kind (gfc_expr *e)
4554 {
4555   int kind;
4556
4557   if (e->expr_type != EXPR_CONSTANT)
4558     return NULL;
4559
4560   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4561       || gfc_compare_with_Cstring (e, "default", false) == 0)
4562     kind = 1;
4563   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4564     kind = 4;
4565   else
4566     kind = -1;
4567
4568   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4569 }
4570
4571
4572 gfc_expr *
4573 gfc_simplify_selected_int_kind (gfc_expr *e)
4574 {
4575   int i, kind, range;
4576
4577   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4578     return NULL;
4579
4580   kind = INT_MAX;
4581
4582   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4583     if (gfc_integer_kinds[i].range >= range
4584         && gfc_integer_kinds[i].kind < kind)
4585       kind = gfc_integer_kinds[i].kind;
4586
4587   if (kind == INT_MAX)
4588     kind = -1;
4589
4590   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4591 }
4592
4593
4594 gfc_expr *
4595 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4596 {
4597   int range, precision, i, kind, found_precision, found_range;
4598
4599   if (p == NULL)
4600     precision = 0;
4601   else
4602     {
4603       if (p->expr_type != EXPR_CONSTANT
4604           || gfc_extract_int (p, &precision) != NULL)
4605         return NULL;
4606     }
4607
4608   if (q == NULL)
4609     range = 0;
4610   else
4611     {
4612       if (q->expr_type != EXPR_CONSTANT
4613           || gfc_extract_int (q, &range) != NULL)
4614         return NULL;
4615     }
4616
4617   kind = INT_MAX;
4618   found_precision = 0;
4619   found_range = 0;
4620
4621   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4622     {
4623       if (gfc_real_kinds[i].precision >= precision)
4624         found_precision = 1;
4625
4626       if (gfc_real_kinds[i].range >= range)
4627         found_range = 1;
4628
4629       if (gfc_real_kinds[i].precision >= precision
4630           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4631         kind = gfc_real_kinds[i].kind;
4632     }
4633
4634   if (kind == INT_MAX)
4635     {
4636       kind = 0;
4637
4638       if (!found_precision)
4639         kind = -1;
4640       if (!found_range)
4641         kind -= 2;
4642     }
4643
4644   return gfc_get_int_expr (gfc_default_integer_kind,
4645                            p ? &p->where : &q->where, kind);
4646 }
4647
4648
4649 gfc_expr *
4650 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4651 {
4652   gfc_expr *result;
4653   mpfr_t exp, absv, log2, pow2, frac;
4654   unsigned long exp2;
4655
4656   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4657     return NULL;
4658
4659   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4660
4661   if (mpfr_sgn (x->value.real) == 0)
4662     {
4663       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4664       return result;
4665     }
4666
4667   gfc_set_model_kind (x->ts.kind);
4668   mpfr_init (absv);
4669   mpfr_init (log2);
4670   mpfr_init (exp);
4671   mpfr_init (pow2);
4672   mpfr_init (frac);
4673
4674   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4675   mpfr_log2 (log2, absv, GFC_RND_MODE);
4676
4677   mpfr_trunc (log2, log2);
4678   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4679
4680   /* Old exponent value, and fraction.  */
4681   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4682
4683   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4684
4685   /* New exponent.  */
4686   exp2 = (unsigned long) mpz_get_d (i->value.integer);
4687   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4688
4689   mpfr_clears (absv, log2, pow2, frac, NULL);
4690
4691   return range_check (result, "SET_EXPONENT");
4692 }
4693
4694
4695 gfc_expr *
4696 gfc_simplify_shape (gfc_expr *source)
4697 {
4698   mpz_t shape[GFC_MAX_DIMENSIONS];
4699   gfc_expr *result, *e, *f;
4700   gfc_array_ref *ar;
4701   int n;
4702   gfc_try t;
4703
4704   if (source->rank == 0)
4705     return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4706                                &source->where);
4707
4708   if (source->expr_type != EXPR_VARIABLE)
4709     return NULL;
4710
4711   result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4712                                &source->where);
4713
4714   ar = gfc_find_array_ref (source);
4715
4716   t = gfc_array_ref_shape (ar, shape);
4717
4718   for (n = 0; n < source->rank; n++)
4719     {
4720       e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4721                                  &source->where);
4722
4723       if (t == SUCCESS)
4724         {
4725           mpz_set (e->value.integer, shape[n]);
4726           mpz_clear (shape[n]);
4727         }
4728       else
4729         {
4730           mpz_set_ui (e->value.integer, n + 1);
4731
4732           f = gfc_simplify_size (source, e, NULL);
4733           gfc_free_expr (e);
4734           if (f == NULL)
4735             {
4736               gfc_free_expr (result);
4737               return NULL;
4738             }
4739           else
4740             {
4741               e = f;
4742             }
4743         }
4744
4745       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4746     }
4747
4748   return result;
4749 }
4750
4751
4752 gfc_expr *
4753 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4754 {
4755   mpz_t size;
4756   int d;
4757   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4758
4759   if (k == -1)
4760     return &gfc_bad_expr;
4761
4762   if (dim == NULL)
4763     {
4764       if (gfc_array_size (array, &size) == FAILURE)
4765         return NULL;
4766     }
4767   else
4768     {
4769       if (dim->expr_type != EXPR_CONSTANT)
4770         return NULL;
4771
4772       d = mpz_get_ui (dim->value.integer) - 1;
4773       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4774         return NULL;
4775     }
4776
4777   return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4778 }
4779
4780
4781 gfc_expr *
4782 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4783 {
4784   gfc_expr *result;
4785
4786   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4787     return NULL;
4788
4789   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4790
4791   switch (x->ts.type)
4792     {
4793       case BT_INTEGER:
4794         mpz_abs (result->value.integer, x->value.integer);
4795         if (mpz_sgn (y->value.integer) < 0)
4796           mpz_neg (result->value.integer, result->value.integer);
4797         break;
4798
4799       case BT_REAL:
4800         if (gfc_option.flag_sign_zero)
4801           mpfr_copysign (result->value.real, x->value.real, y->value.real,
4802                         GFC_RND_MODE);
4803         else
4804           mpfr_setsign (result->value.real, x->value.real,
4805                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4806         break;
4807
4808       default:
4809         gfc_internal_error ("Bad type in gfc_simplify_sign");
4810     }
4811
4812   return result;
4813 }
4814
4815
4816 gfc_expr *
4817 gfc_simplify_sin (gfc_expr *x)
4818 {
4819   gfc_expr *result;
4820
4821   if (x->expr_type != EXPR_CONSTANT)
4822     return NULL;
4823
4824   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4825
4826   switch (x->ts.type)
4827     {
4828       case BT_REAL:
4829         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4830         break;
4831
4832       case BT_COMPLEX:
4833         gfc_set_model (x->value.real);
4834         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4835         break;
4836
4837       default:
4838         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4839     }
4840
4841   return range_check (result, "SIN");
4842 }
4843
4844
4845 gfc_expr *
4846 gfc_simplify_sinh (gfc_expr *x)
4847 {
4848   gfc_expr *result;
4849
4850   if (x->expr_type != EXPR_CONSTANT)
4851     return NULL;
4852
4853   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4854
4855   switch (x->ts.type)
4856     {
4857       case BT_REAL:
4858         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4859         break;
4860
4861       case BT_COMPLEX:
4862         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4863         break;
4864
4865       default:
4866         gcc_unreachable ();
4867     }
4868
4869   return range_check (result, "SINH");
4870 }
4871
4872
4873 /* The argument is always a double precision real that is converted to
4874    single precision.  TODO: Rounding!  */
4875
4876 gfc_expr *
4877 gfc_simplify_sngl (gfc_expr *a)
4878 {
4879   gfc_expr *result;
4880
4881   if (a->expr_type != EXPR_CONSTANT)
4882     return NULL;
4883
4884   result = gfc_real2real (a, gfc_default_real_kind);
4885   return range_check (result, "SNGL");
4886 }
4887
4888
4889 gfc_expr *
4890 gfc_simplify_spacing (gfc_expr *x)
4891 {
4892   gfc_expr *result;
4893   int i;
4894   long int en, ep;
4895
4896   if (x->expr_type != EXPR_CONSTANT)
4897     return NULL;
4898
4899   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4900
4901   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4902
4903   /* Special case x = 0 and -0.  */
4904   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4905   if (mpfr_sgn (result->value.real) == 0)
4906     {
4907       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4908       return result;
4909     }
4910
4911   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4912      are the radix, exponent of x, and precision.  This excludes the
4913      possibility of subnormal numbers.  Fortran 2003 states the result is
4914      b**max(e - p, emin - 1).  */
4915
4916   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4917   en = (long int) gfc_real_kinds[i].min_exponent - 1;
4918   en = en > ep ? en : ep;
4919
4920   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4921   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4922
4923   return range_check (result, "SPACING");
4924 }
4925
4926
4927 gfc_expr *
4928 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
4929 {
4930   gfc_expr *result = 0L;
4931   int i, j, dim, ncopies;
4932   mpz_t size;
4933
4934   if ((!gfc_is_constant_expr (source)
4935        && !is_constant_array_expr (source))
4936       || !gfc_is_constant_expr (dim_expr)
4937       || !gfc_is_constant_expr (ncopies_expr))
4938     return NULL;
4939
4940   gcc_assert (dim_expr->ts.type == BT_INTEGER);
4941   gfc_extract_int (dim_expr, &dim);
4942   dim -= 1;   /* zero-base DIM */
4943
4944   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
4945   gfc_extract_int (ncopies_expr, &ncopies);
4946   ncopies = MAX (ncopies, 0);
4947
4948   /* Do not allow the array size to exceed the limit for an array
4949      constructor.  */
4950   if (source->expr_type == EXPR_ARRAY)
4951     {
4952       if (gfc_array_size (source, &size) == FAILURE)
4953         gfc_internal_error ("Failure getting length of a constant array.");
4954     }
4955   else
4956     mpz_init_set_ui (size, 1);
4957
4958   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
4959     return NULL;
4960
4961   if (source->expr_type == EXPR_CONSTANT)
4962     {
4963       gcc_assert (dim == 0);
4964
4965       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4966                                    &source->where);
4967       result->rank = 1;
4968       result->shape = gfc_get_shape (result->rank);
4969       mpz_init_set_si (result->shape[0], ncopies);
4970
4971       for (i = 0; i < ncopies; ++i)
4972         gfc_constructor_append_expr (&result->value.constructor,
4973                                      gfc_copy_expr (source), NULL);
4974     }
4975   else if (source->expr_type == EXPR_ARRAY)
4976     {
4977       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
4978       gfc_constructor *source_ctor;
4979
4980       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
4981       gcc_assert (dim >= 0 && dim <= source->rank);
4982
4983       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4984                                    &source->where);
4985       result->rank = source->rank + 1;
4986       result->shape = gfc_get_shape (result->rank);
4987
4988       for (i = 0, j = 0; i < result->rank; ++i)
4989         {
4990           if (i != dim)
4991             mpz_init_set (result->shape[i], source->shape[j++]);
4992           else
4993             mpz_init_set_si (result->shape[i], ncopies);
4994
4995           extent[i] = mpz_get_si (result->shape[i]);
4996           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
4997         }
4998
4999       offset = 0;
5000       for (source_ctor = gfc_constructor_first (source->value.constructor);
5001            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5002         {
5003           for (i = 0; i < ncopies; ++i)
5004             gfc_constructor_insert_expr (&result->value.constructor,
5005                                          gfc_copy_expr (source_ctor->expr),
5006                                          NULL, offset + i * rstride[dim]);
5007
5008           offset += (dim == 0 ? ncopies : 1);
5009         }
5010     }
5011   else
5012     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5013        Replace NULL with gcc_unreachable() after implementing
5014        gfc_simplify_cshift(). */
5015     return NULL;
5016
5017   if (source->ts.type == BT_CHARACTER)
5018     result->ts.u.cl = source->ts.u.cl;
5019
5020   return result;
5021 }
5022
5023
5024 gfc_expr *
5025 gfc_simplify_sqrt (gfc_expr *e)
5026 {
5027   gfc_expr *result = NULL;
5028
5029   if (e->expr_type != EXPR_CONSTANT)
5030     return NULL;
5031
5032   switch (e->ts.type)
5033     {
5034       case BT_REAL:
5035         if (mpfr_cmp_si (e->value.real, 0) < 0)
5036           {
5037             gfc_error ("Argument of SQRT at %L has a negative value",
5038                        &e->where);
5039             return &gfc_bad_expr;
5040           }
5041         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5042         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5043         break;
5044
5045       case BT_COMPLEX:
5046         gfc_set_model (e->value.real);
5047
5048         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5049         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5050         break;
5051
5052       default:
5053         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5054     }
5055
5056   return range_check (result, "SQRT");
5057 }
5058
5059
5060 gfc_expr *
5061 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5062 {
5063   gfc_expr *result;
5064
5065   if (!is_constant_array_expr (array)
5066       || !gfc_is_constant_expr (dim))
5067     return NULL;
5068
5069   if (mask
5070       && !is_constant_array_expr (mask)
5071       && mask->expr_type != EXPR_CONSTANT)
5072     return NULL;
5073
5074   result = transformational_result (array, dim, array->ts.type,
5075                                     array->ts.kind, &array->where);
5076   init_result_expr (result, 0, NULL);
5077
5078   return !dim || array->rank == 1 ?
5079     simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5080     simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5081 }
5082
5083
5084 gfc_expr *
5085 gfc_simplify_tan (gfc_expr *x)
5086 {
5087   gfc_expr *result;
5088
5089   if (x->expr_type != EXPR_CONSTANT)
5090     return NULL;
5091
5092   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5093
5094   switch (x->ts.type)
5095     {
5096       case BT_REAL:
5097         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5098         break;
5099
5100       case BT_COMPLEX:
5101         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5102         break;
5103
5104       default:
5105         gcc_unreachable ();
5106     }
5107
5108   return range_check (result, "TAN");
5109 }
5110
5111
5112 gfc_expr *
5113 gfc_simplify_tanh (gfc_expr *x)
5114 {
5115   gfc_expr *result;
5116
5117   if (x->expr_type != EXPR_CONSTANT)
5118     return NULL;
5119
5120   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5121
5122   switch (x->ts.type)
5123     {
5124       case BT_REAL:
5125         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5126         break;
5127
5128       case BT_COMPLEX:
5129         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5130         break;
5131
5132       default:
5133         gcc_unreachable ();
5134     }
5135
5136   return range_check (result, "TANH");
5137 }
5138
5139
5140 gfc_expr *
5141 gfc_simplify_tiny (gfc_expr *e)
5142 {
5143   gfc_expr *result;
5144   int i;
5145
5146   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5147
5148   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5149   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5150
5151   return result;
5152 }
5153
5154
5155 gfc_expr *
5156 gfc_simplify_trailz (gfc_expr *e)
5157 {
5158   unsigned long tz, bs;
5159   int i;
5160
5161   if (e->expr_type != EXPR_CONSTANT)
5162     return NULL;
5163
5164   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5165   bs = gfc_integer_kinds[i].bit_size;
5166   tz = mpz_scan1 (e->value.integer, 0);
5167
5168   return gfc_get_int_expr (gfc_default_integer_kind,
5169                            &e->where, MIN (tz, bs));
5170 }
5171
5172
5173 gfc_expr *
5174 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5175 {
5176   gfc_expr *result;
5177   gfc_expr *mold_element;
5178   size_t source_size;
5179   size_t result_size;
5180   size_t result_elt_size;
5181   size_t buffer_size;
5182   mpz_t tmp;
5183   unsigned char *buffer;
5184
5185   if (!gfc_is_constant_expr (source)
5186         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5187         || !gfc_is_constant_expr (size))
5188     return NULL;
5189
5190   if (source->expr_type == EXPR_FUNCTION)
5191     return NULL;
5192
5193   /* Calculate the size of the source.  */
5194   if (source->expr_type == EXPR_ARRAY
5195       && gfc_array_size (source, &tmp) == FAILURE)
5196     gfc_internal_error ("Failure getting length of a constant array.");
5197
5198   source_size = gfc_target_expr_size (source);
5199
5200   /* Create an empty new expression with the appropriate characteristics.  */
5201   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5202                                   &source->where);
5203   result->ts = mold->ts;
5204
5205   mold_element = mold->expr_type == EXPR_ARRAY
5206                  ? gfc_constructor_first (mold->value.constructor)->expr
5207                  : mold;
5208
5209   /* Set result character length, if needed.  Note that this needs to be
5210      set even for array expressions, in order to pass this information into
5211      gfc_target_interpret_expr.  */
5212   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5213     result->value.character.length = mold_element->value.character.length;
5214
5215   /* Set the number of elements in the result, and determine its size.  */
5216   result_elt_size = gfc_target_expr_size (mold_element);
5217   if (result_elt_size == 0)
5218     {
5219       gfc_free_expr (result);
5220       return NULL;
5221     }
5222
5223   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5224     {
5225       int result_length;
5226
5227       result->expr_type = EXPR_ARRAY;
5228       result->rank = 1;
5229
5230       if (size)
5231         result_length = (size_t)mpz_get_ui (size->value.integer);
5232       else
5233         {
5234           result_length = source_size / result_elt_size;
5235           if (result_length * result_elt_size < source_size)
5236             result_length += 1;
5237         }
5238
5239       result->shape = gfc_get_shape (1);
5240       mpz_init_set_ui (result->shape[0], result_length);
5241
5242       result_size = result_length * result_elt_size;
5243     }
5244   else
5245     {
5246       result->rank = 0;
5247       result_size = result_elt_size;
5248     }
5249
5250   if (gfc_option.warn_surprising && source_size < result_size)
5251     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5252                 "source size %ld < result size %ld", &source->where,
5253                 (long) source_size, (long) result_size);
5254
5255   /* Allocate the buffer to store the binary version of the source.  */
5256   buffer_size = MAX (source_size, result_size);
5257   buffer = (unsigned char*)alloca (buffer_size);
5258   memset (buffer, 0, buffer_size);
5259
5260   /* Now write source to the buffer.  */
5261   gfc_target_encode_expr (source, buffer, buffer_size);
5262
5263   /* And read the buffer back into the new expression.  */
5264   gfc_target_interpret_expr (buffer, buffer_size, result);
5265
5266   return result;
5267 }
5268
5269
5270 gfc_expr *
5271 gfc_simplify_transpose (gfc_expr *matrix)
5272 {
5273   int row, matrix_rows, col, matrix_cols;
5274   gfc_expr *result;
5275
5276   if (!is_constant_array_expr (matrix))
5277     return NULL;
5278
5279   gcc_assert (matrix->rank == 2);
5280
5281   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5282                                &matrix->where);
5283   result->rank = 2;
5284   result->shape = gfc_get_shape (result->rank);
5285   mpz_set (result->shape[0], matrix->shape[1]);
5286   mpz_set (result->shape[1], matrix->shape[0]);
5287
5288   if (matrix->ts.type == BT_CHARACTER)
5289     result->ts.u.cl = matrix->ts.u.cl;
5290
5291   matrix_rows = mpz_get_si (matrix->shape[0]);
5292   matrix_cols = mpz_get_si (matrix->shape[1]);
5293   for (row = 0; row < matrix_rows; ++row)
5294     for (col = 0; col < matrix_cols; ++col)
5295       {
5296         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5297                                                    col * matrix_rows + row);
5298         gfc_constructor_insert_expr (&result->value.constructor,
5299                                      gfc_copy_expr (e), &matrix->where,
5300                                      row * matrix_cols + col);
5301       }
5302
5303   return result;
5304 }
5305
5306
5307 gfc_expr *
5308 gfc_simplify_trim (gfc_expr *e)
5309 {
5310   gfc_expr *result;
5311   int count, i, len, lentrim;
5312
5313   if (e->expr_type != EXPR_CONSTANT)
5314     return NULL;
5315
5316   len = e->value.character.length;
5317   for (count = 0, i = 1; i <= len; ++i)
5318     {
5319       if (e->value.character.string[len - i] == ' ')
5320         count++;
5321       else
5322         break;
5323     }
5324
5325   lentrim = len - count;
5326
5327   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5328   for (i = 0; i < lentrim; i++)
5329     result->value.character.string[i] = e->value.character.string[i];
5330
5331   return result;
5332
5333 not_implemented:
5334   gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5335              "cobounds at %L", &coarray->where);
5336   return &gfc_bad_expr;
5337 }
5338
5339
5340 gfc_expr *
5341 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5342 {
5343   gfc_ref *ref;
5344   gfc_array_spec *as;
5345   int d;
5346
5347   if (coarray == NULL)
5348     {
5349       gfc_expr *result;
5350       /* FIXME: gfc_current_locus is wrong.  */
5351       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5352                                       &gfc_current_locus);
5353       mpz_set_si (result->value.integer, 1);
5354       return result;
5355     }
5356
5357   gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5358
5359   /* Follow any component references.  */
5360   as = coarray->symtree->n.sym->as;
5361   for (ref = coarray->ref; ref; ref = ref->next)
5362     if (ref->type == REF_COMPONENT)
5363       as = ref->u.ar.as;
5364
5365   if (as->type == AS_DEFERRED)
5366     goto not_implemented; /* return NULL;*/
5367
5368   if (dim == NULL)
5369     {
5370       /* Multi-dimensional bounds.  */
5371       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5372       gfc_expr *e;
5373
5374       /* Simplify the bounds for each dimension.  */
5375       for (d = 0; d < as->corank; d++)
5376         {
5377           bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5378                                           as, NULL, true);
5379           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5380             {
5381               int j;
5382
5383               for (j = 0; j < d; j++)
5384                 gfc_free_expr (bounds[j]);
5385               if (bounds[d] == NULL)
5386                 goto not_implemented;
5387               return bounds[d];
5388             }
5389         }
5390
5391       /* Allocate the result expression.  */
5392       e = gfc_get_expr ();
5393       e->where = coarray->where;
5394       e->expr_type = EXPR_ARRAY;
5395       e->ts.type = BT_INTEGER;
5396       e->ts.kind = gfc_default_integer_kind;
5397
5398       e->rank = 1;
5399       e->shape = gfc_get_shape (1);
5400       mpz_init_set_ui (e->shape[0], as->corank);
5401
5402       /* Create the constructor for this array.  */
5403       for (d = 0; d < as->corank; d++)
5404         gfc_constructor_append_expr (&e->value.constructor,
5405                                      bounds[d], &e->where);
5406
5407       return e;
5408     }
5409   else
5410     {
5411       gfc_expr *e;
5412       /* A DIM argument is specified.  */
5413       if (dim->expr_type != EXPR_CONSTANT)
5414         goto not_implemented; /*return NULL;*/
5415
5416       d = mpz_get_si (dim->value.integer);
5417
5418       if (d < 1 || d > as->corank)
5419         {
5420           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5421           return &gfc_bad_expr;
5422         }
5423
5424       /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5425       e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5426       if (e != NULL)
5427         return e;
5428       else
5429         goto not_implemented;
5430    }
5431
5432 not_implemented:
5433   gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5434              "cobounds at %L", &coarray->where);
5435   return &gfc_bad_expr;
5436 }
5437
5438
5439 gfc_expr *
5440 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
5441 {
5442   gfc_expr *result;
5443   gfc_ref *ref;
5444   gfc_array_spec *as;
5445   gfc_constructor *sub_cons;
5446   bool first_image;
5447   int d;
5448
5449   if (!is_constant_array_expr (sub))
5450     goto not_implemented; /* return NULL;*/
5451
5452   /* Follow any component references.  */
5453   as = coarray->symtree->n.sym->as;
5454   for (ref = coarray->ref; ref; ref = ref->next)
5455     if (ref->type == REF_COMPONENT)
5456       as = ref->u.ar.as;
5457
5458   if (as->type == AS_DEFERRED)
5459     goto not_implemented; /* return NULL;*/
5460
5461   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
5462      the cosubscript addresses the first image.  */
5463
5464   sub_cons = gfc_constructor_first (sub->value.constructor);
5465   first_image = true;
5466
5467   for (d = 1; d <= as->corank; d++)
5468     {
5469       gfc_expr *ca_bound;
5470       int cmp;
5471
5472       if (sub_cons == NULL)
5473         {
5474           gfc_error ("Too few elements in expression for SUB= argument at %L",
5475                      &sub->where);
5476           return &gfc_bad_expr;
5477         }
5478
5479       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
5480                                      NULL, true);
5481       if (ca_bound == NULL)
5482         goto not_implemented; /* return NULL */
5483
5484       if (ca_bound == &gfc_bad_expr)
5485         return ca_bound;
5486
5487       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
5488
5489       if (cmp == 0)
5490         {
5491           gfc_free_expr (ca_bound);
5492           sub_cons = gfc_constructor_next (sub_cons);
5493           continue;
5494         }
5495
5496       first_image = false;
5497
5498       if (cmp > 0)
5499         {
5500           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5501                      "SUB has %ld and COARRAY lower bound is %ld)",
5502                      &coarray->where, d,
5503                      mpz_get_si (sub_cons->expr->value.integer),
5504                      mpz_get_si (ca_bound->value.integer));
5505           gfc_free_expr (ca_bound);
5506           return &gfc_bad_expr;
5507         }
5508
5509       gfc_free_expr (ca_bound);
5510
5511       /* Check whether upperbound is valid for the multi-images case.  */
5512       if (d < as->corank)
5513         {
5514           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
5515                                          NULL, true);
5516           if (ca_bound == &gfc_bad_expr)
5517             return ca_bound;
5518
5519           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
5520               && mpz_cmp (ca_bound->value.integer,
5521                           sub_cons->expr->value.integer) < 0)
5522           {
5523             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5524                        "SUB has %ld and COARRAY upper bound is %ld)",
5525                        &coarray->where, d,
5526                        mpz_get_si (sub_cons->expr->value.integer),
5527                        mpz_get_si (ca_bound->value.integer));
5528             gfc_free_expr (ca_bound);
5529             return &gfc_bad_expr;
5530           }
5531
5532           if (ca_bound)
5533             gfc_free_expr (ca_bound);
5534         }
5535
5536       sub_cons = gfc_constructor_next (sub_cons);
5537     }
5538
5539   if (sub_cons != NULL)
5540     {
5541       gfc_error ("Too many elements in expression for SUB= argument at %L",
5542                  &sub->where);
5543       return &gfc_bad_expr;
5544     }
5545
5546   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5547                                   &gfc_current_locus);
5548   if (first_image)
5549     mpz_set_si (result->value.integer, 1);
5550   else
5551     mpz_set_si (result->value.integer, 0);
5552
5553   return result;
5554
5555 not_implemented:
5556   gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5557              "cobounds at %L", &coarray->where);
5558   return &gfc_bad_expr;
5559 }
5560
5561
5562 gfc_expr *
5563 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5564 {
5565   gfc_ref *ref;
5566   gfc_array_spec *as;
5567   int d;
5568
5569   if (coarray == NULL)
5570     {
5571       gfc_expr *result;
5572       /* FIXME: gfc_current_locus is wrong.  */
5573       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5574                                       &gfc_current_locus);
5575       mpz_set_si (result->value.integer, 1);
5576       return result;
5577     }
5578
5579   gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5580
5581   /* Follow any component references.  */
5582   as = coarray->symtree->n.sym->as;
5583   for (ref = coarray->ref; ref; ref = ref->next)
5584     if (ref->type == REF_COMPONENT)
5585       as = ref->u.ar.as;
5586
5587   if (as->type == AS_DEFERRED)
5588     goto not_implemented; /* return NULL;*/
5589
5590   if (dim == NULL)
5591     {
5592       /* Multi-dimensional bounds.  */
5593       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5594       gfc_expr *e;
5595
5596       /* Simplify the bounds for each dimension.  */
5597       for (d = 0; d < as->corank; d++)
5598         {
5599           bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5600                                           as, NULL, true);
5601           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5602             {
5603               int j;
5604
5605               for (j = 0; j < d; j++)
5606                 gfc_free_expr (bounds[j]);
5607               if (bounds[d] == NULL)
5608                 goto not_implemented;
5609               return bounds[d];
5610             }
5611         }
5612
5613       /* Allocate the result expression.  */
5614       e = gfc_get_expr ();
5615       e->where = coarray->where;
5616       e->expr_type = EXPR_ARRAY;
5617       e->ts.type = BT_INTEGER;
5618       e->ts.kind = gfc_default_integer_kind;
5619
5620       e->rank = 1;
5621       e->shape = gfc_get_shape (1);
5622       mpz_init_set_ui (e->shape[0], as->corank);
5623
5624       /* Create the constructor for this array.  */
5625       for (d = 0; d < as->corank; d++)
5626         gfc_constructor_append_expr (&e->value.constructor,
5627                                      bounds[d], &e->where);
5628
5629       return e;
5630     }
5631   else
5632     {
5633       gfc_expr *e;
5634       /* A DIM argument is specified.  */
5635       if (dim->expr_type != EXPR_CONSTANT)
5636         goto not_implemented; /*return NULL;*/
5637
5638       d = mpz_get_si (dim->value.integer);
5639
5640       if (d < 1 || d > as->corank)
5641         {
5642           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5643           return &gfc_bad_expr;
5644         }
5645
5646       /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5647       e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5648       if (e != NULL)
5649         return e;
5650       else
5651         goto not_implemented;
5652    }
5653
5654 not_implemented:
5655   gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5656              "cobounds at %L", &coarray->where);
5657   return &gfc_bad_expr;
5658 }
5659
5660
5661 gfc_expr *
5662 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5663 {
5664   return simplify_bound (array, dim, kind, 1);
5665 }
5666
5667 gfc_expr *
5668 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5669 {
5670   gfc_expr *e;
5671   /* return simplify_cobound (array, dim, kind, 1);*/
5672
5673   e = simplify_cobound (array, dim, kind, 1);
5674   if (e != NULL)
5675     return e;
5676
5677   gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5678              "cobounds at %L", &array->where);
5679   return &gfc_bad_expr;
5680 }
5681
5682
5683 gfc_expr *
5684 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5685 {
5686   gfc_expr *result, *e;
5687   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5688
5689   if (!is_constant_array_expr (vector)
5690       || !is_constant_array_expr (mask)
5691       || (!gfc_is_constant_expr (field)
5692           && !is_constant_array_expr(field)))
5693     return NULL;
5694
5695   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5696                                &vector->where);
5697   result->rank = mask->rank;
5698   result->shape = gfc_copy_shape (mask->shape, mask->rank);
5699
5700   if (vector->ts.type == BT_CHARACTER)
5701     result->ts.u.cl = vector->ts.u.cl;
5702
5703   vector_ctor = gfc_constructor_first (vector->value.constructor);
5704   mask_ctor = gfc_constructor_first (mask->value.constructor);
5705   field_ctor
5706     = field->expr_type == EXPR_ARRAY
5707                             ? gfc_constructor_first (field->value.constructor)
5708                             : NULL;
5709
5710   while (mask_ctor)
5711     {
5712       if (mask_ctor->expr->value.logical)
5713         {
5714           gcc_assert (vector_ctor);
5715           e = gfc_copy_expr (vector_ctor->expr);
5716           vector_ctor = gfc_constructor_next (vector_ctor);
5717         }
5718       else if (field->expr_type == EXPR_ARRAY)
5719         e = gfc_copy_expr (field_ctor->expr);
5720       else
5721         e = gfc_copy_expr (field);
5722
5723       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5724
5725       mask_ctor = gfc_constructor_next (mask_ctor);
5726       field_ctor = gfc_constructor_next (field_ctor);
5727     }
5728
5729   return result;
5730 }
5731
5732
5733 gfc_expr *
5734 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5735 {
5736   gfc_expr *result;
5737   int back;
5738   size_t index, len, lenset;
5739   size_t i;
5740   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5741
5742   if (k == -1)
5743     return &gfc_bad_expr;
5744
5745   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5746     return NULL;
5747
5748   if (b != NULL && b->value.logical != 0)
5749     back = 1;
5750   else
5751     back = 0;
5752
5753   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5754
5755   len = s->value.character.length;
5756   lenset = set->value.character.length;
5757
5758   if (len == 0)
5759     {
5760       mpz_set_ui (result->value.integer, 0);
5761       return result;
5762     }
5763
5764   if (back == 0)
5765     {
5766       if (lenset == 0)
5767         {
5768           mpz_set_ui (result->value.integer, 1);
5769           return result;
5770         }
5771
5772       index = wide_strspn (s->value.character.string,
5773                            set->value.character.string) + 1;
5774       if (index > len)
5775         index = 0;
5776
5777     }
5778   else
5779     {
5780       if (lenset == 0)
5781         {
5782           mpz_set_ui (result->value.integer, len);
5783           return result;
5784         }
5785       for (index = len; index > 0; index --)
5786         {
5787           for (i = 0; i < lenset; i++)
5788             {
5789               if (s->value.character.string[index - 1]
5790                   == set->value.character.string[i])
5791                 break;
5792             }
5793           if (i == lenset)
5794             break;
5795         }
5796     }
5797
5798   mpz_set_ui (result->value.integer, index);
5799   return result;
5800 }
5801
5802
5803 gfc_expr *
5804 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5805 {
5806   gfc_expr *result;
5807   int kind;
5808
5809   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5810     return NULL;
5811
5812   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5813
5814   switch (x->ts.type)
5815     {
5816       case BT_INTEGER:
5817         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5818         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5819         return range_check (result, "XOR");
5820
5821       case BT_LOGICAL:
5822         return gfc_get_logical_expr (kind, &x->where,
5823                                      (x->value.logical && !y->value.logical)
5824                                      || (!x->value.logical && y->value.logical));
5825
5826       default:
5827         gcc_unreachable ();
5828     }
5829 }
5830
5831
5832 /****************** Constant simplification *****************/
5833
5834 /* Master function to convert one constant to another.  While this is
5835    used as a simplification function, it requires the destination type
5836    and kind information which is supplied by a special case in
5837    do_simplify().  */
5838
5839 gfc_expr *
5840 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5841 {
5842   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5843   gfc_constructor *c;
5844
5845   switch (e->ts.type)
5846     {
5847     case BT_INTEGER:
5848       switch (type)
5849         {
5850         case BT_INTEGER:
5851           f = gfc_int2int;
5852           break;
5853         case BT_REAL:
5854           f = gfc_int2real;
5855           break;
5856         case BT_COMPLEX:
5857           f = gfc_int2complex;
5858           break;
5859         case BT_LOGICAL:
5860           f = gfc_int2log;
5861           break;
5862         default:
5863           goto oops;
5864         }
5865       break;
5866
5867     case BT_REAL:
5868       switch (type)
5869         {
5870         case BT_INTEGER:
5871           f = gfc_real2int;
5872           break;
5873         case BT_REAL:
5874           f = gfc_real2real;
5875           break;
5876         case BT_COMPLEX:
5877           f = gfc_real2complex;
5878           break;
5879         default:
5880           goto oops;
5881         }
5882       break;
5883
5884     case BT_COMPLEX:
5885       switch (type)
5886         {
5887         case BT_INTEGER:
5888           f = gfc_complex2int;
5889           break;
5890         case BT_REAL:
5891           f = gfc_complex2real;
5892           break;
5893         case BT_COMPLEX:
5894           f = gfc_complex2complex;
5895           break;
5896
5897         default:
5898           goto oops;
5899         }
5900       break;
5901
5902     case BT_LOGICAL:
5903       switch (type)
5904         {
5905         case BT_INTEGER:
5906           f = gfc_log2int;
5907           break;
5908         case BT_LOGICAL:
5909           f = gfc_log2log;
5910           break;
5911         default:
5912           goto oops;
5913         }
5914       break;
5915
5916     case BT_HOLLERITH:
5917       switch (type)
5918         {
5919         case BT_INTEGER:
5920           f = gfc_hollerith2int;
5921           break;
5922
5923         case BT_REAL:
5924           f = gfc_hollerith2real;
5925           break;
5926
5927         case BT_COMPLEX:
5928           f = gfc_hollerith2complex;
5929           break;
5930
5931         case BT_CHARACTER:
5932           f = gfc_hollerith2character;
5933           break;
5934
5935         case BT_LOGICAL:
5936           f = gfc_hollerith2logical;
5937           break;
5938
5939         default:
5940           goto oops;
5941         }
5942       break;
5943
5944     default:
5945     oops:
5946       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5947     }
5948
5949   result = NULL;
5950
5951   switch (e->expr_type)
5952     {
5953     case EXPR_CONSTANT:
5954       result = f (e, kind);
5955       if (result == NULL)
5956         return &gfc_bad_expr;
5957       break;
5958
5959     case EXPR_ARRAY:
5960       if (!gfc_is_constant_expr (e))
5961         break;
5962
5963       result = gfc_get_array_expr (type, kind, &e->where);
5964       result->shape = gfc_copy_shape (e->shape, e->rank);
5965       result->rank = e->rank;
5966
5967       for (c = gfc_constructor_first (e->value.constructor);
5968            c; c = gfc_constructor_next (c))
5969         {
5970           gfc_expr *tmp;
5971           if (c->iterator == NULL)
5972             tmp = f (c->expr, kind);
5973           else
5974             {
5975               g = gfc_convert_constant (c->expr, type, kind);
5976               if (g == &gfc_bad_expr)
5977                 {
5978                   gfc_free_expr (result);
5979                   return g;
5980                 }
5981               tmp = g;
5982             }
5983
5984           if (tmp == NULL)
5985             {
5986               gfc_free_expr (result);
5987               return NULL;
5988             }
5989
5990           gfc_constructor_append_expr (&result->value.constructor,
5991                                        tmp, &c->where);
5992         }
5993
5994       break;
5995
5996     default:
5997       break;
5998     }
5999
6000   return result;
6001 }
6002
6003
6004 /* Function for converting character constants.  */
6005 gfc_expr *
6006 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6007 {
6008   gfc_expr *result;
6009   int i;
6010
6011   if (!gfc_is_constant_expr (e))
6012     return NULL;
6013
6014   if (e->expr_type == EXPR_CONSTANT)
6015     {
6016       /* Simple case of a scalar.  */
6017       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6018       if (result == NULL)
6019         return &gfc_bad_expr;
6020
6021       result->value.character.length = e->value.character.length;
6022       result->value.character.string
6023         = gfc_get_wide_string (e->value.character.length + 1);
6024       memcpy (result->value.character.string, e->value.character.string,
6025               (e->value.character.length + 1) * sizeof (gfc_char_t));
6026
6027       /* Check we only have values representable in the destination kind.  */
6028       for (i = 0; i < result->value.character.length; i++)
6029         if (!gfc_check_character_range (result->value.character.string[i],
6030                                         kind))
6031           {
6032             gfc_error ("Character '%s' in string at %L cannot be converted "
6033                        "into character kind %d",
6034                        gfc_print_wide_char (result->value.character.string[i]),
6035                        &e->where, kind);
6036             return &gfc_bad_expr;
6037           }
6038
6039       return result;
6040     }
6041   else if (e->expr_type == EXPR_ARRAY)
6042     {
6043       /* For an array constructor, we convert each constructor element.  */
6044       gfc_constructor *c;
6045
6046       result = gfc_get_array_expr (type, kind, &e->where);
6047       result->shape = gfc_copy_shape (e->shape, e->rank);
6048       result->rank = e->rank;
6049       result->ts.u.cl = e->ts.u.cl;
6050
6051       for (c = gfc_constructor_first (e->value.constructor);
6052            c; c = gfc_constructor_next (c))
6053         {
6054           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6055           if (tmp == &gfc_bad_expr)
6056             {
6057               gfc_free_expr (result);
6058               return &gfc_bad_expr;
6059             }
6060
6061           if (tmp == NULL)
6062             {
6063               gfc_free_expr (result);
6064               return NULL;
6065             }
6066
6067           gfc_constructor_append_expr (&result->value.constructor,
6068                                        tmp, &c->where);
6069         }
6070
6071       return result;
6072     }
6073   else
6074     return NULL;
6075 }