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