gcc/fortran/simplify.c

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