gcc/fortran/simplify.c

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