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