gcc/fortran/simplify.c

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