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    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
  30 /* Savely advance an array constructor by 'n' elements.
  31    Mainly used by simplifiers of transformational intrinsics.  */
  32 #define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
  33
  34 gfc_expr gfc_bad_expr;
  35
  36
  37 /* Note that 'simplification' is not just transforming expressions.
  38    For functions that are not simplified at compile time, range
  39    checking is done if possible.
  40
  41    The return convention is that each simplification function returns:
  42
  43      A new expression node corresponding to the simplified arguments.
  44      The original arguments are destroyed by the caller, and must not
  45      be a part of the new expression.
  46
  47      NULL pointer indicating that no simplification was possible and
  48      the original expression should remain intact.  If the
  49      simplification function sets the type and/or the function name
  50      via the pointer gfc_simple_expression, then this type is
  51      retained.
  52
  53      An expression pointer to gfc_bad_expr (a static placeholder)
  54      indicating that some error has prevented simplification.  For
  55      example, sqrt(-1.0).  The error is generated within the function
  56      and should be propagated upwards
  57
  58    By the time a simplification function gets control, it has been
  59    decided that the function call is really supposed to be the
  60    intrinsic.  No type checking is strictly necessary, since only
  61    valid types will be passed on.  On the other hand, a simplification
  62    subroutine may have to look at the type of an argument as part of
  63    its processing.
  64
  65    Array arguments are never passed to these subroutines.
  66
  67    The functions in this file don't have much comment with them, but
  68    everything is reasonably straight-forward.  The Standard, chapter 13
  69    is the best comment you'll find for this file anyway.  */
  70
  71 /* Range checks an expression node.  If all goes well, returns the
  72    node, otherwise returns &gfc_bad_expr and frees the node.  */
  73
  74 static gfc_expr *
  75 range_check (gfc_expr *result, const char *name)
  76 {
  77   if (result == NULL)
  78     return &gfc_bad_expr;
  79
  80   switch (gfc_range_check (result))
  81     {
  82       case ARITH_OK:
  83         return result;
  84
  85       case ARITH_OVERFLOW:
  86         gfc_error ("Result of %s overflows its kind at %L", name,
  87                    &result->where);
  88         break;
  89
  90       case ARITH_UNDERFLOW:
  91         gfc_error ("Result of %s underflows its kind at %L", name,
  92                    &result->where);
  93         break;
  94
  95       case ARITH_NAN:
  96         gfc_error ("Result of %s is NaN at %L", name, &result->where);
  97         break;
  98
  99       default:
 100         gfc_error ("Result of %s gives range error for its kind at %L", name,
 101                    &result->where);
 102         break;
 103     }
 104
 105   gfc_free_expr (result);
 106   return &gfc_bad_expr;
 107 }
 108
 109
 110 /* A helper function that gets an optional and possibly missing
 111    kind parameter.  Returns the kind, -1 if something went wrong.  */
 112
 113 static int
 114 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 115 {
 116   int kind;
 117
 118   if (k == NULL)
 119     return default_kind;
 120
 121   if (k->expr_type != EXPR_CONSTANT)
 122     {
 123       gfc_error ("KIND parameter of %s at %L must be an initialization "
 124                  "expression", name, &k->where);
 125       return -1;
 126     }
 127
 128   if (gfc_extract_int (k, &kind) != NULL
 129       || gfc_validate_kind (type, kind, true) < 0)
 130     {
 131       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
 132       return -1;
 133     }
 134
 135   return kind;
 136 }
 137
 138
 139 /* Helper function to get an integer constant with a kind number given
 140    by an integer constant expression.  */
 141 static gfc_expr *
 142 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
 143 {
 144   gfc_expr *res = gfc_int_expr (i);
 145   res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
 146   if (res->ts.kind == -1)
 147     return NULL;
 148   else
 149     return res;
 150 }
 151
 152
 153 /* Converts an mpz_t signed variable into an unsigned one, assuming
 154    two's complement representations and a binary width of bitsize.
 155    The conversion is a no-op unless x is negative; otherwise, it can
 156    be accomplished by masking out the high bits.  */
 157
 158 static void
 159 convert_mpz_to_unsigned (mpz_t x, int bitsize)
 160 {
 161   mpz_t mask;
 162
 163   if (mpz_sgn (x) < 0)
 164     {
 165       /* Confirm that no bits above the signed range are unset.  */
 166       gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
 167
 168       mpz_init_set_ui (mask, 1);
 169       mpz_mul_2exp (mask, mask, bitsize);
 170       mpz_sub_ui (mask, mask, 1);
 171
 172       mpz_and (x, x, mask);
 173
 174       mpz_clear (mask);
 175     }
 176   else
 177     {
 178       /* Confirm that no bits above the signed range are set.  */
 179       gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
 180     }
 181 }
 182
 183
 184 /* Converts an mpz_t unsigned variable into a signed one, assuming
 185    two's complement representations and a binary width of bitsize.
 186    If the bitsize-1 bit is set, this is taken as a sign bit and
 187    the number is converted to the corresponding negative number.  */
 188
 189 static void
 190 convert_mpz_to_signed (mpz_t x, int bitsize)
 191 {
 192   mpz_t mask;
 193
 194   /* Confirm that no bits above the unsigned range are set.  */
 195   gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
 196
 197   if (mpz_tstbit (x, bitsize - 1) == 1)
 198     {
 199       mpz_init_set_ui (mask, 1);
 200       mpz_mul_2exp (mask, mask, bitsize);
 201       mpz_sub_ui (mask, mask, 1);
 202
 203       /* We negate the number by hand, zeroing the high bits, that is
 204          make it the corresponding positive number, and then have it
 205          negated by GMP, giving the correct representation of the
 206          negative number.  */
 207       mpz_com (x, x);
 208       mpz_add_ui (x, x, 1);
 209       mpz_and (x, x, mask);
 210
 211       mpz_neg (x, x);
 212
 213       mpz_clear (mask);
 214     }
 215 }
 216
 217 /* Test that the expression is an constant array.  */
 218
 219 static bool
 220 is_constant_array_expr (gfc_expr *e)
 221 {
 222   gfc_constructor *c;
 223
 224   if (e == NULL)
 225     return true;
 226
 227   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
 228     return false;
 229
 230   for (c = e->value.constructor; c; c = c->next)
 231     if (c->expr->expr_type != EXPR_CONSTANT)
 232       return false;
 233
 234   return true;
 235 }
 236
 237
 238 /* Initialize a transformational result expression with a given value.  */
 239
 240 static void
 241 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
 242 {
 243   if (e && e->expr_type == EXPR_ARRAY)
 244     {
 245       gfc_constructor *ctor = e->value.constructor;
 246       while (ctor)
 247         {
 248           init_result_expr (ctor->expr, init, array);
 249           ctor = ctor->next;
 250         }
 251     }
 252   else if (e && e->expr_type == EXPR_CONSTANT)
 253     {
 254       int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
 255       int length;
 256       gfc_char_t *string;
 257
 258       switch (e->ts.type)
 259         {
 260           case BT_LOGICAL:
 261             e->value.logical = (init ? 1 : 0);
 262             break;
 263
 264           case BT_INTEGER:
 265             if (init == INT_MIN)
 266               mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
 267             else if (init == INT_MAX)
 268               mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
 269             else
 270               mpz_set_si (e->value.integer, init);
 271             break;
 272
 273           case BT_REAL:
 274             if (init == INT_MIN)
 275               {
 276                 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 277                 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
 278               }
 279             else if (init == INT_MAX)
 280               mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
 281             else
 282               mpfr_set_si (e->value.real, init, GFC_RND_MODE);
 283             break;
 284
 285           case BT_COMPLEX:
 286             mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
 287             break;
 288
 289           case BT_CHARACTER:
 290             if (init == INT_MIN)
 291               {
 292                 gfc_expr *len = gfc_simplify_len (array, NULL);
 293                 gfc_extract_int (len, &length);
 294                 string = gfc_get_wide_string (length + 1);
 295                 gfc_wide_memset (string, 0, length);
 296               }
 297             else if (init == INT_MAX)
 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, 255, length);
 303               }
 304             else
 305               {
 306                 length = 0;
 307                 string = gfc_get_wide_string (1);
 308               }
 309
 310             string[length] = '\0';
 311             e->value.character.length = length;
 312             e->value.character.string = string;
 313             break;
 314
 315           default:
 316             gcc_unreachable();
 317         }
 318     }
 319   else
 320     gcc_unreachable();
 321 }
 322
 323
 324 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul.  */
 325
 326 static gfc_expr *
 327 compute_dot_product (gfc_constructor *ctor_a, int stride_a,
 328                      gfc_constructor *ctor_b, int stride_b)
 329 {
 330   gfc_expr *result;
 331   gfc_expr *a = ctor_a->expr, *b = ctor_b->expr;
 332
 333   gcc_assert (gfc_compare_types (&a->ts, &b->ts));
 334
 335   result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
 336   init_result_expr (result, 0, NULL);
 337
 338   while (ctor_a && ctor_b)
 339     {
 340       /* Copying of expressions is required as operands are free'd
 341          by the gfc_arith routines.  */
 342       switch (result->ts.type)
 343         {
 344           case BT_LOGICAL:
 345             result = gfc_or (result,
 346                              gfc_and (gfc_copy_expr (ctor_a->expr),
 347                                       gfc_copy_expr (ctor_b->expr)));
 348             break;
 349
 350           case BT_INTEGER:
 351           case BT_REAL:
 352           case BT_COMPLEX:
 353             result = gfc_add (result,
 354                               gfc_multiply (gfc_copy_expr (ctor_a->expr),
 355                                             gfc_copy_expr (ctor_b->expr)));
 356             break;
 357
 358           default:
 359             gcc_unreachable();
 360         }
 361
 362       ADVANCE (ctor_a, stride_a);
 363       ADVANCE (ctor_b, stride_b);
 364     }
 365
 366   return result;
 367 }
 368
 369
 370 /* Build a result expression for transformational intrinsics,
 371    depending on DIM. */
 372
 373 static gfc_expr *
 374 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
 375                          int kind, locus* where)
 376 {
 377   gfc_expr *result;
 378   int i, nelem;
 379
 380   if (!dim || array->rank == 1)
 381     return gfc_constant_result (type, kind, where);
 382
 383   result = gfc_start_constructor (type, kind, where);
 384   result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
 385   result->rank = array->rank - 1;
 386
 387   /* gfc_array_size() would count the number of elements in the constructor,
 388      we have not built those yet.  */
 389   nelem = 1;
 390   for  (i = 0; i < result->rank; ++i)
 391     nelem *= mpz_get_ui (result->shape[i]);
 392
 393   for (i = 0; i < nelem; ++i)
 394     {
 395       gfc_expr *e = gfc_constant_result (type, kind, where);
 396       gfc_append_constructor (result, e);
 397     }
 398
 399   return result;
 400 }
 401
 402
 403 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
 404
 405 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
 406    of COUNT intrinsic is .TRUE..
 407
 408    Interface and implimentation mimics arith functions as
 409    gfc_add, gfc_multiply, etc.  */
 410
 411 static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
 412 {
 413   gfc_expr *result;
 414
 415   gcc_assert (op1->ts.type == BT_INTEGER);
 416   gcc_assert (op2->ts.type == BT_LOGICAL);
 417   gcc_assert (op2->value.logical);
 418
 419   result = gfc_copy_expr (op1);
 420   mpz_add_ui (result->value.integer, result->value.integer, 1);
 421
 422   gfc_free_expr (op1);
 423   gfc_free_expr (op2);
 424   return result;
 425 }
 426
 427
 428 /* Transforms an ARRAY with operation OP, according to MASK, to a
 429    scalar RESULT. E.g. called if
 430
 431      REAL, PARAMETER :: array(n, m) = ...
 432      REAL, PARAMETER :: s = SUM(array)
 433
 434   where OP == gfc_add().  */
 435
 436 static gfc_expr *
 437 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
 438                                    transformational_op op)
 439 {
 440   gfc_expr *a, *m;
 441   gfc_constructor *array_ctor, *mask_ctor;
 442
 443   /* Shortcut for constant .FALSE. MASK.  */
 444   if (mask
 445       && mask->expr_type == EXPR_CONSTANT
 446       && !mask->value.logical)
 447     return result;
 448
 449   array_ctor = array->value.constructor;
 450   mask_ctor = NULL;
 451   if (mask && mask->expr_type == EXPR_ARRAY)
 452     mask_ctor = mask->value.constructor;
 453
 454   while (array_ctor)
 455     {
 456       a = array_ctor->expr;
 457       array_ctor = array_ctor->next;
 458
 459       /* A constant MASK equals .TRUE. here and can be ignored.  */
 460       if (mask_ctor)
 461         {
 462           m = mask_ctor->expr;
 463           mask_ctor = mask_ctor->next;
 464           if (!m->value.logical)
 465             continue;
 466         }
 467
 468       result = op (result, gfc_copy_expr (a));
 469     }
 470
 471   return result;
 472 }
 473
 474 /* Transforms an ARRAY with operation OP, according to MASK, to an
 475    array RESULT. E.g. called if
 476
 477      REAL, PARAMETER :: array(n, m) = ...
 478      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
 479
 480   where OP == gfc_multiply().  */
 481
 482 static gfc_expr *
 483 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
 484                                   gfc_expr *mask, transformational_op op)
 485 {
 486   mpz_t size;
 487   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
 488   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
 489   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
 490
 491   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
 492       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
 493       tmpstride[GFC_MAX_DIMENSIONS];
 494
 495   /* Shortcut for constant .FALSE. MASK.  */
 496   if (mask
 497       && mask->expr_type == EXPR_CONSTANT
 498       && !mask->value.logical)
 499     return result;
 500
 501   /* Build an indexed table for array element expressions to minimize
 502      linked-list traversal. Masked elements are set to NULL.  */
 503   gfc_array_size (array, &size);
 504   arraysize = mpz_get_ui (size);
 505
 506   arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
 507
 508   array_ctor = array->value.constructor;
 509   mask_ctor = NULL;
 510   if (mask && mask->expr_type == EXPR_ARRAY)
 511     mask_ctor = mask->value.constructor;
 512
 513   for (i = 0; i < arraysize; ++i)
 514     {
 515       arrayvec[i] = array_ctor->expr;
 516       array_ctor = array_ctor->next;
 517
 518       if (mask_ctor)
 519         {
 520           if (!mask_ctor->expr->value.logical)
 521             arrayvec[i] = NULL;
 522
 523           mask_ctor = mask_ctor->next;
 524         }
 525     }
 526
 527   /* Same for the result expression.  */
 528   gfc_array_size (result, &size);
 529   resultsize = mpz_get_ui (size);
 530   mpz_clear (size);
 531
 532   resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
 533   result_ctor = result->value.constructor;
 534   for (i = 0; i < resultsize; ++i)
 535     {
 536       resultvec[i] = result_ctor->expr;
 537       result_ctor = result_ctor->next;
 538     }
 539
 540   gfc_extract_int (dim, &dim_index);
 541   dim_index -= 1;               /* zero-base index */
 542   dim_extent = 0;
 543   dim_stride = 0;
 544
 545   for (i = 0, n = 0; i < array->rank; ++i)
 546     {
 547       count[i] = 0;
 548       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
 549       if (i == dim_index)
 550         {
 551           dim_extent = mpz_get_si (array->shape[i]);
 552           dim_stride = tmpstride[i];
 553           continue;
 554         }
 555
 556       extent[n] = mpz_get_si (array->shape[i]);
 557       sstride[n] = tmpstride[i];
 558       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
 559       n += 1;
 560     }
 561
 562   done = false;
 563   base = arrayvec;
 564   dest = resultvec;
 565   while (!done)
 566     {
 567       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
 568         if (*src)
 569           *dest = op (*dest, gfc_copy_expr (*src));
 570
 571       count[0]++;
 572       base += sstride[0];
 573       dest += dstride[0];
 574
 575       n = 0;
 576       while (!done && count[n] == extent[n])
 577         {
 578           count[n] = 0;
 579           base -= sstride[n] * extent[n];
 580           dest -= dstride[n] * extent[n];
 581
 582           n++;
 583           if (n < result->rank)
 584             {
 585               count [n]++;
 586               base += sstride[n];
 587               dest += dstride[n];
 588             }
 589           else
 590             done = true;
 591        }
 592     }
 593
 594   /* Place updated expression in result constructor.  */
 595   result_ctor = result->value.constructor;
 596   for (i = 0; i < resultsize; ++i)
 597     {
 598       result_ctor->expr = resultvec[i];
 599       result_ctor = result_ctor->next;
 600     }
 601
 602   gfc_free (arrayvec);
 603   gfc_free (resultvec);
 604   return result;
 605 }
 606
 607
 608
 609 /********************** Simplification functions *****************************/
 610
 611 gfc_expr *
 612 gfc_simplify_abs (gfc_expr *e)
 613 {
 614   gfc_expr *result;
 615
 616   if (e->expr_type != EXPR_CONSTANT)
 617     return NULL;
 618
 619   switch (e->ts.type)
 620     {
 621     case BT_INTEGER:
 622       result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
 623
 624       mpz_abs (result->value.integer, e->value.integer);
 625
 626       result = range_check (result, "IABS");
 627       break;
 628
 629     case BT_REAL:
 630       result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 631
 632       mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
 633
 634       result = range_check (result, "ABS");
 635       break;
 636
 637     case BT_COMPLEX:
 638       result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 639
 640       gfc_set_model_kind (e->ts.kind);
 641
 642       mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
 643       result = range_check (result, "CABS");
 644       break;
 645
 646     default:
 647       gfc_internal_error ("gfc_simplify_abs(): Bad type");
 648     }
 649
 650   return result;
 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_constant_result (BT_CHARACTER, kind, &e->where);
 701   result->value.character.string = gfc_get_wide_string (2);
 702   result->value.character.length = 1;
 703   result->value.character.string[0] = mpz_get_ui (e->value.integer);
 704   result->value.character.string[1] = '\0';     /* For debugger */
 705   return result;
 706 }
 707
 708
 709
 710 /* We use the processor's collating sequence, because all
 711    systems that gfortran currently works on are ASCII.  */
 712
 713 gfc_expr *
 714 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
 715 {
 716   return simplify_achar_char (e, k, "ACHAR", true);
 717 }
 718
 719
 720 gfc_expr *
 721 gfc_simplify_acos (gfc_expr *x)
 722 {
 723   gfc_expr *result;
 724
 725   if (x->expr_type != EXPR_CONSTANT)
 726     return NULL;
 727
 728   switch (x->ts.type)
 729     {
 730       case BT_REAL:
 731         if (mpfr_cmp_si (x->value.real, 1) > 0
 732             || mpfr_cmp_si (x->value.real, -1) < 0)
 733           {
 734             gfc_error ("Argument of ACOS at %L must be between -1 and 1",
 735                        &x->where);
 736             return &gfc_bad_expr;
 737           }
 738         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 739         mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 740         break;
 741       case BT_COMPLEX:
 742         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 743         mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 744         break;
 745       default:
 746         gfc_internal_error ("in gfc_simplify_acos(): Bad type");
 747     }
 748
 749
 750   return range_check (result, "ACOS");
 751 }
 752
 753 gfc_expr *
 754 gfc_simplify_acosh (gfc_expr *x)
 755 {
 756   gfc_expr *result;
 757
 758   if (x->expr_type != EXPR_CONSTANT)
 759     return NULL;
 760
 761   switch (x->ts.type)
 762     {
 763       case BT_REAL:
 764         if (mpfr_cmp_si (x->value.real, 1) < 0)
 765           {
 766             gfc_error ("Argument of ACOSH at %L must not be less than 1",
 767                        &x->where);
 768             return &gfc_bad_expr;
 769           }
 770
 771         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 772         mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
 773         break;
 774       case BT_COMPLEX:
 775         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 776         mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
 777         break;
 778       default:
 779         gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
 780     }
 781
 782   return range_check (result, "ACOSH");
 783 }
 784
 785 gfc_expr *
 786 gfc_simplify_adjustl (gfc_expr *e)
 787 {
 788   gfc_expr *result;
 789   int count, i, len;
 790   gfc_char_t ch;
 791
 792   if (e->expr_type != EXPR_CONSTANT)
 793     return NULL;
 794
 795   len = e->value.character.length;
 796
 797   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 798
 799   result->value.character.length = len;
 800   result->value.character.string = gfc_get_wide_string (len + 1);
 801
 802   for (count = 0, i = 0; i < len; ++i)
 803     {
 804       ch = e->value.character.string[i];
 805       if (ch != ' ')
 806         break;
 807       ++count;
 808     }
 809
 810   for (i = 0; i < len - count; ++i)
 811     result->value.character.string[i] = e->value.character.string[count + i];
 812
 813   for (i = len - count; i < len; ++i)
 814     result->value.character.string[i] = ' ';
 815
 816   result->value.character.string[len] = '\0';   /* For debugger */
 817
 818   return result;
 819 }
 820
 821
 822 gfc_expr *
 823 gfc_simplify_adjustr (gfc_expr *e)
 824 {
 825   gfc_expr *result;
 826   int count, i, len;
 827   gfc_char_t ch;
 828
 829   if (e->expr_type != EXPR_CONSTANT)
 830     return NULL;
 831
 832   len = e->value.character.length;
 833
 834   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 835
 836   result->value.character.length = len;
 837   result->value.character.string = gfc_get_wide_string (len + 1);
 838
 839   for (count = 0, i = len - 1; i >= 0; --i)
 840     {
 841       ch = e->value.character.string[i];
 842       if (ch != ' ')
 843         break;
 844       ++count;
 845     }
 846
 847   for (i = 0; i < count; ++i)
 848     result->value.character.string[i] = ' ';
 849
 850   for (i = count; i < len; ++i)
 851     result->value.character.string[i] = e->value.character.string[i - count];
 852
 853   result->value.character.string[len] = '\0';   /* For debugger */
 854
 855   return result;
 856 }
 857
 858
 859 gfc_expr *
 860 gfc_simplify_aimag (gfc_expr *e)
 861 {
 862   gfc_expr *result;
 863
 864   if (e->expr_type != EXPR_CONSTANT)
 865     return NULL;
 866
 867   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
 868   mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
 869
 870   return range_check (result, "AIMAG");
 871 }
 872
 873
 874 gfc_expr *
 875 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 876 {
 877   gfc_expr *rtrunc, *result;
 878   int kind;
 879
 880   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
 881   if (kind == -1)
 882     return &gfc_bad_expr;
 883
 884   if (e->expr_type != EXPR_CONSTANT)
 885     return NULL;
 886
 887   rtrunc = gfc_copy_expr (e);
 888
 889   mpfr_trunc (rtrunc->value.real, e->value.real);
 890
 891   result = gfc_real2real (rtrunc, kind);
 892   gfc_free_expr (rtrunc);
 893
 894   return range_check (result, "AINT");
 895 }
 896
 897
 898 gfc_expr *
 899 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 900 {
 901   gfc_expr *result;
 902
 903   if (!is_constant_array_expr (mask)
 904       || !gfc_is_constant_expr (dim))
 905     return NULL;
 906
 907   result = transformational_result (mask, dim, mask->ts.type,
 908                                     mask->ts.kind, &mask->where);
 909   init_result_expr (result, true, NULL);
 910
 911   return !dim || mask->rank == 1 ?
 912     simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
 913     simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
 914 }
 915
 916
 917 gfc_expr *
 918 gfc_simplify_dint (gfc_expr *e)
 919 {
 920   gfc_expr *rtrunc, *result;
 921
 922   if (e->expr_type != EXPR_CONSTANT)
 923     return NULL;
 924
 925   rtrunc = gfc_copy_expr (e);
 926
 927   mpfr_trunc (rtrunc->value.real, e->value.real);
 928
 929   result = gfc_real2real (rtrunc, gfc_default_double_kind);
 930   gfc_free_expr (rtrunc);
 931
 932   return range_check (result, "DINT");
 933 }
 934
 935
 936 gfc_expr *
 937 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
 938 {
 939   gfc_expr *result;
 940   int kind;
 941
 942   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
 943   if (kind == -1)
 944     return &gfc_bad_expr;
 945
 946   if (e->expr_type != EXPR_CONSTANT)
 947     return NULL;
 948
 949   result = gfc_constant_result (e->ts.type, kind, &e->where);
 950
 951   mpfr_round (result->value.real, e->value.real);
 952
 953   return range_check (result, "ANINT");
 954 }
 955
 956
 957 gfc_expr *
 958 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 959 {
 960   gfc_expr *result;
 961   int kind;
 962
 963   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
 964     return NULL;
 965
 966   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
 967   if (x->ts.type == BT_INTEGER)
 968     {
 969       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
 970       mpz_and (result->value.integer, x->value.integer, y->value.integer);
 971       return range_check (result, "AND");
 972     }
 973   else /* BT_LOGICAL */
 974     {
 975       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
 976       result->value.logical = x->value.logical && y->value.logical;
 977       return result;
 978     }
 979 }
 980
 981
 982 gfc_expr *
 983 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 984 {
 985   gfc_expr *result;
 986
 987   if (!is_constant_array_expr (mask)
 988       || !gfc_is_constant_expr (dim))
 989     return NULL;
 990
 991   result = transformational_result (mask, dim, mask->ts.type,
 992                                     mask->ts.kind, &mask->where);
 993   init_result_expr (result, false, NULL);
 994
 995   return !dim || mask->rank == 1 ?
 996     simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
 997     simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
 998 }
 999
