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