gcc/fortran/simplify.c

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