gcc/fortran/simplify.c

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