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