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   int d;
5481   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5482
5483   if (k == -1)
5484     return &gfc_bad_expr;
5485
5486   /* For unary operations, the size of the result is given by the size
5487      of the operand.  For binary ones, it's the size of the first operand
5488      unless it is scalar, then it is the size of the second.  */
5489   if (array->expr_type == EXPR_OP && !array->value.op.uop)
5490     {
5491       gfc_expr* replacement;
5492       gfc_expr* simplified;
5493
5494       switch (array->value.op.op)
5495         {
5496           /* Unary operations.  */
5497           case INTRINSIC_NOT:
5498           case INTRINSIC_UPLUS:
5499           case INTRINSIC_UMINUS:
5500             replacement = array->value.op.op1;
5501             break;
5502
5503           /* Binary operations.  If any one of the operands is scalar, take
5504              the other one's size.  If both of them are arrays, it does not
5505              matter -- try to find one with known shape, if possible.  */
5506           default:
5507             if (array->value.op.op1->rank == 0)
5508               replacement = array->value.op.op2;
5509             else if (array->value.op.op2->rank == 0)
5510               replacement = array->value.op.op1;
5511             else
5512               {
5513                 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5514                 if (simplified)
5515                   return simplified;
5516
5517                 replacement = array->value.op.op2;
5518               }
5519             break;
5520         }
5521
5522       /* Try to reduce it directly if possible.  */
5523       simplified = gfc_simplify_size (replacement, dim, kind);
5524
5525       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5526          simpler than the original one.  */
5527       if (!simplified)
5528         simplified = gfc_build_intrinsic_call ("size", array->where, 3,
5529                                                gfc_copy_expr (replacement),
5530                                                gfc_copy_expr (dim),
5531                                                gfc_copy_expr (kind));
5532
5533       return simplified;
5534     }
5535
5536   if (dim == NULL)
5537     {
5538       if (gfc_array_size (array, &size) == FAILURE)
5539         return NULL;
5540     }
5541   else
5542     {
5543       if (dim->expr_type != EXPR_CONSTANT)
5544         return NULL;
5545
5546       d = mpz_get_ui (dim->value.integer) - 1;
5547       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
5548         return NULL;
5549     }
5550
5551   return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5552 }
5553
5554
5555 gfc_expr *
5556 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5557 {
5558   gfc_expr *result;
5559
5560   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5561     return NULL;
5562
5563   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5564
5565   switch (x->ts.type)
5566     {
5567       case BT_INTEGER:
5568         mpz_abs (result->value.integer, x->value.integer);
5569         if (mpz_sgn (y->value.integer) < 0)
5570           mpz_neg (result->value.integer, result->value.integer);
5571         break;
5572
5573       case BT_REAL:
5574         if (gfc_option.flag_sign_zero)
5575           mpfr_copysign (result->value.real, x->value.real, y->value.real,
5576                         GFC_RND_MODE);
5577         else
5578           mpfr_setsign (result->value.real, x->value.real,
5579                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5580         break;
5581
5582       default:
5583         gfc_internal_error ("Bad type in gfc_simplify_sign");
5584     }
5585
5586   return result;
5587 }
5588
5589
5590 gfc_expr *
5591 gfc_simplify_sin (gfc_expr *x)
5592 {
5593   gfc_expr *result;
5594
5595   if (x->expr_type != EXPR_CONSTANT)
5596     return NULL;
5597
5598   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5599
5600   switch (x->ts.type)
5601     {
5602       case BT_REAL:
5603         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5604         break;
5605
5606       case BT_COMPLEX:
5607         gfc_set_model (x->value.real);
5608         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5609         break;
5610
5611       default:
5612         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5613     }
5614
5615   return range_check (result, "SIN");
5616 }
5617
5618
5619 gfc_expr *
5620 gfc_simplify_sinh (gfc_expr *x)
5621 {
5622   gfc_expr *result;
5623
5624   if (x->expr_type != EXPR_CONSTANT)
5625     return NULL;
5626
5627   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5628
5629   switch (x->ts.type)
5630     {
5631       case BT_REAL:
5632         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5633         break;
5634
5635       case BT_COMPLEX:
5636         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5637         break;
5638
5639       default:
5640         gcc_unreachable ();
5641     }
5642
5643   return range_check (result, "SINH");
5644 }
5645
5646
5647 /* The argument is always a double precision real that is converted to
5648    single precision.  TODO: Rounding!  */
5649
5650 gfc_expr *
5651 gfc_simplify_sngl (gfc_expr *a)
5652 {
5653   gfc_expr *result;
5654
5655   if (a->expr_type != EXPR_CONSTANT)
5656     return NULL;
5657
5658   result = gfc_real2real (a, gfc_default_real_kind);
5659   return range_check (result, "SNGL");
5660 }
5661
5662
5663 gfc_expr *
5664 gfc_simplify_spacing (gfc_expr *x)
5665 {
5666   gfc_expr *result;
5667   int i;
5668   long int en, ep;
5669
5670   if (x->expr_type != EXPR_CONSTANT)
5671     return NULL;
5672
5673   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5674
5675   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5676
5677   /* Special case x = 0 and -0.  */
5678   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5679   if (mpfr_sgn (result->value.real) == 0)
5680     {
5681       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5682       return result;
5683     }
5684
5685   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5686      are the radix, exponent of x, and precision.  This excludes the
5687      possibility of subnormal numbers.  Fortran 2003 states the result is
5688      b**max(e - p, emin - 1).  */
5689
5690   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5691   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5692   en = en > ep ? en : ep;
5693
5694   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5695   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5696
5697   return range_check (result, "SPACING");
5698 }
5699
5700
5701 gfc_expr *
5702 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5703 {
5704   gfc_expr *result = 0L;
5705   int i, j, dim, ncopies;
5706   mpz_t size;
5707
5708   if ((!gfc_is_constant_expr (source)
5709        && !is_constant_array_expr (source))
5710       || !gfc_is_constant_expr (dim_expr)
5711       || !gfc_is_constant_expr (ncopies_expr))
5712     return NULL;
5713
5714   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5715   gfc_extract_int (dim_expr, &dim);
5716   dim -= 1;   /* zero-base DIM */
5717
5718   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5719   gfc_extract_int (ncopies_expr, &ncopies);
5720   ncopies = MAX (ncopies, 0);
5721
5722   /* Do not allow the array size to exceed the limit for an array
5723      constructor.  */
5724   if (source->expr_type == EXPR_ARRAY)
5725     {
5726       if (gfc_array_size (source, &size) == FAILURE)
5727         gfc_internal_error ("Failure getting length of a constant array.");
5728     }
5729   else
5730     mpz_init_set_ui (size, 1);
5731
5732   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5733     return NULL;
5734
5735   if (source->expr_type == EXPR_CONSTANT)
5736     {
5737       gcc_assert (dim == 0);
5738
5739       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5740                                    &source->where);
5741       if (source->ts.type == BT_DERIVED)
5742         result->ts.u.derived = source->ts.u.derived;
5743       result->rank = 1;
5744       result->shape = gfc_get_shape (result->rank);
5745       mpz_init_set_si (result->shape[0], ncopies);
5746
5747       for (i = 0; i < ncopies; ++i)
5748         gfc_constructor_append_expr (&result->value.constructor,
5749                                      gfc_copy_expr (source), NULL);
5750     }
5751   else if (source->expr_type == EXPR_ARRAY)
5752     {
5753       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5754       gfc_constructor *source_ctor;
5755
5756       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5757       gcc_assert (dim >= 0 && dim <= source->rank);
5758
5759       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5760                                    &source->where);
5761       if (source->ts.type == BT_DERIVED)
5762         result->ts.u.derived = source->ts.u.derived;
5763       result->rank = source->rank + 1;
5764       result->shape = gfc_get_shape (result->rank);
5765
5766       for (i = 0, j = 0; i < result->rank; ++i)
5767         {
5768           if (i != dim)
5769             mpz_init_set (result->shape[i], source->shape[j++]);
5770           else
5771             mpz_init_set_si (result->shape[i], ncopies);
5772
5773           extent[i] = mpz_get_si (result->shape[i]);
5774           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5775         }
5776
5777       offset = 0;
5778       for (source_ctor = gfc_constructor_first (source->value.constructor);
5779            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5780         {
5781           for (i = 0; i < ncopies; ++i)
5782             gfc_constructor_insert_expr (&result->value.constructor,
5783                                          gfc_copy_expr (source_ctor->expr),
5784                                          NULL, offset + i * rstride[dim]);
5785
5786           offset += (dim == 0 ? ncopies : 1);
5787         }
5788     }
5789   else
5790     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5791        Replace NULL with gcc_unreachable() after implementing
5792        gfc_simplify_cshift(). */
5793     return NULL;
5794
5795   if (source->ts.type == BT_CHARACTER)
5796     result->ts.u.cl = source->ts.u.cl;
5797
5798   return result;
5799 }
5800
5801
5802 gfc_expr *
5803 gfc_simplify_sqrt (gfc_expr *e)
5804 {
5805   gfc_expr *result = NULL;
5806
5807   if (e->expr_type != EXPR_CONSTANT)
5808     return NULL;
5809
5810   switch (e->ts.type)
5811     {
5812       case BT_REAL:
5813         if (mpfr_cmp_si (e->value.real, 0) < 0)
5814           {
5815             gfc_error ("Argument of SQRT at %L has a negative value",
5816                        &e->where);
5817             return &gfc_bad_expr;
5818           }
5819         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5820         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5821         break;
5822
5823       case BT_COMPLEX:
5824         gfc_set_model (e->value.real);
5825
5826         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5827         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5828         break;
5829
5830       default:
5831         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5832     }
5833
5834   return range_check (result, "SQRT");
5835 }
5836
5837
5838 gfc_expr *
5839 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5840 {
5841   return simplify_transformation (array, dim, mask, 0, gfc_add);
5842 }
5843
5844
5845 gfc_expr *
5846 gfc_simplify_tan (gfc_expr *x)
5847 {
5848   gfc_expr *result;
5849
5850   if (x->expr_type != EXPR_CONSTANT)
5851     return NULL;
5852
5853   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5854
5855   switch (x->ts.type)
5856     {
5857       case BT_REAL:
5858         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5859         break;
5860
5861       case BT_COMPLEX:
5862         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5863         break;
5864
5865       default:
5866         gcc_unreachable ();
5867     }
5868
5869   return range_check (result, "TAN");
5870 }
5871
5872
5873 gfc_expr *
5874 gfc_simplify_tanh (gfc_expr *x)
5875 {
5876   gfc_expr *result;
5877
5878   if (x->expr_type != EXPR_CONSTANT)
5879     return NULL;
5880
5881   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5882
5883   switch (x->ts.type)
5884     {
5885       case BT_REAL:
5886         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5887         break;
5888
5889       case BT_COMPLEX:
5890         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5891         break;
5892
5893       default:
5894         gcc_unreachable ();
5895     }
5896
5897   return range_check (result, "TANH");
5898 }
5899
5900
5901 gfc_expr *
5902 gfc_simplify_tiny (gfc_expr *e)
5903 {
5904   gfc_expr *result;
5905   int i;
5906
5907   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5908
5909   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5910   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5911
5912   return result;
5913 }
5914
5915
5916 gfc_expr *
5917 gfc_simplify_trailz (gfc_expr *e)
5918 {
5919   unsigned long tz, bs;
5920   int i;
5921
5922   if (e->expr_type != EXPR_CONSTANT)
5923     return NULL;
5924
5925   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5926   bs = gfc_integer_kinds[i].bit_size;
5927   tz = mpz_scan1 (e->value.integer, 0);
5928
5929   return gfc_get_int_expr (gfc_default_integer_kind,
5930                            &e->where, MIN (tz, bs));
5931 }
5932
5933
5934 gfc_expr *
5935 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5936 {
5937   gfc_expr *result;
5938   gfc_expr *mold_element;
5939   size_t source_size;
5940   size_t result_size;
5941   size_t result_elt_size;
5942   size_t buffer_size;
5943   mpz_t tmp;
5944   unsigned char *buffer;
5945
5946   if (!gfc_is_constant_expr (source)
5947         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5948         || !gfc_is_constant_expr (size))
5949     return NULL;
5950
5951   if (source->expr_type == EXPR_FUNCTION)
5952     return NULL;
5953
5954   /* Calculate the size of the source.  */
5955   if (source->expr_type == EXPR_ARRAY
5956       && gfc_array_size (source, &tmp) == FAILURE)
5957     gfc_internal_error ("Failure getting length of a constant array.");
5958
5959   source_size = gfc_target_expr_size (source);
5960
5961   /* Create an empty new expression with the appropriate characteristics.  */
5962   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5963                                   &source->where);
5964   result->ts = mold->ts;
5965
5966   mold_element = mold->expr_type == EXPR_ARRAY
5967                  ? gfc_constructor_first (mold->value.constructor)->expr
5968                  : mold;
5969
5970   /* Set result character length, if needed.  Note that this needs to be
5971      set even for array expressions, in order to pass this information into
5972      gfc_target_interpret_expr.  */
5973   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5974     result->value.character.length = mold_element->value.character.length;
5975
5976   /* Set the number of elements in the result, and determine its size.  */
5977   result_elt_size = gfc_target_expr_size (mold_element);
5978   if (result_elt_size == 0)
5979     {
5980       gfc_free_expr (result);
5981       return NULL;
5982     }
5983
5984   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5985     {
5986       int result_length;
5987
5988       result->expr_type = EXPR_ARRAY;
5989       result->rank = 1;
5990
5991       if (size)
5992         result_length = (size_t)mpz_get_ui (size->value.integer);
5993       else
5994         {
5995           result_length = source_size / result_elt_size;
5996           if (result_length * result_elt_size < source_size)
5997             result_length += 1;
5998         }
5999
6000       result->shape = gfc_get_shape (1);
6001       mpz_init_set_ui (result->shape[0], result_length);
6002
6003       result_size = result_length * result_elt_size;
6004     }
6005   else
6006     {
6007       result->rank = 0;
6008       result_size = result_elt_size;
6009     }
6010
6011   if (gfc_option.warn_surprising && source_size < result_size)
6012     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
6013                 "source size %ld < result size %ld", &source->where,
6014                 (long) source_size, (long) result_size);
6015
6016   /* Allocate the buffer to store the binary version of the source.  */
6017   buffer_size = MAX (source_size, result_size);
6018   buffer = (unsigned char*)alloca (buffer_size);
6019   memset (buffer, 0, buffer_size);
6020
6021   /* Now write source to the buffer.  */
6022   gfc_target_encode_expr (source, buffer, buffer_size);
6023
6024   /* And read the buffer back into the new expression.  */
6025   gfc_target_interpret_expr (buffer, buffer_size, result);
6026
6027   return result;
6028 }
6029
6030
6031 gfc_expr *
6032 gfc_simplify_transpose (gfc_expr *matrix)
6033 {
6034   int row, matrix_rows, col, matrix_cols;
6035   gfc_expr *result;
6036
6037   if (!is_constant_array_expr (matrix))
6038     return NULL;
6039
6040   gcc_assert (matrix->rank == 2);
6041
6042   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6043                                &matrix->where);
6044   result->rank = 2;
6045   result->shape = gfc_get_shape (result->rank);
6046   mpz_set (result->shape[0], matrix->shape[1]);
6047   mpz_set (result->shape[1], matrix->shape[0]);
6048
6049   if (matrix->ts.type == BT_CHARACTER)
6050     result->ts.u.cl = matrix->ts.u.cl;
6051   else if (matrix->ts.type == BT_DERIVED)
6052     result->ts.u.derived = matrix->ts.u.derived;
6053
6054   matrix_rows = mpz_get_si (matrix->shape[0]);
6055   matrix_cols = mpz_get_si (matrix->shape[1]);
6056   for (row = 0; row < matrix_rows; ++row)
6057     for (col = 0; col < matrix_cols; ++col)
6058       {
6059         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6060                                                    col * matrix_rows + row);
6061         gfc_constructor_insert_expr (&result->value.constructor,
6062                                      gfc_copy_expr (e), &matrix->where,
6063                                      row * matrix_cols + col);
6064       }
6065
6066   return result;
6067 }
6068
6069
6070 gfc_expr *
6071 gfc_simplify_trim (gfc_expr *e)
6072 {
6073   gfc_expr *result;
6074   int count, i, len, lentrim;
6075
6076   if (e->expr_type != EXPR_CONSTANT)
6077     return NULL;
6078
6079   len = e->value.character.length;
6080   for (count = 0, i = 1; i <= len; ++i)
6081     {
6082       if (e->value.character.string[len - i] == ' ')
6083         count++;
6084       else
6085         break;
6086     }
6087
6088   lentrim = len - count;
6089
6090   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6091   for (i = 0; i < lentrim; i++)
6092     result->value.character.string[i] = e->value.character.string[i];
6093
6094   return result;
6095 }
6096
6097
6098 gfc_expr *
6099 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6100 {
6101   gfc_expr *result;
6102   gfc_ref *ref;
6103   gfc_array_spec *as;
6104   gfc_constructor *sub_cons;
6105   bool first_image;
6106   int d;
6107
6108   if (!is_constant_array_expr (sub))
6109     goto not_implemented; /* return NULL;*/
6110
6111   /* Follow any component references.  */
6112   as = coarray->symtree->n.sym->as;
6113   for (ref = coarray->ref; ref; ref = ref->next)
6114     if (ref->type == REF_COMPONENT)
6115       as = ref->u.ar.as;
6116
6117   if (as->type == AS_DEFERRED)
6118     goto not_implemented; /* return NULL;*/
6119
6120   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6121      the cosubscript addresses the first image.  */
6122
6123   sub_cons = gfc_constructor_first (sub->value.constructor);
6124   first_image = true;
6125
6126   for (d = 1; d <= as->corank; d++)
6127     {
6128       gfc_expr *ca_bound;
6129       int cmp;
6130
6131       if (sub_cons == NULL)
6132         {
6133           gfc_error ("Too few elements in expression for SUB= argument at %L",
6134                      &sub->where);
6135           return &gfc_bad_expr;
6136         }
6137
6138       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6139                                      NULL, true);
6140       if (ca_bound == NULL)
6141         goto not_implemented; /* return NULL */
6142
6143       if (ca_bound == &gfc_bad_expr)
6144         return ca_bound;
6145
6146       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6147
6148       if (cmp == 0)
6149         {
6150           gfc_free_expr (ca_bound);
6151           sub_cons = gfc_constructor_next (sub_cons);
6152           continue;
6153         }
6154
6155       first_image = false;
6156
6157       if (cmp > 0)
6158         {
6159           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6160                      "SUB has %ld and COARRAY lower bound is %ld)",
6161                      &coarray->where, d,
6162                      mpz_get_si (sub_cons->expr->value.integer),
6163                      mpz_get_si (ca_bound->value.integer));
6164           gfc_free_expr (ca_bound);
6165           return &gfc_bad_expr;
6166         }
6167
6168       gfc_free_expr (ca_bound);
6169
6170       /* Check whether upperbound is valid for the multi-images case.  */
6171       if (d < as->corank)
6172         {
6173           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6174                                          NULL, true);
6175           if (ca_bound == &gfc_bad_expr)
6176             return ca_bound;
6177
6178           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6179               && mpz_cmp (ca_bound->value.integer,
6180                           sub_cons->expr->value.integer) < 0)
6181           {
6182             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6183                        "SUB has %ld and COARRAY upper bound is %ld)",
6184                        &coarray->where, d,
6185                        mpz_get_si (sub_cons->expr->value.integer),
6186                        mpz_get_si (ca_bound->value.integer));
6187             gfc_free_expr (ca_bound);
6188             return &gfc_bad_expr;
6189           }
6190
6191           if (ca_bound)
6192             gfc_free_expr (ca_bound);
6193         }
6194
6195       sub_cons = gfc_constructor_next (sub_cons);
6196     }
6197
6198   if (sub_cons != NULL)
6199     {
6200       gfc_error ("Too many elements in expression for SUB= argument at %L",
6201                  &sub->where);
6202       return &gfc_bad_expr;
6203     }
6204
6205   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6206                                   &gfc_current_locus);
6207   if (first_image)
6208     mpz_set_si (result->value.integer, 1);
6209   else
6210     mpz_set_si (result->value.integer, 0);
6211
6212   return result;
6213
6214 not_implemented:
6215   gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
6216              "cobounds at %L", &coarray->where);
6217   return &gfc_bad_expr;
6218 }
6219
6220
6221 gfc_expr *
6222 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6223 {
6224   gfc_ref *ref;
6225   gfc_array_spec *as;
6226   int d;
6227
6228   if (coarray == NULL)
6229     {
6230       gfc_expr *result;
6231       /* FIXME: gfc_current_locus is wrong.  */
6232       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6233                                       &gfc_current_locus);
6234       mpz_set_si (result->value.integer, 1);
6235       return result;
6236     }
6237
6238   gcc_assert (coarray->expr_type == EXPR_VARIABLE);
6239
6240   /* Follow any component references.  */
6241   as = coarray->symtree->n.sym->as;
6242   for (ref = coarray->ref; ref; ref = ref->next)
6243     if (ref->type == REF_COMPONENT)
6244       as = ref->u.ar.as;
6245
6246   if (as->type == AS_DEFERRED)
6247     goto not_implemented; /* return NULL;*/
6248
6249   if (dim == NULL)
6250     {
6251       /* Multi-dimensional bounds.  */
6252       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
6253       gfc_expr *e;
6254
6255       /* Simplify the bounds for each dimension.  */
6256       for (d = 0; d < as->corank; d++)
6257         {
6258           bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
6259                                           as, NULL, true);
6260           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
6261             {
6262               int j;
6263
6264               for (j = 0; j < d; j++)
6265                 gfc_free_expr (bounds[j]);
6266               if (bounds[d] == NULL)
6267                 goto not_implemented;
6268               return bounds[d];
6269             }
6270         }
6271
6272       /* Allocate the result expression.  */
6273       e = gfc_get_expr ();
6274       e->where = coarray->where;
6275       e->expr_type = EXPR_ARRAY;
6276       e->ts.type = BT_INTEGER;
6277       e->ts.kind = gfc_default_integer_kind;
6278
6279       e->rank = 1;
6280       e->shape = gfc_get_shape (1);
6281       mpz_init_set_ui (e->shape[0], as->corank);
6282
6283       /* Create the constructor for this array.  */
6284       for (d = 0; d < as->corank; d++)
6285         gfc_constructor_append_expr (&e->value.constructor,
6286                                      bounds[d], &e->where);
6287
6288       return e;
6289     }
6290   else
6291     {
6292       gfc_expr *e;
6293       /* A DIM argument is specified.  */
6294       if (dim->expr_type != EXPR_CONSTANT)
6295         goto not_implemented; /*return NULL;*/
6296
6297       d = mpz_get_si (dim->value.integer);
6298
6299       if (d < 1 || d > as->corank)
6300         {
6301           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
6302           return &gfc_bad_expr;
6303         }
6304
6305       /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
6306       e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
6307       if (e != NULL)
6308         return e;
6309       else
6310         goto not_implemented;
6311    }
6312
6313 not_implemented:
6314   gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
6315              "cobounds at %L", &coarray->where);
6316   return &gfc_bad_expr;
6317 }
6318
6319
6320 gfc_expr *
6321 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6322 {
6323   return simplify_bound (array, dim, kind, 1);
6324 }
6325
6326 gfc_expr *
6327 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6328 {
6329   gfc_expr *e;
6330   /* return simplify_cobound (array, dim, kind, 1);*/
6331
6332   e = simplify_cobound (array, dim, kind, 1);
6333   if (e != NULL)
6334     return e;
6335
6336   gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
6337              "cobounds at %L", &array->where);
6338   return &gfc_bad_expr;
6339 }
6340
6341
6342 gfc_expr *
6343 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6344 {
6345   gfc_expr *result, *e;
6346   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6347
6348   if (!is_constant_array_expr (vector)
6349       || !is_constant_array_expr (mask)
6350       || (!gfc_is_constant_expr (field)
6351           && !is_constant_array_expr(field)))
6352     return NULL;
6353
6354   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6355                                &vector->where);
6356   if (vector->ts.type == BT_DERIVED)
6357     result->ts.u.derived = vector->ts.u.derived;
6358   result->rank = mask->rank;
6359   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6360
6361   if (vector->ts.type == BT_CHARACTER)
6362     result->ts.u.cl = vector->ts.u.cl;
6363
6364   vector_ctor = gfc_constructor_first (vector->value.constructor);
6365   mask_ctor = gfc_constructor_first (mask->value.constructor);
6366   field_ctor
6367     = field->expr_type == EXPR_ARRAY
6368                             ? gfc_constructor_first (field->value.constructor)
6369                             : NULL;
6370
6371   while (mask_ctor)
6372     {
6373       if (mask_ctor->expr->value.logical)
6374         {
6375           gcc_assert (vector_ctor);
6376           e = gfc_copy_expr (vector_ctor->expr);
6377           vector_ctor = gfc_constructor_next (vector_ctor);
6378         }
6379       else if (field->expr_type == EXPR_ARRAY)
6380         e = gfc_copy_expr (field_ctor->expr);
6381       else
6382         e = gfc_copy_expr (field);
6383
6384       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6385
6386       mask_ctor = gfc_constructor_next (mask_ctor);
6387       field_ctor = gfc_constructor_next (field_ctor);
6388     }
6389
6390   return result;
6391 }
6392
6393
6394 gfc_expr *
6395 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6396 {
6397   gfc_expr *result;
6398   int back;
6399   size_t index, len, lenset;
6400   size_t i;
6401   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6402
6403   if (k == -1)
6404     return &gfc_bad_expr;
6405
6406   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
6407     return NULL;
6408
6409   if (b != NULL && b->value.logical != 0)
6410     back = 1;
6411   else
6412     back = 0;
6413
6414   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6415
6416   len = s->value.character.length;
6417   lenset = set->value.character.length;
6418
6419   if (len == 0)
6420     {
6421       mpz_set_ui (result->value.integer, 0);
6422       return result;
6423     }
6424
6425   if (back == 0)
6426     {
6427       if (lenset == 0)
6428         {
6429           mpz_set_ui (result->value.integer, 1);
6430           return result;
6431         }
6432
6433       index = wide_strspn (s->value.character.string,
6434                            set->value.character.string) + 1;
6435       if (index > len)
6436         index = 0;
6437
6438     }
6439   else
6440     {
6441       if (lenset == 0)
6442         {
6443           mpz_set_ui (result->value.integer, len);
6444           return result;
6445         }
6446       for (index = len; index > 0; index --)
6447         {
6448           for (i = 0; i < lenset; i++)
6449             {
6450               if (s->value.character.string[index - 1]
6451                   == set->value.character.string[i])
6452                 break;
6453             }
6454           if (i == lenset)
6455             break;
6456         }
6457     }
6458
6459   mpz_set_ui (result->value.integer, index);
6460   return result;
6461 }
6462
6463
6464 gfc_expr *
6465 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6466 {
6467   gfc_expr *result;
6468   int kind;
6469
6470   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6471     return NULL;
6472
6473   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6474
6475   switch (x->ts.type)
6476     {
6477       case BT_INTEGER:
6478         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6479         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6480         return range_check (result, "XOR");
6481
6482       case BT_LOGICAL:
6483         return gfc_get_logical_expr (kind, &x->where,
6484                                      (x->value.logical && !y->value.logical)
6485                                      || (!x->value.logical && y->value.logical));
6486
6487       default:
6488         gcc_unreachable ();
6489     }
6490 }
6491
6492
6493 /****************** Constant simplification *****************/
6494
6495 /* Master function to convert one constant to another.  While this is
6496    used as a simplification function, it requires the destination type
6497    and kind information which is supplied by a special case in
6498    do_simplify().  */
6499
6500 gfc_expr *
6501 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6502 {
6503   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6504   gfc_constructor *c;
6505
6506   switch (e->ts.type)
6507     {
6508     case BT_INTEGER:
6509       switch (type)
6510         {
6511         case BT_INTEGER:
6512           f = gfc_int2int;
6513           break;
6514         case BT_REAL:
6515           f = gfc_int2real;
6516           break;
6517         case BT_COMPLEX:
6518           f = gfc_int2complex;
6519           break;
6520         case BT_LOGICAL:
6521           f = gfc_int2log;
6522           break;
6523         default:
6524           goto oops;
6525         }
6526       break;
6527
6528     case BT_REAL:
6529       switch (type)
6530         {
6531         case BT_INTEGER:
6532           f = gfc_real2int;
6533           break;
6534         case BT_REAL:
6535           f = gfc_real2real;
6536           break;
6537         case BT_COMPLEX:
6538           f = gfc_real2complex;
6539           break;
6540         default:
6541           goto oops;
6542         }
6543       break;
6544
6545     case BT_COMPLEX:
6546       switch (type)
6547         {
6548         case BT_INTEGER:
6549           f = gfc_complex2int;
6550           break;
6551         case BT_REAL:
6552           f = gfc_complex2real;
6553           break;
6554         case BT_COMPLEX:
6555           f = gfc_complex2complex;
6556           break;
6557
6558         default:
6559           goto oops;
6560         }
6561       break;
6562
6563     case BT_LOGICAL:
6564       switch (type)
6565         {
6566         case BT_INTEGER:
6567           f = gfc_log2int;
6568           break;
6569         case BT_LOGICAL:
6570           f = gfc_log2log;
6571           break;
6572         default:
6573           goto oops;
6574         }
6575       break;
6576
6577     case BT_HOLLERITH:
6578       switch (type)
6579         {
6580         case BT_INTEGER:
6581           f = gfc_hollerith2int;
6582           break;
6583
6584         case BT_REAL:
6585           f = gfc_hollerith2real;
6586           break;
6587
6588         case BT_COMPLEX:
6589           f = gfc_hollerith2complex;
6590           break;
6591
6592         case BT_CHARACTER:
6593           f = gfc_hollerith2character;
6594           break;
6595
6596         case BT_LOGICAL:
6597           f = gfc_hollerith2logical;
6598           break;
6599
6600         default:
6601           goto oops;
6602         }
6603       break;
6604
6605     default:
6606     oops:
6607       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6608     }
6609
6610   result = NULL;
6611
6612   switch (e->expr_type)
6613     {
6614     case EXPR_CONSTANT:
6615       result = f (e, kind);
6616       if (result == NULL)
6617         return &gfc_bad_expr;
6618       break;
6619
6620     case EXPR_ARRAY:
6621       if (!gfc_is_constant_expr (e))
6622         break;
6623
6624       result = gfc_get_array_expr (type, kind, &e->where);
6625       result->shape = gfc_copy_shape (e->shape, e->rank);
6626       result->rank = e->rank;
6627
6628       for (c = gfc_constructor_first (e->value.constructor);
6629            c; c = gfc_constructor_next (c))
6630         {
6631           gfc_expr *tmp;
6632           if (c->iterator == NULL)
6633             tmp = f (c->expr, kind);
6634           else
6635             {
6636               g = gfc_convert_constant (c->expr, type, kind);
6637               if (g == &gfc_bad_expr)
6638                 {
6639                   gfc_free_expr (result);
6640                   return g;
6641                 }
6642               tmp = g;
6643             }
6644
6645           if (tmp == NULL)
6646             {
6647               gfc_free_expr (result);
6648               return NULL;
6649             }
6650
6651           gfc_constructor_append_expr (&result->value.constructor,
6652                                        tmp, &c->where);
6653         }
6654
6655       break;
6656
6657     default:
6658       break;
6659     }
6660
6661   return result;
6662 }
6663
6664
6665 /* Function for converting character constants.  */
6666 gfc_expr *
6667 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6668 {
6669   gfc_expr *result;
6670   int i;
6671
6672   if (!gfc_is_constant_expr (e))
6673     return NULL;
6674
6675   if (e->expr_type == EXPR_CONSTANT)
6676     {
6677       /* Simple case of a scalar.  */
6678       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6679       if (result == NULL)
6680         return &gfc_bad_expr;
6681
6682       result->value.character.length = e->value.character.length;
6683       result->value.character.string
6684         = gfc_get_wide_string (e->value.character.length + 1);
6685       memcpy (result->value.character.string, e->value.character.string,
6686               (e->value.character.length + 1) * sizeof (gfc_char_t));
6687
6688       /* Check we only have values representable in the destination kind.  */
6689       for (i = 0; i < result->value.character.length; i++)
6690         if (!gfc_check_character_range (result->value.character.string[i],
6691                                         kind))
6692           {
6693             gfc_error ("Character '%s' in string at %L cannot be converted "
6694                        "into character kind %d",
6695                        gfc_print_wide_char (result->value.character.string[i]),
6696                        &e->where, kind);
6697             return &gfc_bad_expr;
6698           }
6699
6700       return result;
6701     }
6702   else if (e->expr_type == EXPR_ARRAY)
6703     {
6704       /* For an array constructor, we convert each constructor element.  */
6705       gfc_constructor *c;
6706
6707       result = gfc_get_array_expr (type, kind, &e->where);
6708       result->shape = gfc_copy_shape (e->shape, e->rank);
6709       result->rank = e->rank;
6710       result->ts.u.cl = e->ts.u.cl;
6711
6712       for (c = gfc_constructor_first (e->value.constructor);
6713            c; c = gfc_constructor_next (c))
6714         {
6715           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6716           if (tmp == &gfc_bad_expr)
6717             {
6718               gfc_free_expr (result);
6719               return &gfc_bad_expr;
6720             }
6721
6722           if (tmp == NULL)
6723             {
6724               gfc_free_expr (result);
6725               return NULL;
6726             }
6727
6728           gfc_constructor_append_expr (&result->value.constructor,
6729                                        tmp, &c->where);
6730         }
6731
6732       return result;
6733     }
6734   else
6735     return NULL;
6736 }
6737
6738
6739 gfc_expr *
6740 gfc_simplify_compiler_options (void)
6741 {
6742   char *str;
6743   gfc_expr *result;
6744
6745   str = gfc_get_option_string ();
6746   result = gfc_get_character_expr (gfc_default_character_kind,
6747                                    &gfc_current_locus, str, strlen (str));
6748   gfc_free (str);
6749   return result;
6750 }
6751
6752
6753 gfc_expr *
6754 gfc_simplify_compiler_version (void)
6755 {
6756   char *buffer;
6757   size_t len;
6758
6759   len = strlen ("GCC version ") + strlen (version_string) + 1;
6760   buffer = (char*) alloca (len);
6761   snprintf (buffer, len, "GCC version %s", version_string);
6762   return gfc_get_character_expr (gfc_default_character_kind,
6763                                 &gfc_current_locus, buffer, len);
6764 }