1000
1001 gfc_expr *
1002 gfc_simplify_dnint (gfc_expr *e)
1003 {
1004   gfc_expr *result;
1005
1006   if (e->expr_type != EXPR_CONSTANT)
1007     return NULL;
1008
1009   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
1010
1011   mpfr_round (result->value.real, e->value.real);
1012
1013   return range_check (result, "DNINT");
1014 }
1015
1016
1017 gfc_expr *
1018 gfc_simplify_asin (gfc_expr *x)
1019 {
1020   gfc_expr *result;
1021
1022   if (x->expr_type != EXPR_CONSTANT)
1023     return NULL;
1024
1025   switch (x->ts.type)
1026     {
1027       case BT_REAL:
1028         if (mpfr_cmp_si (x->value.real, 1) > 0
1029             || mpfr_cmp_si (x->value.real, -1) < 0)
1030           {
1031             gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1032                        &x->where);
1033             return &gfc_bad_expr;
1034           }
1035         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1036         mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1037         break;
1038       case BT_COMPLEX:
1039         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1040         mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1041         break;
1042       default:
1043         gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1044     }
1045
1046   return range_check (result, "ASIN");
1047 }
1048
1049
1050 gfc_expr *
1051 gfc_simplify_asinh (gfc_expr *x)
1052 {
1053   gfc_expr *result;
1054
1055   if (x->expr_type != EXPR_CONSTANT)
1056     return NULL;
1057
1058   switch (x->ts.type)
1059     {
1060       case BT_REAL:
1061         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1062         mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1063         break;
1064       case BT_COMPLEX:
1065         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1066         mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1067         break;
1068       default:
1069         gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1070     }
1071
1072   return range_check (result, "ASINH");
1073 }
1074
1075
1076 gfc_expr *
1077 gfc_simplify_atan (gfc_expr *x)
1078 {
1079   gfc_expr *result;
1080
1081   if (x->expr_type != EXPR_CONSTANT)
1082     return NULL;
1083
1084   switch (x->ts.type)
1085     {
1086       case BT_REAL:
1087         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1088         mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1089         break;
1090       case BT_COMPLEX:
1091         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1092         mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1093         break;
1094       default:
1095         gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1096     }
1097
1098   return range_check (result, "ATAN");
1099 }
1100
1101
1102 gfc_expr *
1103 gfc_simplify_atanh (gfc_expr *x)
1104 {
1105   gfc_expr *result;
1106
1107   if (x->expr_type != EXPR_CONSTANT)
1108     return NULL;
1109
1110   switch (x->ts.type)
1111     {
1112       case BT_REAL:
1113         if (mpfr_cmp_si (x->value.real, 1) >= 0
1114             || mpfr_cmp_si (x->value.real, -1) <= 0)
1115           {
1116             gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1117                        "to 1", &x->where);
1118             return &gfc_bad_expr;
1119           }
1120
1121         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1122         mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1123         break;
1124       case BT_COMPLEX:
1125         result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1126         mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1127         break;
1128       default:
1129         gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1130     }
1131
1132   return range_check (result, "ATANH");
1133 }
1134
1135
1136 gfc_expr *
1137 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1138 {
1139   gfc_expr *result;
1140
1141   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1142     return NULL;
1143
1144   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
1145     {
1146       gfc_error ("If first argument of ATAN2 %L is zero, then the "
1147                  "second argument must not be zero", &x->where);
1148       return &gfc_bad_expr;
1149     }
1150
1151   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1152
1153   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1154
1155   return range_check (result, "ATAN2");
1156 }
1157
1158
1159 gfc_expr *
1160 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
1161 {
1162   gfc_expr *result;
1163
1164   if (x->expr_type != EXPR_CONSTANT)
1165     return NULL;
1166
1167   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1168   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1169
1170   return range_check (result, "BESSEL_J0");
1171 }
1172
1173
1174 gfc_expr *
1175 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
1176 {
1177   gfc_expr *result;
1178
1179   if (x->expr_type != EXPR_CONSTANT)
1180     return NULL;
1181
1182   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1183   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1184
1185   return range_check (result, "BESSEL_J1");
1186 }
1187
1188
1189 gfc_expr *
1190 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
1191                         gfc_expr *x ATTRIBUTE_UNUSED)
1192 {
1193   gfc_expr *result;
1194   long n;
1195
1196   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1197     return NULL;
1198
1199   n = mpz_get_si (order->value.integer);
1200   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1201   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1202
1203   return range_check (result, "BESSEL_JN");
1204 }
1205
1206
1207 gfc_expr *
1208 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
1209 {
1210   gfc_expr *result;
1211
1212   if (x->expr_type != EXPR_CONSTANT)
1213     return NULL;
1214
1215   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1216   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1217
1218   return range_check (result, "BESSEL_Y0");
1219 }
1220
1221
1222 gfc_expr *
1223 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
1224 {
1225   gfc_expr *result;
1226
1227   if (x->expr_type != EXPR_CONSTANT)
1228     return NULL;
1229
1230   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1231   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1232
1233   return range_check (result, "BESSEL_Y1");
1234 }
1235
1236
1237 gfc_expr *
1238 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
1239                         gfc_expr *x ATTRIBUTE_UNUSED)
1240 {
1241   gfc_expr *result;
1242   long n;
1243
1244   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1245     return NULL;
1246
1247   n = mpz_get_si (order->value.integer);
1248   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1249   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1250
1251   return range_check (result, "BESSEL_YN");
1252 }
1253
1254
1255 gfc_expr *
1256 gfc_simplify_bit_size (gfc_expr *e)
1257 {
1258   gfc_expr *result;
1259   int i;
1260
1261   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1262   result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
1263   mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
1264
1265   return result;
1266 }
1267
1268
1269 gfc_expr *
1270 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1271 {
1272   int b;
1273
1274   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1275     return NULL;
1276
1277   if (gfc_extract_int (bit, &b) != NULL || b < 0)
1278     return gfc_logical_expr (0, &e->where);
1279
1280   return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
1281 }
1282
1283
1284 gfc_expr *
1285 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1286 {
1287   gfc_expr *ceil, *result;
1288   int kind;
1289
1290   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1291   if (kind == -1)
1292     return &gfc_bad_expr;
1293
1294   if (e->expr_type != EXPR_CONSTANT)
1295     return NULL;
1296
1297   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1298
1299   ceil = gfc_copy_expr (e);
1300
1301   mpfr_ceil (ceil->value.real, e->value.real);
1302   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1303
1304   gfc_free_expr (ceil);
1305
1306   return range_check (result, "CEILING");
1307 }
1308
1309
1310 gfc_expr *
1311 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1312 {
1313   return simplify_achar_char (e, k, "CHAR", false);
1314 }
1315
1316
1317 /* Common subroutine for simplifying CMPLX and DCMPLX.  */
1318
1319 static gfc_expr *
1320 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1321 {
1322   gfc_expr *result;
1323
1324   result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
1325
1326   switch (x->ts.type)
1327     {
1328     case BT_INTEGER:
1329       if (!x->is_boz)
1330         mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1331       break;
1332
1333     case BT_REAL:
1334       mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1335       break;
1336
1337     case BT_COMPLEX:
1338       mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1339       break;
1340
1341     default:
1342       gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1343     }
1344
1345   if (y != NULL)
1346     {
1347       switch (y->ts.type)
1348         {
1349         case BT_INTEGER:
1350           if (!y->is_boz)
1351             mpfr_set_z (mpc_imagref (result->value.complex),
1352                         y->value.integer, GFC_RND_MODE);
1353           break;
1354
1355         case BT_REAL:
1356           mpfr_set (mpc_imagref (result->value.complex),
1357                     y->value.real, GFC_RND_MODE);
1358           break;
1359
1360         default:
1361           gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1362         }
1363     }
1364
1365   /* Handle BOZ.  */
1366   if (x->is_boz)
1367     {
1368       gfc_typespec ts;
1369       gfc_clear_ts (&ts);
1370       ts.kind = result->ts.kind;
1371       ts.type = BT_REAL;
1372       if (!gfc_convert_boz (x, &ts))
1373         return &gfc_bad_expr;
1374       mpfr_set (mpc_realref (result->value.complex),
1375                 x->value.real, GFC_RND_MODE);
1376     }
1377
1378   if (y && y->is_boz)
1379     {
1380       gfc_typespec ts;
1381       gfc_clear_ts (&ts);
1382       ts.kind = result->ts.kind;
1383       ts.type = BT_REAL;
1384       if (!gfc_convert_boz (y, &ts))
1385         return &gfc_bad_expr;
1386       mpfr_set (mpc_imagref (result->value.complex),
1387                 y->value.real, GFC_RND_MODE);
1388     }
1389
1390   return range_check (result, name);
1391 }
1392
1393
1394 /* Function called when we won't simplify an expression like CMPLX (or
1395    COMPLEX or DCMPLX) but still want to convert BOZ arguments.  */
1396
1397 static gfc_expr *
1398 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
1399 {
1400   gfc_typespec ts;
1401   gfc_clear_ts (&ts);
1402   ts.type = BT_REAL;
1403   ts.kind = kind;
1404
1405   if (x->is_boz && !gfc_convert_boz (x, &ts))
1406     return &gfc_bad_expr;
1407
1408   if (y && y->is_boz && !gfc_convert_boz (y, &ts))
1409     return &gfc_bad_expr;
1410
1411   return NULL;
1412 }
1413
1414
1415 gfc_expr *
1416 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1417 {
1418   int kind;
1419
1420   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
1421   if (kind == -1)
1422     return &gfc_bad_expr;
1423
1424   if (x->expr_type != EXPR_CONSTANT
1425       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1426     return only_convert_cmplx_boz (x, y, kind);
1427
1428   return simplify_cmplx ("CMPLX", x, y, kind);
1429 }
1430
1431
1432 gfc_expr *
1433 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1434 {
1435   int kind;
1436
1437   if (x->ts.type == BT_INTEGER)
1438     {
1439       if (y->ts.type == BT_INTEGER)
1440         kind = gfc_default_real_kind;
1441       else
1442         kind = y->ts.kind;
1443     }
1444   else
1445     {
1446       if (y->ts.type == BT_REAL)
1447         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1448       else
1449         kind = x->ts.kind;
1450     }
1451
1452   if (x->expr_type != EXPR_CONSTANT
1453       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1454     return only_convert_cmplx_boz (x, y, kind);
1455
1456   return simplify_cmplx ("COMPLEX", x, y, kind);
1457 }
1458
1459
1460 gfc_expr *
1461 gfc_simplify_conjg (gfc_expr *e)
1462 {
1463   gfc_expr *result;
1464
1465   if (e->expr_type != EXPR_CONSTANT)
1466     return NULL;
1467
1468   result = gfc_copy_expr (e);
1469   mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1470   return range_check (result, "CONJG");
1471 }
1472
1473
1474 gfc_expr *
1475 gfc_simplify_cos (gfc_expr *x)
1476 {
1477   gfc_expr *result;
1478
1479   if (x->expr_type != EXPR_CONSTANT)
1480     return NULL;
1481
1482   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1483
1484   switch (x->ts.type)
1485     {
1486     case BT_REAL:
1487       mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1488       break;
1489     case BT_COMPLEX:
1490       gfc_set_model_kind (x->ts.kind);
1491       mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1492       break;
1493     default:
1494       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1495     }
1496
1497   return range_check (result, "COS");
1498
1499 }
1500
1501
1502 gfc_expr *
1503 gfc_simplify_cosh (gfc_expr *x)
1504 {
1505   gfc_expr *result;
1506
1507   if (x->expr_type != EXPR_CONSTANT)
1508     return NULL;
1509
1510   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1511
1512   if (x->ts.type == BT_REAL)
1513     mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1514   else if (x->ts.type == BT_COMPLEX)
1515     mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1516   else
1517     gcc_unreachable ();
1518
1519   return range_check (result, "COSH");
1520 }
1521
1522
1523 gfc_expr *
1524 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1525 {
1526   gfc_expr *result;
1527
1528   if (!is_constant_array_expr (mask)
1529       || !gfc_is_constant_expr (dim)
1530       || !gfc_is_constant_expr (kind))
1531     return NULL;
1532
1533   result = transformational_result (mask, dim,
1534                                     BT_INTEGER,
1535                                     get_kind (BT_INTEGER, kind, "COUNT",
1536                                               gfc_default_integer_kind),
1537                                     &mask->where);
1538
1539   init_result_expr (result, 0, NULL);
1540
1541   /* Passing MASK twice, once as data array, once as mask.
1542      Whenever gfc_count is called, '1' is added to the result.  */
1543   return !dim || mask->rank == 1 ?
1544     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1545     simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
1546 }
1547
1548
1549 gfc_expr *
1550 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1551 {
1552
1553   if (x->expr_type != EXPR_CONSTANT
1554       || (y != NULL && y->expr_type != EXPR_CONSTANT))
1555     return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1556
1557   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1558 }
1559
1560
1561 gfc_expr *
1562 gfc_simplify_dble (gfc_expr *e)
1563 {
1564   gfc_expr *result = NULL;
1565
1566   if (e->expr_type != EXPR_CONSTANT)
1567     return NULL;
1568
1569   switch (e->ts.type)
1570     {
1571     case BT_INTEGER:
1572       if (!e->is_boz)
1573         result = gfc_int2real (e, gfc_default_double_kind);
1574       break;
1575
1576     case BT_REAL:
1577       result = gfc_real2real (e, gfc_default_double_kind);
1578       break;
1579
1580     case BT_COMPLEX:
1581       result = gfc_complex2real (e, gfc_default_double_kind);
1582       break;
1583
1584     default:
1585       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1586     }
1587
1588   if (e->ts.type == BT_INTEGER && e->is_boz)
1589     {
1590       gfc_typespec ts;
1591       gfc_clear_ts (&ts);
1592       ts.type = BT_REAL;
1593       ts.kind = gfc_default_double_kind;
1594       result = gfc_copy_expr (e);
1595       if (!gfc_convert_boz (result, &ts))
1596         {
1597           gfc_free_expr (result);
1598           return &gfc_bad_expr;
1599         }
1600     }
1601
1602   return range_check (result, "DBLE");
1603 }
1604
1605
1606 gfc_expr *
1607 gfc_simplify_digits (gfc_expr *x)
1608 {
1609   int i, digits;
1610
1611   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1612   switch (x->ts.type)
1613     {
1614     case BT_INTEGER:
1615       digits = gfc_integer_kinds[i].digits;
1616       break;
1617
1618     case BT_REAL:
1619     case BT_COMPLEX:
1620       digits = gfc_real_kinds[i].digits;
1621       break;
1622
1623     default:
1624       gcc_unreachable ();
1625     }
1626
1627   return gfc_int_expr (digits);
1628 }
1629
1630
1631 gfc_expr *
1632 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1633 {
1634   gfc_expr *result;
1635   int kind;
1636
1637   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1638     return NULL;
1639
1640   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1641   result = gfc_constant_result (x->ts.type, kind, &x->where);
1642
1643   switch (x->ts.type)
1644     {
1645     case BT_INTEGER:
1646       if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1647         mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1648       else
1649         mpz_set_ui (result->value.integer, 0);
1650
1651       break;
1652
1653     case BT_REAL:
1654       if (mpfr_cmp (x->value.real, y->value.real) > 0)
1655         mpfr_sub (result->value.real, x->value.real, y->value.real,
1656                   GFC_RND_MODE);
1657       else
1658         mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1659
1660       break;
1661
1662     default:
1663       gfc_internal_error ("gfc_simplify_dim(): Bad type");
1664     }
1665
1666   return range_check (result, "DIM");
1667 }
1668
1669
1670 gfc_expr*
1671 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1672 {
1673   gfc_expr *result;
1674
1675   if (!is_constant_array_expr (vector_a)
1676       || !is_constant_array_expr (vector_b))
1677     return NULL;
1678
1679   gcc_assert (vector_a->rank == 1);
1680   gcc_assert (vector_b->rank == 1);
1681   gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1682
1683   if (vector_a->value.constructor && vector_b->value.constructor)
1684     return compute_dot_product (vector_a->value.constructor, 1,
1685                                 vector_b->value.constructor, 1);
1686
1687   /* Zero sized array ...  */
1688   result = gfc_constant_result (vector_a->ts.type,
1689                                 vector_a->ts.kind,
1690                                 &vector_a->where);
1691   init_result_expr (result, 0, NULL);
1692   return result;
1693 }
1694
1695
1696 gfc_expr *
1697 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1698 {
1699   gfc_expr *a1, *a2, *result;
1700
1701   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1702     return NULL;
1703
1704   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1705
1706   a1 = gfc_real2real (x, gfc_default_double_kind);
1707   a2 = gfc_real2real (y, gfc_default_double_kind);
1708
1709   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1710
1711   gfc_free_expr (a1);
1712   gfc_free_expr (a2);
1713
1714   return range_check (result, "DPROD");
1715 }
1716
1717
1718 gfc_expr *
1719 gfc_simplify_erf (gfc_expr *x)
1720 {
1721   gfc_expr *result;
1722
1723   if (x->expr_type != EXPR_CONSTANT)
1724     return NULL;
1725
1726   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1727
1728   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1729
1730   return range_check (result, "ERF");
1731 }
1732
1733
1734 gfc_expr *
1735 gfc_simplify_erfc (gfc_expr *x)
1736 {
1737   gfc_expr *result;
1738
1739   if (x->expr_type != EXPR_CONSTANT)
1740     return NULL;
1741
1742   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1743
1744   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1745
1746   return range_check (result, "ERFC");
1747 }
1748
1749
1750 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */
1751
1752 #define MAX_ITER 200
1753 #define ARG_LIMIT 12
1754
1755 /* Calculate ERFC_SCALED directly by its definition:
1756
1757      ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1758
1759    using a large precision for intermediate results.  This is used for all
1760    but large values of the argument.  */
1761 static void
1762 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
1763 {
1764   mp_prec_t prec;
1765   mpfr_t a, b;
1766
1767   prec = mpfr_get_default_prec ();
1768   mpfr_set_default_prec (10 * prec);
1769
1770   mpfr_init (a);
1771   mpfr_init (b);
1772
1773   mpfr_set (a, arg, GFC_RND_MODE);
1774   mpfr_sqr (b, a, GFC_RND_MODE);
1775   mpfr_exp (b, b, GFC_RND_MODE);
1776   mpfr_erfc (a, a, GFC_RND_MODE);
1777   mpfr_mul (a, a, b, GFC_RND_MODE);
1778
1779   mpfr_set (res, a, GFC_RND_MODE);
1780   mpfr_set_default_prec (prec);
1781
1782   mpfr_clear (a);
1783   mpfr_clear (b);
1784 }
1785
1786 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
1787
1788     ERFC_SCALED(x) = 1 / (x * sqrt(pi))
1789                      * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
1790                                           / (2 * x**2)**n)
1791
1792   This is used for large values of the argument.  Intermediate calculations
1793   are performed with twice the precision.  We don't do a fixed number of
1794   iterations of the sum, but stop when it has converged to the required
1795   precision.  */
1796 static void
1797 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
1798 {
1799   mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
1800   mpz_t num;
1801   mp_prec_t prec;
1802   unsigned i;
1803
1804   prec = mpfr_get_default_prec ();
1805   mpfr_set_default_prec (2 * prec);
1806
1807   mpfr_init (sum);
1808   mpfr_init (x);
1809   mpfr_init (u);
1810   mpfr_init (v);
1811   mpfr_init (w);
1812   mpz_init (num);
1813
1814   mpfr_init (oldsum);
1815   mpfr_init (sumtrunc);
1816   mpfr_set_prec (oldsum, prec);
1817   mpfr_set_prec (sumtrunc, prec);
1818
1819   mpfr_set (x, arg, GFC_RND_MODE);
1820   mpfr_set_ui (sum, 1, GFC_RND_MODE);
1821   mpz_set_ui (num, 1);
1822
1823   mpfr_set (u, x, GFC_RND_MODE);
1824   mpfr_sqr (u, u, GFC_RND_MODE);
1825   mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
1826   mpfr_pow_si (u, u, -1, GFC_RND_MODE);
1827
1828   for (i = 1; i < MAX_ITER; i++)
1829   {
1830     mpfr_set (oldsum, sum, GFC_RND_MODE);
1831
1832     mpz_mul_ui (num, num, 2 * i - 1);
1833     mpz_neg (num, num);
1834
1835     mpfr_set (w, u, GFC_RND_MODE);
1836     mpfr_pow_ui (w, w, i, GFC_RND_MODE);
1837
1838     mpfr_set_z (v, num, GFC_RND_MODE);
1839     mpfr_mul (v, v, w, GFC_RND_MODE);
1840
1841     mpfr_add (sum, sum, v, GFC_RND_MODE);
1842
1843     mpfr_set (sumtrunc, sum, GFC_RND_MODE);
1844     if (mpfr_cmp (sumtrunc, oldsum) == 0)
1845       break;
1846   }
1847
1848   /* We should have converged by now; otherwise, ARG_LIMIT is probably
1849      set too low.  */
1850   gcc_assert (i < MAX_ITER);
1851
1852   /* Divide by x * sqrt(Pi).  */
1853   mpfr_const_pi (u, GFC_RND_MODE);
1854   mpfr_sqrt (u, u, GFC_RND_MODE);
1855   mpfr_mul (u, u, x, GFC_RND_MODE);
1856   mpfr_div (sum, sum, u, GFC_RND_MODE);
1857
1858   mpfr_set (res, sum, GFC_RND_MODE);
1859   mpfr_set_default_prec (prec);
1860
1861   mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
1862   mpz_clear (num);
1863 }
1864
1865
1866 gfc_expr *
1867 gfc_simplify_erfc_scaled (gfc_expr *x)
1868 {
1869   gfc_expr *result;
1870
1871   if (x->expr_type != EXPR_CONSTANT)
1872     return NULL;
1873
1874   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1875   if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
1876     asympt_erfc_scaled (result->value.real, x->value.real);
1877   else
1878     fullprec_erfc_scaled (result->value.real, x->value.real);
1879
1880   return range_check (result, "ERFC_SCALED");
1881 }
1882
1883 #undef MAX_ITER
1884 #undef ARG_LIMIT
1885
1886
1887 gfc_expr *
1888 gfc_simplify_epsilon (gfc_expr *e)
1889 {
1890   gfc_expr *result;
1891   int i;
1892
1893   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1894
1895   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1896
1897   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1898
1899   return range_check (result, "EPSILON");
1900 }
1901
1902
1903 gfc_expr *
1904 gfc_simplify_exp (gfc_expr *x)
1905 {
1906   gfc_expr *result;
1907
1908   if (x->expr_type != EXPR_CONSTANT)
1909     return NULL;
1910
1911   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1912
1913   switch (x->ts.type)
1914     {
1915     case BT_REAL:
1916       mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1917       break;
1918
1919     case BT_COMPLEX:
1920       gfc_set_model_kind (x->ts.kind);
1921       mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1922       break;
1923
1924     default:
1925       gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1926     }
1927
1928   return range_check (result, "EXP");
1929 }
1930
1931 gfc_expr *
1932 gfc_simplify_exponent (gfc_expr *x)
1933 {
1934   int i;
1935   gfc_expr *result;
1936
1937   if (x->expr_type != EXPR_CONSTANT)
1938     return NULL;
1939
1940   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1941                                 &x->where);
1942
1943   gfc_set_model (x->value.real);
1944
1945   if (mpfr_sgn (x->value.real) == 0)
1946     {
1947       mpz_set_ui (result->value.integer, 0);
1948       return result;
1949     }
1950
1951   i = (int) mpfr_get_exp (x->value.real);
1952   mpz_set_si (result->value.integer, i);
1953
1954   return range_check (result, "EXPONENT");
1955 }
1956
1957
1958 gfc_expr *
1959 gfc_simplify_float (gfc_expr *a)
1960 {
1961   gfc_expr *result;
1962
1963   if (a->expr_type != EXPR_CONSTANT)
1964     return NULL;
1965
1966   if (a->is_boz)
1967     {
1968       gfc_typespec ts;
1969       gfc_clear_ts (&ts);
1970
1971       ts.type = BT_REAL;
1972       ts.kind = gfc_default_real_kind;
1973
1974       result = gfc_copy_expr (a);
1975       if (!gfc_convert_boz (result, &ts))
1976         {
1977           gfc_free_expr (result);
1978           return &gfc_bad_expr;
1979         }
1980     }
1981   else
1982     result = gfc_int2real (a, gfc_default_real_kind);
1983   return range_check (result, "FLOAT");
1984 }
1985
1986
1987 gfc_expr *
1988 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1989 {
1990   gfc_expr *result;
1991   mpfr_t floor;
1992   int kind;
1993
1994   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1995   if (kind == -1)
1996     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1997
1998   if (e->expr_type != EXPR_CONSTANT)
1999     return NULL;
2000
2001   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2002
2003   gfc_set_model_kind (kind);
2004   mpfr_init (floor);
2005   mpfr_floor (floor, e->value.real);
2006
2007   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
2008
2009   mpfr_clear (floor);
2010
2011   return range_check (result, "FLOOR");
2012 }
2013
2014
2015 gfc_expr *
2016 gfc_simplify_fraction (gfc_expr *x)
2017 {
2018   gfc_expr *result;
2019   mpfr_t absv, exp, pow2;
2020
2021   if (x->expr_type != EXPR_CONSTANT)
2022     return NULL;
2023
2024   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2025
2026   if (mpfr_sgn (x->value.real) == 0)
2027     {
2028       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2029       return result;
2030     }
2031
2032   gfc_set_model_kind (x->ts.kind);
2033   mpfr_init (exp);
2034   mpfr_init (absv);
2035   mpfr_init (pow2);
2036
2037   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2038   mpfr_log2 (exp, absv, GFC_RND_MODE);
2039
2040   mpfr_trunc (exp, exp);
2041   mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
2042
2043   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2044
2045   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
2046
2047   mpfr_clears (exp, absv, pow2, NULL);
2048
2049   return range_check (result, "FRACTION");
2050 }
2051
2052
2053 gfc_expr *
2054 gfc_simplify_gamma (gfc_expr *x)
2055 {
2056   gfc_expr *result;
2057
2058   if (x->expr_type != EXPR_CONSTANT)
2059     return NULL;
2060
2061   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2062
2063   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2064
2065   return range_check (result, "GAMMA");
2066 }
2067
2068
2069 gfc_expr *
2070 gfc_simplify_huge (gfc_expr *e)
2071 {
2072   gfc_expr *result;
2073   int i;
2074
2075   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2076
2077   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2078
2079   switch (e->ts.type)
2080     {
2081     case BT_INTEGER:
2082       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2083       break;
2084
2085     case BT_REAL:
2086       mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2087       break;
2088
2089     default:
2090       gcc_unreachable ();
2091     }
2092
2093   return result;
2094 }
2095
2096
2097 gfc_expr *
2098 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2099 {
2100   gfc_expr *result;
2101
2102   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2103     return NULL;
2104
2105   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2106   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2107   return range_check (result, "HYPOT");
2108 }
2109
2110
2111 /* We use the processor's collating sequence, because all
2112    systems that gfortran currently works on are ASCII.  */
2113
2114 gfc_expr *
2115 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2116 {
2117   gfc_expr *result;
2118   gfc_char_t index;
2119
2120   if (e->expr_type != EXPR_CONSTANT)
2121     return NULL;
2122
2123   if (e->value.character.length != 1)
2124     {
2125       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2126       return &gfc_bad_expr;
2127     }
2128
2129   index = e->value.character.string[0];
2130
2131   if (gfc_option.warn_surprising && index > 127)
2132     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2133                  &e->where);
2134
2135   if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
2136     return &gfc_bad_expr;
2137
2138   result->where = e->where;
2139
2140   return range_check (result, "IACHAR");
2141 }
2142
2143
2144 gfc_expr *
2145 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2146 {
2147   gfc_expr *result;
2148
2149   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2150     return NULL;
2151
2152   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
2153
2154   mpz_and (result->value.integer, x->value.integer, y->value.integer);
2155
2156   return range_check (result, "IAND");
2157 }
2158
2159
2160 gfc_expr *
2161 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2162 {
2163   gfc_expr *result;
2164   int k, pos;
2165
2166   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2167     return NULL;
2168
2169   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2170     {
2171       gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
2172       return &gfc_bad_expr;
2173     }
2174
2175   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2176
2177   if (pos >= gfc_integer_kinds[k].bit_size)
2178     {
2179       gfc_error ("Second argument of IBCLR exceeds bit size at %L",
2180                  &y->where);
2181       return &gfc_bad_expr;
2182     }
2183
2184   result = gfc_copy_expr (x);
2185
2186   convert_mpz_to_unsigned (result->value.integer,
2187                            gfc_integer_kinds[k].bit_size);
2188
2189   mpz_clrbit (result->value.integer, pos);
2190
2191   convert_mpz_to_signed (result->value.integer,
2192                          gfc_integer_kinds[k].bit_size);
2193
2194   return result;
2195 }
2196
2197
2198 gfc_expr *
2199 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2200 {
2201   gfc_expr *result;
2202   int pos, len;
2203   int i, k, bitsize;
2204   int *bits;
2205
2206   if (x->expr_type != EXPR_CONSTANT
2207       || y->expr_type != EXPR_CONSTANT
2208       || z->expr_type != EXPR_CONSTANT)
2209     return NULL;
2210
2211   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2212     {
2213       gfc_error ("Invalid second argument of IBITS at %L", &y->where);
2214       return &gfc_bad_expr;
2215     }
2216
2217   if (gfc_extract_int (z, &len) != NULL || len < 0)
2218     {
2219       gfc_error ("Invalid third argument of IBITS at %L", &z->where);
2220       return &gfc_bad_expr;
2221     }
2222
2223   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2224
2225   bitsize = gfc_integer_kinds[k].bit_size;
2226
2227   if (pos + len > bitsize)
2228     {
2229       gfc_error ("Sum of second and third arguments of IBITS exceeds "
2230                  "bit size at %L", &y->where);
2231       return &gfc_bad_expr;
2232     }
2233
2234   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2235   convert_mpz_to_unsigned (result->value.integer,
2236                            gfc_integer_kinds[k].bit_size);
2237
2238   bits = XCNEWVEC (int, bitsize);
2239
2240   for (i = 0; i < bitsize; i++)
2241     bits[i] = 0;
2242
2243   for (i = 0; i < len; i++)
2244     bits[i] = mpz_tstbit (x->value.integer, i + pos);
2245
2246   for (i = 0; i < bitsize; i++)
2247     {
2248       if (bits[i] == 0)
2249         mpz_clrbit (result->value.integer, i);
2250       else if (bits[i] == 1)
2251         mpz_setbit (result->value.integer, i);
2252       else
2253         gfc_internal_error ("IBITS: Bad bit");
2254     }
2255
2256   gfc_free (bits);
2257
2258   convert_mpz_to_signed (result->value.integer,
2259                          gfc_integer_kinds[k].bit_size);
2260
2261   return result;
2262 }
2263
2264
2265 gfc_expr *
2266 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2267 {
2268   gfc_expr *result;
2269   int k, pos;
2270
2271   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2272     return NULL;
2273
2274   if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2275     {
2276       gfc_error ("Invalid second argument of IBSET at %L", &y->where);
2277       return &gfc_bad_expr;
2278     }
2279
2280   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2281
2282   if (pos >= gfc_integer_kinds[k].bit_size)
2283     {
2284       gfc_error ("Second argument of IBSET exceeds bit size at %L",
2285                  &y->where);
2286       return &gfc_bad_expr;
2287     }
2288
2289   result = gfc_copy_expr (x);
2290
2291   convert_mpz_to_unsigned (result->value.integer,
2292                            gfc_integer_kinds[k].bit_size);
2293
2294   mpz_setbit (result->value.integer, pos);
2295
2296   convert_mpz_to_signed (result->value.integer,
2297                          gfc_integer_kinds[k].bit_size);
2298
2299   return result;
2300 }
2301
2302
2303 gfc_expr *
2304 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2305 {
2306   gfc_expr *result;
2307   gfc_char_t index;
2308
2309   if (e->expr_type != EXPR_CONSTANT)
2310     return NULL;
2311
2312   if (e->value.character.length != 1)
2313     {
2314       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2315       return &gfc_bad_expr;
2316     }
2317
2318   index = e->value.character.string[0];
2319
2320   if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
2321     return &gfc_bad_expr;
2322
2323   result->where = e->where;
2324   return range_check (result, "ICHAR");
2325 }
2326
2327
2328 gfc_expr *
2329 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2330 {
2331   gfc_expr *result;
2332
2333   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2334     return NULL;
2335
2336   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
2337
2338   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2339
2340   return range_check (result, "IEOR");
2341 }
2342
2343
2344 gfc_expr *
2345 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2346 {
2347   gfc_expr *result;
2348   int back, len, lensub;
2349   int i, j, k, count, index = 0, start;
2350
2351   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2352       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
2353     return NULL;
2354
2355   if (b != NULL && b->value.logical != 0)
2356     back = 1;
2357   else
2358     back = 0;
2359
2360   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2361   if (k == -1)
2362     return &gfc_bad_expr;
2363
2364   result = gfc_constant_result (BT_INTEGER, k, &x->where);
2365
2366   len = x->value.character.length;
2367   lensub = y->value.character.length;
2368
2369   if (len < lensub)
2370     {
2371       mpz_set_si (result->value.integer, 0);
2372       return result;
2373     }
2374
2375   if (back == 0)
2376     {
2377       if (lensub == 0)
2378         {
2379           mpz_set_si (result->value.integer, 1);
2380           return result;
2381         }
2382       else if (lensub == 1)
2383         {
2384           for (i = 0; i < len; i++)
2385             {
2386               for (j = 0; j < lensub; j++)
2387                 {
2388                   if (y->value.character.string[j]
2389                       == x->value.character.string[i])
2390                     {
2391                       index = i + 1;
2392                       goto done;
2393                     }
2394                 }
2395             }
2396         }
2397       else
2398         {
2399           for (i = 0; i < len; i++)
2400             {
2401               for (j = 0; j < lensub; j++)
2402                 {
2403                   if (y->value.character.string[j]
2404                       == x->value.character.string[i])
2405                     {
2406                       start = i;
2407                       count = 0;
2408
2409                       for (k = 0; k < lensub; k++)
2410                         {
2411                           if (y->value.character.string[k]
2412                               == x->value.character.string[k + start])
2413                             count++;
2414                         }
2415
2416                       if (count == lensub)
2417                         {
2418                           index = start + 1;
2419                           goto done;
2420                         }
2421                     }
2422                 }
2423             }
2424         }
2425
2426     }
2427   else
2428     {
2429       if (lensub == 0)
2430         {
2431           mpz_set_si (result->value.integer, len + 1);
2432           return result;
2433         }
2434       else if (lensub == 1)
2435         {
2436           for (i = 0; i < len; i++)
2437             {
2438               for (j = 0; j < lensub; j++)
2439                 {
2440                   if (y->value.character.string[j]
2441                       == x->value.character.string[len - i])
2442                     {
2443                       index = len - i + 1;
2444                       goto done;
2445                     }
2446                 }
2447             }
2448         }
2449       else
2450         {
2451           for (i = 0; i < len; i++)
2452             {
2453               for (j = 0; j < lensub; j++)
2454                 {
2455                   if (y->value.character.string[j]
2456                       == x->value.character.string[len - i])
2457                     {
2458                       start = len - i;
2459                       if (start <= len - lensub)
2460                         {
2461                           count = 0;
2462                           for (k = 0; k < lensub; k++)
2463                             if (y->value.character.string[k]
2464                                 == x->value.character.string[k + start])
2465                               count++;
2466
2467                           if (count == lensub)
2468                             {
2469                               index = start + 1;
2470                               goto done;
2471                             }
2472                         }
2473                       else
2474                         {
2475                           continue;
2476                         }
2477                     }
2478                 }
2479             }
2480         }
2481     }
2482
2483 done:
2484   mpz_set_si (result->value.integer, index);
2485   return range_check (result, "INDEX");
2486 }
2487
2488
2489 gfc_expr *
2490 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2491 {
2492   gfc_expr *result = NULL;
2493   int kind;
2494
2495   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2496   if (kind == -1)
2497     return &gfc_bad_expr;
2498
2499   if (e->expr_type != EXPR_CONSTANT)
2500     return NULL;
2501
2502   switch (e->ts.type)
2503     {
2504     case BT_INTEGER:
2505       result = gfc_int2int (e, kind);
2506       break;
2507
2508     case BT_REAL:
2509       result = gfc_real2int (e, kind);
2510       break;
2511
2512     case BT_COMPLEX:
2513       result = gfc_complex2int (e, kind);
2514       break;
2515
2516     default:
2517       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
2518       return &gfc_bad_expr;
2519     }
2520
2521   return range_check (result, "INT");
2522 }
2523
2524
2525 static gfc_expr *
2526 simplify_intconv (gfc_expr *e, int kind, const char *name)
2527 {
2528   gfc_expr *result = NULL;
2529
2530   if (e->expr_type != EXPR_CONSTANT)
2531     return NULL;
2532
2533   switch (e->ts.type)
2534     {
2535     case BT_INTEGER:
2536       result = gfc_int2int (e, kind);
2537       break;
2538
2539     case BT_REAL:
2540       result = gfc_real2int (e, kind);
2541       break;
2542
2543     case BT_COMPLEX:
2544       result = gfc_complex2int (e, kind);
2545       break;
2546
2547     default:
2548       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
2549       return &gfc_bad_expr;
2550     }
2551
2552   return range_check (result, name);
2553 }
2554
2555
2556 gfc_expr *
2557 gfc_simplify_int2 (gfc_expr *e)
2558 {
2559   return simplify_intconv (e, 2, "INT2");
2560 }
2561
2562
2563 gfc_expr *
2564 gfc_simplify_int8 (gfc_expr *e)
2565 {
2566   return simplify_intconv (e, 8, "INT8");
2567 }
2568
2569
2570 gfc_expr *
2571 gfc_simplify_long (gfc_expr *e)
2572 {
2573   return simplify_intconv (e, 4, "LONG");
2574 }
2575
2576
2577 gfc_expr *
2578 gfc_simplify_ifix (gfc_expr *e)
2579 {
2580   gfc_expr *rtrunc, *result;
2581
2582   if (e->expr_type != EXPR_CONSTANT)
2583     return NULL;
2584
2585   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2586                                 &e->where);
2587
2588   rtrunc = gfc_copy_expr (e);
2589
2590   mpfr_trunc (rtrunc->value.real, e->value.real);
2591   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2592
2593   gfc_free_expr (rtrunc);
2594   return range_check (result, "IFIX");
2595 }
2596
2597
2598 gfc_expr *
2599 gfc_simplify_idint (gfc_expr *e)
2600 {
2601   gfc_expr *rtrunc, *result;
2602
2603   if (e->expr_type != EXPR_CONSTANT)
2604     return NULL;
2605
2606   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2607                                 &e->where);
2608
2609   rtrunc = gfc_copy_expr (e);
2610
2611   mpfr_trunc (rtrunc->value.real, e->value.real);
2612   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2613
2614   gfc_free_expr (rtrunc);
2615   return range_check (result, "IDINT");
2616 }
2617
2618
2619 gfc_expr *
2620 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2621 {
2622   gfc_expr *result;
2623
2624   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2625     return NULL;
2626
2627   result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
2628
2629   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2630   return range_check (result, "IOR");
2631 }
2632
2633
2634 gfc_expr *
2635 gfc_simplify_is_iostat_end (gfc_expr *x)
2636 {
2637   gfc_expr *result;
2638
2639   if (x->expr_type != EXPR_CONSTANT)
2640     return NULL;
2641
2642   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
2643                                 &x->where);
2644   result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0);
2645
2646   return result;
2647 }
2648
2649
2650 gfc_expr *
2651 gfc_simplify_is_iostat_eor (gfc_expr *x)
2652 {
2653   gfc_expr *result;
2654
2655   if (x->expr_type != EXPR_CONSTANT)
2656     return NULL;
2657
2658   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
2659                                 &x->where);
2660   result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0);
2661
2662   return result;
2663 }
2664
2665
2666 gfc_expr *
2667 gfc_simplify_isnan (gfc_expr *x)
2668 {
2669   gfc_expr *result;
2670
2671   if (x->expr_type != EXPR_CONSTANT)
2672     return NULL;
2673
2674   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
2675                                 &x->where);
2676   result->value.logical = mpfr_nan_p (x->value.real);
2677
2678   return result;
2679 }
2680
2681
2682 gfc_expr *
2683 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2684 {
2685   gfc_expr *result;
2686   int shift, ashift, isize, k, *bits, i;
2687
2688   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2689     return NULL;
2690
2691   if (gfc_extract_int (s, &shift) != NULL)
2692     {
2693       gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2694       return &gfc_bad_expr;
2695     }
2696
2697   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2698
2699   isize = gfc_integer_kinds[k].bit_size;
2700
2701   if (shift >= 0)
2702     ashift = shift;
2703   else
2704     ashift = -shift;
2705
2706   if (ashift > isize)
2707     {
2708       gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2709                  "at %L", &s->where);
2710       return &gfc_bad_expr;
2711     }
2712
2713   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2714
2715   if (shift == 0)
2716     {
2717       mpz_set (result->value.integer, e->value.integer);
2718       return range_check (result, "ISHFT");
2719     }
2720
2721   bits = XCNEWVEC (int, isize);
2722
2723   for (i = 0; i < isize; i++)
2724     bits[i] = mpz_tstbit (e->value.integer, i);
2725
2726   if (shift > 0)
2727     {
2728       for (i = 0; i < shift; i++)
2729         mpz_clrbit (result->value.integer, i);
2730
2731       for (i = 0; i < isize - shift; i++)
2732         {
2733           if (bits[i] == 0)
2734             mpz_clrbit (result->value.integer, i + shift);
2735           else
2736             mpz_setbit (result->value.integer, i + shift);
2737         }
2738     }
2739   else
2740     {
2741       for (i = isize - 1; i >= isize - ashift; i--)
2742         mpz_clrbit (result->value.integer, i);
2743
2744       for (i = isize - 1; i >= ashift; i--)
2745         {
2746           if (bits[i] == 0)
2747             mpz_clrbit (result->value.integer, i - ashift);
2748           else
2749             mpz_setbit (result->value.integer, i - ashift);
2750         }
2751     }
2752
2753   convert_mpz_to_signed (result->value.integer, isize);
2754
2755   gfc_free (bits);
2756   return result;
2757 }
2758
2759
2760 gfc_expr *
2761 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2762 {
2763   gfc_expr *result;
2764   int shift, ashift, isize, ssize, delta, k;
2765   int i, *bits;
2766
2767   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2768     return NULL;
2769
2770   if (gfc_extract_int (s, &shift) != NULL)
2771     {
2772       gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2773       return &gfc_bad_expr;
2774     }
2775
2776   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2777   isize = gfc_integer_kinds[k].bit_size;
2778
2779   if (sz != NULL)
2780     {
2781       if (sz->expr_type != EXPR_CONSTANT)
2782         return NULL;
2783
2784       if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2785         {
2786           gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2787           return &gfc_bad_expr;
2788         }
2789
2790       if (ssize > isize)
2791         {
2792           gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2793                      "BIT_SIZE of first argument at %L", &s->where);
2794           return &gfc_bad_expr;
2795         }
2796     }
2797   else
2798     ssize = isize;
2799
2800   if (shift >= 0)
2801     ashift = shift;
2802   else
2803     ashift = -shift;
2804
2805   if (ashift > ssize)
2806     {
2807       if (sz != NULL)
2808         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2809                    "third argument at %L", &s->where);
2810       else
2811         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2812                    "BIT_SIZE of first argument at %L", &s->where);
2813       return &gfc_bad_expr;
2814     }
2815
2816   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2817
2818   mpz_set (result->value.integer, e->value.integer);
2819
2820   if (shift == 0)
2821     return result;
2822
2823   convert_mpz_to_unsigned (result->value.integer, isize);
2824
2825   bits = XCNEWVEC (int, ssize);
2826
2827   for (i = 0; i < ssize; i++)
2828     bits[i] = mpz_tstbit (e->value.integer, i);
2829
2830   delta = ssize - ashift;
2831
2832   if (shift > 0)
2833     {
2834       for (i = 0; i < delta; i++)
2835         {
2836           if (bits[i] == 0)
2837             mpz_clrbit (result->value.integer, i + shift);
2838           else
2839             mpz_setbit (result->value.integer, i + shift);
2840         }
2841
2842       for (i = delta; i < ssize; i++)
2843         {
2844           if (bits[i] == 0)
2845             mpz_clrbit (result->value.integer, i - delta);
2846           else
2847             mpz_setbit (result->value.integer, i - delta);
2848         }
2849     }
2850   else
2851     {
2852       for (i = 0; i < ashift; i++)
2853         {
2854           if (bits[i] == 0)
2855             mpz_clrbit (result->value.integer, i + delta);
2856           else
2857             mpz_setbit (result->value.integer, i + delta);
2858         }
2859
2860       for (i = ashift; i < ssize; i++)
2861         {
2862           if (bits[i] == 0)
2863             mpz_clrbit (result->value.integer, i + shift);
2864           else
2865             mpz_setbit (result->value.integer, i + shift);
2866         }
2867     }
2868
2869   convert_mpz_to_signed (result->value.integer, isize);
2870
2871   gfc_free (bits);
2872   return result;
2873 }
2874
2875
2876 gfc_expr *
2877 gfc_simplify_kind (gfc_expr *e)
2878 {
2879
2880   if (e->ts.type == BT_DERIVED)
2881     {
2882       gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2883       return &gfc_bad_expr;
2884     }
2885
2886   return gfc_int_expr (e->ts.kind);
2887 }
2888
2889
2890 static gfc_expr *
2891 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2892                     gfc_array_spec *as, gfc_ref *ref)
2893 {
2894   gfc_expr *l, *u, *result;
2895   int k;
2896
2897   /* The last dimension of an assumed-size array is special.  */
2898   if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2899     {
2900       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2901         return gfc_copy_expr (as->lower[d-1]);
2902       else
2903         return NULL;
2904     }
2905
2906   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2907                 gfc_default_integer_kind);
2908   if (k == -1)
2909     return &gfc_bad_expr;
2910
2911   result = gfc_constant_result (BT_INTEGER, k, &array->where);
2912
2913
2914   /* Then, we need to know the extent of the given dimension.  */
2915   if (ref->u.ar.type == AR_FULL)
2916     {
2917       l = as->lower[d-1];
2918       u = as->upper[d-1];
2919
2920       if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2921         return NULL;
2922
2923       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2924         {
2925           /* Zero extent.  */
2926           if (upper)
2927             mpz_set_si (result->value.integer, 0);
2928           else
2929             mpz_set_si (result->value.integer, 1);
2930         }
2931       else
2932         {
2933           /* Nonzero extent.  */
2934           if (upper)
2935             mpz_set (result->value.integer, u->value.integer);
2936           else
2937             mpz_set (result->value.integer, l->value.integer);
2938         }
2939     }
2940   else
2941     {
2942       if (upper)
2943         {
2944           if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
2945               != SUCCESS)
2946             return NULL;
2947         }
2948       else
2949         mpz_set_si (result->value.integer, (long int) 1);
2950     }
2951
2952   return range_check (result, upper ? "UBOUND" : "LBOUND");
2953 }
2954
2955
2956 static gfc_expr *
2957 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2958 {
2959   gfc_ref *ref;
2960   gfc_array_spec *as;
2961   int d;
2962
2963   if (array->expr_type != EXPR_VARIABLE)
2964     return NULL;
2965
2966   /* Follow any component references.  */
2967   as = array->symtree->n.sym->as;
2968   for (ref = array->ref; ref; ref = ref->next)
2969     {
2970       switch (ref->type)
2971         {
2972         case REF_ARRAY:
2973           switch (ref->u.ar.type)
2974             {
2975             case AR_ELEMENT:
2976               as = NULL;
2977               continue;
2978
2979             case AR_FULL:
2980               /* We're done because 'as' has already been set in the
2981                  previous iteration.  */
2982               if (!ref->next)
2983                 goto done;
2984
2985             /* Fall through.  */
2986
2987             case AR_UNKNOWN:
2988               return NULL;
2989
2990             case AR_SECTION:
2991               as = ref->u.ar.as;
2992               goto done;
2993             }
2994
2995           gcc_unreachable ();
2996
2997         case REF_COMPONENT:
2998           as = ref->u.c.component->as;
2999           continue;
3000
3001         case REF_SUBSTRING:
3002           continue;
3003         }
3004     }
3005
3006   gcc_unreachable ();
3007
3008  done:
3009
3010   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3011     return NULL;
3012
3013   if (dim == NULL)
3014     {
3015       /* Multi-dimensional bounds.  */
3016       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3017       gfc_expr *e;
3018       gfc_constructor *head, *tail;
3019       int k;
3020
3021       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
3022       if (upper && as->type == AS_ASSUMED_SIZE)
3023         {
3024           /* An error message will be emitted in
3025              check_assumed_size_reference (resolve.c).  */
3026           return &gfc_bad_expr;
3027         }
3028
3029       /* Simplify the bounds for each dimension.  */
3030       for (d = 0; d < array->rank; d++)
3031         {
3032           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
3033           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3034             {
3035               int j;
3036
3037               for (j = 0; j < d; j++)
3038                 gfc_free_expr (bounds[j]);
3039               return bounds[d];
3040             }
3041         }
3042
3043       /* Allocate the result expression.  */
3044       e = gfc_get_expr ();
3045       e->where = array->where;
3046       e->expr_type = EXPR_ARRAY;
3047       e->ts.type = BT_INTEGER;
3048       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3049                     gfc_default_integer_kind);
3050       if (k == -1)
3051         {
3052           gfc_free_expr (e);
3053           return &gfc_bad_expr;
3054         }
3055       e->ts.kind = k;
3056
3057       /* The result is a rank 1 array; its size is the rank of the first
3058          argument to {L,U}BOUND.  */
3059       e->rank = 1;
3060       e->shape = gfc_get_shape (1);
3061       mpz_init_set_ui (e->shape[0], array->rank);
3062
3063       /* Create the constructor for this array.  */
3064       head = tail = NULL;
3065       for (d = 0; d < array->rank; d++)
3066         {
3067           /* Get a new constructor element.  */
3068           if (head == NULL)
3069             head = tail = gfc_get_constructor ();
3070           else
3071             {
3072               tail->next = gfc_get_constructor ();
3073               tail = tail->next;
3074             }
3075
3076           tail->where = e->where;
3077           tail->expr = bounds[d];
3078         }
3079       e->value.constructor = head;
3080
3081       return e;
3082     }
3083   else
3084     {
3085       /* A DIM argument is specified.  */
3086       if (dim->expr_type != EXPR_CONSTANT)
3087         return NULL;
3088
3089       d = mpz_get_si (dim->value.integer);
3090
3091       if (d < 1 || d > as->rank
3092           || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
3093         {
3094           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3095           return &gfc_bad_expr;
3096         }
3097
3098       return simplify_bound_dim (array, kind, d, upper, as, ref);
3099     }
3100 }
3101
3102
3103 gfc_expr *
3104 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3105 {
3106   return simplify_bound (array, dim, kind, 0);
3107 }
3108
3109
3110 gfc_expr *
3111 gfc_simplify_leadz (gfc_expr *e)
3112 {
3113   gfc_expr *result;
3114   unsigned long lz, bs;
3115   int i;
3116
3117   if (e->expr_type != EXPR_CONSTANT)
3118     return NULL;
3119
3120   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3121   bs = gfc_integer_kinds[i].bit_size;
3122   if (mpz_cmp_si (e->value.integer, 0) == 0)
3123     lz = bs;
3124   else if (mpz_cmp_si (e->value.integer, 0) < 0)
3125     lz = 0;
3126   else
3127     lz = bs - mpz_sizeinbase (e->value.integer, 2);
3128
3129   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3130                                 &e->where);
3131   mpz_set_ui (result->value.integer, lz);
3132
3133   return result;
3134 }
3135
3136
3137 gfc_expr *
3138 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3139 {
3140   gfc_expr *result;
3141   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3142
3143   if (k == -1)
3144     return &gfc_bad_expr;
3145
3146   if (e->expr_type == EXPR_CONSTANT)
3147     {
3148       result = gfc_constant_result (BT_INTEGER, k, &e->where);
3149       mpz_set_si (result->value.integer, e->value.character.length);
3150       if (gfc_range_check (result) == ARITH_OK)
3151         return result;
3152       else
3153         {
3154           gfc_free_expr (result);
3155           return NULL;
3156         }
3157     }
3158
3159   if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3160       && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3161       && e->ts.u.cl->length->ts.type == BT_INTEGER)
3162     {
3163       result = gfc_constant_result (BT_INTEGER, k, &e->where);
3164       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3165       if (gfc_range_check (result) == ARITH_OK)
3166         return result;
3167       else
3168         {
3169           gfc_free_expr (result);
3170           return NULL;
3171         }
3172     }
3173
3174   return NULL;
3175 }
3176
3177
3178 gfc_expr *
3179 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3180 {
3181   gfc_expr *result;
3182   int count, len, lentrim, i;
3183   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3184
3185   if (k == -1)
3186     return &gfc_bad_expr;
3187
3188   if (e->expr_type != EXPR_CONSTANT)
3189     return NULL;
3190
3191   result = gfc_constant_result (BT_INTEGER, k, &e->where);
3192   len = e->value.character.length;
3193
3194   for (count = 0, i = 1; i <= len; i++)
3195     if (e->value.character.string[len - i] == ' ')
3196       count++;
3197     else
3198       break;
3199
3200   lentrim = len - count;
3201
3202   mpz_set_si (result->value.integer, lentrim);
3203   return range_check (result, "LEN_TRIM");
3204 }
3205
3206 gfc_expr *
3207 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
3208 {
3209   gfc_expr *result;
3210   int sg;
3211
3212   if (x->expr_type != EXPR_CONSTANT)
3213     return NULL;
3214
3215   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3216
3217   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3218
3219   return range_check (result, "LGAMMA");
3220 }
3221
3222
3223 gfc_expr *
3224 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3225 {
3226   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3227     return NULL;
3228
3229   return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
3230 }
3231
3232
3233 gfc_expr *
3234 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3235 {
3236   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3237     return NULL;
3238
3239   return gfc_logical_expr (gfc_compare_string (a, b) > 0,
3240                            &a->where);
3241 }
3242
3243
3244 gfc_expr *
3245 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3246 {
3247   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3248     return NULL;
3249
3250   return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
3251 }
3252
3253
3254 gfc_expr *
3255 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3256 {
3257   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3258     return NULL;
3259
3260   return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
3261 }
3262
3263
3264 gfc_expr *
3265 gfc_simplify_log (gfc_expr *x)
3266 {
3267   gfc_expr *result;
3268
3269   if (x->expr_type != EXPR_CONSTANT)
3270     return NULL;
3271
3272   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3273
3274
3275   switch (x->ts.type)
3276     {
3277     case BT_REAL:
3278       if (mpfr_sgn (x->value.real) <= 0)
3279         {
3280           gfc_error ("Argument of LOG at %L cannot be less than or equal "
3281                      "to zero", &x->where);
3282           gfc_free_expr (result);
3283           return &gfc_bad_expr;
3284         }
3285
3286       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3287       break;
3288
3289     case BT_COMPLEX:
3290       if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3291           && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3292         {
3293           gfc_error ("Complex argument of LOG at %L cannot be zero",
3294                      &x->where);
3295           gfc_free_expr (result);
3296           return &gfc_bad_expr;
3297         }
3298
3299       gfc_set_model_kind (x->ts.kind);
3300       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3301       break;
3302
3303     default:
3304       gfc_internal_error ("gfc_simplify_log: bad type");
3305     }
3306
3307   return range_check (result, "LOG");
3308 }
3309
3310
3311 gfc_expr *
3312 gfc_simplify_log10 (gfc_expr *x)
3313 {
3314   gfc_expr *result;
3315
3316   if (x->expr_type != EXPR_CONSTANT)
3317     return NULL;
3318
3319   if (mpfr_sgn (x->value.real) <= 0)
3320     {
3321       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3322                  "to zero", &x->where);
3323       return &gfc_bad_expr;
3324     }
3325
3326   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3327
3328   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3329
3330   return range_check (result, "LOG10");
3331 }
3332
3333
3334 gfc_expr *
3335 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3336 {
3337   gfc_expr *result;
3338   int kind;
3339
3340   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3341   if (kind < 0)
3342     return &gfc_bad_expr;
3343
3344   if (e->expr_type != EXPR_CONSTANT)
3345     return NULL;
3346
3347   result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
3348
3349   result->value.logical = e->value.logical;
3350
3351   return result;
3352 }
3353
3354
3355 gfc_expr*
3356 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3357 {
3358   gfc_expr *result;
3359   gfc_constructor *ma_ctor, *mb_ctor;
3360   int row, result_rows, col, result_columns, stride_a, stride_b;
3361
3362   if (!is_constant_array_expr (matrix_a)
3363       || !is_constant_array_expr (matrix_b))
3364     return NULL;
3365
3366   gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3367   result = gfc_start_constructor (matrix_a->ts.type,
3368                                   matrix_a->ts.kind,
3369                                   &matrix_a->where);
3370
3371   if (matrix_a->rank == 1 && matrix_b->rank == 2)
3372     {
3373       result_rows = 1;
3374       result_columns = mpz_get_si (matrix_b->shape[0]);
3375       stride_a = 1;
3376       stride_b = mpz_get_si (matrix_b->shape[0]);
3377
3378       result->rank = 1;
3379       result->shape = gfc_get_shape (result->rank);
3380       mpz_init_set_si (result->shape[0], result_columns);
3381     }
3382   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3383     {
3384       result_rows = mpz_get_si (matrix_b->shape[0]);
3385       result_columns = 1;
3386       stride_a = mpz_get_si (matrix_a->shape[0]);
3387       stride_b = 1;
3388
3389       result->rank = 1;
3390       result->shape = gfc_get_shape (result->rank);
3391       mpz_init_set_si (result->shape[0], result_rows);
3392     }
3393   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3394     {
3395       result_rows = mpz_get_si (matrix_a->shape[0]);
3396       result_columns = mpz_get_si (matrix_b->shape[1]);
3397       stride_a = mpz_get_si (matrix_a->shape[1]);
3398       stride_b = mpz_get_si (matrix_b->shape[0]);
3399
3400       result->rank = 2;
3401       result->shape = gfc_get_shape (result->rank);
3402       mpz_init_set_si (result->shape[0], result_rows);
3403       mpz_init_set_si (result->shape[1], result_columns);
3404     }
3405   else
3406     gcc_unreachable();
3407
3408   ma_ctor = matrix_a->value.constructor;
3409   mb_ctor = matrix_b->value.constructor;
3410
3411   for (col = 0; col < result_columns; ++col)
3412     {
3413       ma_ctor = matrix_a->value.constructor;
3414
3415       for (row = 0; row < result_rows; ++row)
3416         {
3417           gfc_expr *e;
3418           e = compute_dot_product (ma_ctor, stride_a,
3419                                    mb_ctor, 1);
3420
3421           gfc_append_constructor (result, e);
3422
3423           ADVANCE (ma_ctor, 1);
3424         }
3425
3426       ADVANCE (mb_ctor, stride_b);
3427     }
3428
3429   return result;
3430 }
3431
3432
3433 gfc_expr *
3434 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3435 {
3436   if (tsource->expr_type != EXPR_CONSTANT
3437       || fsource->expr_type != EXPR_CONSTANT
3438       || mask->expr_type != EXPR_CONSTANT)
3439     return NULL;
3440
3441   return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3442 }
3443
3444
3445 /* Selects bewteen current value and extremum for simplify_min_max
3446    and simplify_minval_maxval.  */
3447 static void
3448 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3449 {
3450   switch (arg->ts.type)
3451     {
3452       case BT_INTEGER:
3453         if (mpz_cmp (arg->value.integer,
3454                         extremum->value.integer) * sign > 0)
3455         mpz_set (extremum->value.integer, arg->value.integer);
3456         break;
3457
3458       case BT_REAL:
3459         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
3460         if (sign > 0)
3461           mpfr_max (extremum->value.real, extremum->value.real,
3462                       arg->value.real, GFC_RND_MODE);
3463         else
3464           mpfr_min (extremum->value.real, extremum->value.real,
3465                       arg->value.real, GFC_RND_MODE);
3466         break;
3467
3468       case BT_CHARACTER:
3469 #define LENGTH(x) ((x)->value.character.length)
3470 #define STRING(x) ((x)->value.character.string)
3471         if (LENGTH(extremum) < LENGTH(arg))
3472           {
3473             gfc_char_t *tmp = STRING(extremum);
3474
3475             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3476             memcpy (STRING(extremum), tmp,
3477                       LENGTH(extremum) * sizeof (gfc_char_t));
3478             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3479                                LENGTH(arg) - LENGTH(extremum));
3480             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
3481             LENGTH(extremum) = LENGTH(arg);
3482             gfc_free (tmp);
3483           }
3484
3485         if (gfc_compare_string (arg, extremum) * sign > 0)
3486           {
3487             gfc_free (STRING(extremum));
3488             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3489             memcpy (STRING(extremum), STRING(arg),
3490                       LENGTH(arg) * sizeof (gfc_char_t));
3491             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3492                                LENGTH(extremum) - LENGTH(arg));
3493             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
3494           }
3495 #undef LENGTH
3496 #undef STRING
3497         break;
3498
3499       default:
3500         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3501     }
3502 }
3503
3504
3505 /* This function is special since MAX() can take any number of
3506    arguments.  The simplified expression is a rewritten version of the
3507    argument list containing at most one constant element.  Other
3508    constant elements are deleted.  Because the argument list has
3509    already been checked, this function always succeeds.  sign is 1 for
3510    MAX(), -1 for MIN().  */
3511
3512 static gfc_expr *
3513 simplify_min_max (gfc_expr *expr, int sign)
3514 {
3515   gfc_actual_arglist *arg, *last, *extremum;
3516   gfc_intrinsic_sym * specific;
3517
3518   last = NULL;
3519   extremum = NULL;
3520   specific = expr->value.function.isym;
3521
3522   arg = expr->value.function.actual;
3523
3524   for (; arg; last = arg, arg = arg->next)
3525     {
3526       if (arg->expr->expr_type != EXPR_CONSTANT)
3527         continue;
3528
3529       if (extremum == NULL)
3530         {
3531           extremum = arg;
3532           continue;
3533         }
3534
3535       min_max_choose (arg->expr, extremum->expr, sign);
3536
3537       /* Delete the extra constant argument.  */
3538       if (last == NULL)
3539         expr->value.function.actual = arg->next;
3540       else
3541         last->next = arg->next;
3542
3543       arg->next = NULL;
3544       gfc_free_actual_arglist (arg);
3545       arg = last;
3546     }
3547
3548   /* If there is one value left, replace the function call with the
3549      expression.  */
3550   if (expr->value.function.actual->next != NULL)
3551     return NULL;
3552
3553   /* Convert to the correct type and kind.  */
3554   if (expr->ts.type != BT_UNKNOWN)
3555     return gfc_convert_constant (expr->value.function.actual->expr,
3556         expr->ts.type, expr->ts.kind);
3557
3558   if (specific->ts.type != BT_UNKNOWN)
3559     return gfc_convert_constant (expr->value.function.actual->expr,
3560         specific->ts.type, specific->ts.kind);
3561
3562   return gfc_copy_expr (expr->value.function.actual->expr);
3563 }
3564
3565
3566 gfc_expr *
3567 gfc_simplify_min (gfc_expr *e)
3568 {
3569   return simplify_min_max (e, -1);
3570 }
3571
3572
3573 gfc_expr *
3574 gfc_simplify_max (gfc_expr *e)
3575 {
3576   return simplify_min_max (e, 1);
3577 }
3578
3579
3580 /* This is a simplified version of simplify_min_max to provide
3581    simplification of minval and maxval for a vector.  */
3582
3583 static gfc_expr *
3584 simplify_minval_maxval (gfc_expr *expr, int sign)
3585 {
3586   gfc_constructor *ctr, *extremum;
3587   gfc_intrinsic_sym * specific;
3588
3589   extremum = NULL;
3590   specific = expr->value.function.isym;
3591
3592   ctr = expr->value.constructor;
3593
3594   for (; ctr; ctr = ctr->next)
3595     {
3596       if (ctr->expr->expr_type != EXPR_CONSTANT)
3597         return NULL;
3598
3599       if (extremum == NULL)
3600         {
3601           extremum = ctr;
3602           continue;
3603         }
3604
3605       min_max_choose (ctr->expr, extremum->expr, sign);
3606      }
3607
3608   if (extremum == NULL)
3609     return NULL;
3610
3611   /* Convert to the correct type and kind.  */
3612   if (expr->ts.type != BT_UNKNOWN)
3613     return gfc_convert_constant (extremum->expr,
3614         expr->ts.type, expr->ts.kind);
3615
3616   if (specific->ts.type != BT_UNKNOWN)
3617     return gfc_convert_constant (extremum->expr,
3618         specific->ts.type, specific->ts.kind);
3619
3620   return gfc_copy_expr (extremum->expr);
3621 }
3622
3623
3624 gfc_expr *
3625 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3626 {
3627   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3628     return NULL;
3629
3630   return simplify_minval_maxval (array, -1);
3631 }
3632
3633
3634 gfc_expr *
3635 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3636 {
3637   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3638     return NULL;
3639   return simplify_minval_maxval (array, 1);
3640 }
3641
3642
3643 gfc_expr *
3644 gfc_simplify_maxexponent (gfc_expr *x)
3645 {
3646   gfc_expr *result;
3647   int i;
3648
3649   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3650
3651   result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
3652   result->where = x->where;
3653
3654   return result;
3655 }
3656
3657
3658 gfc_expr *
3659 gfc_simplify_minexponent (gfc_expr *x)
3660 {
3661   gfc_expr *result;
3662   int i;
3663
3664   i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3665
3666   result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
3667   result->where = x->where;
3668
3669   return result;
3670 }
3671
3672
3673 gfc_expr *
3674 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3675 {
3676   gfc_expr *result;
3677   mpfr_t tmp;
3678   int kind;
3679
3680   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3681     return NULL;
3682
3683   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3684   result = gfc_constant_result (a->ts.type, kind, &a->where);
3685
3686   switch (a->ts.type)
3687     {
3688     case BT_INTEGER:
3689       if (mpz_cmp_ui (p->value.integer, 0) == 0)
3690         {
3691           /* Result is processor-dependent.  */
3692           gfc_error ("Second argument MOD at %L is zero", &a->where);
3693           gfc_free_expr (result);
3694           return &gfc_bad_expr;
3695         }
3696       mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3697       break;
3698
3699     case BT_REAL:
3700       if (mpfr_cmp_ui (p->value.real, 0) == 0)
3701         {
3702           /* Result is processor-dependent.  */
3703           gfc_error ("Second argument of MOD at %L is zero", &p->where);
3704           gfc_free_expr (result);
3705           return &gfc_bad_expr;
3706         }
3707
3708       gfc_set_model_kind (kind);
3709       mpfr_init (tmp);
3710       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3711       mpfr_trunc (tmp, tmp);
3712       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3713       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3714       mpfr_clear (tmp);
3715       break;
3716
3717     default:
3718       gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3719     }
3720
3721   return range_check (result, "MOD");
3722 }
3723
3724
3725 gfc_expr *
3726 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3727 {
3728   gfc_expr *result;
3729   mpfr_t tmp;
3730   int kind;
3731
3732   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3733     return NULL;
3734
3735   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3736   result = gfc_constant_result (a->ts.type, kind, &a->where);
3737
3738   switch (a->ts.type)
3739     {
3740     case BT_INTEGER:
3741       if (mpz_cmp_ui (p->value.integer, 0) == 0)
3742         {
3743           /* Result is processor-dependent. This processor just opts
3744              to not handle it at all.  */
3745           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3746           gfc_free_expr (result);
3747           return &gfc_bad_expr;
3748         }
3749       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3750
3751       break;
3752
3753     case BT_REAL:
3754       if (mpfr_cmp_ui (p->value.real, 0) == 0)
3755         {
3756           /* Result is processor-dependent.  */
3757           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3758           gfc_free_expr (result);
3759           return &gfc_bad_expr;
3760         }
3761
3762       gfc_set_model_kind (kind);
3763       mpfr_init (tmp);
3764       mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3765       mpfr_floor (tmp, tmp);
3766       mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3767       mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3768       mpfr_clear (tmp);
3769       break;
3770
3771     default:
3772       gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3773     }
3774
3775   return range_check (result, "MODULO");
3776 }
3777
3778
3779 /* Exists for the sole purpose of consistency with other intrinsics.  */
3780 gfc_expr *
3781 gfc_simplify_mvbits (gfc_expr *f  ATTRIBUTE_UNUSED,
3782                      gfc_expr *fp ATTRIBUTE_UNUSED,
3783                      gfc_expr *l  ATTRIBUTE_UNUSED,
3784                      gfc_expr *to ATTRIBUTE_UNUSED,
3785                      gfc_expr *tp ATTRIBUTE_UNUSED)
3786 {
3787   return NULL;
3788 }
3789
3790
3791 gfc_expr *
3792 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3793 {
3794   gfc_expr *result;
3795   mp_exp_t emin, emax;
3796   int kind;
3797
3798   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3799     return NULL;
3800
3801   if (mpfr_sgn (s->value.real) == 0)
3802     {
3803       gfc_error ("Second argument of NEAREST at %L shall not be zero",
3804                  &s->where);
3805       return &gfc_bad_expr;
3806     }
3807
3808   result = gfc_copy_expr (x);
3809
3810   /* Save current values of emin and emax.  */
3811   emin = mpfr_get_emin ();
3812   emax = mpfr_get_emax ();
3813
3814   /* Set emin and emax for the current model number.  */
3815   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3816   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3817                 mpfr_get_prec(result->value.real) + 1);
3818   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3819   mpfr_check_range (result->value.real, 0, GMP_RNDU);
3820
3821   if (mpfr_sgn (s->value.real) > 0)
3822     {
3823       mpfr_nextabove (result->value.real);
3824       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3825     }
3826   else
3827     {
3828       mpfr_nextbelow (result->value.real);
3829       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3830     }
3831
3832   mpfr_set_emin (emin);
3833   mpfr_set_emax (emax);
3834
3835   /* Only NaN can occur. Do not use range check as it gives an
3836      error for denormal numbers.  */
3837   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3838     {
3839       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3840       gfc_free_expr (result);
3841       return &gfc_bad_expr;
3842     }
3843
3844   return result;
3845 }
3846
3847
3848 static gfc_expr *
3849 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3850 {
3851   gfc_expr *itrunc, *result;
3852   int kind;
3853
3854   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3855   if (kind == -1)
3856     return &gfc_bad_expr;
3857
3858   if (e->expr_type != EXPR_CONSTANT)
3859     return NULL;
3860
3861   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
3862
3863   itrunc = gfc_copy_expr (e);
3864
3865   mpfr_round (itrunc->value.real, e->value.real);
3866
3867   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3868
3869   gfc_free_expr (itrunc);
3870
3871   return range_check (result, name);
3872 }
3873
3874
3875 gfc_expr *
3876 gfc_simplify_new_line (gfc_expr *e)
3877 {
3878   gfc_expr *result;
3879
3880   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3881   result->value.character.string = gfc_get_wide_string (2);
3882   result->value.character.length = 1;
3883   result->value.character.string[0] = '\n';
3884   result->value.character.string[1] = '\0';     /* For debugger */
3885   return result;
3886 }
3887
3888
3889 gfc_expr *
3890 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3891 {
3892   return simplify_nint ("NINT", e, k);
3893 }
3894
3895
3896 gfc_expr *
3897 gfc_simplify_idnint (gfc_expr *e)
3898 {
3899   return simplify_nint ("IDNINT", e, NULL);
3900 }
3901
3902
3903 gfc_expr *
3904 gfc_simplify_not (gfc_expr *e)
3905 {
3906   gfc_expr *result;
3907
3908   if (e->expr_type != EXPR_CONSTANT)
3909     return NULL;
3910
3911   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3912
3913   mpz_com (result->value.integer, e->value.integer);
3914
3915   return range_check (result, "NOT");
3916 }
3917
3918
3919 gfc_expr *
3920 gfc_simplify_null (gfc_expr *mold)
3921 {
3922   gfc_expr *result;
3923
3924   if (mold == NULL)
3925     {
3926       result = gfc_get_expr ();
3927       result->ts.type = BT_UNKNOWN;
3928     }
3929   else
3930     result = gfc_copy_expr (mold);
3931   result->expr_type = EXPR_NULL;
3932
3933   return result;
3934 }
3935
3936
3937 gfc_expr *
3938 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3939 {
3940   gfc_expr *result;
3941   int kind;
3942
3943   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3944     return NULL;
3945
3946   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3947   if (x->ts.type == BT_INTEGER)
3948     {
3949       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3950       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3951       return range_check (result, "OR");
3952     }
3953   else /* BT_LOGICAL */
3954     {
3955       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3956       result->value.logical = x->value.logical || y->value.logical;
3957       return result;
3958     }
3959 }
3960
3961
3962 gfc_expr *
3963 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3964 {
3965   gfc_expr *result;
3966   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3967
3968   if (!is_constant_array_expr(array)
3969       || !is_constant_array_expr(vector)
3970       || (!gfc_is_constant_expr (mask)
3971           && !is_constant_array_expr(mask)))
3972     return NULL;
3973
3974   result = gfc_start_constructor (array->ts.type,
3975                                   array->ts.kind,
3976                                   &array->where);
3977
3978   array_ctor = array->value.constructor;
3979   vector_ctor = vector ? vector->value.constructor : NULL;
3980
3981   if (mask->expr_type == EXPR_CONSTANT
3982       && mask->value.logical)
3983     {
3984       /* Copy all elements of ARRAY to RESULT.  */
3985       while (array_ctor)
3986         {
3987           gfc_append_constructor (result,
3988                                   gfc_copy_expr (array_ctor->expr));
3989
3990           ADVANCE (array_ctor, 1);
3991           ADVANCE (vector_ctor, 1);
3992         }
3993     }
3994   else if (mask->expr_type == EXPR_ARRAY)
3995     {
3996       /* Copy only those elements of ARRAY to RESULT whose
3997          MASK equals .TRUE..  */
3998       mask_ctor = mask->value.constructor;
3999       while (mask_ctor)
4000         {
4001           if (mask_ctor->expr->value.logical)
4002             {
4003               gfc_append_constructor (result,
4004                                       gfc_copy_expr (array_ctor->expr));
4005               ADVANCE (vector_ctor, 1);
4006             }
4007
4008           ADVANCE (array_ctor, 1);
4009           ADVANCE (mask_ctor, 1);
4010         }
4011     }
4012
4013   /* Append any left-over elements from VECTOR to RESULT.  */
4014   while (vector_ctor)
4015     {
4016       gfc_append_constructor (result,
4017                               gfc_copy_expr (vector_ctor->expr));
4018       ADVANCE (vector_ctor, 1);
4019     }
4020
4021   result->shape = gfc_get_shape (1);
4022   gfc_array_size (result, &result->shape[0]);
4023
4024   if (array->ts.type == BT_CHARACTER)
4025     result->ts.u.cl = array->ts.u.cl;
4026
4027   return result;
4028 }
4029
4030
4031 gfc_expr *
4032 gfc_simplify_precision (gfc_expr *e)
4033 {
4034   gfc_expr *result;
4035   int i;
4036
4037   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4038
4039   result = gfc_int_expr (gfc_real_kinds[i].precision);
4040   result->where = e->where;
4041
4042   return result;
4043 }
4044
4045
4046 gfc_expr *
4047 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4048 {
4049   gfc_expr *result;
4050
4051   if (!is_constant_array_expr (array)
4052       || !gfc_is_constant_expr (dim))
4053     return NULL;
4054
4055   if (mask
4056       && !is_constant_array_expr (mask)
4057       && mask->expr_type != EXPR_CONSTANT)
4058     return NULL;
4059
4060   result = transformational_result (array, dim, array->ts.type,
4061                                     array->ts.kind, &array->where);
4062   init_result_expr (result, 1, NULL);
4063
4064   return !dim || array->rank == 1 ?
4065     simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
4066     simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4067 }
4068
4069
4070 gfc_expr *
4071 gfc_simplify_radix (gfc_expr *e)
4072 {
4073   gfc_expr *result;
4074   int i;
4075
4076   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4077   switch (e->ts.type)
4078     {
4079     case BT_INTEGER:
4080       i = gfc_integer_kinds[i].radix;
4081       break;
4082
4083     case BT_REAL:
4084       i = gfc_real_kinds[i].radix;
4085       break;
4086
4087     default:
4088       gcc_unreachable ();
4089     }
4090
4091   result = gfc_int_expr (i);
4092   result->where = e->where;
4093
4094   return result;
4095 }
4096
4097
4098 gfc_expr *
4099 gfc_simplify_range (gfc_expr *e)
4100 {
4101   gfc_expr *result;
4102   int i;
4103   long j;
4104
4105   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4106
4107   switch (e->ts.type)
4108     {
4109     case BT_INTEGER:
4110       j = gfc_integer_kinds[i].range;
4111       break;
4112
4113     case BT_REAL:
4114     case BT_COMPLEX:
4115       j = gfc_real_kinds[i].range;
4116       break;
4117
4118     default:
4119       gcc_unreachable ();
4120     }
4121
4122   result = gfc_int_expr (j);
4123   result->where = e->where;
4124
4125   return result;
4126 }
4127
4128
4129 gfc_expr *
4130 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4131 {
4132   gfc_expr *result = NULL;
4133   int kind;
4134
4135   if (e->ts.type == BT_COMPLEX)
4136     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4137   else
4138     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4139
4140   if (kind == -1)
4141     return &gfc_bad_expr;
4142
4143   if (e->expr_type != EXPR_CONSTANT)
4144     return NULL;
4145
4146   switch (e->ts.type)
4147     {
4148     case BT_INTEGER:
4149       if (!e->is_boz)
4150         result = gfc_int2real (e, kind);
4151       break;
4152
4153     case BT_REAL:
4154       result = gfc_real2real (e, kind);
4155       break;
4156
4157     case BT_COMPLEX:
4158       result = gfc_complex2real (e, kind);
4159       break;
4160
4161     default:
4162       gfc_internal_error ("bad type in REAL");
4163       /* Not reached */
4164     }
4165
4166   if (e->ts.type == BT_INTEGER && e->is_boz)
4167     {
4168       gfc_typespec ts;
4169       gfc_clear_ts (&ts);
4170       ts.type = BT_REAL;
4171       ts.kind = kind;
4172       result = gfc_copy_expr (e);
4173       if (!gfc_convert_boz (result, &ts))
4174         {
4175           gfc_free_expr (result);
4176           return &gfc_bad_expr;
4177         }
4178     }
4179
4180   return range_check (result, "REAL");
4181 }
4182
4183
4184 gfc_expr *
4185 gfc_simplify_realpart (gfc_expr *e)
4186 {
4187   gfc_expr *result;
4188
4189   if (e->expr_type != EXPR_CONSTANT)
4190     return NULL;
4191
4192   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4193   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4194   return range_check (result, "REALPART");
4195 }
4196
4197 gfc_expr *
4198 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4199 {
4200   gfc_expr *result;
4201   int i, j, len, ncop, nlen;
4202   mpz_t ncopies;
4203   bool have_length = false;
4204
4205   /* If NCOPIES isn't a constant, there's nothing we can do.  */
4206   if (n->expr_type != EXPR_CONSTANT)
4207     return NULL;
4208
4209   /* If NCOPIES is negative, it's an error.  */
4210   if (mpz_sgn (n->value.integer) < 0)
4211     {
4212       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4213                  &n->where);
4214       return &gfc_bad_expr;
4215     }
4216
4217   /* If we don't know the character length, we can do no more.  */
4218   if (e->ts.u.cl && e->ts.u.cl->length
4219         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4220     {
4221       len = mpz_get_si (e->ts.u.cl->length->value.integer);
4222       have_length = true;
4223     }
4224   else if (e->expr_type == EXPR_CONSTANT
4225              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4226     {
4227       len = e->value.character.length;
4228     }
4229   else
4230     return NULL;
4231
4232   /* If the source length is 0, any value of NCOPIES is valid
4233      and everything behaves as if NCOPIES == 0.  */
4234   mpz_init (ncopies);
4235   if (len == 0)
4236     mpz_set_ui (ncopies, 0);
4237   else
4238     mpz_set (ncopies, n->value.integer);
4239
4240   /* Check that NCOPIES isn't too large.  */
4241   if (len)
4242     {
4243       mpz_t max, mlen;
4244       int i;
4245
4246       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
4247       mpz_init (max);
4248       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4249
4250       if (have_length)
4251         {
4252           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4253                       e->ts.u.cl->length->value.integer);
4254         }
4255       else
4256         {
4257           mpz_init_set_si (mlen, len);
4258           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4259           mpz_clear (mlen);
4260         }
4261
4262       /* The check itself.  */
4263       if (mpz_cmp (ncopies, max) > 0)
4264         {
4265           mpz_clear (max);
4266           mpz_clear (ncopies);
4267           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4268                      &n->where);
4269           return &gfc_bad_expr;
4270         }
4271
4272       mpz_clear (max);
4273     }
4274   mpz_clear (ncopies);
4275
4276   /* For further simplification, we need the character string to be
4277      constant.  */
4278   if (e->expr_type != EXPR_CONSTANT)
4279     return NULL;
4280
4281   if (len ||
4282       (e->ts.u.cl->length &&
4283        mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4284     {
4285       const char *res = gfc_extract_int (n, &ncop);
4286       gcc_assert (res == NULL);
4287     }
4288   else
4289     ncop = 0;
4290
4291   len = e->value.character.length;
4292   nlen = ncop * len;
4293
4294   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4295
4296   if (ncop == 0)
4297     {
4298       result->value.character.string = gfc_get_wide_string (1);
4299       result->value.character.length = 0;
4300       result->value.character.string[0] = '\0';
4301       return result;
4302     }
4303
4304   result->value.character.length = nlen;
4305   result->value.character.string = gfc_get_wide_string (nlen + 1);
4306
4307   for (i = 0; i < ncop; i++)
4308     for (j = 0; j < len; j++)
4309       result->value.character.string[j+i*len]= e->value.character.string[j];
4310
4311   result->value.character.string[nlen] = '\0';  /* For debugger */
4312   return result;
4313 }
4314
4315
4316 /* This one is a bear, but mainly has to do with shuffling elements.  */
4317
4318 gfc_expr *
4319 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4320                       gfc_expr *pad, gfc_expr *order_exp)
4321 {
4322   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4323   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4324   gfc_constructor *head, *tail;
4325   mpz_t index, size;
4326   unsigned long j;
4327   size_t nsource;
4328   gfc_expr *e;
4329
4330   /* Check that argument expression types are OK.  */
4331   if (!is_constant_array_expr (source)
4332       || !is_constant_array_expr (shape_exp)
4333       || !is_constant_array_expr (pad)
4334       || !is_constant_array_expr (order_exp))
4335     return NULL;
4336
4337   /* Proceed with simplification, unpacking the array.  */
4338
4339   mpz_init (index);
4340   rank = 0;
4341   head = tail = NULL;
4342
4343   for (;;)
4344     {
4345       e = gfc_get_array_element (shape_exp, rank);
4346       if (e == NULL)
4347         break;
4348
4349       gfc_extract_int (e, &shape[rank]);
4350
4351       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4352       gcc_assert (shape[rank] >= 0);
4353
4354       gfc_free_expr (e);
4355       rank++;
4356     }
4357
4358   gcc_assert (rank > 0);
4359
4360   /* Now unpack the order array if present.  */
4361   if (order_exp == NULL)
4362     {
4363       for (i = 0; i < rank; i++)
4364         order[i] = i;
4365     }
4366   else
4367     {
4368       for (i = 0; i < rank; i++)
4369         x[i] = 0;
4370
4371       for (i = 0; i < rank; i++)
4372         {
4373           e = gfc_get_array_element (order_exp, i);
4374           gcc_assert (e);
4375
4376           gfc_extract_int (e, &order[i]);
4377           gfc_free_expr (e);
4378
4379           gcc_assert (order[i] >= 1 && order[i] <= rank);
4380           order[i]--;
4381           gcc_assert (x[order[i]] == 0);
4382           x[order[i]] = 1;
4383         }
4384     }
4385
4386   /* Count the elements in the source and padding arrays.  */
4387
4388   npad = 0;
4389   if (pad != NULL)
4390     {
4391       gfc_array_size (pad, &size);
4392       npad = mpz_get_ui (size);
4393       mpz_clear (size);
4394     }
4395
4396   gfc_array_size (source, &size);
4397   nsource = mpz_get_ui (size);
4398   mpz_clear (size);
4399
4400   /* If it weren't for that pesky permutation we could just loop
4401      through the source and round out any shortage with pad elements.
4402      But no, someone just had to have the compiler do something the
4403      user should be doing.  */
4404
4405   for (i = 0; i < rank; i++)
4406     x[i] = 0;
4407
4408   while (nsource > 0 || npad > 0)
4409     {
4410       /* Figure out which element to extract.  */
4411       mpz_set_ui (index, 0);
4412
4413       for (i = rank - 1; i >= 0; i--)
4414         {
4415           mpz_add_ui (index, index, x[order[i]]);
4416           if (i != 0)
4417             mpz_mul_ui (index, index, shape[order[i - 1]]);
4418         }
4419
4420       if (mpz_cmp_ui (index, INT_MAX) > 0)
4421         gfc_internal_error ("Reshaped array too large at %C");
4422
4423       j = mpz_get_ui (index);
4424
4425       if (j < nsource)
4426         e = gfc_get_array_element (source, j);
4427       else
4428         {
4429           gcc_assert (npad > 0);
4430
4431           j = j - nsource;
4432           j = j % npad;
4433           e = gfc_get_array_element (pad, j);
4434         }
4435       gcc_assert (e);
4436
4437       if (head == NULL)
4438         head = tail = gfc_get_constructor ();
4439       else
4440         {
4441           tail->next = gfc_get_constructor ();
4442           tail = tail->next;
4443         }
4444
4445       tail->where = e->where;
4446       tail->expr = e;
4447
4448       /* Calculate the next element.  */
4449       i = 0;
4450
4451 inc:
4452       if (++x[i] < shape[i])
4453         continue;
4454       x[i++] = 0;
4455       if (i < rank)
4456         goto inc;
4457
4458       break;
4459     }
4460
4461   mpz_clear (index);
4462
4463   e = gfc_get_expr ();
4464   e->where = source->where;
4465   e->expr_type = EXPR_ARRAY;
4466   e->value.constructor = head;
4467   e->shape = gfc_get_shape (rank);
4468
4469   for (i = 0; i < rank; i++)
4470     mpz_init_set_ui (e->shape[i], shape[i]);
4471
4472   e->ts = source->ts;
4473   e->rank = rank;
4474
4475   return e;
4476 }
4477
4478
4479 gfc_expr *
4480 gfc_simplify_rrspacing (gfc_expr *x)
4481 {
4482   gfc_expr *result;
4483   int i;
4484   long int e, p;
4485
4486   if (x->expr_type != EXPR_CONSTANT)
4487     return NULL;
4488
4489   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4490
4491   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4492
4493   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4494
4495   /* Special case x = -0 and 0.  */
4496   if (mpfr_sgn (result->value.real) == 0)
4497     {
4498       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4499       return result;
4500     }
4501
4502   /* | x * 2**(-e) | * 2**p.  */
4503   e = - (long int) mpfr_get_exp (x->value.real);
4504   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4505
4506   p = (long int) gfc_real_kinds[i].digits;
4507   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4508
4509   return range_check (result, "RRSPACING");
4510 }
4511
4512
4513 gfc_expr *
4514 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4515 {
4516   int k, neg_flag, power, exp_range;
4517   mpfr_t scale, radix;
4518   gfc_expr *result;
4519
4520   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4521     return NULL;
4522
4523   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4524
4525   if (mpfr_sgn (x->value.real) == 0)
4526     {
4527       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4528       return result;
4529     }
4530
4531   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4532
4533   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4534
4535   /* This check filters out values of i that would overflow an int.  */
4536   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4537       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4538     {
4539       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4540       gfc_free_expr (result);
4541       return &gfc_bad_expr;
4542     }
4543
4544   /* Compute scale = radix ** power.  */
4545   power = mpz_get_si (i->value.integer);
4546
4547   if (power >= 0)
4548     neg_flag = 0;
4549   else
4550     {
4551       neg_flag = 1;
4552       power = -power;
4553     }
4554
4555   gfc_set_model_kind (x->ts.kind);
4556   mpfr_init (scale);
4557   mpfr_init (radix);
4558   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4559   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4560
4561   if (neg_flag)
4562     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4563   else
4564     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4565
4566   mpfr_clears (scale, radix, NULL);
4567
4568   return range_check (result, "SCALE");
4569 }
4570
4571
4572 /* Variants of strspn and strcspn that operate on wide characters.  */
4573
4574 static size_t
4575 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4576 {
4577   size_t i = 0;
4578   const gfc_char_t *c;
4579
4580   while (s1[i])
4581     {
4582       for (c = s2; *c; c++)
4583         {
4584           if (s1[i] == *c)
4585             break;
4586         }
4587       if (*c == '\0')
4588         break;
4589       i++;
4590     }
4591
4592   return i;
4593 }
4594
4595 static size_t
4596 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4597 {
4598   size_t i = 0;
4599   const gfc_char_t *c;
4600
4601   while (s1[i])
4602     {
4603       for (c = s2; *c; c++)
4604         {
4605           if (s1[i] == *c)
4606             break;
4607         }
4608       if (*c)
4609         break;
4610       i++;
4611     }
4612
4613   return i;
4614 }
4615
4616
4617 gfc_expr *
4618 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4619 {
4620   gfc_expr *result;
4621   int back;
4622   size_t i;
4623   size_t indx, len, lenc;
4624   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4625
4626   if (k == -1)
4627     return &gfc_bad_expr;
4628
4629   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4630     return NULL;
4631
4632   if (b != NULL && b->value.logical != 0)
4633     back = 1;
4634   else
4635     back = 0;
4636
4637   result = gfc_constant_result (BT_INTEGER, k, &e->where);
4638
4639   len = e->value.character.length;
4640   lenc = c->value.character.length;
4641
4642   if (len == 0 || lenc == 0)
4643     {
4644       indx = 0;
4645     }
4646   else
4647     {
4648       if (back == 0)
4649         {
4650           indx = wide_strcspn (e->value.character.string,
4651                                c->value.character.string) + 1;
4652           if (indx > len)
4653             indx = 0;
4654         }
4655       else
4656         {
4657           i = 0;
4658           for (indx = len; indx > 0; indx--)
4659             {
4660               for (i = 0; i < lenc; i++)
4661                 {
4662                   if (c->value.character.string[i]
4663                       == e->value.character.string[indx - 1])
4664                     break;
4665                 }
4666               if (i < lenc)
4667                 break;
4668             }
4669         }
4670     }
4671   mpz_set_ui (result->value.integer, indx);
4672   return range_check (result, "SCAN");
4673 }
4674
4675
4676 gfc_expr *
4677 gfc_simplify_selected_char_kind (gfc_expr *e)
4678 {
4679   int kind;
4680   gfc_expr *result;
4681
4682   if (e->expr_type != EXPR_CONSTANT)
4683     return NULL;
4684
4685   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4686       || gfc_compare_with_Cstring (e, "default", false) == 0)
4687     kind = 1;
4688   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4689     kind = 4;
4690   else
4691     kind = -1;
4692
4693   result = gfc_int_expr (kind);
4694   result->where = e->where;
4695
4696   return result;
4697 }
4698
4699
4700 gfc_expr *
4701 gfc_simplify_selected_int_kind (gfc_expr *e)
4702 {
4703   int i, kind, range;
4704   gfc_expr *result;
4705
4706   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4707     return NULL;
4708
4709   kind = INT_MAX;
4710
4711   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4712     if (gfc_integer_kinds[i].range >= range
4713         && gfc_integer_kinds[i].kind < kind)
4714       kind = gfc_integer_kinds[i].kind;
4715
4716   if (kind == INT_MAX)
4717     kind = -1;
4718
4719   result = gfc_int_expr (kind);
4720   result->where = e->where;
4721
4722   return result;
4723 }
4724
4725
4726 gfc_expr *
4727 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4728 {
4729   int range, precision, i, kind, found_precision, found_range;
4730   gfc_expr *result;
4731
4732   if (p == NULL)
4733     precision = 0;
4734   else
4735     {
4736       if (p->expr_type != EXPR_CONSTANT
4737           || gfc_extract_int (p, &precision) != NULL)
4738         return NULL;
4739     }
4740
4741   if (q == NULL)
4742     range = 0;
4743   else
4744     {
4745       if (q->expr_type != EXPR_CONSTANT
4746           || gfc_extract_int (q, &range) != NULL)
4747         return NULL;
4748     }
4749
4750   kind = INT_MAX;
4751   found_precision = 0;
4752   found_range = 0;
4753
4754   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4755     {
4756       if (gfc_real_kinds[i].precision >= precision)
4757         found_precision = 1;
4758
4759       if (gfc_real_kinds[i].range >= range)
4760         found_range = 1;
4761
4762       if (gfc_real_kinds[i].precision >= precision
4763           && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4764         kind = gfc_real_kinds[i].kind;
4765     }
4766
4767   if (kind == INT_MAX)
4768     {
4769       kind = 0;
4770
4771       if (!found_precision)
4772         kind = -1;
4773       if (!found_range)
4774         kind -= 2;
4775     }
4776
4777   result = gfc_int_expr (kind);
4778   result->where = (p != NULL) ? p->where : q->where;
4779
4780   return result;
4781 }
4782
4783
4784 gfc_expr *
4785 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4786 {
4787   gfc_expr *result;
4788   mpfr_t exp, absv, log2, pow2, frac;
4789   unsigned long exp2;
4790
4791   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4792     return NULL;
4793
4794   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4795
4796   if (mpfr_sgn (x->value.real) == 0)
4797     {
4798       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4799       return result;
4800     }
4801
4802   gfc_set_model_kind (x->ts.kind);
4803   mpfr_init (absv);
4804   mpfr_init (log2);
4805   mpfr_init (exp);
4806   mpfr_init (pow2);
4807   mpfr_init (frac);
4808
4809   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4810   mpfr_log2 (log2, absv, GFC_RND_MODE);
4811
4812   mpfr_trunc (log2, log2);
4813   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4814
4815   /* Old exponent value, and fraction.  */
4816   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4817
4818   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4819
4820   /* New exponent.  */
4821   exp2 = (unsigned long) mpz_get_d (i->value.integer);
4822   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4823
4824   mpfr_clears (absv, log2, pow2, frac, NULL);
4825
4826   return range_check (result, "SET_EXPONENT");
4827 }
4828
4829
4830 gfc_expr *
4831 gfc_simplify_shape (gfc_expr *source)
4832 {
4833   mpz_t shape[GFC_MAX_DIMENSIONS];
4834   gfc_expr *result, *e, *f;
4835   gfc_array_ref *ar;
4836   int n;
4837   gfc_try t;
4838
4839   if (source->rank == 0)
4840     return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4841                                   &source->where);
4842
4843   if (source->expr_type != EXPR_VARIABLE)
4844     return NULL;
4845
4846   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4847                                   &source->where);
4848
4849   ar = gfc_find_array_ref (source);
4850
4851   t = gfc_array_ref_shape (ar, shape);
4852
4853   for (n = 0; n < source->rank; n++)
4854     {
4855       e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4856                                &source->where);
4857
4858       if (t == SUCCESS)
4859         {
4860           mpz_set (e->value.integer, shape[n]);
4861           mpz_clear (shape[n]);
4862         }
4863       else
4864         {
4865           mpz_set_ui (e->value.integer, n + 1);
4866
4867           f = gfc_simplify_size (source, e, NULL);
4868           gfc_free_expr (e);
4869           if (f == NULL)
4870             {
4871               gfc_free_expr (result);
4872               return NULL;
4873             }
4874           else
4875             {
4876               e = f;
4877             }
4878         }
4879
4880       gfc_append_constructor (result, e);
4881     }
4882
4883   return result;
4884 }
4885
4886
4887 gfc_expr *
4888 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4889 {
4890   mpz_t size;
4891   gfc_expr *result;
4892   int d;
4893   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4894
4895   if (k == -1)
4896     return &gfc_bad_expr;
4897
4898   if (dim == NULL)
4899     {
4900       if (gfc_array_size (array, &size) == FAILURE)
4901         return NULL;
4902     }
4903   else
4904     {
4905       if (dim->expr_type != EXPR_CONSTANT)
4906         return NULL;
4907
4908       d = mpz_get_ui (dim->value.integer) - 1;
4909       if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4910         return NULL;
4911     }
4912
4913   result = gfc_constant_result (BT_INTEGER, k, &array->where);
4914   mpz_set (result->value.integer, size);
4915   return result;
4916 }
4917
4918
4919 gfc_expr *
4920 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4921 {
4922   gfc_expr *result;
4923
4924   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4925     return NULL;
4926
4927   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4928
4929   switch (x->ts.type)
4930     {
4931     case BT_INTEGER:
4932       mpz_abs (result->value.integer, x->value.integer);
4933       if (mpz_sgn (y->value.integer) < 0)
4934         mpz_neg (result->value.integer, result->value.integer);
4935       break;
4936
4937     case BT_REAL:
4938       if (gfc_option.flag_sign_zero)
4939         mpfr_copysign (result->value.real, x->value.real, y->value.real,
4940                        GFC_RND_MODE);
4941       else
4942         mpfr_setsign (result->value.real, x->value.real,
4943                       mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4944       break;
4945
4946     default:
4947       gfc_internal_error ("Bad type in gfc_simplify_sign");
4948     }
4949
4950   return result;
4951 }
4952
4953
4954 gfc_expr *
4955 gfc_simplify_sin (gfc_expr *x)
4956 {
4957   gfc_expr *result;
4958
4959   if (x->expr_type != EXPR_CONSTANT)
4960     return NULL;
4961
4962   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4963
4964   switch (x->ts.type)
4965     {
4966     case BT_REAL:
4967       mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4968       break;
4969
4970     case BT_COMPLEX:
4971       gfc_set_model (x->value.real);
4972       mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4973       break;
4974
4975     default:
4976       gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4977     }
4978
4979   return range_check (result, "SIN");
4980 }
4981
4982
4983 gfc_expr *
4984 gfc_simplify_sinh (gfc_expr *x)
4985 {
4986   gfc_expr *result;
4987
4988   if (x->expr_type != EXPR_CONSTANT)
4989     return NULL;
4990
4991   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4992
4993   if (x->ts.type == BT_REAL)
4994     mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4995   else if (x->ts.type == BT_COMPLEX)
4996     mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4997   else
4998     gcc_unreachable ();
4999
5000
5001   return range_check (result, "SINH");
5002 }
5003
5004
5005 /* The argument is always a double precision real that is converted to
5006    single precision.  TODO: Rounding!  */
5007
5008 gfc_expr *
5009 gfc_simplify_sngl (gfc_expr *a)
5010 {
5011   gfc_expr *result;
5012
5013   if (a->expr_type != EXPR_CONSTANT)
5014     return NULL;
5015
5016   result = gfc_real2real (a, gfc_default_real_kind);
5017   return range_check (result, "SNGL");
5018 }
5019
5020
5021 gfc_expr *
5022 gfc_simplify_spacing (gfc_expr *x)
5023 {
5024   gfc_expr *result;
5025   int i;
5026   long int en, ep;
5027
5028   if (x->expr_type != EXPR_CONSTANT)
5029     return NULL;
5030
5031   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5032
5033   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
5034
5035   /* Special case x = 0 and -0.  */
5036   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5037   if (mpfr_sgn (result->value.real) == 0)
5038     {
5039       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5040       return result;
5041     }
5042
5043   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5044      are the radix, exponent of x, and precision.  This excludes the
5045      possibility of subnormal numbers.  Fortran 2003 states the result is
5046      b**max(e - p, emin - 1).  */
5047
5048   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5049   en = (long int) gfc_real_kinds[i].min_exponent - 1;
5050   en = en > ep ? en : ep;
5051
5052   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5053   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5054
5055   return range_check (result, "SPACING");
5056 }
5057
5058
5059 gfc_expr *
5060 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5061 {
5062   gfc_expr *result = 0L;
5063   int i, j, dim, ncopies;
5064   mpz_t size;
5065
5066   if ((!gfc_is_constant_expr (source)
5067        && !is_constant_array_expr (source))
5068       || !gfc_is_constant_expr (dim_expr)
5069       || !gfc_is_constant_expr (ncopies_expr))
5070     return NULL;
5071
5072   gcc_assert (dim_expr->ts.type == BT_INTEGER);
5073   gfc_extract_int (dim_expr, &dim);
5074   dim -= 1;   /* zero-base DIM */
5075
5076   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5077   gfc_extract_int (ncopies_expr, &ncopies);
5078   ncopies = MAX (ncopies, 0);
5079
5080   /* Do not allow the array size to exceed the limit for an array
5081      constructor.  */
5082   if (source->expr_type == EXPR_ARRAY)
5083     {
5084       if (gfc_array_size (source, &size) == FAILURE)
5085         gfc_internal_error ("Failure getting length of a constant array.");
5086     }
5087   else
5088     mpz_init_set_ui (size, 1);
5089
5090   if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5091     return NULL;
5092
5093   if (source->expr_type == EXPR_CONSTANT)
5094     {
5095       gcc_assert (dim == 0);
5096
5097       result = gfc_start_constructor (source->ts.type,
5098                                       source->ts.kind,
5099                                       &source->where);
5100       result->rank = 1;
5101       result->shape = gfc_get_shape (result->rank);
5102       mpz_init_set_si (result->shape[0], ncopies);
5103
5104       for (i = 0; i < ncopies; ++i)
5105         gfc_append_constructor (result, gfc_copy_expr (source));
5106     }
5107   else if (source->expr_type == EXPR_ARRAY)
5108     {
5109       int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5110       gfc_constructor *ctor, *source_ctor, *result_ctor;
5111
5112       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5113       gcc_assert (dim >= 0 && dim <= source->rank);
5114
5115       result = gfc_start_constructor (source->ts.type,
5116                                       source->ts.kind,
5117                                       &source->where);
5118       result->rank = source->rank + 1;
5119       result->shape = gfc_get_shape (result->rank);
5120
5121       result_size = 1;
5122       for (i = 0, j = 0; i < result->rank; ++i)
5123         {
5124           if (i != dim)
5125             mpz_init_set (result->shape[i], source->shape[j++]);
5126           else
5127             mpz_init_set_si (result->shape[i], ncopies);
5128
5129           extent[i] = mpz_get_si (result->shape[i]);
5130           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5131           result_size *= extent[i];
5132         }
5133
5134       for (i = 0; i < result_size; ++i)
5135         gfc_append_constructor (result, NULL);
5136
5137       source_ctor = source->value.constructor;
5138       result_ctor = result->value.constructor;
5139       while (source_ctor)
5140         {
5141           ctor = result_ctor;
5142
5143           for (i = 0; i < ncopies; ++i)
5144           {
5145             ctor->expr = gfc_copy_expr (source_ctor->expr);
5146             ADVANCE (ctor, rstride[dim]);
5147           }
5148
5149           ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
5150           ADVANCE (source_ctor, 1);
5151         }
5152     }
5153   else
5154     /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5155        Replace NULL with gcc_unreachable() after implementing
5156        gfc_simplify_cshift(). */
5157     return NULL;
5158
5159   if (source->ts.type == BT_CHARACTER)
5160     result->ts.u.cl = source->ts.u.cl;
5161
5162   return result;
5163 }
5164
5165
5166 gfc_expr *
5167 gfc_simplify_sqrt (gfc_expr *e)
5168 {
5169   gfc_expr *result;
5170
5171   if (e->expr_type != EXPR_CONSTANT)
5172     return NULL;
5173
5174   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
5175
5176   switch (e->ts.type)
5177     {
5178     case BT_REAL:
5179       if (mpfr_cmp_si (e->value.real, 0) < 0)
5180         goto negative_arg;
5181       mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5182
5183       break;
5184
5185     case BT_COMPLEX:
5186       gfc_set_model (e->value.real);
5187       mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5188       break;
5189
5190     default:
5191       gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5192     }
5193
5194   return range_check (result, "SQRT");
5195
5196 negative_arg:
5197   gfc_free_expr (result);
5198   gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
5199   return &gfc_bad_expr;
5200 }
5201
5202
5203 gfc_expr *
5204 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5205 {
5206   gfc_expr *result;
5207
5208   if (!is_constant_array_expr (array)
5209       || !gfc_is_constant_expr (dim))
5210     return NULL;
5211
5212   if (mask
5213       && !is_constant_array_expr (mask)
5214       && mask->expr_type != EXPR_CONSTANT)
5215     return NULL;
5216
5217   result = transformational_result (array, dim, array->ts.type,
5218                                     array->ts.kind, &array->where);
5219   init_result_expr (result, 0, NULL);
5220
5221   return !dim || array->rank == 1 ?
5222     simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5223     simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5224 }
5225
5226
5227 gfc_expr *
5228 gfc_simplify_tan (gfc_expr *x)
5229 {
5230   gfc_expr *result;
5231
5232   if (x->expr_type != EXPR_CONSTANT)
5233     return NULL;
5234
5235   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
5236
5237   if (x->ts.type == BT_REAL)
5238     mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5239   else if (x->ts.type == BT_COMPLEX)
5240     mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5241   else
5242     gcc_unreachable ();
5243
5244   return range_check (result, "TAN");
5245 }
5246
5247
5248 gfc_expr *
5249 gfc_simplify_tanh (gfc_expr *x)
5250 {
5251   gfc_expr *result;
5252
5253   if (x->expr_type != EXPR_CONSTANT)
5254     return NULL;
5255
5256   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
5257
5258   if (x->ts.type == BT_REAL)
5259     mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5260   else if (x->ts.type == BT_COMPLEX)
5261     mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5262   else
5263     gcc_unreachable ();
5264
5265   return range_check (result, "TANH");
5266
5267 }
5268
5269
5270 gfc_expr *
5271 gfc_simplify_tiny (gfc_expr *e)
5272 {
5273   gfc_expr *result;
5274   int i;
5275
5276   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5277
5278   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
5279   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5280
5281   return result;
5282 }
5283
5284
5285 gfc_expr *
5286 gfc_simplify_trailz (gfc_expr *e)
5287 {
5288   gfc_expr *result;
5289   unsigned long tz, bs;
5290   int i;
5291
5292   if (e->expr_type != EXPR_CONSTANT)
5293     return NULL;
5294
5295   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5296   bs = gfc_integer_kinds[i].bit_size;
5297   tz = mpz_scan1 (e->value.integer, 0);
5298
5299   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
5300   mpz_set_ui (result->value.integer, MIN (tz, bs));
5301
5302   return result;
5303 }
5304
5305
5306 gfc_expr *
5307 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5308 {
5309   gfc_expr *result;
5310   gfc_expr *mold_element;
5311   size_t source_size;
5312   size_t result_size;
5313   size_t result_elt_size;
5314   size_t buffer_size;
5315   mpz_t tmp;
5316   unsigned char *buffer;
5317
5318   if (!gfc_is_constant_expr (source)
5319         || (gfc_init_expr && !gfc_is_constant_expr (mold))
5320         || !gfc_is_constant_expr (size))
5321     return NULL;
5322
5323   if (source->expr_type == EXPR_FUNCTION)
5324     return NULL;
5325
5326   /* Calculate the size of the source.  */
5327   if (source->expr_type == EXPR_ARRAY
5328       && gfc_array_size (source, &tmp) == FAILURE)
5329     gfc_internal_error ("Failure getting length of a constant array.");
5330
5331   source_size = gfc_target_expr_size (source);
5332
5333   /* Create an empty new expression with the appropriate characteristics.  */
5334   result = gfc_constant_result (mold->ts.type, mold->ts.kind,
5335                                 &source->where);
5336   result->ts = mold->ts;
5337
5338   mold_element = mold->expr_type == EXPR_ARRAY
5339                  ? mold->value.constructor->expr
5340                  : mold;
5341
5342   /* Set result character length, if needed.  Note that this needs to be
5343      set even for array expressions, in order to pass this information into
5344      gfc_target_interpret_expr.  */
5345   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5346     result->value.character.length = mold_element->value.character.length;
5347
5348   /* Set the number of elements in the result, and determine its size.  */
5349   result_elt_size = gfc_target_expr_size (mold_element);
5350   if (result_elt_size == 0)
5351     {
5352       gfc_free_expr (result);
5353       return NULL;
5354     }
5355
5356   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5357     {
5358       int result_length;
5359
5360       result->expr_type = EXPR_ARRAY;
5361       result->rank = 1;
5362
5363       if (size)
5364         result_length = (size_t)mpz_get_ui (size->value.integer);
5365       else
5366         {
5367           result_length = source_size / result_elt_size;
5368           if (result_length * result_elt_size < source_size)
5369             result_length += 1;
5370         }
5371
5372       result->shape = gfc_get_shape (1);
5373       mpz_init_set_ui (result->shape[0], result_length);
5374
5375       result_size = result_length * result_elt_size;
5376     }
5377   else
5378     {
5379       result->rank = 0;
5380       result_size = result_elt_size;
5381     }
5382
5383   if (gfc_option.warn_surprising && source_size < result_size)
5384     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5385                 "source size %ld < result size %ld", &source->where,
5386                 (long) source_size, (long) result_size);
5387
5388   /* Allocate the buffer to store the binary version of the source.  */
5389   buffer_size = MAX (source_size, result_size);
5390   buffer = (unsigned char*)alloca (buffer_size);
5391   memset (buffer, 0, buffer_size);
5392
5393   /* Now write source to the buffer.  */
5394   gfc_target_encode_expr (source, buffer, buffer_size);
5395
5396   /* And read the buffer back into the new expression.  */
5397   gfc_target_interpret_expr (buffer, buffer_size, result);
5398
5399   return result;
5400 }
5401
5402
5403 gfc_expr *
5404 gfc_simplify_transpose (gfc_expr *matrix)
5405 {
5406   int i, matrix_rows;
5407   gfc_expr *result;
5408   gfc_constructor *matrix_ctor;
5409
5410   if (!is_constant_array_expr (matrix))
5411     return NULL;
5412
5413   gcc_assert (matrix->rank == 2);
5414
5415   result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where);
5416   result->rank = 2;
5417   result->shape = gfc_get_shape (result->rank);
5418   mpz_set (result->shape[0], matrix->shape[1]);
5419   mpz_set (result->shape[1], matrix->shape[0]);
5420
5421   if (matrix->ts.type == BT_CHARACTER)
5422     result->ts.u.cl = matrix->ts.u.cl;
5423
5424   matrix_rows = mpz_get_si (matrix->shape[0]);
5425   matrix_ctor = matrix->value.constructor;
5426   for (i = 0; i < matrix_rows; ++i)
5427     {
5428       gfc_constructor *column_ctor = matrix_ctor;
5429       while (column_ctor)
5430         {
5431           gfc_append_constructor (result,
5432                                   gfc_copy_expr (column_ctor->expr));
5433
5434           ADVANCE (column_ctor, matrix_rows);
5435         }
5436
5437       ADVANCE (matrix_ctor, 1);
5438     }
5439
5440   return result;
5441 }
5442
5443
5444 gfc_expr *
5445 gfc_simplify_trim (gfc_expr *e)
5446 {
5447   gfc_expr *result;
5448   int count, i, len, lentrim;
5449
5450   if (e->expr_type != EXPR_CONSTANT)
5451     return NULL;
5452
5453   len = e->value.character.length;
5454
5455   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
5456
5457   for (count = 0, i = 1; i <= len; ++i)
5458     {
5459       if (e->value.character.string[len - i] == ' ')
5460         count++;
5461       else
5462         break;
5463     }
5464
5465   lentrim = len - count;
5466
5467   result->value.character.length = lentrim;
5468   result->value.character.string = gfc_get_wide_string (lentrim + 1);
5469
5470   for (i = 0; i < lentrim; i++)
5471     result->value.character.string[i] = e->value.character.string[i];
5472
5473   result->value.character.string[lentrim] = '\0';       /* For debugger */
5474
5475   return result;
5476 }
5477
5478
5479 gfc_expr *
5480 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5481 {
5482   return simplify_bound (array, dim, kind, 1);
5483 }
5484
5485
5486 gfc_expr *
5487 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5488 {
5489   gfc_expr *result, *e;
5490   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5491
5492   if (!is_constant_array_expr (vector)
5493       || !is_constant_array_expr (mask)
5494       || (!gfc_is_constant_expr (field)
5495           && !is_constant_array_expr(field)))
5496     return NULL;
5497
5498   result = gfc_start_constructor (vector->ts.type,
5499                                   vector->ts.kind,
5500                                   &vector->where);
5501   result->rank = mask->rank;
5502   result->shape = gfc_copy_shape (mask->shape, mask->rank);
5503
5504   if (vector->ts.type == BT_CHARACTER)
5505     result->ts.u.cl = vector->ts.u.cl;
5506
5507   vector_ctor = vector->value.constructor;
5508   mask_ctor = mask->value.constructor;
5509   field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
5510
5511   while (mask_ctor)
5512     {
5513       if (mask_ctor->expr->value.logical)
5514         {
5515           gcc_assert (vector_ctor);
5516           e = gfc_copy_expr (vector_ctor->expr);
5517           ADVANCE (vector_ctor, 1);
5518         }
5519       else if (field->expr_type == EXPR_ARRAY)
5520         e = gfc_copy_expr (field_ctor->expr);
5521       else
5522         e = gfc_copy_expr (field);
5523
5524       gfc_append_constructor (result, e);
5525
5526       ADVANCE (mask_ctor, 1);
5527       ADVANCE (field_ctor, 1);
5528     }
5529
5530   return result;
5531 }
5532
5533
5534 gfc_expr *
5535 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5536 {
5537   gfc_expr *result;
5538   int back;
5539   size_t index, len, lenset;
5540   size_t i;
5541   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5542
5543   if (k == -1)
5544     return &gfc_bad_expr;
5545
5546   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5547     return NULL;
5548
5549   if (b != NULL && b->value.logical != 0)
5550     back = 1;
5551   else
5552     back = 0;
5553
5554   result = gfc_constant_result (BT_INTEGER, k, &s->where);
5555
5556   len = s->value.character.length;
5557   lenset = set->value.character.length;
5558
5559   if (len == 0)
5560     {
5561       mpz_set_ui (result->value.integer, 0);
5562       return result;
5563     }
5564
5565   if (back == 0)
5566     {
5567       if (lenset == 0)
5568         {
5569           mpz_set_ui (result->value.integer, 1);
5570           return result;
5571         }
5572
5573       index = wide_strspn (s->value.character.string,
5574                            set->value.character.string) + 1;
5575       if (index > len)
5576         index = 0;
5577
5578     }
5579   else
5580     {
5581       if (lenset == 0)
5582         {
5583           mpz_set_ui (result->value.integer, len);
5584           return result;
5585         }
5586       for (index = len; index > 0; index --)
5587         {
5588           for (i = 0; i < lenset; i++)
5589             {
5590               if (s->value.character.string[index - 1]
5591                   == set->value.character.string[i])
5592                 break;
5593             }
5594           if (i == lenset)
5595             break;
5596         }
5597     }
5598
5599   mpz_set_ui (result->value.integer, index);
5600   return result;
5601 }
5602
5603
5604 gfc_expr *
5605 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5606 {
5607   gfc_expr *result;
5608   int kind;
5609
5610   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5611     return NULL;
5612
5613   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5614   if (x->ts.type == BT_INTEGER)
5615     {
5616       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
5617       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5618       return range_check (result, "XOR");
5619     }
5620   else /* BT_LOGICAL */
5621     {
5622       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
5623       result->value.logical = (x->value.logical && !y->value.logical)
5624                               || (!x->value.logical && y->value.logical);
5625       return result;
5626     }
5627
5628 }
5629
5630
5631 /****************** Constant simplification *****************/
5632
5633 /* Master function to convert one constant to another.  While this is
5634    used as a simplification function, it requires the destination type
5635    and kind information which is supplied by a special case in
5636    do_simplify().  */
5637
5638 gfc_expr *
5639 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5640 {
5641   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5642   gfc_constructor *head, *c, *tail = NULL;
5643
5644   switch (e->ts.type)
5645     {
5646     case BT_INTEGER:
5647       switch (type)
5648         {
5649         case BT_INTEGER:
5650           f = gfc_int2int;
5651           break;
5652         case BT_REAL:
5653           f = gfc_int2real;
5654           break;
5655         case BT_COMPLEX:
5656           f = gfc_int2complex;
5657           break;
5658         case BT_LOGICAL:
5659           f = gfc_int2log;
5660           break;
5661         default:
5662           goto oops;
5663         }
5664       break;
5665
5666     case BT_REAL:
5667       switch (type)
5668         {
5669         case BT_INTEGER:
5670           f = gfc_real2int;
5671           break;
5672         case BT_REAL:
5673           f = gfc_real2real;
5674           break;
5675         case BT_COMPLEX:
5676           f = gfc_real2complex;
5677           break;
5678         default:
5679           goto oops;
5680         }
5681       break;
5682
5683     case BT_COMPLEX:
5684       switch (type)
5685         {
5686         case BT_INTEGER:
5687           f = gfc_complex2int;
5688           break;
5689         case BT_REAL:
5690           f = gfc_complex2real;
5691           break;
5692         case BT_COMPLEX:
5693           f = gfc_complex2complex;
5694           break;
5695
5696         default:
5697           goto oops;
5698         }
5699       break;
5700
5701     case BT_LOGICAL:
5702       switch (type)
5703         {
5704         case BT_INTEGER:
5705           f = gfc_log2int;
5706           break;
5707         case BT_LOGICAL:
5708           f = gfc_log2log;
5709           break;
5710         default:
5711           goto oops;
5712         }
5713       break;
5714
5715     case BT_HOLLERITH:
5716       switch (type)
5717         {
5718         case BT_INTEGER:
5719           f = gfc_hollerith2int;
5720           break;
5721
5722         case BT_REAL:
5723           f = gfc_hollerith2real;
5724           break;
5725
5726         case BT_COMPLEX:
5727           f = gfc_hollerith2complex;
5728           break;
5729
5730         case BT_CHARACTER:
5731           f = gfc_hollerith2character;
5732           break;
5733
5734         case BT_LOGICAL:
5735           f = gfc_hollerith2logical;
5736           break;
5737
5738         default:
5739           goto oops;
5740         }
5741       break;
5742
5743     default:
5744     oops:
5745       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5746     }
5747
5748   result = NULL;
5749
5750   switch (e->expr_type)
5751     {
5752     case EXPR_CONSTANT:
5753       result = f (e, kind);
5754       if (result == NULL)
5755         return &gfc_bad_expr;
5756       break;
5757
5758     case EXPR_ARRAY:
5759       if (!gfc_is_constant_expr (e))
5760         break;
5761
5762       head = NULL;
5763
5764       for (c = e->value.constructor; c; c = c->next)
5765         {
5766           if (head == NULL)
5767             head = tail = gfc_get_constructor ();
5768           else
5769             {
5770               tail->next = gfc_get_constructor ();
5771               tail = tail->next;
5772             }
5773
5774           tail->where = c->where;
5775
5776           if (c->iterator == NULL)
5777             tail->expr = f (c->expr, kind);
5778           else
5779             {
5780               g = gfc_convert_constant (c->expr, type, kind);
5781               if (g == &gfc_bad_expr)
5782                 return g;
5783               tail->expr = g;
5784             }
5785
5786           if (tail->expr == NULL)
5787             {
5788               gfc_free_constructor (head);
5789               return NULL;
5790             }
5791         }
5792
5793       result = gfc_get_expr ();
5794       result->ts.type = type;
5795       result->ts.kind = kind;
5796       result->expr_type = EXPR_ARRAY;
5797       result->value.constructor = head;
5798       result->shape = gfc_copy_shape (e->shape, e->rank);
5799       result->where = e->where;
5800       result->rank = e->rank;
5801       break;
5802
5803     default:
5804       break;
5805     }
5806
5807   return result;
5808 }
5809
5810
5811 /* Function for converting character constants.  */
5812 gfc_expr *
5813 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5814 {
5815   gfc_expr *result;
5816   int i;
5817
5818   if (!gfc_is_constant_expr (e))
5819     return NULL;
5820
5821   if (e->expr_type == EXPR_CONSTANT)
5822     {
5823       /* Simple case of a scalar.  */
5824       result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
5825       if (result == NULL)
5826         return &gfc_bad_expr;
5827
5828       result->value.character.length = e->value.character.length;
5829       result->value.character.string
5830         = gfc_get_wide_string (e->value.character.length + 1);
5831       memcpy (result->value.character.string, e->value.character.string,
5832               (e->value.character.length + 1) * sizeof (gfc_char_t));
5833
5834       /* Check we only have values representable in the destination kind.  */
5835       for (i = 0; i < result->value.character.length; i++)
5836         if (!gfc_check_character_range (result->value.character.string[i],
5837                                         kind))
5838           {
5839             gfc_error ("Character '%s' in string at %L cannot be converted "
5840                        "into character kind %d",
5841                        gfc_print_wide_char (result->value.character.string[i]),
5842                        &e->where, kind);
5843             return &gfc_bad_expr;
5844           }
5845
5846       return result;
5847     }
5848   else if (e->expr_type == EXPR_ARRAY)
5849     {
5850       /* For an array constructor, we convert each constructor element.  */
5851       gfc_constructor *head = NULL, *tail = NULL, *c;
5852
5853       for (c = e->value.constructor; c; c = c->next)
5854         {
5855           if (head == NULL)
5856             head = tail = gfc_get_constructor ();
5857           else
5858             {
5859               tail->next = gfc_get_constructor ();
5860               tail = tail->next;
5861             }
5862
5863           tail->where = c->where;
5864           tail->expr = gfc_convert_char_constant (c->expr, type, kind);
5865           if (tail->expr == &gfc_bad_expr)
5866             {
5867               tail->expr = NULL;
5868               return &gfc_bad_expr;
5869             }
5870
5871           if (tail->expr == NULL)
5872             {
5873               gfc_free_constructor (head);
5874               return NULL;
5875             }
5876         }
5877
5878       result = gfc_get_expr ();
5879       result->ts.type = type;
5880       result->ts.kind = kind;
5881       result->expr_type = EXPR_ARRAY;
5882       result->value.constructor = head;
5883       result->shape = gfc_copy_shape (e->shape, e->rank);
5884       result->where = e->where;
5885       result->rank = e->rank;
5886       result->ts.u.cl = e->ts.u.cl;
5887
5888       return result;
5889     }
5890   else
5891     return NULL;
5892 }