gcc/fortran/simplify.c

   1 /* Simplify intrinsic functions at compile-time.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
   3    2010 Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "arith.h"
  27 #include "intrinsic.h"
  28 #include "target-memory.h"
  29 #include "constructor.h"
  30
  31
  32 gfc_expr gfc_bad_expr;
  33
  34
  35 /* Note that 'simplification' is not just transforming expressions.
  36    For functions that are not simplified at compile time, range
  37    checking is done if possible.
  38
  39    The return convention is that each simplification function returns:
  40
  41      A new expression node corresponding to the simplified arguments.
  42      The original arguments are destroyed by the caller, and must not
  43      be a part of the new expression.
  44
  45      NULL pointer indicating that no simplification was possible and
  46      the original expression should remain intact.
  47
  48      An expression pointer to gfc_bad_expr (a static placeholder)
  49      indicating that some error has prevented simplification.  The
  50      error is generated within the function and should be propagated
  51      upwards
  52
  53    By the time a simplification function gets control, it has been
  54    decided that the function call is really supposed to be the
  55    intrinsic.  No type checking is strictly necessary, since only
  56    valid types will be passed on.  On the other hand, a simplification
  57    subroutine may have to look at the type of an argument as part of
  58    its processing.
  59
  60    Array arguments are only passed to these subroutines that implement
  61    the simplification of transformational intrinsics.
  62
  63    The functions in this file don't have much comment with them, but
  64    everything is reasonably straight-forward.  The Standard, chapter 13
  65    is the best comment you'll find for this file anyway.  */
  66
  67 /* Range checks an expression node.  If all goes well, returns the
  68    node, otherwise returns &gfc_bad_expr and frees the node.  */
  69
  70 static gfc_expr *
  71 range_check (gfc_expr *result, const char *name)
  72 {
  73   if (result == NULL)
  74     return &gfc_bad_expr;
  75
  76   if (result->expr_type != EXPR_CONSTANT)
  77     return result;
  78
  79   switch (gfc_range_check (result))
  80     {
  81       case ARITH_OK:
  82         return result;
  83
  84       case ARITH_OVERFLOW:
  85         gfc_error ("Result of %s overflows its kind at %L", name,
  86                    &result->where);
  87         break;
  88
  89       case ARITH_UNDERFLOW:
  90         gfc_error ("Result of %s underflows its kind at %L", name,
  91                    &result->where);
  92         break;
  93
  94       case ARITH_NAN:
  95         gfc_error ("Result of %s is NaN at %L", name, &result->where);
  96         break;
  97
  98       default:
  99         gfc_error ("Result of %s gives range error for its kind at %L", name,
 100                    &result->where);
 101         break;
 102     }
 103
 104   gfc_free_expr (result);
 105   return &gfc_bad_expr;
 106 }
 107
 108
 109 /* A helper function that gets an optional and possibly missing
 110    kind parameter.  Returns the kind, -1 if something went wrong.  */
 111
 112 static int
 113 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 114 {
 115   int kind;
 116
 117   if (k == NULL)
 118     return default_kind;
 119
 120   if (k->expr_type != EXPR_CONSTANT)
 121     {
 122       gfc_error ("KIND parameter of %s at %L must be an initialization "
 123                  "expression", name, &k->where);
 124       return -1;
 125     }
 126
 127   if (gfc_extract_int (k, &kind) != NULL
 128       || gfc_validate_kind (type, kind, true) < 0)
 129     {
 130       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
 131       return -1;
 132     }
 133
 134   return kind;
 135 }
 136
 137
 138 /* Converts an mpz_t signed variable into an unsigned one, assuming
 139    two's complement representations and a binary width of bitsize.
 140    The conversion is a no-op unless x is negative; otherwise, it can
 141    be accomplished by masking out the high bits.  */
 142
 143 static void
 144 convert_mpz_to_unsigned (mpz_t x, int bitsize)
 145 {
 146   mpz_t mask;
 147
 148   if (mpz_sgn (x) < 0)
 149     {
 150       /* Confirm that no bits above the signed range are unset.  */
 151       gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
 152
 153       mpz_init_set_ui (mask, 1);
 154       mpz_mul_2exp (mask, mask, bitsize);
 155       mpz_sub_ui (mask, mask, 1);
 156
 157       mpz_and (x, x, mask);
 158
 159       mpz_clear (mask);
 160     }
 161   else
 162     {
 163       /* Confirm that no bits above the signed range are set.  */
 164       gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
 165     }
 166 }
 167
 168
 169 /* Converts an mpz_t unsigned variable into a signed one, assuming
 170    two's complement representations and a binary width of bitsize.
 171    If the bitsize-1 bit is set, this is taken as a sign bit and
 172    the number is converted to the corresponding negative number.  */
 173
 174 static void
 175 convert_mpz_to_signed (mpz_t x, int bitsize)
 176 {
 177   mpz_t mask;
 178
 179   /* Confirm that no bits above the unsigned range are set.  */
 180   gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
 181
 182   if (mpz_tstbit (x, bitsize - 1) == 1)
 183     {
 184       mpz_init_set_ui (mask, 1);
 185       mpz_mul_2exp (mask, mask, bitsize);
 186       mpz_sub_ui (mask, mask, 1);
 187
 188       /* We negate the number by hand, zeroing the high bits, that is
 189          make it the corresponding positive number, and then have it
 190          negated by GMP, giving the correct representation of the
 191          negative number.  */
 192       mpz_com (x, x);
 193       mpz_add_ui (x, x, 1);
 194       mpz_and (x, x, mask);
 195
 196       mpz_neg (x, x);
 197
 198       mpz_clear (mask);
 199     }
 200 }
 201
 202
 203 /* In-place convert BOZ to REAL of the specified kind.  */
 204
 205 static gfc_expr *
 206 convert_boz (gfc_expr *x, int kind)
 207 {
 208   if (x && x->ts.type == BT_INTEGER && x->is_boz)
 209     {
 210       gfc_typespec ts;
 211       gfc_clear_ts (&ts);
 212       ts.type = BT_REAL;
 213       ts.kind = kind;
 214
 215       if (!gfc_convert_boz (x, &ts))
 216         return &gfc_bad_expr;
 217     }
 218
 219   return x;
 220 }
 221
 222
 223 /* Test that the expression is an constant array.  */
 224
 225 static bool
 226 is_constant_array_expr (gfc_expr *e)
 227 {
 228   gfc_constructor *c;
 229
 230   if (e == NULL)
 231     return true;
 232
 233   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
 234     return false;
 235
 236   for (c = gfc_constructor_first (e->value.constructor);
 237        c; c = gfc_constructor_next (c))
 238     if (c->expr->expr_type != EXPR_CONSTANT)
 239       return false;
 240
 241   return true;
 242 }
 243
 244
 245 /* Initialize a transformational result expression with a given value.  */
 246
 247 static void
 248 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
 249 {
 250   if (e && e->expr_type == EXPR_ARRAY)
 251     {
 252       gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
 253       while (ctor)
 254         {
 255           init_result_expr (ctor->expr, init, array);
 256           ctor = gfc_constructor_next (ctor);
 257         }
 258     }
 259   else if (e && e->expr_type == EXPR_CONSTANT)
 260     {
 261       int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 262       int length;
 263       gfc_char_t *string;
 264
 265       switch (e->ts.type)
 266         {
 267           case BT_LOGICAL:
 268             e->value.logical = (init ? 1 : 0);
 269             break;
 270
 271           case BT_INTEGER:
 272             if (init == INT_MIN)
 273               mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
 274             else if (init == INT_MAX)
 275               mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
 276             else
 277               mpz_set_si (e->value.integer, init);
 278             break;
 279
 280           case BT_REAL:
 281             if (init == INT_MIN)
 282               {
 283                 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 284                 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
 285               }
 286             else if (init == INT_MAX)
 287               mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 288             else
 289               mpfr_set_si (e->value.real, init, GFC_RND_MODE);
 290             break;
 291
 292           case BT_COMPLEX:
 293             mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
 294             break;
 295
 296           case BT_CHARACTER:
 297             if (init == INT_MIN)
 298               {
 299                 gfc_expr *len = gfc_simplify_len (array, NULL);
 300                 gfc_extract_int (len, &length);
 301                 string = gfc_get_wide_string (length + 1);
 302                 gfc_wide_memset (string, 0, length);
 303               }
 304             else if (init == INT_MAX)
 305               {
 306                 gfc_expr *len = gfc_simplify_len (array, NULL);
 307                 gfc_extract_int (len, &length);
 308                 string = gfc_get_wide_string (length + 1);
 309                 gfc_wide_memset (string, 255, length);
 310               }
 311             else
 312               {
 313                 length = 0;
 314                 string = gfc_get_wide_string (1);
 315               }
 316
 317             string[length] = '\0';
 318             e->value.character.length = length;
 319             e->value.character.string = string;
 320             break;
 321
 322           default:
 323             gcc_unreachable();
 324         }
 325     }
 326   else
 327     gcc_unreachable();
 328 }
 329
 330
 331 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul.  */
 332
 333 static gfc_expr *
 334 compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
 335                      gfc_expr *matrix_b, int stride_b, int offset_b)
 336 {
 337   gfc_expr *result, *a, *b;
 338
 339   result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
 340                                   &matrix_a->where);
 341   init_result_expr (result, 0, NULL);
 342
 343   a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
 344   b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
 345   while (a && b)
 346     {
 347       /* Copying of expressions is required as operands are free'd
 348          by the gfc_arith routines.  */
 349       switch (result->ts.type)
 350         {
 351           case BT_LOGICAL:
 352             result = gfc_or (result,
 353                              gfc_and (gfc_copy_expr (a),
 354                                       gfc_copy_expr (b)));
 355             break;
 356
 357           case BT_INTEGER:
 358           case BT_REAL:
 359           case BT_COMPLEX:
 360             result = gfc_add (result,
 361                               gfc_multiply (gfc_copy_expr (a),
 362                                             gfc_copy_expr (b)));
 363             break;
 364
 365           default:
 366             gcc_unreachable();
 367         }
 368
 369       offset_a += stride_a;
 370       a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
 371
 372       offset_b += stride_b;
 373       b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
 374     }
 375
 376   return result;
 377 }
 378
 379
 380 /* Build a result expression for transformational intrinsics,
 381    depending on DIM. */
 382
 383 static gfc_expr *
 384 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
 385                          int kind, locus* where)
 386 {
 387   gfc_expr *result;
 388   int i, nelem;
 389
 390   if (!dim || array->rank == 1)
 391     return gfc_get_constant_expr (type, kind, where);
 392
 393   result = gfc_get_array_expr (type, kind, where);
 394   result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
 395   result->rank = array->rank - 1;
 396
 397   /* gfc_array_size() would count the number of elements in the constructor,
 398      we have not built those yet.  */
 399   nelem = 1;
 400   for  (i = 0; i < result->rank; ++i)
 401     nelem *= mpz_get_ui (result->shape[i]);
 402
 403   for (i = 0; i < nelem; ++i)
 404     {
 405       gfc_constructor_append_expr (&result->value.constructor,
 406                                    gfc_get_constant_expr (type, kind, where),
 407                                    NULL);
 408     }
 409
 410   return result;
 411 }
 412
 413
 414 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
 415
 416 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
 417    of COUNT intrinsic is .TRUE..
 418
 419    Interface and implimentation mimics arith functions as
 420    gfc_add, gfc_multiply, etc.  */
 421
 422 static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
 423 {
 424   gfc_expr *result;
 425
 426   gcc_assert (op1->ts.type == BT_INTEGER);
 427   gcc_assert (op2->ts.type == BT_LOGICAL);
 428   gcc_assert (op2->value.logical);
 429
 430   result = gfc_copy_expr (op1);
 431   mpz_add_ui (result->value.integer, result->value.integer, 1);
 432
 433   gfc_free_expr (op1);
 434   gfc_free_expr (op2);
 435   return result;
 436 }
 437
 438
 439 /* Transforms an ARRAY with operation OP, according to MASK, to a
 440    scalar RESULT. E.g. called if
 441
 442      REAL, PARAMETER :: array(n, m) = ...
 443      REAL, PARAMETER :: s = SUM(array)
 444
 445   where OP == gfc_add().  */
 446
 447 static gfc_expr *
 448 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
 449                                    transformational_op op)
 450 {
 451   gfc_expr *a, *m;
 452   gfc_constructor *array_ctor, *mask_ctor;
 453
 454   /* Shortcut for constant .FALSE. MASK.  */
 455   if (mask
 456       && mask->expr_type == EXPR_CONSTANT
 457       && !mask->value.logical)
 458     return result;
 459
 460   array_ctor = gfc_constructor_first (array->value.constructor);
 461   mask_ctor = NULL;
 462   if (mask && mask->expr_type == EXPR_ARRAY)
 463     mask_ctor = gfc_constructor_first (mask->value.constructor);
 464
 465   while (array_ctor)
 466     {
 467       a = array_ctor->expr;
 468       array_ctor = gfc_constructor_next (array_ctor);
 469
 470       /* A constant MASK equals .TRUE. here and can be ignored.  */
 471       if (mask_ctor)
 472         {
 473           m = mask_ctor->expr;
 474           mask_ctor = gfc_constructor_next (mask_ctor);
 475           if (!m->value.logical)
 476             continue;
 477         }
 478
 479       result = op (result, gfc_copy_expr (a));
 480     }
 481
 482   return result;
 483 }
 484
 485 /* Transforms an ARRAY with operation OP, according to MASK, to an
 486    array RESULT. E.g. called if
 487
 488      REAL, PARAMETER :: array(n, m) = ...
 489      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
 490
 491   where OP == gfc_multiply().  */
 492
 493 static gfc_expr *
 494 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
 495                                   gfc_expr *mask, transformational_op op)
 496 {
 497   mpz_t size;
 498   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
 499   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
 500   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
 501
 502   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
 503       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
 504       tmpstride[GFC_MAX_DIMENSIONS];
 505
 506   /* Shortcut for constant .FALSE. MASK.  */
 507   if (mask
 508       && mask->expr_type == EXPR_CONSTANT
 509       && !mask->value.logical)
 510     return result;
 511
 512   /* Build an indexed table for array element expressions to minimize
 513      linked-list traversal. Masked elements are set to NULL.  */
 514   gfc_array_size (array, &size);
 515   arraysize = mpz_get_ui (size);
 516
 517   arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
 518
 519   array_ctor = gfc_constructor_first (array->value.constructor);
 520   mask_ctor = NULL;
 521   if (mask && mask->expr_type == EXPR_ARRAY)
 522     mask_ctor = gfc_constructor_first (mask->value.constructor);
 523
 524   for (i = 0; i < arraysize; ++i)
 525     {
 526       arrayvec[i] = array_ctor->expr;
 527       array_ctor = gfc_constructor_next (array_ctor);
 528
 529       if (mask_ctor)
 530         {
 531           if (!mask_ctor->expr->value.logical)
 532             arrayvec[i] = NULL;
 533
 534           mask_ctor = gfc_constructor_next (mask_ctor);
 535         }
 536     }
 537
 538   /* Same for the result expression.  */
 539   gfc_array_size (result, &size);
 540   resultsize = mpz_get_ui (size);
 541   mpz_clear (size);
 542
 543   resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
 544   result_ctor = gfc_constructor_first (result->value.constructor);
 545   for (i = 0; i < resultsize; ++i)
 546     {
 547       resultvec[i] = result_ctor->expr;
 548       result_ctor = gfc_constructor_next (result_ctor);
 549     }
 550
 551   gfc_extract_int (dim, &dim_index);
 552   dim_index -= 1;               /* zero-base index */
 553   dim_extent = 0;
 554   dim_stride = 0;
 555
 556   for (i = 0, n = 0; i < array->rank; ++i)
 557     {
 558       count[i] = 0;
 559       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
 560       if (i == dim_index)
 561         {
 562           dim_extent = mpz_get_si (array->shape[i]);
 563           dim_stride = tmpstride[i];
 564           continue;
 565         }
 566
 567       extent[n] = mpz_get_si (array->shape[i]);
 568       sstride[n] = tmpstride[i];
 569       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
 570       n += 1;
 571     }
 572
 573   done = false;
 574   base = arrayvec;
 575   dest = resultvec;
 576   while (!done)
 577     {
 578       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
 579         if (*src)
 580           *dest = op (*dest, gfc_copy_expr (*src));
 581
 582       count[0]++;
 583       base += sstride[0];
 584       dest += dstride[0];
 585
 586       n = 0;
 587       while (!done && count[n] == extent[n])
 588         {
 589           count[n] = 0;
 590           base -= sstride[n] * extent[n];
 591           dest -= dstride[n] * extent[n];
 592
 593           n++;
 594           if (n < result->rank)
 595             {
 596               count [n]++;
 597               base += sstride[n];
 598               dest += dstride[n];
 599             }
 600           else
 601             done = true;
 602        }
 603     }
 604
 605   /* Place updated expression in result constructor.  */
 606   result_ctor = gfc_constructor_first (result->value.constructor);
 607   for (i = 0; i < resultsize; ++i)
 608     {
 609       result_ctor->expr = resultvec[i];
 610       result_ctor = gfc_constructor_next (result_ctor);
 611     }
 612
 613   gfc_free (arrayvec);
 614   gfc_free (resultvec);
 615   return result;
 616 }
 617
 618
 619
 620 /********************** Simplification functions *****************************/
 621
 622 gfc_expr *
 623 gfc_simplify_abs (gfc_expr *e)
 624 {
 625   gfc_expr *result;
 626
 627   if (e->expr_type != EXPR_CONSTANT)
 628     return NULL;
 629
 630   switch (e->ts.type)
 631     {
 632       case BT_INTEGER:
 633         result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
 634         mpz_abs (result->value.integer, e->value.integer);
 635         return range_check (result, "IABS");
 636
 637       case BT_REAL:
 638         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 639         mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
 640         return range_check (result, "ABS");
 641
 642       case BT_COMPLEX:
 643         gfc_set_model_kind (e->ts.kind);
 644         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 645         mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
 646         return range_check (result, "CABS");
 647
 648       default:
 649         gfc_internal_error ("gfc_simplify_abs(): Bad type");
 650     }
 651 }
 652
 653
 654 static gfc_expr *
 655 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
 656 {
 657   gfc_expr *result;
 658   int kind;
 659   bool too_large = false;
 660
 661   if (e->expr_type != EXPR_CONSTANT)
 662     return NULL;
 663
 664   kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
 665   if (kind == -1)
 666     return &gfc_bad_expr;
 667
 668   if (mpz_cmp_si (e->value.integer, 0) < 0)
 669     {
 670       gfc_error ("Argument of %s function at %L is negative", name,
 671                  &e->where);
 672       return &gfc_bad_expr;
 673     }
 674
 675   if (ascii && gfc_option.warn_surprising
 676       && mpz_cmp_si (e->value.integer, 127) > 0)
 677     gfc_warning ("Argument of %s function at %L outside of range [0,127]",
 678                  name, &e->where);
 679
 680   if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
 681     too_large = true;
 682   else if (kind == 4)
 683     {
 684       mpz_t t;
 685       mpz_init_set_ui (t, 2);
 686       mpz_pow_ui (t, t, 32);
 687       mpz_sub_ui (t, t, 1);
 688       if (mpz_cmp (e->value.integer, t) > 0)
 689         too_large = true;
 690       mpz_clear (t);
 691     }
 692
 693   if (too_large)
 694     {
 695       gfc_error ("Argument of %s function at %L is too large for the "
 696                  "collating sequence of kind %d", name, &e->where, kind);
 697       return &gfc_bad_expr;
 698     }
 699
 700   result = gfc_get_character_expr (kind, &e->where, NULL, 1);
 701   result->value.character.string[0] = mpz_get_ui (e->value.integer);
 702
 703   return result;
 704 }
 705
 706
 707
 708 /* We use the processor's collating sequence, because all
 709    systems that gfortran currently works on are ASCII.  */
 710
 711 gfc_expr *
 712 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
 713 {
 714   return simplify_achar_char (e, k, "ACHAR", true);
 715 }
 716
 717
 718 gfc_expr *
 719 gfc_simplify_acos (gfc_expr *x)
 720 {
 721   gfc_expr *result;
 722
 723   if (x->expr_type != EXPR_CONSTANT)
 724     return NULL;
 725
 726   switch (x->ts.type)
 727     {
 728       case BT_REAL:
 729         if (mpfr_cmp_si (x->value.real, 1) > 0
 730             || mpfr_cmp_si (x->value.real, -1) < 0)
 731           {
 732             gfc_error ("Argument of ACOS at %L must be between -1 and 1",
 733                        &x->where);
 734             return &gfc_bad_expr;
 735           }
 736         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 737         mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 738         break;
 739
 740       case BT_COMPLEX:
 741         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 742         mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 743         break;
 744
 745       default:
 746         gfc_internal_error ("in gfc_simplify_acos(): Bad type");
 747     }
 748
 749   return range_check (result, "ACOS");
 750 }
 751
 752 gfc_expr *
 753 gfc_simplify_acosh (gfc_expr *x)
 754 {
 755   gfc_expr *result;
 756
 757   if (x->expr_type != EXPR_CONSTANT)
 758     return NULL;
 759
 760   switch (x->ts.type)
 761     {
 762       case BT_REAL:
 763         if (mpfr_cmp_si (x->value.real, 1) < 0)
 764           {
 765             gfc_error ("Argument of ACOSH at %L must not be less than 1",
 766                        &x->where);
 767             return &gfc_bad_expr;
 768           }
 769
 770         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 771         mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
 772         break;
 773
 774       case BT_COMPLEX:
 775         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 776         mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 777         break;
 778
 779       default:
 780         gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
 781     }
 782
 783   return range_check (result, "ACOSH");
 784 }
 785
 786 gfc_expr *
 787 gfc_simplify_adjustl (gfc_expr *e)
 788 {
 789   gfc_expr *result;
 790   int count, i, len;
 791   gfc_char_t ch;
 792
 793   if (e->expr_type != EXPR_CONSTANT)
 794     return NULL;
 795
 796   len = e->value.character.length;
 797
 798   for (count = 0, i = 0; i < len; ++i)
 799     {
 800       ch = e->value.character.string[i];
 801       if (ch != ' ')
 802         break;
 803       ++count;
 804     }
 805
 806   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
 807   for (i = 0; i < len - count; ++i)
 808     result->value.character.string[i] = e->value.character.string[count + i];
 809
 810   return result;
 811 }
 812
 813
 814 gfc_expr *
 815 gfc_simplify_adjustr (gfc_expr *e)
 816 {
 817   gfc_expr *result;
 818   int count, i, len;
 819   gfc_char_t ch;
 820
 821   if (e->expr_type != EXPR_CONSTANT)
 822     return NULL;
 823
 824   len = e->value.character.length;
 825
 826   for (count = 0, i = len - 1; i >= 0; --i)
 827     {
 828       ch = e->value.character.string[i];
 829       if (ch != ' ')
 830         break;
 831       ++count;
 832     }
 833
 834   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
 835   for (i = 0; i < count; ++i)
 836     result->value.character.string[i] = ' ';
 837
 838   for (i = count; i < len; ++i)
 839     result->value.character.string[i] = e->value.character.string[i - count];
 840
 841   return result;
 842 }
 843
 844
 845 gfc_expr *
 846 gfc_simplify_aimag (gfc_expr *e)
 847 {
 848   gfc_expr *result;
 849
 850   if (e->expr_type != EXPR_CONSTANT)
 851     return NULL;
 852
 853   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
 854   mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
 855
 856   return range_check (result, "AIMAG");
 857 }
 858
 859
 860 gfc_expr *
 861 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 862 {
 863   gfc_expr *rtrunc, *result;
 864   int kind;
 865
 866   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
 867   if (kind == -1)
 868     return &gfc_bad_expr;
 869
 870   if (e->expr_type != EXPR_CONSTANT)
 871     return NULL;
 872
 873   rtrunc = gfc_copy_expr (e);
 874   mpfr_trunc (rtrunc->value.real, e->value.real);
 875
 876   result = gfc_real2real (rtrunc, kind);
 877
 878   gfc_free_expr (rtrunc);
 879
 880   return range_check (result, "AINT");
 881 }
 882
 883
 884 gfc_expr *
 885 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 886 {
 887   gfc_expr *result;
 888
 889   if (!is_constant_array_expr (mask)
 890       || !gfc_is_constant_expr (dim))
 891     return NULL;
 892
 893   result = transformational_result (mask, dim, mask->ts.type,
 894                                     mask->ts.kind, &mask->where);
 895   init_result_expr (result, true, NULL);
 896
 897   return !dim || mask->rank == 1 ?
 898     simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
 899     simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
 900 }
 901
 902
 903 gfc_expr *
 904 gfc_simplify_dint (gfc_expr *e)
 905 {
 906   gfc_expr *rtrunc, *result;
 907
 908   if (e->expr_type != EXPR_CONSTANT)
 909     return NULL;
 910
 911   rtrunc = gfc_copy_expr (e);
 912   mpfr_trunc (rtrunc->value.real, e->value.real);
 913
 914   result = gfc_real2real (rtrunc, gfc_default_double_kind);
 915
 916   gfc_free_expr (rtrunc);
 917
 918   return range_check (result, "DINT");
 919 }
 920
 921
 922 gfc_expr *
 923 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
 924 {
 925   gfc_expr *result;
 926   int kind;
 927
 928   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
 929   if (kind == -1)
 930     return &gfc_bad_expr;
 931
 932   if (e->expr_type != EXPR_CONSTANT)
 933     return NULL;
 934
 935   result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
 936   mpfr_round (result->value.real, e->value.real);
 937
 938   return range_check (result, "ANINT");
 939 }
 940
 941
 942 gfc_expr *
 943 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 944 {
 945   gfc_expr *result;
 946   int kind;
 947
 948   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 949     return NULL;
 950
 951   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
 952
 953   switch (x->ts.type)
 954     {
 955       case BT_INTEGER:
 956         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
 957         mpz_and (result->value.integer, x->value.integer, y->value.integer);
 958         return range_check (result, "AND");
 959
 960       case BT_LOGICAL:
 961         return gfc_get_logical_expr (kind, &x->where,
 962                                      x->value.logical && y->value.logical);
 963
 964       default:
 965         gcc_unreachable ();
 966     }
 967 }
 968
 969
 970 gfc_expr *
 971 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 972 {
 973   gfc_expr *result;
 974
 975   if (!is_constant_array_expr (mask)
 976       || !gfc_is_constant_expr (dim))
 977     return NULL;
 978
 979   result = transformational_result (mask, dim, mask->ts.type,
 980                                     mask->ts.kind, &mask->where);
 981   init_result_expr (result, false, NULL);
 982
 983   return !dim || mask->rank == 1 ?
 984     simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
 985     simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
 986 }
 987
 988
 989 gfc_expr *
 990 gfc_simplify_dnint (gfc_expr *e)
 991 {
 992   gfc_expr *result;
 993
 994   if (e->expr_type != EXPR_CONSTANT)
 995     return NULL;
 996
 997   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
 998   mpfr_round (result->value.real, e->value.real);
 999
1000   return range_check (result, "DNINT");
1001 }
1002
1003
1004 gfc_expr *
1005 gfc_simplify_asin (gfc_expr *x)
1006 {
1007   gfc_expr *result;
1008
1009   if (x->expr_type != EXPR_CONSTANT)
1010     return NULL;
1011
1012   switch (x->ts.type)
1013     {
1014       case BT_REAL:
1015         if (mpfr_cmp_si (x->value.real, 1) > 0
1016             || mpfr_cmp_si (x->value.real, -1) < 0)
1017           {
1018             gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1019                        &x->where);
1020             return &gfc_bad_expr;
1021           }
1022         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1023         mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1024         break;
1025
1026       case BT_COMPLEX:
1027         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1028         mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1029         break;
1030
1031       default:
1032         gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1033     }
1034
1035   return range_check (result, "ASIN");
1036 }
1037
1038
1039 gfc_expr *
1040 gfc_simplify_asinh (gfc_expr *x)
1041 {
1042   gfc_expr *result;
1043
1044   if (x->expr_type != EXPR_CONSTANT)
1045     return NULL;
1046
1047   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1048
1049   switch (x->ts.type)
1050     {
1051       case BT_REAL:
1052         mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1053         break;
1054
1055       case BT_COMPLEX:
1056         mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1057         break;
1058
1059       default:
1060         gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1061     }
1062
1063   return range_check (result, "ASINH");
1064 }
1065
1066
1067 gfc_expr *
1068 gfc_simplify_atan (gfc_expr *x)
1069 {
1070   gfc_expr *result;
1071
1072   if (x->expr_type != EXPR_CONSTANT)
1073     return NULL;
1074
1075   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1076
1077   switch (x->ts.type)
1078     {
1079       case BT_REAL:
1080         mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1081         break;
1082
1083       case BT_COMPLEX:
1084         mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1085         break;
1086
1087       default:
1088         gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1089     }
1090
1091   return range_check (result, "ATAN");
1092 }
1093
1094
1095 gfc_expr *
1096 gfc_simplify_atanh (gfc_expr *x)
1097 {
1098   gfc_expr *result;
1099
1100   if (x->expr_type != EXPR_CONSTANT)
1101     return NULL;
1102
1103   switch (x->ts.type)
1104     {
1105       case BT_REAL:
1106         if (mpfr_cmp_si (x->value.real, 1) >= 0
1107             || mpfr_cmp_si (x->value.real, -1) <= 0)
1108           {
1109             gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1110                        "to 1", &x->where);
1111             return &gfc_bad_expr;
1112           }
1113         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1114         mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1115         break;
1116
1117       case BT_COMPLEX:
1118         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1119         mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1120         break;
1121
1122       default:
1123         gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1124     }
1125
1126   return range_check (result, "ATANH");
1127 }
1128
1129
1130 gfc_expr *
1131 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1132 {
1133   gfc_expr *result;
1134
1135   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1136     return NULL;
1137
1138   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
1139     {
1140       gfc_error ("If first argument of ATAN2 %L is zero, then the "
1141                  "second argument must not be zero", &x->where);
1142       return &gfc_bad_expr;
1143     }
1144
1145   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1146   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1147
1148   return range_check (result, "ATAN2");
1149 }
1150
1151
1152 gfc_expr *
1153 gfc_simplify_bessel_j0 (gfc_expr *x)
1154 {
1155   gfc_expr *result;
1156
1157   if (x->expr_type != EXPR_CONSTANT)
1158     return NULL;
1159
1160   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1161   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1162
1163   return range_check (result, "BESSEL_J0");
1164 }
1165
1166
1167 gfc_expr *
1168 gfc_simplify_bessel_j1 (gfc_expr *x)
1169 {
1170   gfc_expr *result;
1171
1172   if (x->expr_type != EXPR_CONSTANT)
1173     return NULL;
1174
1175   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1176   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1177
1178   return range_check (result, "BESSEL_J1");
1179 }
1180
1181
1182 gfc_expr *
1183 gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1184 {
1185   gfc_expr *result;
1186   long n;
1187
1188   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1189     return NULL;
1190
1191   n = mpz_get_si (order->value.integer);
1192   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1193   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1194
1195   return range_check (result, "BESSEL_JN");
1196 }
1197
1198
1199 /* Simplify transformational form of JN and YN.  */
1200
1201 static gfc_expr *
1202 gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1203                         bool jn)
1204 {
1205   gfc_expr *result;
1206   gfc_expr *e;
1207   long n1, n2;
1208   int i;
1209   mpfr_t x2rev, last1, last2;
1210
1211   if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1212       || order2->expr_type != EXPR_CONSTANT)
1213     {
1214       gfc_error ("Sorry, non-constant transformational Bessel function at %L"
1215                    " not yet supported", &order2->where);
1216       return &gfc_bad_expr;
1217     }
1218
1219   n1 = mpz_get_si (order1->value.integer);
1220   n2 = mpz_get_si (order2->value.integer);
1221   result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1222   result->rank = 1;
1223   result->shape = gfc_get_shape (1);
1224   mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1225
1226   if (n2 < n1)
1227     return result;
1228
1229   /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1230      YN(N, 0.0) = -Inf.  */
1231
1232   if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1233     {
1234       if (!jn && gfc_option.flag_range_check)
1235         {
1236           gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1237           gfc_free_expr (result);
1238           return &gfc_bad_expr;
1239         }
1240
1241       if (jn && n1 == 0)
1242         {
1243           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1244           mpfr_set_ui (e->value.real, 1.0, GFC_RND_MODE);
1245           gfc_constructor_append_expr (&result->value.constructor, e,
1246                                        &x->where);
1247           n1++;
1248         }
1249
1250       for (i = n1; i <= n2; i++)
1251         {
1252           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1253           if (jn)
1254             mpfr_set_ui (e->value.real, 0.0, GFC_RND_MODE);
1255           else
1256             mpfr_set_inf (e->value.real, -1);
1257           gfc_constructor_append_expr (&result->value.constructor, e,
1258                                        &x->where);
1259         }
1260
1261       return result;
1262     }
1263
1264   /* Use the faster but more verbose recurrence algorithm. Bessel functions
1265      are stable for downward recursion and Neumann functions are stable
1266      for upward recursion. It is
1267        x2rev = 2.0/x,
1268        J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1269        Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1270      Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1  */
1271
1272   gfc_set_model_kind (x->ts.kind);
1273
1274   /* Get first recursion anchor.  */
1275
1276   mpfr_init (last1);
1277   if (jn)
1278     mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1279   else
1280     mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1281
1282   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1283   mpfr_set (e->value.real, last1, GFC_RND_MODE);
1284   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1285     {
1286       mpfr_clear (last1);
1287       gfc_free_expr (e);
1288       gfc_free_expr (result);
1289       return &gfc_bad_expr;
1290     }
1291   gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1292
1293   if (n1 == n2)
1294     {
1295       mpfr_clear (last1);
1296       return result;
1297     }
1298
1299   /* Get second recursion anchor.  */
1300
1301   mpfr_init (last2);
1302   if (jn)
1303     mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1304   else
1305     mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1306
1307   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1308   mpfr_set (e->value.real, last2, GFC_RND_MODE);
1309   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1310     {
1311       mpfr_clear (last1);
1312       mpfr_clear (last2);
1313       gfc_free_expr (e);
1314       gfc_free_expr (result);
1315       return &gfc_bad_expr;
1316     }
1317   if (jn)
1318      gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
1319   else
1320     gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1321
1322   if (n1 + 1 == n2)
1323     {
1324       mpfr_clear (last1);
1325       mpfr_clear (last2);
1326       return result;
1327     }
1328
1329   /* Start actual recursion.  */
1330
1331   mpfr_init (x2rev);
1332   mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
1333
1334   for (i = 2; i <= n2-n1; i++)
1335     {
1336       e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1337       mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1338                    GFC_RND_MODE);
1339       mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1340       mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1341
1342       if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1343         goto error;
1344
1345       if (jn)
1346         gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1347                                      -i-1);
1348       else
1349         gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1350
1351       mpfr_set (last1, last2, GFC_RND_MODE);
1352       mpfr_set (last2, e->value.real, GFC_RND_MODE);
1353     }
1354
1355   mpfr_clear (last1);
1356   mpfr_clear (last2);
1357   mpfr_clear (x2rev);
1358   return result;
1359
1360 error:
1361   mpfr_clear (last1);
1362   mpfr_clear (last2);
1363   mpfr_clear (x2rev);
1364   gfc_free_expr (e);
1365   gfc_free_expr (result);
1366   return &gfc_bad_expr;
1367 }
1368
1369
1370 gfc_expr *
1371 gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1372 {
1373   return gfc_simplify_bessel_n2 (order1, order2, x, true);
1374 }
1375
1376
1377 gfc_expr *
1378 gfc_simplify_bessel_y0 (gfc_expr *x)
1379 {
1380   gfc_expr *result;
1381
1382   if (x->expr_type != EXPR_CONSTANT)
1383     return NULL;
1384
1385   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1386   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1387
1388   return range_check (result, "BESSEL_Y0");
1389 }
1390
1391
1392 gfc_expr *
1393 gfc_simplify_bessel_y1 (gfc_expr *x)
1394 {
1395   gfc_expr *result;
1396
1397   if (x->expr_type != EXPR_CONSTANT)
1398     return NULL;
1399
1400   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1401   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1402
1403   return range_check (result, "BESSEL_Y1");
1404 }
1405
1406
1407 gfc_expr *
1408 gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1409 {
1410   gfc_expr *result;
1411   long n;
1412
1413   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1414     return NULL;
1415
1416   n = mpz_get_si (order->value.integer);
1417   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1418   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1419
1420   return range_check (result, "BESSEL_YN");
1421 }
1422
1423
1424 gfc_expr *
1425 gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1426 {
1427   return gfc_simplify_bessel_n2 (order1, order2, x, false);
1428 }
1429
1430
1431 gfc_expr *
1432 gfc_simplify_bit_size (gfc_expr *e)
1433 {
1434   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1435   return gfc_get_int_expr (e->ts.kind, &e->where,
1436                            gfc_integer_kinds[i].bit_size);
1437 }
1438
1439
1440 gfc_expr *
1441 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1442 {
1443   int b;
1444
1445   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1446     return NULL;
1447
1448   if (gfc_extract_int (bit, &b) != NULL || b < 0)
1449     return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1450
1451   return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1452                                mpz_tstbit (e->value.integer, b));
1453 }
1454
1455
1456 gfc_expr *
1457 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1458 {
1459   gfc_expr *ceil, *result;
1460   int kind;
1461
1462   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1463   if (kind == -1)
1464     return &gfc_bad_expr;
1465
1466   if (e->expr_type != EXPR_CONSTANT)
1467     return NULL;
1468
1469   ceil = gfc_copy_expr (e);
1470   mpfr_ceil (ceil->value.real, e->value.real);
1471
1472   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1473   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1474
1475   gfc_free_expr (ceil);
1476
1477   return range_check (result, "CEILING");
1478 }
1479
1480
1481 gfc_expr *
1482 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1483 {
1484   return simplify_achar_char (e, k, "CHAR", false);
1485 }
1486
1487
1488 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX.  */
1489
1490 static gfc_expr *
1491 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1492 {
1493   gfc_expr *result;
1494
1495   if (convert_boz (x, kind) == &gfc_bad_expr)
1496     return &gfc_bad_expr;
1497
1498   if (convert_boz (y, kind) == &gfc_bad_expr)
1499     return &gfc_bad_expr;
1500
1501   if (x->expr_type != EXPR_CONSTANT
1502       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1503     return NULL;
1504
1505   result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1506
1507   switch (x->ts.type)
1508     {
1509       case BT_INTEGER:
1510         mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1511         break;
1512
1513       case BT_REAL:
1514         mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1515         break;
1516
1517       case BT_COMPLEX:
1518         mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1519         break;
1520
1521       default:
1522         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1523     }
1524
1525   if (!y)
1526     return range_check (result, name);
1527
1528   switch (y->ts.type)
1529     {
1530       case BT_INTEGER:
1531         mpfr_set_z (mpc_imagref (result->value.complex),
1532                     y->value.integer, GFC_RND_MODE);
1533         break;
1534
1535       case BT_REAL:
1536         mpfr_set (mpc_imagref (result->value.complex),
1537                   y->value.real, GFC_RND_MODE);
1538         break;
1539
1540       default:
1541         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1542     }
1543
1544   return range_check (result, name);
1545 }
1546
1547
1548 gfc_expr *
1549 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1550 {
1551   int kind;
1552
1553   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1554   if (kind == -1)
1555     return &gfc_bad_expr;
1556
1557   return simplify_cmplx ("CMPLX", x, y, kind);
1558 }
1559
1560
1561 gfc_expr *
1562 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1563 {
1564   int kind;
1565
1566   if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1567     kind = gfc_default_complex_kind;
1568   else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1569     kind = x->ts.kind;
1570   else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1571     kind = y->ts.kind;
1572   else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1573     kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1574   else
1575     gcc_unreachable ();
1576
1577   return simplify_cmplx ("COMPLEX", x, y, kind);
1578 }
1579
1580
1581 gfc_expr *
1582 gfc_simplify_conjg (gfc_expr *e)
1583 {
1584   gfc_expr *result;
1585
1586   if (e->expr_type != EXPR_CONSTANT)
1587     return NULL;
1588
1589   result = gfc_copy_expr (e);
1590   mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1591
1592   return range_check (result, "CONJG");
1593 }
1594
1595
1596 gfc_expr *
1597 gfc_simplify_cos (gfc_expr *x)
1598 {
1599   gfc_expr *result;
1600
1601   if (x->expr_type != EXPR_CONSTANT)
1602     return NULL;
1603
1604   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1605
1606   switch (x->ts.type)
1607     {
1608       case BT_REAL:
1609         mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1610         break;
1611
1612       case BT_COMPLEX:
1613         gfc_set_model_kind (x->ts.kind);
1614         mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1615         break;
1616
1617       default:
1618         gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1619     }
1620
1621   return range_check (result, "COS");
1622 }
1623
1624
1625 gfc_expr *
1626 gfc_simplify_cosh (gfc_expr *x)
1627 {
1628   gfc_expr *result;
1629
1630   if (x->expr_type != EXPR_CONSTANT)
1631     return NULL;
1632
1633   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1634
1635   switch (x->ts.type)
1636     {
1637       case BT_REAL:
1638         mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1639         break;
1640
1641       case BT_COMPLEX:
1642         mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1643         break;
1644
1645       default:
1646         gcc_unreachable ();
1647     }
1648
1649   return range_check (result, "COSH");
1650 }
1651
1652
1653 gfc_expr *
1654 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1655 {
1656   gfc_expr *result;
1657
1658   if (!is_constant_array_expr (mask)
1659       || !gfc_is_constant_expr (dim)
1660       || !gfc_is_constant_expr (kind))
1661     return NULL;
1662
1663   result = transformational_result (mask, dim,
1664                                     BT_INTEGER,
1665                                     get_kind (BT_INTEGER, kind, "COUNT",
1666                                               gfc_default_integer_kind),
1667                                     &mask->where);
1668
1669   init_result_expr (result, 0, NULL);
1670
1671   /* Passing MASK twice, once as data array, once as mask.
1672      Whenever gfc_count is called, '1' is added to the result.  */
1673   return !dim || mask->rank == 1 ?
1674     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1675     simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
1676 }
1677
1678
1679 gfc_expr *
1680 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1681 {
1682   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1683 }
1684
1685
1686 gfc_expr *
1687 gfc_simplify_dble (gfc_expr *e)
1688 {
1689   gfc_expr *result = NULL;
1690
1691   if (e->expr_type != EXPR_CONSTANT)
1692     return NULL;
1693
1694   if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
1695     return &gfc_bad_expr;
1696
1697   result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
1698   if (result == &gfc_bad_expr)
1699     return &gfc_bad_expr;
1700
1701   return range_check (result, "DBLE");
1702 }
1703
1704
1705 gfc_expr *
1706 gfc_simplify_digits (gfc_expr *x)
1707 {
1708   int i, digits;
1709
1710   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1711
1712   switch (x->ts.type)
1713     {
1714       case BT_INTEGER:
1715         digits = gfc_integer_kinds[i].digits;
1716         break;
1717
1718       case BT_REAL:
1719       case BT_COMPLEX:
1720         digits = gfc_real_kinds[i].digits;
1721         break;
1722
1723       default:
1724         gcc_unreachable ();
1725     }
1726
1727   return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
1728 }
1729
1730
1731 gfc_expr *
1732 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1733 {
1734   gfc_expr *result;
1735   int kind;
1736
1737   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1738     return NULL;
1739
1740   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1741   result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
1742
1743   switch (x->ts.type)
1744     {
1745       case BT_INTEGER:
1746         if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1747           mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1748         else
1749           mpz_set_ui (result->value.integer, 0);
1750
1751         break;
1752
1753       case BT_REAL:
1754         if (mpfr_cmp (x->value.real, y->value.real) > 0)
1755           mpfr_sub (result->value.real, x->value.real, y->value.real,
1756                     GFC_RND_MODE);
1757         else
1758           mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1759
1760         break;
1761
1762       default:
1763         gfc_internal_error ("gfc_simplify_dim(): Bad type");
1764     }
1765
1766   return range_check (result, "DIM");
1767 }
1768
1769
1770 gfc_expr*
1771 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1772 {
1773   if (!is_constant_array_expr (vector_a)
1774       || !is_constant_array_expr (vector_b))
1775     return NULL;
1776
1777   gcc_assert (vector_a->rank == 1);
1778   gcc_assert (vector_b->rank == 1);
1779   gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1780
1781   return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
1782 }
1783
1784
1785 gfc_expr *
1786 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1787 {
1788   gfc_expr *a1, *a2, *result;
1789
1790   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1791     return NULL;
1792
1793   a1 = gfc_real2real (x, gfc_default_double_kind);
1794   a2 = gfc_real2real (y, gfc_default_double_kind);
1795
1796   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
1797   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1798
1799   gfc_free_expr (a2);
1800   gfc_free_expr (a1);
1801
1802   return range_check (result, "DPROD");
1803 }
1804
1805
1806 gfc_expr *
1807 gfc_simplify_erf (gfc_expr *x)
1808 {
1809   gfc_expr *result;
1810
1811   if (x->expr_type != EXPR_CONSTANT)
1812     return NULL;
1813
1814   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1815   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1816
1817   return range_check (result, "ERF");
1818 }
1819
1820
1821 gfc_expr *
1822 gfc_simplify_erfc (gfc_expr *x)
1823 {
1824   gfc_expr *result;
1825
1826   if (x->expr_type != EXPR_CONSTANT)
1827     return NULL;
1828
1829   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1830   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1831
1832   return range_check (result, "ERFC");
1833 }
1834
1835
1836 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */
1837
1838 #define MAX_ITER 200
1839 #define ARG_LIMIT 12
1840
1841 /* Calculate ERFC_SCALED directly by its definition:
1842
1843      ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1844
1845    using a large precision for intermediate results.  This is used for all
1846    but large values of the argument.  */
1847 static void
1848 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
1849 {
1850   mp_prec_t prec;
1851   mpfr_t a, b;
1852
1853   prec = mpfr_get_default_prec ();
1854   mpfr_set_default_prec (10 * prec);
1855
1856   mpfr_init (a);
1857   mpfr_init (b);
1858
1859   mpfr_set (a, arg, GFC_RND_MODE);
1860   mpfr_sqr (b, a, GFC_RND_MODE);
1861   mpfr_exp (b, b, GFC_RND_MODE);
1862   mpfr_erfc (a, a, GFC_RND_MODE);
1863   mpfr_mul (a, a, b, GFC_RND_MODE);
1864
1865   mpfr_set (res, a, GFC_RND_MODE);
1866   mpfr_set_default_prec (prec);
1867
1868   mpfr_clear (a);
1869   mpfr_clear (b);
1870 }
1871
1872 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
1873
1874     ERFC_SCALED(x) = 1 / (x * sqrt(pi))
1875                      * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
1876                                           / (2 * x**2)**n)
1877
1878   This is used for large values of the argument.  Intermediate calculations
1879   are performed with twice the precision.  We don't do a fixed number of
1880   iterations of the sum, but stop when it has converged to the required
1881   precision.  */
1882 static void
1883 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
1884 {
1885   mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
1886   mpz_t num;
1887   mp_prec_t prec;
1888   unsigned i;
1889
1890   prec = mpfr_get_default_prec ();
1891   mpfr_set_default_prec (2 * prec);
1892
1893   mpfr_init (sum);
1894   mpfr_init (x);
1895   mpfr_init (u);
1896   mpfr_init (v);
1897   mpfr_init (w);
1898   mpz_init (num);
1899
1900   mpfr_init (oldsum);
1901   mpfr_init (sumtrunc);
1902   mpfr_set_prec (oldsum, prec);
1903   mpfr_set_prec (sumtrunc, prec);
1904
1905   mpfr_set (x, arg, GFC_RND_MODE);
1906   mpfr_set_ui (sum, 1, GFC_RND_MODE);
1907   mpz_set_ui (num, 1);
1908
1909   mpfr_set (u, x, GFC_RND_MODE);
1910   mpfr_sqr (u, u, GFC_RND_MODE);
1911   mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
1912   mpfr_pow_si (u, u, -1, GFC_RND_MODE);
1913
1914   for (i = 1; i < MAX_ITER; i++)
1915   {
1916     mpfr_set (oldsum, sum, GFC_RND_MODE);
1917
1918     mpz_mul_ui (num, num, 2 * i - 1);
1919     mpz_neg (num, num);
1920
1921     mpfr_set (w, u, GFC_RND_MODE);
1922     mpfr_pow_ui (w, w, i, GFC_RND_MODE);
1923
1924     mpfr_set_z (v, num, GFC_RND_MODE);
1925     mpfr_mul (v, v, w, GFC_RND_MODE);
1926
1927     mpfr_add (sum, sum, v, GFC_RND_MODE);
1928
1929     mpfr_set (sumtrunc, sum, GFC_RND_MODE);
1930     if (mpfr_cmp (sumtrunc, oldsum) == 0)
1931       break;
1932   }
1933
1934   /* We should have converged by now; otherwise, ARG_LIMIT is probably
1935      set too low.  */
1936   gcc_assert (i < MAX_ITER);
1937
1938   /* Divide by x * sqrt(Pi).  */
1939   mpfr_const_pi (u, GFC_RND_MODE);
1940   mpfr_sqrt (u, u, GFC_RND_MODE);
1941   mpfr_mul (u, u, x, GFC_RND_MODE);
1942   mpfr_div (sum, sum, u, GFC_RND_MODE);
1943
1944   mpfr_set (res, sum, GFC_RND_MODE);
1945   mpfr_set_default_prec (prec);
1946
1947   mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
1948   mpz_clear (num);
1949 }
1950
1951
1952 gfc_expr *
1953 gfc_simplify_erfc_scaled (gfc_expr *x)
1954 {
1955   gfc_expr *result;
1956
1957   if (x->expr_type != EXPR_CONSTANT)
1958     return NULL;
1959
1960   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1961   if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
1962     asympt_erfc_scaled (result->value.real, x->value.real);
1963   else
1964     fullprec_erfc_scaled (result->value.real, x->value.real);
1965
1966   return range_check (result, "ERFC_SCALED");
1967 }
1968
1969 #undef MAX_ITER
1970 #undef ARG_LIMIT
1971
1972
1973 gfc_expr *
1974 gfc_simplify_epsilon (gfc_expr *e)
1975 {
1976   gfc_expr *result;
1977   int i;
1978
1979   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1980
1981   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1982   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1983
1984   return range_check (result, "EPSILON");
1985 }
1986
1987
1988 gfc_expr *
1989 gfc_simplify_exp (gfc_expr *x)
1990 {
1991   gfc_expr *result;
1992
1993   if (x->expr_type != EXPR_CONSTANT)
1994     return NULL;
1995
1996   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1997
1998   switch (x->ts.type)
1999     {
2000       case BT_REAL:
2001         mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2002         break;
2003
2004       case BT_COMPLEX:
2005         gfc_set_model_kind (x->ts.kind);
2006         mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2007         break;
2008
2009       default:
2010         gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2011     }
2012
2013   return range_check (result, "EXP");
2014 }
2015
2016
2017 gfc_expr *
2018 gfc_simplify_exponent (gfc_expr *x)
2019 {
2020   int i;
2021   gfc_expr *result;
2022
2023   if (x->expr_type != EXPR_CONSTANT)
2024     return NULL;
2025
2026   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2027                                   &x->where);
2028
2029   gfc_set_model (x->value.real);
2030
2031   if (mpfr_sgn (x->value.real) == 0)
2032     {
2033       mpz_set_ui (result->value.integer, 0);
2034       return result;
2035     }
2036
2037   i = (int) mpfr_get_exp (x->value.real);
2038   mpz_set_si (result->value.integer, i);
2039
2040   return range_check (result, "EXPONENT");
2041 }
2042
2043
2044 gfc_expr *
2045 gfc_simplify_float (gfc_expr *a)
2046 {
2047   gfc_expr *result;
2048
2049   if (a->expr_type != EXPR_CONSTANT)
2050     return NULL;
2051
2052   if (a->is_boz)
2053     {
2054       if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
2055         return &gfc_bad_expr;
2056
2057       result = gfc_copy_expr (a);
2058     }
2059   else
2060     result = gfc_int2real (a, gfc_default_real_kind);
2061
2062   return range_check (result, "FLOAT");
2063 }
2064
2065
2066 gfc_expr *
2067 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
2068 {
2069   gfc_expr *result;
2070   mpfr_t floor;
2071   int kind;
2072
2073   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
2074   if (kind == -1)
2075     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2076
2077   if (e->expr_type != EXPR_CONSTANT)
2078     return NULL;
2079
2080   gfc_set_model_kind (kind);
2081
2082   mpfr_init (floor);
2083   mpfr_floor (floor, e->value.real);
2084
2085   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
2086   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
2087
2088   mpfr_clear (floor);
2089
2090   return range_check (result, "FLOOR");
2091 }
2092
2093
2094 gfc_expr *
2095 gfc_simplify_fraction (gfc_expr *x)
2096 {
2097   gfc_expr *result;
2098   mpfr_t absv, exp, pow2;
2099
2100   if (x->expr_type != EXPR_CONSTANT)
2101     return NULL;
2102
2103   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
2104
2105   if (mpfr_sgn (x->value.real) == 0)
2106     {
2107       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2108       return result;
2109     }
2110
2111   gfc_set_model_kind (x->ts.kind);
2112   mpfr_init (exp);
2113   mpfr_init (absv);
2114   mpfr_init (pow2);
2115
2116   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2117   mpfr_log2 (exp, absv, GFC_RND_MODE);
2118
2119   mpfr_trunc (exp, exp);
2120   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
2121
2122   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2123
2124   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
2125
2126   mpfr_clears (exp, absv, pow2, NULL);
2127
2128   return range_check (result, "FRACTION");
2129 }
2130
2131
2132 gfc_expr *
2133 gfc_simplify_gamma (gfc_expr *x)
2134 {
2135   gfc_expr *result;
2136
2137   if (x->expr_type != EXPR_CONSTANT)
2138     return NULL;
2139
2140   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2141   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2142
2143   return range_check (result, "GAMMA");
2144 }
2145
2146
2147 gfc_expr *
2148 gfc_simplify_huge (gfc_expr *e)
2149 {
2150   gfc_expr *result;
2151   int i;
2152
2153   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2154   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2155
2156   switch (e->ts.type)
2157     {
2158       case BT_INTEGER:
2159         mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2160         break;
2161
2162       case BT_REAL:
2163         mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2164         break;
2165
2166       default:
2167         gcc_unreachable ();
2168     }
2169
2170   return result;
2171 }
2172
2173
2174 gfc_expr *
2175 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2176 {
2177   gfc_expr *result;
2178
2179   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2180     return NULL;
2181
2182   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2183   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2184   return range_check (result, "HYPOT");
2185 }
2186
2187
2188 /* We use the processor's collating sequence, because all
2189    systems that gfortran currently works on are ASCII.  */
2190
2191 gfc_expr *
2192 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2193 {
2194   gfc_expr *result;
2195   gfc_char_t index;
2196   int k;
2197
2198   if (e->expr_type != EXPR_CONSTANT)
2199     return NULL;
2200
2201   if (e->value.character.length != 1)
2202     {
2203       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2204       return &gfc_bad_expr;
2205     }
2206
2207   index = e->value.character.string[0];
2208
2209   if (gfc_option.warn_surprising && index > 127)
2210     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2211                  &e->where);
2212
2213   k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2214   if (k == -1)
2215     return &gfc_bad_expr;
2216
2217   result = gfc_get_int_expr (k, &e->where, index);
2218
2219   return range_check (result, "IACHAR");
2220 }
2221
2222
2223 gfc_expr *
2224 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2225 {
2226   gfc_expr *result;
2227
2228   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2229     return NULL;
2230
2231   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2232   mpz_and (result->value.integer, x->value.integer, y->value.integer);
2233
2234   return range_check (result, "IAND");
2235 }
2236
2237
2238 gfc_expr *
2239 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2240 {
2241   gfc_expr *result;
2242   int k, pos;
2243
2244   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2245     return NULL;
2246
2247   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2248     {
2249       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
2250       return &gfc_bad_expr;
2251     }
2252
2253   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2254
2255   if (pos >= gfc_integer_kinds[k].bit_size)
2256     {
2257       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
2258                  &y->where);
2259       return &gfc_bad_expr;
2260     }
2261
2262   result = gfc_copy_expr (x);
2263
2264   convert_mpz_to_unsigned (result->value.integer,
2265                            gfc_integer_kinds[k].bit_size);
2266
2267   mpz_clrbit (result->value.integer, pos);
2268
2269   convert_mpz_to_signed (result->value.integer,
2270                          gfc_integer_kinds[k].bit_size);
2271
2272   return result;
2273 }
2274
2275
2276 gfc_expr *
2277 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2278 {
2279   gfc_expr *result;
2280   int pos, len;
2281   int i, k, bitsize;
2282   int *bits;
2283
2284   if (x->expr_type != EXPR_CONSTANT
2285       || y->expr_type != EXPR_CONSTANT
2286       || z->expr_type != EXPR_CONSTANT)
2287     return NULL;
2288
2289   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2290     {
2291       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
2292       return &gfc_bad_expr;
2293     }
2294
2295   if (gfc_extract_int (z, &len) != NULL || len < 0)
2296     {
2297       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
2298       return &gfc_bad_expr;
2299     }
2300
2301   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2302
2303   bitsize = gfc_integer_kinds[k].bit_size;
2304
2305   if (pos + len > bitsize)
2306     {
2307       gfc_error ("Sum of second and third arguments of IBITS exceeds "
2308                  "bit size at %L", &y->where);
2309       return &gfc_bad_expr;
2310     }
2311
2312   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2313   convert_mpz_to_unsigned (result->value.integer,
2314                            gfc_integer_kinds[k].bit_size);
2315
2316   bits = XCNEWVEC (int, bitsize);
2317
2318   for (i = 0; i < bitsize; i++)
2319     bits[i] = 0;
2320
2321   for (i = 0; i < len; i++)
2322     bits[i] = mpz_tstbit (x->value.integer, i + pos);
2323
2324   for (i = 0; i < bitsize; i++)
2325     {
2326       if (bits[i] == 0)
2327         mpz_clrbit (result->value.integer, i);
2328       else if (bits[i] == 1)
2329         mpz_setbit (result->value.integer, i);
2330       else
2331         gfc_internal_error ("IBITS: Bad bit");
2332     }
2333
2334   gfc_free (bits);
2335
2336   convert_mpz_to_signed (result->value.integer,
2337                          gfc_integer_kinds[k].bit_size);
2338
2339   return result;
2340 }
2341
2342
2343 gfc_expr *
2344 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2345 {
2346   gfc_expr *result;
2347   int k, pos;
2348
2349   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2350     return NULL;
2351
2352   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2353     {
2354       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
2355       return &gfc_bad_expr;
2356     }
2357
2358   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2359
2360   if (pos >= gfc_integer_kinds[k].bit_size)
2361     {
2362       gfc_error ("Second argument of IBSET exceeds bit size at %L",
2363                  &y->where);
2364       return &gfc_bad_expr;
2365     }
2366
2367   result = gfc_copy_expr (x);
2368
2369   convert_mpz_to_unsigned (result->value.integer,
2370                            gfc_integer_kinds[k].bit_size);
2371
2372   mpz_setbit (result->value.integer, pos);
2373
2374   convert_mpz_to_signed (result->value.integer,
2375                          gfc_integer_kinds[k].bit_size);
2376
2377   return result;
2378 }
2379
2380
2381 gfc_expr *
2382 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2383 {
2384   gfc_expr *result;
2385   gfc_char_t index;
2386   int k;
2387
2388   if (e->expr_type != EXPR_CONSTANT)
2389     return NULL;
2390
2391   if (e->value.character.length != 1)
2392     {
2393       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2394       return &gfc_bad_expr;
2395     }
2396
2397   index = e->value.character.string[0];
2398
2399   k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2400   if (k == -1)
2401     return &gfc_bad_expr;
2402
2403   result = gfc_get_int_expr (k, &e->where, index);
2404
2405   return range_check (result, "ICHAR");
2406 }
2407
2408
2409 gfc_expr *
2410 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2411 {
2412   gfc_expr *result;
2413
2414   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2415     return NULL;
2416
2417   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2418   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2419
2420   return range_check (result, "IEOR");
2421 }
2422
2423
2424 gfc_expr *
2425 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2426 {
2427   gfc_expr *result;
2428   int back, len, lensub;
2429   int i, j, k, count, index = 0, start;
2430
2431   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2432       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
2433     return NULL;
2434
2435   if (b != NULL && b->value.logical != 0)
2436     back = 1;
2437   else
2438     back = 0;
2439
2440   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2441   if (k == -1)
2442     return &gfc_bad_expr;
2443
2444   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2445
2446   len = x->value.character.length;
2447   lensub = y->value.character.length;
2448
2449   if (len < lensub)
2450     {
2451       mpz_set_si (result->value.integer, 0);
2452       return result;
2453     }
2454
2455   if (back == 0)
2456     {
2457       if (lensub == 0)
2458         {
2459           mpz_set_si (result->value.integer, 1);
2460           return result;
2461         }
2462       else if (lensub == 1)
2463         {
2464           for (i = 0; i < len; i++)
2465             {
2466               for (j = 0; j < lensub; j++)
2467                 {
2468                   if (y->value.character.string[j]
2469                       == x->value.character.string[i])
2470                     {
2471                       index = i + 1;
2472                       goto done;
2473                     }
2474                 }
2475             }
2476         }
2477       else
2478         {
2479           for (i = 0; i < len; i++)
2480             {
2481               for (j = 0; j < lensub; j++)
2482                 {
2483                   if (y->value.character.string[j]
2484                       == x->value.character.string[i])
2485                     {
2486                       start = i;
2487                       count = 0;
2488
2489                       for (k = 0; k < lensub; k++)
2490                         {
2491                           if (y->value.character.string[k]
2492                               == x->value.character.string[k + start])
2493                             count++;
2494                         }
2495
2496                       if (count == lensub)
2497                         {
2498                           index = start + 1;
2499                           goto done;
2500                         }
2501                     }
2502                 }
2503             }
2504         }
2505
2506     }
2507   else
2508     {
2509       if (lensub == 0)
2510         {
2511           mpz_set_si (result->value.integer, len + 1);
2512           return result;
2513         }
2514       else if (lensub == 1)
2515         {
2516           for (i = 0; i < len; i++)
2517             {
2518               for (j = 0; j < lensub; j++)
2519                 {
2520                   if (y->value.character.string[j]
2521                       == x->value.character.string[len - i])
2522                     {
2523                       index = len - i + 1;
2524                       goto done;
2525                     }
2526                 }
2527             }
2528         }
2529       else
2530         {
2531           for (i = 0; i < len; i++)
2532             {
2533               for (j = 0; j < lensub; j++)
2534                 {
2535                   if (y->value.character.string[j]
2536                       == x->value.character.string[len - i])
2537                     {
2538                       start = len - i;
2539                       if (start <= len - lensub)
2540                         {
2541                           count = 0;
2542                           for (k = 0; k < lensub; k++)
2543                             if (y->value.character.string[k]
2544                                 == x->value.character.string[k + start])
2545                               count++;
2546
2547                           if (count == lensub)
2548                             {
2549                               index = start + 1;
2550                               goto done;
2551                             }
2552                         }
2553                       else
2554                         {
2555                           continue;
2556                         }
2557                     }
2558                 }
2559             }
2560         }
2561     }
2562
2563 done:
2564   mpz_set_si (result->value.integer, index);
2565   return range_check (result, "INDEX");
2566 }
2567
2568
2569 static gfc_expr *
2570 simplify_intconv (gfc_expr *e, int kind, const char *name)
2571 {
2572   gfc_expr *result = NULL;
2573
2574   if (e->expr_type != EXPR_CONSTANT)
2575     return NULL;
2576
2577   result = gfc_convert_constant (e, BT_INTEGER, kind);
2578   if (result == &gfc_bad_expr)
2579     return &gfc_bad_expr;
2580
2581   return range_check (result, name);
2582 }
2583
2584
2585 gfc_expr *
2586 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2587 {
2588   int kind;
2589
2590   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2591   if (kind == -1)
2592     return &gfc_bad_expr;
2593
2594   return simplify_intconv (e, kind, "INT");
2595 }
2596
2597 gfc_expr *
2598 gfc_simplify_int2 (gfc_expr *e)
2599 {
2600   return simplify_intconv (e, 2, "INT2");
2601 }
2602
2603
2604 gfc_expr *
2605 gfc_simplify_int8 (gfc_expr *e)
2606 {
2607   return simplify_intconv (e, 8, "INT8");
2608 }
2609
2610
2611 gfc_expr *
2612 gfc_simplify_long (gfc_expr *e)
2613 {
2614   return simplify_intconv (e, 4, "LONG");
2615 }
2616
2617
2618 gfc_expr *
2619 gfc_simplify_ifix (gfc_expr *e)
2620 {
2621   gfc_expr *rtrunc, *result;
2622
2623   if (e->expr_type != EXPR_CONSTANT)
2624     return NULL;
2625
2626   rtrunc = gfc_copy_expr (e);
2627   mpfr_trunc (rtrunc->value.real, e->value.real);
2628
2629   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2630                                   &e->where);
2631   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2632
2633   gfc_free_expr (rtrunc);
2634
2635   return range_check (result, "IFIX");
2636 }
2637
2638
2639 gfc_expr *
2640 gfc_simplify_idint (gfc_expr *e)
2641 {
2642   gfc_expr *rtrunc, *result;
2643
2644   if (e->expr_type != EXPR_CONSTANT)
2645     return NULL;
2646
2647   rtrunc = gfc_copy_expr (e);
2648   mpfr_trunc (rtrunc->value.real, e->value.real);
2649
2650   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2651                                   &e->where);
2652   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2653
2654   gfc_free_expr (rtrunc);
2655
2656   return range_check (result, "IDINT");
2657 }
2658
2659
2660 gfc_expr *
2661 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2662 {
2663   gfc_expr *result;
2664
2665   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2666     return NULL;
2667
2668   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2669   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2670
2671   return range_check (result, "IOR");
2672 }
2673
2674
2675 gfc_expr *
2676 gfc_simplify_is_iostat_end (gfc_expr *x)
2677 {
2678   if (x->expr_type != EXPR_CONSTANT)
2679     return NULL;
2680
2681   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2682                                mpz_cmp_si (x->value.integer,
2683                                            LIBERROR_END) == 0);
2684 }
2685
2686
2687 gfc_expr *
2688 gfc_simplify_is_iostat_eor (gfc_expr *x)
2689 {
2690   if (x->expr_type != EXPR_CONSTANT)
2691     return NULL;
2692
2693   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2694                                mpz_cmp_si (x->value.integer,
2695                                            LIBERROR_EOR) == 0);
2696 }
2697
2698
2699 gfc_expr *
2700 gfc_simplify_isnan (gfc_expr *x)
2701 {
2702   if (x->expr_type != EXPR_CONSTANT)
2703     return NULL;
2704
2705   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2706                                mpfr_nan_p (x->value.real));
2707 }
2708
2709
2710 gfc_expr *
2711 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2712 {
2713   gfc_expr *result;
2714   int shift, ashift, isize, k, *bits, i;
2715
2716   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2717     return NULL;
2718
2719   if (gfc_extract_int (s, &shift) != NULL)
2720     {
2721       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2722       return &gfc_bad_expr;
2723     }
2724
2725   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2726
2727   isize = gfc_integer_kinds[k].bit_size;
2728
2729   if (shift >= 0)
2730     ashift = shift;
2731   else
2732     ashift = -shift;
2733
2734   if (ashift > isize)
2735     {
2736       gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2737                  "at %L", &s->where);
2738       return &gfc_bad_expr;
2739     }
2740
2741   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2742
2743   if (shift == 0)
2744     {
2745       mpz_set (result->value.integer, e->value.integer);
2746       return range_check (result, "ISHFT");
2747     }
2748
2749   bits = XCNEWVEC (int, isize);
2750
2751   for (i = 0; i < isize; i++)
2752     bits[i] = mpz_tstbit (e->value.integer, i);
2753
2754   if (shift > 0)
2755     {
2756       for (i = 0; i < shift; i++)
2757         mpz_clrbit (result->value.integer, i);
2758
2759       for (i = 0; i < isize - shift; i++)
2760         {
2761           if (bits[i] == 0)
2762             mpz_clrbit (result->value.integer, i + shift);
2763           else
2764             mpz_setbit (result->value.integer, i + shift);
2765         }
2766     }
2767   else
2768     {
2769       for (i = isize - 1; i >= isize - ashift; i--)
2770         mpz_clrbit (result->value.integer, i);
2771
2772       for (i = isize - 1; i >= ashift; i--)
2773         {
2774           if (bits[i] == 0)
2775             mpz_clrbit (result->value.integer, i - ashift);
2776           else
2777             mpz_setbit (result->value.integer, i - ashift);
2778         }
2779     }
2780
2781   convert_mpz_to_signed (result->value.integer, isize);
2782
2783   gfc_free (bits);
2784   return result;
2785 }
2786
2787
2788 gfc_expr *
2789 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2790 {
2791   gfc_expr *result;
2792   int shift, ashift, isize, ssize, delta, k;
2793   int i, *bits;
2794
2795   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2796     return NULL;
2797
2798   if (gfc_extract_int (s, &shift) != NULL)
2799     {
2800       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2801       return &gfc_bad_expr;
2802     }
2803
2804   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2805   isize = gfc_integer_kinds[k].bit_size;
2806
2807   if (sz != NULL)
2808     {
2809       if (sz->expr_type != EXPR_CONSTANT)
2810         return NULL;
2811
2812       if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2813         {
2814           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2815           return &gfc_bad_expr;
2816         }
2817
2818       if (ssize > isize)
2819         {
2820           gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2821                      "BIT_SIZE of first argument at %L", &s->where);
2822           return &gfc_bad_expr;
2823         }
2824     }
2825   else
2826     ssize = isize;
2827
2828   if (shift >= 0)
2829     ashift = shift;
2830   else
2831     ashift = -shift;
2832
2833   if (ashift > ssize)
2834     {
2835       if (sz != NULL)
2836         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2837                    "third argument at %L", &s->where);
2838       else
2839         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2840                    "BIT_SIZE of first argument at %L", &s->where);
2841       return &gfc_bad_expr;
2842     }
2843
2844   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2845
2846   mpz_set (result->value.integer, e->value.integer);
2847
2848   if (shift == 0)
2849     return result;
2850
2851   convert_mpz_to_unsigned (result->value.integer, isize);
2852
2853   bits = XCNEWVEC (int, ssize);
2854
2855   for (i = 0; i < ssize; i++)
2856     bits[i] = mpz_tstbit (e->value.integer, i);
2857
2858   delta = ssize - ashift;
2859
2860   if (shift > 0)
2861     {
2862       for (i = 0; i < delta; i++)
2863         {
2864           if (bits[i] == 0)
2865             mpz_clrbit (result->value.integer, i + shift);
2866           else
2867             mpz_setbit (result->value.integer, i + shift);
2868         }
2869
2870       for (i = delta; i < ssize; i++)
2871         {
2872           if (bits[i] == 0)
2873             mpz_clrbit (result->value.integer, i - delta);
2874           else
2875             mpz_setbit (result->value.integer, i - delta);
2876         }
2877     }
2878   else
2879     {
2880       for (i = 0; i < ashift; i++)
2881         {
2882           if (bits[i] == 0)
2883             mpz_clrbit (result->value.integer, i + delta);
2884           else
2885             mpz_setbit (result->value.integer, i + delta);
2886         }
2887
2888       for (i = ashift; i < ssize; i++)
2889         {
2890           if (bits[i] == 0)
2891             mpz_clrbit (result->value.integer, i + shift);
2892           else
2893             mpz_setbit (result->value.integer, i + shift);
2894         }
2895     }
2896
2897   convert_mpz_to_signed (result->value.integer, isize);
2898
2899   gfc_free (bits);
2900   return result;
2901 }
2902
2903
2904 gfc_expr *
2905 gfc_simplify_kind (gfc_expr *e)
2906 {
2907   return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
2908 }
2909
2910
2911 static gfc_expr *
2912 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2913                     gfc_array_spec *as, gfc_ref *ref, bool coarray)
2914 {
2915   gfc_expr *l, *u, *result;
2916   int k;
2917
2918   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2919                 gfc_default_integer_kind);
2920   if (k == -1)
2921     return &gfc_bad_expr;
2922
2923   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
2924
2925   /* For non-variables, LBOUND(expr, DIM=n) = 1 and
2926      UBOUND(expr, DIM=n) = SIZE(expr, DIM=n).  */
2927   if (!coarray && array->expr_type != EXPR_VARIABLE)
2928     {
2929       if (upper)
2930         {
2931           gfc_expr* dim = result;
2932           mpz_set_si (dim->value.integer, d);
2933
2934           result = gfc_simplify_size (array, dim, kind);
2935           gfc_free_expr (dim);
2936           if (!result)
2937             goto returnNull;
2938         }
2939       else
2940         mpz_set_si (result->value.integer, 1);
2941
2942       goto done;
2943     }
2944
2945   /* Otherwise, we have a variable expression.  */
2946   gcc_assert (array->expr_type == EXPR_VARIABLE);
2947   gcc_assert (as);
2948
2949   /* The last dimension of an assumed-size array is special.  */
2950   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2951       || (coarray && d == as->rank + as->corank))
2952     {
2953       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2954         {
2955           gfc_free_expr (result);
2956           return gfc_copy_expr (as->lower[d-1]);
2957         }
2958
2959       goto returnNull;
2960     }
2961
2962   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
2963
2964   /* Then, we need to know the extent of the given dimension.  */
2965   if (coarray || ref->u.ar.type == AR_FULL)
2966     {
2967       l = as->lower[d-1];
2968       u = as->upper[d-1];
2969
2970       if (l->expr_type != EXPR_CONSTANT || u == NULL
2971           || u->expr_type != EXPR_CONSTANT)
2972         goto returnNull;
2973
2974       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2975         {
2976           /* Zero extent.  */
2977           if (upper)
2978             mpz_set_si (result->value.integer, 0);
2979           else
2980             mpz_set_si (result->value.integer, 1);
2981         }
2982       else
2983         {
2984           /* Nonzero extent.  */
2985           if (upper)
2986             mpz_set (result->value.integer, u->value.integer);
2987           else
2988             mpz_set (result->value.integer, l->value.integer);
2989         }
2990     }
2991   else
2992     {
2993       if (upper)
2994         {
2995           if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
2996               != SUCCESS)
2997             goto returnNull;
2998         }
2999       else
3000         mpz_set_si (result->value.integer, (long int) 1);
3001     }
3002
3003 done:
3004   return range_check (result, upper ? "UBOUND" : "LBOUND");
3005
3006 returnNull:
3007   gfc_free_expr (result);
3008   return NULL;
3009 }
3010
3011
3012 static gfc_expr *
3013 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3014 {
3015   gfc_ref *ref;
3016   gfc_array_spec *as;
3017   int d;
3018
3019   if (array->expr_type != EXPR_VARIABLE)
3020     {
3021       as = NULL;
3022       ref = NULL;
3023       goto done;
3024     }
3025
3026   /* Follow any component references.  */
3027   as = array->symtree->n.sym->as;
3028   for (ref = array->ref; ref; ref = ref->next)
3029     {
3030       switch (ref->type)
3031         {
3032         case REF_ARRAY:
3033           switch (ref->u.ar.type)
3034             {
3035             case AR_ELEMENT:
3036               as = NULL;
3037               continue;
3038
3039             case AR_FULL:
3040               /* We're done because 'as' has already been set in the
3041                  previous iteration.  */
3042               if (!ref->next)
3043                 goto done;
3044
3045             /* Fall through.  */
3046
3047             case AR_UNKNOWN:
3048               return NULL;
3049
3050             case AR_SECTION:
3051               as = ref->u.ar.as;
3052               goto done;
3053             }
3054
3055           gcc_unreachable ();
3056
3057         case REF_COMPONENT:
3058           as = ref->u.c.component->as;
3059           continue;
3060
3061         case REF_SUBSTRING:
3062           continue;
3063         }
3064     }
3065
3066   gcc_unreachable ();
3067
3068  done:
3069
3070   if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
3071     return NULL;
3072
3073   if (dim == NULL)
3074     {
3075       /* Multi-dimensional bounds.  */
3076       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3077       gfc_expr *e;
3078       int k;
3079
3080       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
3081       if (upper && as && as->type == AS_ASSUMED_SIZE)
3082         {
3083           /* An error message will be emitted in
3084              check_assumed_size_reference (resolve.c).  */
3085           return &gfc_bad_expr;
3086         }
3087
3088       /* Simplify the bounds for each dimension.  */
3089       for (d = 0; d < array->rank; d++)
3090         {
3091           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3092                                           false);
3093           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3094             {
3095               int j;
3096
3097               for (j = 0; j < d; j++)
3098                 gfc_free_expr (bounds[j]);
3099               return bounds[d];
3100             }
3101         }
3102
3103       /* Allocate the result expression.  */
3104       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3105                     gfc_default_integer_kind);
3106       if (k == -1)
3107         return &gfc_bad_expr;
3108
3109       e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3110
3111       /* The result is a rank 1 array; its size is the rank of the first
3112          argument to {L,U}BOUND.  */
3113       e->rank = 1;
3114       e->shape = gfc_get_shape (1);
3115       mpz_init_set_ui (e->shape[0], array->rank);
3116
3117       /* Create the constructor for this array.  */
3118       for (d = 0; d < array->rank; d++)
3119         gfc_constructor_append_expr (&e->value.constructor,
3120                                      bounds[d], &e->where);
3121
3122       return e;
3123     }
3124   else
3125     {
3126       /* A DIM argument is specified.  */
3127       if (dim->expr_type != EXPR_CONSTANT)
3128         return NULL;
3129
3130       d = mpz_get_si (dim->value.integer);
3131
3132       if (d < 1 || d > array->rank
3133           || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3134         {
3135           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3136           return &gfc_bad_expr;
3137         }
3138
3139       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3140     }
3141 }
3142
3143
3144 static gfc_expr *
3145 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3146 {
3147   gfc_ref *ref;
3148   gfc_array_spec *as;
3149   int d;
3150
3151   if (array->expr_type != EXPR_VARIABLE)
3152     return NULL;
3153
3154   /* Follow any component references.  */
3155   as = array->symtree->n.sym->as;
3156   for (ref = array->ref; ref; ref = ref->next)
3157     {
3158       switch (ref->type)
3159         {
3160         case REF_ARRAY:
3161           switch (ref->u.ar.type)
3162             {
3163             case AR_ELEMENT:
3164               if (ref->next == NULL)
3165                 {
3166                   gcc_assert (ref->u.ar.as->corank > 0
3167                               && ref->u.ar.as->rank == 0);
3168                   as = ref->u.ar.as;
3169                   goto done;
3170                 }
3171               as = NULL;
3172               continue;
3173
3174             case AR_FULL:
3175               /* We're done because 'as' has already been set in the
3176                  previous iteration.  */
3177               if (!ref->next)
3178                 goto done;
3179
3180             /* Fall through.  */
3181
3182             case AR_UNKNOWN:
3183               return NULL;
3184
3185             case AR_SECTION:
3186               as = ref->u.ar.as;
3187               goto done;
3188             }
3189
3190           gcc_unreachable ();
3191
3192         case REF_COMPONENT:
3193           as = ref->u.c.component->as;
3194           continue;
3195
3196         case REF_SUBSTRING:
3197           continue;
3198         }
3199     }
3200
3201   gcc_unreachable ();
3202
3203  done:
3204
3205   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3206     return NULL;
3207
3208   if (dim == NULL)
3209     {
3210       /* Multi-dimensional cobounds.  */
3211       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3212       gfc_expr *e;
3213       int k;
3214
3215       /* Simplify the cobounds for each dimension.  */
3216       for (d = 0; d < as->corank; d++)
3217         {
3218           bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
3219                                           upper, as, ref, true);
3220           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3221             {
3222               int j;
3223
3224               for (j = 0; j < d; j++)
3225                 gfc_free_expr (bounds[j]);
3226               return bounds[d];
3227             }
3228         }
3229
3230       /* Allocate the result expression.  */
3231       e = gfc_get_expr ();
3232       e->where = array->where;
3233       e->expr_type = EXPR_ARRAY;
3234       e->ts.type = BT_INTEGER;
3235       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3236                     gfc_default_integer_kind);
3237       if (k == -1)
3238         {
3239           gfc_free_expr (e);
3240           return &gfc_bad_expr;
3241         }
3242       e->ts.kind = k;
3243
3244       /* The result is a rank 1 array; its size is the rank of the first
3245          argument to {L,U}COBOUND.  */
3246       e->rank = 1;
3247       e->shape = gfc_get_shape (1);
3248       mpz_init_set_ui (e->shape[0], as->corank);
3249
3250       /* Create the constructor for this array.  */
3251       for (d = 0; d < as->corank; d++)
3252         gfc_constructor_append_expr (&e->value.constructor,
3253                                      bounds[d], &e->where);
3254       return e;
3255     }
3256   else
3257     {
3258       /* A DIM argument is specified.  */
3259       if (dim->expr_type != EXPR_CONSTANT)
3260         return NULL;
3261
3262       d = mpz_get_si (dim->value.integer);
3263
3264       if (d < 1 || d > as->corank)
3265         {
3266           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3267           return &gfc_bad_expr;
3268         }
3269
3270       return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3271     }
3272 }
3273
3274
3275 gfc_expr *
3276 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3277 {
3278   return simplify_bound (array, dim, kind, 0);
3279 }
3280
3281
3282 gfc_expr *
3283 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3284 {
3285   gfc_expr *e;
3286   /* return simplify_cobound (array, dim, kind, 0);*/
3287
3288   e = simplify_cobound (array, dim, kind, 0);
3289   if (e != NULL)
3290     return e;
3291
3292   gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3293              "cobounds at %L", &array->where);
3294   return &gfc_bad_expr;
3295 }
3296
3297 gfc_expr *
3298 gfc_simplify_leadz (gfc_expr *e)
3299 {
3300   unsigned long lz, bs;
3301   int i;
3302
3303   if (e->expr_type != EXPR_CONSTANT)
3304     return NULL;
3305
3306   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3307   bs = gfc_integer_kinds[i].bit_size;
3308   if (mpz_cmp_si (e->value.integer, 0) == 0)
3309     lz = bs;
3310   else if (mpz_cmp_si (e->value.integer, 0) < 0)
3311     lz = 0;
3312   else
3313     lz = bs - mpz_sizeinbase (e->value.integer, 2);
3314
3315   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3316 }
3317
3318
3319 gfc_expr *
3320 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3321 {
3322   gfc_expr *result;
3323   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3324
3325   if (k == -1)
3326     return &gfc_bad_expr;
3327
3328   if (e->expr_type == EXPR_CONSTANT)
3329     {
3330       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3331       mpz_set_si (result->value.integer, e->value.character.length);
3332       return range_check (result, "LEN");
3333     }
3334   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3335            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3336            && e->ts.u.cl->length->ts.type == BT_INTEGER)
3337     {
3338       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3339       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3340       return range_check (result, "LEN");
3341     }
3342   else
3343     return NULL;
3344 }
3345
3346
3347 gfc_expr *
3348 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3349 {
3350   gfc_expr *result;
3351   int count, len, i;
3352   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3353
3354   if (k == -1)
3355     return &gfc_bad_expr;
3356
3357   if (e->expr_type != EXPR_CONSTANT)
3358     return NULL;
3359
3360   len = e->value.character.length;
3361   for (count = 0, i = 1; i <= len; i++)
3362     if (e->value.character.string[len - i] == ' ')
3363       count++;
3364     else
3365       break;
3366
3367   result = gfc_get_int_expr (k, &e->where, len - count);
3368   return range_check (result, "LEN_TRIM");
3369 }
3370
3371 gfc_expr *
3372 gfc_simplify_lgamma (gfc_expr *x)
3373 {
3374   gfc_expr *result;
3375   int sg;
3376
3377   if (x->expr_type != EXPR_CONSTANT)
3378     return NULL;
3379
3380   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3381   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3382
3383   return range_check (result, "LGAMMA");
3384 }
3385
3386
3387 gfc_expr *
3388 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3389 {
3390   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3391     return NULL;
3392
3393   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3394                                gfc_compare_string (a, b) >= 0);
3395 }
3396
3397
3398 gfc_expr *
3399 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3400 {
3401   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3402     return NULL;
3403
3404   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3405                                gfc_compare_string (a, b) > 0);
3406 }
3407
3408
3409 gfc_expr *
3410 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3411 {
3412   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3413     return NULL;
3414
3415   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3416                                gfc_compare_string (a, b) <= 0);
3417 }
3418
3419
3420 gfc_expr *
3421 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3422 {
3423   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3424     return NULL;
3425
3426   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3427                                gfc_compare_string (a, b) < 0);
3428 }
3429
3430
3431 gfc_expr *
3432 gfc_simplify_log (gfc_expr *x)
3433 {
3434   gfc_expr *result;
3435
3436   if (x->expr_type != EXPR_CONSTANT)
3437     return NULL;
3438
3439   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3440
3441   switch (x->ts.type)
3442     {
3443     case BT_REAL:
3444       if (mpfr_sgn (x->value.real) <= 0)
3445         {
3446           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3447                      "to zero", &x->where);
3448           gfc_free_expr (result);
3449           return &gfc_bad_expr;
3450         }
3451
3452       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3453       break;
3454
3455     case BT_COMPLEX:
3456       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3457           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3458         {
3459           gfc_error ("Complex argument of LOG at %L cannot be zero",
3460                      &x->where);
3461           gfc_free_expr (result);
3462           return &gfc_bad_expr;
3463         }
3464
3465       gfc_set_model_kind (x->ts.kind);
3466       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3467       break;
3468
3469     default:
3470       gfc_internal_error ("gfc_simplify_log: bad type");
3471     }
3472
3473   return range_check (result, "LOG");
3474 }
3475
3476
3477 gfc_expr *
3478 gfc_simplify_log10 (gfc_expr *x)
3479 {
3480   gfc_expr *result;
3481
3482   if (x->expr_type != EXPR_CONSTANT)
3483     return NULL;
3484
3485   if (mpfr_sgn (x->value.real) <= 0)
3486     {
3487       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3488                  "to zero", &x->where);
3489       return &gfc_bad_expr;
3490     }
3491
3492   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3493   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3494
3495   return range_check (result, "LOG10");
3496 }
3497
3498
3499 gfc_expr *
3500 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3501 {
3502   int kind;
3503
3504   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3505   if (kind < 0)
3506     return &gfc_bad_expr;
3507
3508   if (e->expr_type != EXPR_CONSTANT)
3509     return NULL;
3510
3511   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3512 }
3513
3514
3515 gfc_expr*
3516 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3517 {
3518   gfc_expr *result;
3519   int row, result_rows, col, result_columns;
3520   int stride_a, offset_a, stride_b, offset_b;
3521
3522   if (!is_constant_array_expr (matrix_a)
3523       || !is_constant_array_expr (matrix_b))
3524     return NULL;
3525
3526   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3527   result = gfc_get_array_expr (matrix_a->ts.type,
3528                                matrix_a->ts.kind,
3529                                &matrix_a->where);
3530
3531   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3532     {
3533       result_rows = 1;
3534       result_columns = mpz_get_si (matrix_b->shape[0]);
3535       stride_a = 1;
3536       stride_b = mpz_get_si (matrix_b->shape[0]);
3537
3538       result->rank = 1;
3539       result->shape = gfc_get_shape (result->rank);
3540       mpz_init_set_si (result->shape[0], result_columns);
3541     }
3542   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3543     {
3544       result_rows = mpz_get_si (matrix_b->shape[0]);
3545       result_columns = 1;
3546       stride_a = mpz_get_si (matrix_a->shape[0]);
3547       stride_b = 1;
3548
3549       result->rank = 1;
3550       result->shape = gfc_get_shape (result->rank);
3551       mpz_init_set_si (result->shape[0], result_rows);
3552     }
3553   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3554     {
3555       result_rows = mpz_get_si (matrix_a->shape[0]);
3556       result_columns = mpz_get_si (matrix_b->shape[1]);
3557       stride_a = mpz_get_si (matrix_a->shape[1]);
3558       stride_b = mpz_get_si (matrix_b->shape[0]);
3559
3560       result->rank = 2;
3561       result->shape = gfc_get_shape (result->rank);
3562       mpz_init_set_si (result->shape[0], result_rows);
3563       mpz_init_set_si (result->shape[1], result_columns);
3564     }
3565   else
3566     gcc_unreachable();
3567
3568   offset_a = offset_b = 0;
3569   for (col = 0; col < result_columns; ++col)
3570     {
3571       offset_a = 0;
3572
3573       for (row = 0; row < result_rows; ++row)
3574         {
3575           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3576                                              matrix_b, 1, offset_b);
3577           gfc_constructor_append_expr (&result->value.constructor,
3578                                        e, NULL);
3579
3580           offset_a += 1;
3581         }
3582
3583       offset_b += stride_b;
3584     }
3585
3586   return result;
3587 }
3588
3589
3590 gfc_expr *
3591 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3592 {
3593   if (tsource->expr_type != EXPR_CONSTANT
3594       || fsource->expr_type != EXPR_CONSTANT
3595       || mask->expr_type != EXPR_CONSTANT)
3596     return NULL;
3597
3598   return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3599 }
3600
3601
3602 /* Selects bewteen current value and extremum for simplify_min_max
3603    and simplify_minval_maxval.  */
3604 static void
3605 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3606 {
3607   switch (arg->ts.type)
3608     {
3609       case BT_INTEGER:
3610         if (mpz_cmp (arg->value.integer,
3611                         extremum->value.integer) * sign > 0)
3612         mpz_set (extremum->value.integer, arg->value.integer);
3613         break;
3614
3615       case BT_REAL:
3616         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
3617         if (sign > 0)
3618           mpfr_max (extremum->value.real, extremum->value.real,
3619                       arg->value.real, GFC_RND_MODE);
3620         else
3621           mpfr_min (extremum->value.real, extremum->value.real,
3622                       arg->value.real, GFC_RND_MODE);
3623         break;
3624
3625       case BT_CHARACTER:
3626 #define LENGTH(x) ((x)->value.character.length)
3627 #define STRING(x) ((x)->value.character.string)
3628         if (LENGTH(extremum) < LENGTH(arg))
3629           {
3630             gfc_char_t *tmp = STRING(extremum);
3631
3632             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3633             memcpy (STRING(extremum), tmp,
3634                       LENGTH(extremum) * sizeof (gfc_char_t));
3635             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3636                                LENGTH(arg) - LENGTH(extremum));
3637             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
3638             LENGTH(extremum) = LENGTH(arg);
3639             gfc_free (tmp);
3640           }
3641
3642         if (gfc_compare_string (arg, extremum) * sign > 0)
3643           {
3644             gfc_free (STRING(extremum));
3645             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3646             memcpy (STRING(extremum), STRING(arg),
3647                       LENGTH(arg) * sizeof (gfc_char_t));
3648             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3649                                LENGTH(extremum) - LENGTH(arg));
3650             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
3651           }
3652 #undef LENGTH
3653 #undef STRING
3654         break;
3655
3656       default:
3657         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3658     }
3659 }
3660
3661
3662 /* This function is special since MAX() can take any number of
3663    arguments.  The simplified expression is a rewritten version of the
3664    argument list containing at most one constant element.  Other
3665    constant elements are deleted.  Because the argument list has
3666    already been checked, this function always succeeds.  sign is 1 for
3667    MAX(), -1 for MIN().  */
3668
3669 static gfc_expr *
3670 simplify_min_max (gfc_expr *expr, int sign)
3671 {
3672   gfc_actual_arglist *arg, *last, *extremum;
3673   gfc_intrinsic_sym * specific;
3674
3675   last = NULL;
3676   extremum = NULL;
3677   specific = expr->value.function.isym;
3678
3679   arg = expr->value.function.actual;
3680
3681   for (; arg; last = arg, arg = arg->next)
3682     {
3683       if (arg->expr->expr_type != EXPR_CONSTANT)
3684         continue;
3685
3686       if (extremum == NULL)
3687         {
3688           extremum = arg;
3689           continue;
3690         }
3691
3692       min_max_choose (arg->expr, extremum->expr, sign);
3693
3694       /* Delete the extra constant argument.  */
3695       if (last == NULL)
3696         expr->value.function.actual = arg->next;
3697       else
3698         last->next = arg->next;
3699
3700       arg->next = NULL;
3701       gfc_free_actual_arglist (arg);
3702       arg = last;
3703     }
3704
3705   /* If there is one value left, replace the function call with the
3706      expression.  */
3707   if (expr->value.function.actual->next != NULL)
3708     return NULL;
3709
3710   /* Convert to the correct type and kind.  */
3711   if (expr->ts.type != BT_UNKNOWN)
3712     return gfc_convert_constant (expr->value.function.actual->expr,
3713         expr->ts.type, expr->ts.kind);
3714
3715   if (specific->ts.type != BT_UNKNOWN)
3716     return gfc_convert_constant (expr->value.function.actual->expr,
3717         specific->ts.type, specific->ts.kind);
3718
3719   return gfc_copy_expr (expr->value.function.actual->expr);
3720 }
3721
3722
3723 gfc_expr *
3724 gfc_simplify_min (gfc_expr *e)
3725 {
3726   return simplify_min_max (e, -1);
3727 }
3728
3729
3730 gfc_expr *
3731 gfc_simplify_max (gfc_expr *e)
3732 {
3733   return simplify_min_max (e, 1);
3734 }
3735
3736
3737 /* This is a simplified version of simplify_min_max to provide
3738    simplification of minval and maxval for a vector.  */
3739
3740 static gfc_expr *
3741 simplify_minval_maxval (gfc_expr *expr, int sign)
3742 {
3743   gfc_constructor *c, *extremum;
3744   gfc_intrinsic_sym * specific;
3745
3746   extremum = NULL;
3747   specific = expr->value.function.isym;
3748
3749   for (c = gfc_constructor_first (expr->value.constructor);
3750        c; c = gfc_constructor_next (c))
3751     {
3752       if (c->expr->expr_type != EXPR_CONSTANT)
3753         return NULL;
3754
3755       if (extremum == NULL)
3756         {
3757           extremum = c;
3758           continue;
3759         }
3760
3761       min_max_choose (c->expr, extremum->expr, sign);
3762      }
3763
3764   if (extremum == NULL)
3765     return NULL;
3766
3767   /* Convert to the correct type and kind.  */
3768   if (expr->ts.type != BT_UNKNOWN)
3769     return gfc_convert_constant (extremum->expr,
3770         expr->ts.type, expr->ts.kind);
3771
3772   if (specific->ts.type != BT_UNKNOWN)
3773     return gfc_convert_constant (extremum->expr,
3774         specific->ts.type, specific->ts.kind);
3775
3776   return gfc_copy_expr (extremum->expr);
3777 }
3778
3779
3780 gfc_expr *
3781 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3782 {
3783   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3784     return NULL;
3785
3786   return simplify_minval_maxval (array, -1);
3787 }
3788
3789
3790 gfc_expr *
3791 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3792 {
3793   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3794     return NULL;
3795
3796   return simplify_minval_maxval (array, 1);
3797 }
3798
3799
3800 gfc_expr *
3801 gfc_simplify_maxexponent (gfc_expr *x)
3802 {
3803   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3804   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3805                            gfc_real_kinds[i].max_exponent);
3806 }
3807
3808
3809 gfc_expr *
3810 gfc_simplify_minexponent (gfc_expr *x)
3811 {
3812   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3813   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3814                            gfc_real_kinds[i].min_exponent);
3815 }
3816
3817
3818 gfc_expr *
3819 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3820 {
3821   gfc_expr *result;
3822   mpfr_t tmp;
3823   int kind;
3824
3825   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3826     return NULL;
3827
3828   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3829   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3830
3831   switch (a->ts.type)
3832     {
3833       case BT_INTEGER:
3834         if (mpz_cmp_ui (p->value.integer, 0) == 0)
3835           {
3836             /* Result is processor-dependent.  */
3837             gfc_error ("Second argument MOD at %L is zero", &a->where);
3838             gfc_free_expr (result);
3839             return &gfc_bad_expr;
3840           }
3841         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3842         break;
3843
3844       case BT_REAL:
3845         if (mpfr_cmp_ui (p->value.real, 0) == 0)
3846           {
3847             /* Result is processor-dependent.  */
3848             gfc_error ("Second argument of MOD at %L is zero", &p->where);
3849             gfc_free_expr (result);
3850             return &gfc_bad_expr;
3851           }
3852
3853         gfc_set_model_kind (kind);
3854         mpfr_init (tmp);
3855         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3856         mpfr_trunc (tmp, tmp);
3857         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3858         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3859         mpfr_clear (tmp);
3860         break;
3861
3862       default:
3863         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3864     }
3865
3866   return range_check (result, "MOD");
3867 }
3868
3869
3870 gfc_expr *
3871 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3872 {
3873   gfc_expr *result;
3874   mpfr_t tmp;
3875   int kind;
3876
3877   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3878     return NULL;
3879
3880   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3881   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3882
3883   switch (a->ts.type)
3884     {
3885       case BT_INTEGER:
3886         if (mpz_cmp_ui (p->value.integer, 0) == 0)
3887           {
3888             /* Result is processor-dependent. This processor just opts
3889               to not handle it at all.  */
3890             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3891             gfc_free_expr (result);
3892             return &gfc_bad_expr;
3893           }
3894         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3895
3896         break;
3897
3898       case BT_REAL:
3899         if (mpfr_cmp_ui (p->value.real, 0) == 0)
3900           {
3901             /* Result is processor-dependent.  */
3902             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3903             gfc_free_expr (result);
3904             return &gfc_bad_expr;
3905           }
3906
3907         gfc_set_model_kind (kind);
3908         mpfr_init (tmp);
3909         mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3910         mpfr_floor (tmp, tmp);
3911         mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3912         mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3913         mpfr_clear (tmp);
3914         break;
3915
3916       default:
3917         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3918     }
3919
3920   return range_check (result, "MODULO");
3921 }
3922
3923
3924 /* Exists for the sole purpose of consistency with other intrinsics.  */
3925 gfc_expr *
3926 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
3927                      gfc_expr *fp ATTRIBUTE_UNUSED,
3928                      gfc_expr *l  ATTRIBUTE_UNUSED,
3929                      gfc_expr *to ATTRIBUTE_UNUSED,
3930                      gfc_expr *tp ATTRIBUTE_UNUSED)
3931 {
3932   return NULL;
3933 }
3934
3935
3936 gfc_expr *
3937 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3938 {
3939   gfc_expr *result;
3940   mp_exp_t emin, emax;
3941   int kind;
3942
3943   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3944     return NULL;
3945
3946   if (mpfr_sgn (s->value.real) == 0)
3947     {
3948       gfc_error ("Second argument of NEAREST at %L shall not be zero",
3949                  &s->where);
3950       return &gfc_bad_expr;
3951     }
3952
3953   result = gfc_copy_expr (x);
3954
3955   /* Save current values of emin and emax.  */
3956   emin = mpfr_get_emin ();
3957   emax = mpfr_get_emax ();
3958
3959   /* Set emin and emax for the current model number.  */
3960   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3961   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3962                 mpfr_get_prec(result->value.real) + 1);
3963   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3964   mpfr_check_range (result->value.real, 0, GMP_RNDU);
3965
3966   if (mpfr_sgn (s->value.real) > 0)
3967     {
3968       mpfr_nextabove (result->value.real);
3969       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3970     }
3971   else
3972     {
3973       mpfr_nextbelow (result->value.real);
3974       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3975     }
3976
3977   mpfr_set_emin (emin);
3978   mpfr_set_emax (emax);
3979
3980   /* Only NaN can occur. Do not use range check as it gives an
3981      error for denormal numbers.  */
3982   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3983     {
3984       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3985       gfc_free_expr (result);
3986       return &gfc_bad_expr;
3987     }
3988
3989   return result;
3990 }
3991
3992
3993 static gfc_expr *
3994 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3995 {
3996   gfc_expr *itrunc, *result;
3997   int kind;
3998
3999   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4000   if (kind == -1)
4001     return &gfc_bad_expr;
4002
4003   if (e->expr_type != EXPR_CONSTANT)
4004     return NULL;
4005
4006   itrunc = gfc_copy_expr (e);
4007   mpfr_round (itrunc->value.real, e->value.real);
4008
4009   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4010   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4011
4012   gfc_free_expr (itrunc);
4013
4014   return range_check (result, name);
4015 }
4016
4017
4018 gfc_expr *
4019 gfc_simplify_new_line (gfc_expr *e)
4020 {
4021   gfc_expr *result;
4022
4023   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4024   result->value.character.string[0] = '\n';
4025
4026   return result;
4027 }
4028
4029
4030 gfc_expr *
4031 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4032 {
4033   return simplify_nint ("NINT", e, k);
4034 }
4035
4036
4037 gfc_expr *
4038 gfc_simplify_idnint (gfc_expr *e)
4039 {
4040   return simplify_nint ("IDNINT", e, NULL);
4041 }
4042
4043
4044 gfc_expr *
4045 gfc_simplify_not (gfc_expr *e)
4046 {
4047   gfc_expr *result;
4048
4049   if (e->expr_type != EXPR_CONSTANT)
4050     return NULL;
4051
4052   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4053   mpz_com (result->value.integer, e->value.integer);
4054
4055   return range_check (result, "NOT");
4056 }
4057
4058
4059 gfc_expr *
4060 gfc_simplify_null (gfc_expr *mold)
4061 {
4062   gfc_expr *result;
4063
4064   if (mold)
4065     {
4066       result = gfc_copy_expr (mold);
4067       result->expr_type = EXPR_NULL;
4068     }
4069   else
4070     result = gfc_get_null_expr (NULL);
4071
4072   return result;
4073 }
4074
4075
4076 gfc_expr *
4077 gfc_simplify_num_images (void)
4078 {
4079   gfc_expr *result;
4080
4081   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4082     {
4083       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4084       return &gfc_bad_expr;
4085     }
4086
4087   /* FIXME: gfc_current_locus is wrong.  */
4088   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4089                                   &gfc_current_locus);
4090   mpz_set_si (result->value.integer, 1);
4091   return result;
4092 }
4093
4094
4095 gfc_expr *
4096 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4097 {
4098   gfc_expr *result;
4099   int kind;
4100
4101   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4102     return NULL;
4103
4104   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4105
4106   switch (x->ts.type)
4107     {
4108       case BT_INTEGER:
4109         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4110         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4111         return range_check (result, "OR");
4112
4113       case BT_LOGICAL:
4114         return gfc_get_logical_expr (kind, &x->where,
4115                                      x->value.logical || y->value.logical);
4116       default:
4117         gcc_unreachable();
4118     }
4119 }
4120
4121
4122 gfc_expr *
4123 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4124 {
4125   gfc_expr *result;
4126   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4127
4128   if (!is_constant_array_expr(array)
4129       || !is_constant_array_expr(vector)
4130       || (!gfc_is_constant_expr (mask)
4131           && !is_constant_array_expr(mask)))
4132     return NULL;
4133
4134   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4135
4136   array_ctor = gfc_constructor_first (array->value.constructor);
4137   vector_ctor = vector
4138                   ? gfc_constructor_first (vector->value.constructor)
4139                   : NULL;
4140
4141   if (mask->expr_type == EXPR_CONSTANT
4142       && mask->value.logical)
4143     {
4144       /* Copy all elements of ARRAY to RESULT.  */
4145       while (array_ctor)
4146         {
4147           gfc_constructor_append_expr (&result->value.constructor,
4148                                        gfc_copy_expr (array_ctor->expr),
4149                                        NULL);
4150
4151           array_ctor = gfc_constructor_next (array_ctor);
4152           vector_ctor = gfc_constructor_next (vector_ctor);
4153         }
4154     }
4155   else if (mask->expr_type == EXPR_ARRAY)
4156     {
4157       /* Copy only those elements of ARRAY to RESULT whose
4158          MASK equals .TRUE..  */
4159       mask_ctor = gfc_constructor_first (mask->value.constructor);
4160       while (mask_ctor)
4161         {
4162           if (mask_ctor->expr->value.logical)
4163             {
4164               gfc_constructor_append_expr (&result->value.constructor,
4165                                            gfc_copy_expr (array_ctor->expr),
4166                                            NULL);
4167               vector_ctor = gfc_constructor_next (vector_ctor);
4168             }
4169
4170           array_ctor = gfc_constructor_next (array_ctor);
4171           mask_ctor = gfc_constructor_next (mask_ctor);
4172         }
4173     }
4174
4175   /* Append any left-over elements from VECTOR to RESULT.  */
4176   while (vector_ctor)
4177     {
4178       gfc_constructor_append_expr (&result->value.constructor,
4179                                    gfc_copy_expr (vector_ctor->expr),
4180                                    NULL);
4181       vector_ctor = gfc_constructor_next (vector_ctor);
4182     }
4183
4184   result->shape = gfc_get_shape (1);
4185   gfc_array_size (result, &result->shape[0]);
4186
4187   if (array->ts.type == BT_CHARACTER)
4188     result->ts.u.cl = array->ts.u.cl;
4189
4190   return result;
4191 }
4192
4193
4194 gfc_expr *
4195 gfc_simplify_precision (gfc_expr *e)
4196 {
4197   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4198   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4199                            gfc_real_kinds[i].precision);
4200 }
4201
4202
4203 gfc_expr *
4204 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4205 {
4206   gfc_expr *result;
4207
4208   if (!is_constant_array_expr (array)
4209       || !gfc_is_constant_expr (dim))
4210     return NULL;
4211
4212   if (mask
4213       && !is_constant_array_expr (mask)
4214       && mask->expr_type != EXPR_CONSTANT)
4215     return NULL;
4216
4217   result = transformational_result (array, dim, array->ts.type,
4218                                     array->ts.kind, &array->where);
4219   init_result_expr (result, 1, NULL);
4220
4221   return !dim || array->rank == 1 ?
4222     simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
4223     simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4224 }
4225
4226
4227 gfc_expr *
4228 gfc_simplify_radix (gfc_expr *e)
4229 {
4230   int i;
4231   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4232
4233   switch (e->ts.type)
4234     {
4235       case BT_INTEGER:
4236         i = gfc_integer_kinds[i].radix;
4237         break;
4238
4239       case BT_REAL:
4240         i = gfc_real_kinds[i].radix;
4241         break;
4242
4243       default:
4244         gcc_unreachable ();
4245     }
4246
4247   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4248 }
4249
4250
4251 gfc_expr *
4252 gfc_simplify_range (gfc_expr *e)
4253 {
4254   int i;
4255   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4256
4257   switch (e->ts.type)
4258     {
4259       case BT_INTEGER:
4260         i = gfc_integer_kinds[i].range;
4261         break;
4262
4263       case BT_REAL:
4264       case BT_COMPLEX:
4265         i = gfc_real_kinds[i].range;
4266         break;
4267
4268       default:
4269         gcc_unreachable ();
4270     }
4271
4272   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4273 }
4274
4275
4276 gfc_expr *
4277 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4278 {
4279   gfc_expr *result = NULL;
4280   int kind;
4281
4282   if (e->ts.type == BT_COMPLEX)
4283     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4284   else
4285     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4286
4287   if (kind == -1)
4288     return &gfc_bad_expr;
4289
4290   if (e->expr_type != EXPR_CONSTANT)
4291     return NULL;
4292
4293   if (convert_boz (e, kind) == &gfc_bad_expr)
4294     return &gfc_bad_expr;
4295
4296   result = gfc_convert_constant (e, BT_REAL, kind);
4297   if (result == &gfc_bad_expr)
4298     return &gfc_bad_expr;
4299
4300   return range_check (result, "REAL");
4301 }
4302
4303
4304 gfc_expr *
4305 gfc_simplify_realpart (gfc_expr *e)
4306 {
4307   gfc_expr *result;
4308
4309   if (e->expr_type != EXPR_CONSTANT)
4310     return NULL;
4311
4312   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4313   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4314
4315   return range_check (result, "REALPART");
4316 }
4317
4318 gfc_expr *
4319 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4320 {
4321   gfc_expr *result;
4322   int i, j, len, ncop, nlen;
4323   mpz_t ncopies;
4324   bool have_length = false;
4325
4326   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4327   if (n->expr_type != EXPR_CONSTANT)
4328     return NULL;
4329
4330   /* If NCOPIES is negative, it's an error.  */
4331   if (mpz_sgn (n->value.integer) < 0)
4332     {
4333       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4334                  &n->where);
4335       return &gfc_bad_expr;
4336     }
4337
4338   /* If we don't know the character length, we can do no more.  */
4339   if (e->ts.u.cl && e->ts.u.cl->length
4340         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4341     {
4342       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4343       have_length = true;
4344     }
4345   else if (e->expr_type == EXPR_CONSTANT
4346              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4347     {
4348       len = e->value.character.length;
4349     }
4350   else
4351     return NULL;
4352
4353   /* If the source length is 0, any value of NCOPIES is valid
4354      and everything behaves as if NCOPIES == 0.  */
4355   mpz_init (ncopies);
4356   if (len == 0)
4357     mpz_set_ui (ncopies, 0);
4358   else
4359     mpz_set (ncopies, n->value.integer);
4360
4361   /* Check that NCOPIES isn't too large.  */
4362   if (len)
4363     {
4364       mpz_t max, mlen;
4365       int i;
4366
4367       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4368       mpz_init (max);
4369       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4370
4371       if (have_length)
4372         {
4373           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4374                       e->ts.u.cl->length->value.integer);
4375         }
4376       else
4377         {
4378           mpz_init_set_si (mlen, len);
4379           mpz_tdiv_q (max, g