gcc/fortran/simplify.c

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