gcc/fortran/simplify.cc

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