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