gcc/fortran/simplify.cc

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