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)
 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) || 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
4238   if (i->expr_type != EXPR_CONSTANT)
4239     return NULL;
4240
4241   kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4242   if (kind == -1)
4243     return &gfc_bad_expr;
4244   k = gfc_validate_kind (BT_INTEGER, kind, false);
4245
4246   bool fail = gfc_extract_int (i, &arg);
4247   gcc_assert (!fail);
4248
4249   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4250
4251   /* MASKR(n) = 2^n - 1 */
4252   mpz_set_ui (result->value.integer, 1);
4253   mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4254   mpz_sub_ui (result->value.integer, result->value.integer, 1);
4255
4256   gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4257
4258   return result;
4259 }
4260
4261
4262 gfc_expr *
4263 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4264 {
4265   gfc_expr *result;
4266   int kind, arg, k;
4267   mpz_t z;
4268
4269   if (i->expr_type != EXPR_CONSTANT)
4270     return NULL;
4271
4272   kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4273   if (kind == -1)
4274     return &gfc_bad_expr;
4275   k = gfc_validate_kind (BT_INTEGER, kind, false);
4276
4277   bool fail = gfc_extract_int (i, &arg);
4278   gcc_assert (!fail);
4279
4280   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4281
4282   /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4283   mpz_init_set_ui (z, 1);
4284   mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4285   mpz_set_ui (result->value.integer, 1);
4286   mpz_mul_2exp (result->value.integer, result->value.integer,
4287                 gfc_integer_kinds[k].bit_size - arg);
4288   mpz_sub (result->value.integer, z, result->value.integer);
4289   mpz_clear (z);
4290
4291   gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4292
4293   return result;
4294 }
4295
4296
4297 gfc_expr *
4298 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4299 {
4300   gfc_expr * result;
4301   gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4302
4303   if (mask->expr_type == EXPR_CONSTANT)
4304     return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
4305                                                ? tsource : fsource));
4306
4307   if (!mask->rank || !is_constant_array_expr (mask)
4308       || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
4309     return NULL;
4310
4311   result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4312                                &tsource->where);
4313   if (tsource->ts.type == BT_DERIVED)
4314     result->ts.u.derived = tsource->ts.u.derived;
4315   else if (tsource->ts.type == BT_CHARACTER)
4316     result->ts.u.cl = tsource->ts.u.cl;
4317
4318   tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4319   fsource_ctor = gfc_constructor_first (fsource->value.constructor);
4320   mask_ctor = gfc_constructor_first (mask->value.constructor);
4321
4322   while (mask_ctor)
4323     {
4324       if (mask_ctor->expr->value.logical)
4325         gfc_constructor_append_expr (&result->value.constructor,
4326                                      gfc_copy_expr (tsource_ctor->expr),
4327                                      NULL);
4328       else
4329         gfc_constructor_append_expr (&result->value.constructor,
4330                                      gfc_copy_expr (fsource_ctor->expr),
4331                                      NULL);
4332       tsource_ctor = gfc_constructor_next (tsource_ctor);
4333       fsource_ctor = gfc_constructor_next (fsource_ctor);
4334       mask_ctor = gfc_constructor_next (mask_ctor);
4335     }
4336
4337   result->shape = gfc_get_shape (1);
4338   gfc_array_size (result, &result->shape[0]);
4339
4340   return result;
4341 }
4342
4343
4344 gfc_expr *
4345 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4346 {
4347   mpz_t arg1, arg2, mask;
4348   gfc_expr *result;
4349
4350   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4351       || mask_expr->expr_type != EXPR_CONSTANT)
4352     return NULL;
4353
4354   result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4355
4356   /* Convert all argument to unsigned.  */
4357   mpz_init_set (arg1, i->value.integer);
4358   mpz_init_set (arg2, j->value.integer);
4359   mpz_init_set (mask, mask_expr->value.integer);
4360
4361   /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
4362   mpz_and (arg1, arg1, mask);
4363   mpz_com (mask, mask);
4364   mpz_and (arg2, arg2, mask);
4365   mpz_ior (result->value.integer, arg1, arg2);
4366
4367   mpz_clear (arg1);
4368   mpz_clear (arg2);
4369   mpz_clear (mask);
4370
4371   return result;
4372 }
4373
4374
4375 /* Selects between current value and extremum for simplify_min_max
4376    and simplify_minval_maxval.  */
4377 static void
4378 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4379 {
4380   switch (arg->ts.type)
4381     {
4382       case BT_INTEGER:
4383         if (mpz_cmp (arg->value.integer,
4384                         extremum->value.integer) * sign > 0)
4385         mpz_set (extremum->value.integer, arg->value.integer);
4386         break;
4387
4388       case BT_REAL:
4389         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
4390         if (sign > 0)
4391           mpfr_max (extremum->value.real, extremum->value.real,
4392                       arg->value.real, GFC_RND_MODE);
4393         else
4394           mpfr_min (extremum->value.real, extremum->value.real,
4395                       arg->value.real, GFC_RND_MODE);
4396         break;
4397
4398       case BT_CHARACTER:
4399 #define LENGTH(x) ((x)->value.character.length)
4400 #define STRING(x) ((x)->value.character.string)
4401         if (LENGTH (extremum) < LENGTH(arg))
4402           {
4403             gfc_char_t *tmp = STRING(extremum);
4404
4405             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4406             memcpy (STRING(extremum), tmp,
4407                       LENGTH(extremum) * sizeof (gfc_char_t));
4408             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4409                                LENGTH(arg) - LENGTH(extremum));
4410             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
4411             LENGTH(extremum) = LENGTH(arg);
4412             free (tmp);
4413           }
4414
4415         if (gfc_compare_string (arg, extremum) * sign > 0)
4416           {
4417             free (STRING(extremum));
4418             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4419             memcpy (STRING(extremum), STRING(arg),
4420                       LENGTH(arg) * sizeof (gfc_char_t));
4421             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4422                                LENGTH(extremum) - LENGTH(arg));
4423             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
4424           }
4425 #undef LENGTH
4426 #undef STRING
4427         break;
4428
4429       default:
4430         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4431     }
4432 }
4433
4434
4435 /* This function is special since MAX() can take any number of
4436    arguments.  The simplified expression is a rewritten version of the
4437    argument list containing at most one constant element.  Other
4438    constant elements are deleted.  Because the argument list has
4439    already been checked, this function always succeeds.  sign is 1 for
4440    MAX(), -1 for MIN().  */
4441
4442 static gfc_expr *
4443 simplify_min_max (gfc_expr *expr, int sign)
4444 {
4445   gfc_actual_arglist *arg, *last, *extremum;
4446   gfc_intrinsic_sym * specific;
4447
4448   last = NULL;
4449   extremum = NULL;
4450   specific = expr->value.function.isym;
4451
4452   arg = expr->value.function.actual;
4453
4454   for (; arg; last = arg, arg = arg->next)
4455     {
4456       if (arg->expr->expr_type != EXPR_CONSTANT)
4457         continue;
4458
4459       if (extremum == NULL)
4460         {
4461           extremum = arg;
4462           continue;
4463         }
4464
4465       min_max_choose (arg->expr, extremum->expr, sign);
4466
4467       /* Delete the extra constant argument.  */
4468       last->next = arg->next;
4469
4470       arg->next = NULL;
4471       gfc_free_actual_arglist (arg);
4472       arg = last;
4473     }
4474
4475   /* If there is one value left, replace the function call with the
4476      expression.  */
4477   if (expr->value.function.actual->next != NULL)
4478     return NULL;
4479
4480   /* Convert to the correct type and kind.  */
4481   if (expr->ts.type != BT_UNKNOWN)
4482     return gfc_convert_constant (expr->value.function.actual->expr,
4483         expr->ts.type, expr->ts.kind);
4484
4485   if (specific->ts.type != BT_UNKNOWN)
4486     return gfc_convert_constant (expr->value.function.actual->expr,
4487         specific->ts.type, specific->ts.kind);
4488
4489   return gfc_copy_expr (expr->value.function.actual->expr);
4490 }
4491
4492
4493 gfc_expr *
4494 gfc_simplify_min (gfc_expr *e)
4495 {
4496   return simplify_min_max (e, -1);
4497 }
4498
4499
4500 gfc_expr *
4501 gfc_simplify_max (gfc_expr *e)
4502 {
4503   return simplify_min_max (e, 1);
4504 }
4505
4506
4507 /* This is a simplified version of simplify_min_max to provide
4508    simplification of minval and maxval for a vector.  */
4509
4510 static gfc_expr *
4511 simplify_minval_maxval (gfc_expr *expr, int sign)
4512 {
4513   gfc_constructor *c, *extremum;
4514   gfc_intrinsic_sym * specific;
4515
4516   extremum = NULL;
4517   specific = expr->value.function.isym;
4518
4519   for (c = gfc_constructor_first (expr->value.constructor);
4520        c; c = gfc_constructor_next (c))
4521     {
4522       if (c->expr->expr_type != EXPR_CONSTANT)
4523         return NULL;
4524
4525       if (extremum == NULL)
4526         {
4527           extremum = c;
4528           continue;
4529         }
4530
4531       min_max_choose (c->expr, extremum->expr, sign);
4532      }
4533
4534   if (extremum == NULL)
4535     return NULL;
4536
4537   /* Convert to the correct type and kind.  */
4538   if (expr->ts.type != BT_UNKNOWN)
4539     return gfc_convert_constant (extremum->expr,
4540         expr->ts.type, expr->ts.kind);
4541
4542   if (specific->ts.type != BT_UNKNOWN)
4543     return gfc_convert_constant (extremum->expr,
4544         specific->ts.type, specific->ts.kind);
4545
4546   return gfc_copy_expr (extremum->expr);
4547 }
4548
4549
4550 gfc_expr *
4551 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4552 {
4553   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4554     return NULL;
4555
4556   return simplify_minval_maxval (array, -1);
4557 }
4558
4559
4560 gfc_expr *
4561 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4562 {
4563   if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4564     return NULL;
4565
4566   return simplify_minval_maxval (array, 1);
4567 }
4568
4569
4570 gfc_expr *
4571 gfc_simplify_maxexponent (gfc_expr *x)
4572 {
4573   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4574   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4575                            gfc_real_kinds[i].max_exponent);
4576 }
4577
4578
4579 gfc_expr *
4580 gfc_simplify_minexponent (gfc_expr *x)
4581 {
4582   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4583   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4584                            gfc_real_kinds[i].min_exponent);
4585 }
4586
4587
4588 gfc_expr *
4589 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4590 {
4591   gfc_expr *result;
4592   int kind;
4593
4594   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4595     return NULL;
4596
4597   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4598   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4599
4600   switch (a->ts.type)
4601     {
4602       case BT_INTEGER:
4603         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4604           {
4605             /* Result is processor-dependent.  */
4606             gfc_error ("Second argument MOD at %L is zero", &a->where);
4607             gfc_free_expr (result);
4608             return &gfc_bad_expr;
4609           }
4610         mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4611         break;
4612
4613       case BT_REAL:
4614         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4615           {
4616             /* Result is processor-dependent.  */
4617             gfc_error ("Second argument of MOD at %L is zero", &p->where);
4618             gfc_free_expr (result);
4619             return &gfc_bad_expr;
4620           }
4621
4622         gfc_set_model_kind (kind);
4623         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4624                    GFC_RND_MODE);
4625         break;
4626
4627       default:
4628         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4629     }
4630
4631   return range_check (result, "MOD");
4632 }
4633
4634
4635 gfc_expr *
4636 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4637 {
4638   gfc_expr *result;
4639   int kind;
4640
4641   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4642     return NULL;
4643
4644   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4645   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4646
4647   switch (a->ts.type)
4648     {
4649       case BT_INTEGER:
4650         if (mpz_cmp_ui (p->value.integer, 0) == 0)
4651           {
4652             /* Result is processor-dependent. This processor just opts
4653               to not handle it at all.  */
4654             gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4655             gfc_free_expr (result);
4656             return &gfc_bad_expr;
4657           }
4658         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4659
4660         break;
4661
4662       case BT_REAL:
4663         if (mpfr_cmp_ui (p->value.real, 0) == 0)
4664           {
4665             /* Result is processor-dependent.  */
4666             gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4667             gfc_free_expr (result);
4668             return &gfc_bad_expr;
4669           }
4670
4671         gfc_set_model_kind (kind);
4672         mpfr_fmod (result->value.real, a->value.real, p->value.real,
4673                    GFC_RND_MODE);
4674         if (mpfr_cmp_ui (result->value.real, 0) != 0)
4675           {
4676             if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
4677               mpfr_add (result->value.real, result->value.real, p->value.real,
4678                         GFC_RND_MODE);
4679           }
4680         else
4681           mpfr_copysign (result->value.real, result->value.real,
4682                          p->value.real, GFC_RND_MODE);
4683         break;
4684
4685       default:
4686         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4687     }
4688
4689   return range_check (result, "MODULO");
4690 }
4691
4692
4693 gfc_expr *
4694 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4695 {
4696   gfc_expr *result;
4697   mp_exp_t emin, emax;
4698   int kind;
4699
4700   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4701     return NULL;
4702
4703   result = gfc_copy_expr (x);
4704
4705   /* Save current values of emin and emax.  */
4706   emin = mpfr_get_emin ();
4707   emax = mpfr_get_emax ();
4708
4709   /* Set emin and emax for the current model number.  */
4710   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4711   mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4712                 mpfr_get_prec(result->value.real) + 1);
4713   mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4714   mpfr_check_range (result->value.real, 0, GMP_RNDU);
4715
4716   if (mpfr_sgn (s->value.real) > 0)
4717     {
4718       mpfr_nextabove (result->value.real);
4719       mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4720     }
4721   else
4722     {
4723       mpfr_nextbelow (result->value.real);
4724       mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4725     }
4726
4727   mpfr_set_emin (emin);
4728   mpfr_set_emax (emax);
4729
4730   /* Only NaN can occur. Do not use range check as it gives an
4731      error for denormal numbers.  */
4732   if (mpfr_nan_p (result->value.real) && flag_range_check)
4733     {
4734       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4735       gfc_free_expr (result);
4736       return &gfc_bad_expr;
4737     }
4738
4739   return result;
4740 }
4741
4742
4743 static gfc_expr *
4744 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4745 {
4746   gfc_expr *itrunc, *result;
4747   int kind;
4748
4749   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4750   if (kind == -1)
4751     return &gfc_bad_expr;
4752
4753   if (e->expr_type != EXPR_CONSTANT)
4754     return NULL;
4755
4756   itrunc = gfc_copy_expr (e);
4757   mpfr_round (itrunc->value.real, e->value.real);
4758
4759   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4760   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4761
4762   gfc_free_expr (itrunc);
4763
4764   return range_check (result, name);
4765 }
4766
4767
4768 gfc_expr *
4769 gfc_simplify_new_line (gfc_expr *e)
4770 {
4771   gfc_expr *result;
4772
4773   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4774   result->value.character.string[0] = '\n';
4775
4776   return result;
4777 }
4778
4779
4780 gfc_expr *
4781 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4782 {
4783   return simplify_nint ("NINT", e, k);
4784 }
4785
4786
4787 gfc_expr *
4788 gfc_simplify_idnint (gfc_expr *e)
4789 {
4790   return simplify_nint ("IDNINT", e, NULL);
4791 }
4792
4793
4794 static gfc_expr *
4795 add_squared (gfc_expr *result, gfc_expr *e)
4796 {
4797   mpfr_t tmp;
4798
4799   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4800   gcc_assert (result->ts.type == BT_REAL
4801               && result->expr_type == EXPR_CONSTANT);
4802
4803   gfc_set_model_kind (result->ts.kind);
4804   mpfr_init (tmp);
4805   mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4806   mpfr_add (result->value.real, result->value.real, tmp,
4807             GFC_RND_MODE);
4808   mpfr_clear (tmp);
4809
4810   return result;
4811 }
4812
4813
4814 static gfc_expr *
4815 do_sqrt (gfc_expr *result, gfc_expr *e)
4816 {
4817   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4818   gcc_assert (result->ts.type == BT_REAL
4819               && result->expr_type == EXPR_CONSTANT);
4820
4821   mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4822   mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4823   return result;
4824 }
4825
4826
4827 gfc_expr *
4828 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4829 {
4830   gfc_expr *result;
4831
4832   if (!is_constant_array_expr (e)
4833       || (dim != NULL && !gfc_is_constant_expr (dim)))
4834     return NULL;
4835
4836   result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4837   init_result_expr (result, 0, NULL);
4838
4839   if (!dim || e->rank == 1)
4840     {
4841       result = simplify_transformation_to_scalar (result, e, NULL,
4842                                                   add_squared);
4843       mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4844     }
4845   else
4846     result = simplify_transformation_to_array (result, e, dim, NULL,
4847                                                add_squared, &do_sqrt);
4848
4849   return result;
4850 }
4851
4852
4853 gfc_expr *
4854 gfc_simplify_not (gfc_expr *e)
4855 {
4856   gfc_expr *result;
4857
4858   if (e->expr_type != EXPR_CONSTANT)
4859     return NULL;
4860
4861   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4862   mpz_com (result->value.integer, e->value.integer);
4863
4864   return range_check (result, "NOT");
4865 }
4866
4867
4868 gfc_expr *
4869 gfc_simplify_null (gfc_expr *mold)
4870 {
4871   gfc_expr *result;
4872
4873   if (mold)
4874     {
4875       result = gfc_copy_expr (mold);
4876       result->expr_type = EXPR_NULL;
4877     }
4878   else
4879     result = gfc_get_null_expr (NULL);
4880
4881   return result;
4882 }
4883
4884
4885 gfc_expr *
4886 gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
4887 {
4888   gfc_expr *result;
4889
4890   if (flag_coarray == GFC_FCOARRAY_NONE)
4891     {
4892       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4893       return &gfc_bad_expr;
4894     }
4895
4896   if (flag_coarray != GFC_FCOARRAY_SINGLE)
4897     return NULL;
4898
4899   if (failed && failed->expr_type != EXPR_CONSTANT)
4900     return NULL;
4901
4902   /* FIXME: gfc_current_locus is wrong.  */
4903   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4904                                   &gfc_current_locus);
4905
4906   if (failed && failed->value.logical != 0)
4907     mpz_set_si (result->value.integer, 0);
4908   else
4909     mpz_set_si (result->value.integer, 1);
4910
4911   return result;
4912 }
4913
4914
4915 gfc_expr *
4916 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4917 {
4918   gfc_expr *result;
4919   int kind;
4920
4921   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4922     return NULL;
4923
4924   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4925
4926   switch (x->ts.type)
4927     {
4928       case BT_INTEGER:
4929         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4930         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4931         return range_check (result, "OR");
4932
4933       case BT_LOGICAL:
4934         return gfc_get_logical_expr (kind, &x->where,
4935                                      x->value.logical || y->value.logical);
4936       default:
4937         gcc_unreachable();
4938     }
4939 }
4940
4941
4942 gfc_expr *
4943 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4944 {
4945   gfc_expr *result;
4946   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4947
4948   if (!is_constant_array_expr (array)
4949       || !is_constant_array_expr (vector)
4950       || (!gfc_is_constant_expr (mask)
4951           && !is_constant_array_expr (mask)))
4952     return NULL;
4953
4954   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4955   if (array->ts.type == BT_DERIVED)
4956     result->ts.u.derived = array->ts.u.derived;
4957
4958   array_ctor = gfc_constructor_first (array->value.constructor);
4959   vector_ctor = vector
4960                   ? gfc_constructor_first (vector->value.constructor)
4961                   : NULL;
4962
4963   if (mask->expr_type == EXPR_CONSTANT
4964       && mask->value.logical)
4965     {
4966       /* Copy all elements of ARRAY to RESULT.  */
4967       while (array_ctor)
4968         {
4969           gfc_constructor_append_expr (&result->value.constructor,
4970                                        gfc_copy_expr (array_ctor->expr),
4971                                        NULL);
4972
4973           array_ctor = gfc_constructor_next (array_ctor);
4974           vector_ctor = gfc_constructor_next (vector_ctor);
4975         }
4976     }
4977   else if (mask->expr_type == EXPR_ARRAY)
4978     {
4979       /* Copy only those elements of ARRAY to RESULT whose
4980          MASK equals .TRUE..  */
4981       mask_ctor = gfc_constructor_first (mask->value.constructor);
4982       while (mask_ctor)
4983         {
4984           if (mask_ctor->expr->value.logical)
4985             {
4986               gfc_constructor_append_expr (&result->value.constructor,
4987                                            gfc_copy_expr (array_ctor->expr),
4988                                            NULL);
4989               vector_ctor = gfc_constructor_next (vector_ctor);
4990             }
4991
4992           array_ctor = gfc_constructor_next (array_ctor);
4993           mask_ctor = gfc_constructor_next (mask_ctor);
4994         }
4995     }
4996
4997   /* Append any left-over elements from VECTOR to RESULT.  */
4998   while (vector_ctor)
4999     {
5000       gfc_constructor_append_expr (&result->value.constructor,
5001                                    gfc_copy_expr (vector_ctor->expr),
5002                                    NULL);
5003       vector_ctor = gfc_constructor_next (vector_ctor);
5004     }
5005
5006   result->shape = gfc_get_shape (1);
5007   gfc_array_size (result, &result->shape[0]);
5008
5009   if (array->ts.type == BT_CHARACTER)
5010     result->ts.u.cl = array->ts.u.cl;
5011
5012   return result;
5013 }
5014
5015
5016 static gfc_expr *
5017 do_xor (gfc_expr *result, gfc_expr *e)
5018 {
5019   gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
5020   gcc_assert (result->ts.type == BT_LOGICAL
5021               && result->expr_type == EXPR_CONSTANT);
5022
5023   result->value.logical = result->value.logical != e->value.logical;
5024   return result;
5025 }
5026
5027
5028
5029 gfc_expr *
5030 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
5031 {
5032   return simplify_transformation (e, dim, NULL, 0, do_xor);
5033 }
5034
5035
5036 gfc_expr *
5037 gfc_simplify_popcnt (gfc_expr *e)
5038 {
5039   int res, k;
5040   mpz_t x;
5041
5042   if (e->expr_type != EXPR_CONSTANT)
5043     return NULL;
5044
5045   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5046
5047   /* Convert argument to unsigned, then count the '1' bits.  */
5048   mpz_init_set (x, e->value.integer);
5049   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
5050   res = mpz_popcount (x);
5051   mpz_clear (x);
5052
5053   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
5054 }
5055
5056
5057 gfc_expr *
5058 gfc_simplify_poppar (gfc_expr *e)
5059 {
5060   gfc_expr *popcnt;
5061   int i;
5062
5063   if (e->expr_type != EXPR_CONSTANT)
5064     return NULL;
5065
5066   popcnt = gfc_simplify_popcnt (e);
5067   gcc_assert (popcnt);
5068
5069   bool fail = gfc_extract_int (popcnt, &i);
5070   gcc_assert (!fail);
5071
5072   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
5073 }
5074
5075
5076 gfc_expr *
5077 gfc_simplify_precision (gfc_expr *e)
5078 {
5079   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5080   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
5081                            gfc_real_kinds[i].precision);
5082 }
5083
5084
5085 gfc_expr *
5086 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5087 {
5088   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
5089 }
5090
5091
5092 gfc_expr *
5093 gfc_simplify_radix (gfc_expr *e)
5094 {
5095   int i;
5096   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5097
5098   switch (e->ts.type)
5099     {
5100       case BT_INTEGER:
5101         i = gfc_integer_kinds[i].radix;
5102         break;
5103
5104       case BT_REAL:
5105         i = gfc_real_kinds[i].radix;
5106         break;
5107
5108       default:
5109         gcc_unreachable ();
5110     }
5111
5112   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
5113 }
5114
5115
5116 gfc_expr *
5117 gfc_simplify_range (gfc_expr *e)
5118 {
5119   int i;
5120   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5121
5122   switch (e->ts.type)
5123     {
5124       case BT_INTEGER:
5125         i = gfc_integer_kinds[i].range;
5126         break;
5127
5128       case BT_REAL:
5129       case BT_COMPLEX:
5130         i = gfc_real_kinds[i].range;
5131         break;
5132
5133       default:
5134         gcc_unreachable ();
5135     }
5136
5137   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
5138 }
5139
5140
5141 gfc_expr *
5142 gfc_simplify_rank (gfc_expr *e)
5143 {
5144   /* Assumed rank.  */
5145   if (e->rank == -1)
5146     return NULL;
5147
5148   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
5149 }
5150
5151
5152 gfc_expr *
5153 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
5154 {
5155   gfc_expr *result = NULL;
5156   int kind;
5157
5158   if (e->ts.type == BT_COMPLEX)
5159     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
5160   else
5161     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
5162
5163   if (kind == -1)
5164     return &gfc_bad_expr;
5165
5166   if (e->expr_type != EXPR_CONSTANT)
5167     return NULL;
5168
5169   if (convert_boz (e, kind) == &gfc_bad_expr)
5170     return &gfc_bad_expr;
5171
5172   result = gfc_convert_constant (e, BT_REAL, kind);
5173   if (result == &gfc_bad_expr)
5174     return &gfc_bad_expr;
5175
5176   return range_check (result, "REAL");
5177 }
5178
5179
5180 gfc_expr *
5181 gfc_simplify_realpart (gfc_expr *e)
5182 {
5183   gfc_expr *result;
5184
5185   if (e->expr_type != EXPR_CONSTANT)
5186     return NULL;
5187
5188   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5189   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
5190
5191   return range_check (result, "REALPART");
5192 }
5193
5194 gfc_expr *
5195 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
5196 {
5197   gfc_expr *result;
5198   int i, j, len, ncop, nlen;
5199   mpz_t ncopies;
5200   bool have_length = false;
5201
5202   /* If NCOPIES isn't a constant, there's nothing we can do.  */
5203   if (n->expr_type != EXPR_CONSTANT)
5204     return NULL;
5205
5206   /* If NCOPIES is negative, it's an error.  */
5207   if (mpz_sgn (n->value.integer) < 0)
5208     {
5209       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5210                  &n->where);
5211       return &gfc_bad_expr;
5212     }
5213
5214   /* If we don't know the character length, we can do no more.  */
5215   if (e->ts.u.cl && e->ts.u.cl->length
5216         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5217     {
5218       len = mpz_get_si (e->ts.u.cl->length->value.integer);
5219       have_length = true;
5220     }
5221   else if (e->expr_type == EXPR_CONSTANT
5222              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
5223     {
5224       len = e->value.character.length;
5225     }
5226   else
5227     return NULL;
5228
5229   /* If the source length is 0, any value of NCOPIES is valid
5230      and everything behaves as if NCOPIES == 0.  */
5231   mpz_init (ncopies);
5232   if (len == 0)
5233     mpz_set_ui (ncopies, 0);
5234   else
5235     mpz_set (ncopies, n->value.integer);
5236
5237   /* Check that NCOPIES isn't too large.  */
5238   if (len)
5239     {
5240       mpz_t max, mlen;
5241       int i;
5242
5243       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
5244       mpz_init (max);
5245       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5246
5247       if (have_length)
5248         {
5249           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
5250                       e->ts.u.cl->length->value.integer);
5251         }
5252       else
5253         {
5254           mpz_init_set_si (mlen, len);
5255           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
5256           mpz_clear (mlen);
5257         }
5258
5259       /* The check itself.  */
5260       if (mpz_cmp (ncopies, max) > 0)
5261         {
5262           mpz_clear (max);
5263           mpz_clear (ncopies);
5264           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5265                      &n->where);
5266           return &gfc_bad_expr;
5267         }
5268
5269       mpz_clear (max);
5270     }
5271   mpz_clear (ncopies);
5272
5273   /* For further simplification, we need the character string to be
5274      constant.  */
5275   if (e->expr_type != EXPR_CONSTANT)
5276     return NULL;
5277
5278   if (len ||
5279       (e->ts.u.cl->length &&
5280        mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
5281     {
5282       bool fail = gfc_extract_int (n, &ncop);
5283       gcc_assert (!fail);
5284     }
5285   else
5286     ncop = 0;
5287
5288   if (ncop == 0)
5289     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
5290
5291   len = e->value.character.length;
5292   nlen = ncop * len;
5293
5294   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
5295   for (i = 0; i < ncop; i++)
5296     for (j = 0; j < len; j++)
5297       result->value.character.string[j+i*len]= e->value.character.string[j];
5298
5299   result->value.character.string[nlen] = '\0';  /* For debugger */
5300   return result;
5301 }
5302
5303
5304 /* This one is a bear, but mainly has to do with shuffling elements.  */
5305
5306 gfc_expr *
5307 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
5308                       gfc_expr *pad, gfc_expr *order_exp)
5309 {
5310   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
5311   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
5312   mpz_t index, size;
5313   unsigned long j;
5314   size_t nsource;
5315   gfc_expr *e, *result;
5316
5317   /* Check that argument expression types are OK.  */
5318   if (!is_constant_array_expr (source)
5319       || !is_constant_array_expr (shape_exp)
5320       || !is_constant_array_expr (pad)
5321       || !is_constant_array_expr (order_exp))
5322     return NULL;
5323
5324   if (source->shape == NULL)
5325     return NULL;
5326
5327   /* Proceed with simplification, unpacking the array.  */
5328
5329   mpz_init (index);
5330   rank = 0;
5331
5332   for (;;)
5333     {
5334       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
5335       if (e == NULL)
5336         break;
5337
5338       gfc_extract_int (e, &shape[rank]);
5339
5340       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
5341       gcc_assert (shape[rank] >= 0);
5342
5343       rank++;
5344     }
5345
5346   gcc_assert (rank > 0);
5347
5348   /* Now unpack the order array if present.  */
5349   if (order_exp == NULL)
5350     {
5351       for (i = 0; i < rank; i++)
5352         order[i] = i;
5353     }
5354   else
5355     {
5356       for (i = 0; i < rank; i++)
5357         x[i] = 0;
5358
5359       for (i = 0; i < rank; i++)
5360         {
5361           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
5362           gcc_assert (e);
5363
5364           gfc_extract_int (e, &order[i]);
5365
5366           gcc_assert (order[i] >= 1 && order[i] <= rank);
5367           order[i]--;
5368           gcc_assert (x[order[i]] == 0);
5369           x[order[i]] = 1;
5370         }
5371     }
5372
5373   /* Count the elements in the source and padding arrays.  */
5374
5375   npad = 0;
5376   if (pad != NULL)
5377     {
5378       gfc_array_size (pad, &size);
5379       npad = mpz_get_ui (size);
5380       mpz_clear (size);
5381     }
5382
5383   gfc_array_size (source, &size);
5384   nsource = mpz_get_ui (size);
5385   mpz_clear (size);
5386
5387   /* If it weren't for that pesky permutation we could just loop
5388      through the source and round out any shortage with pad elements.
5389      But no, someone just had to have the compiler do something the
5390      user should be doing.  */
5391
5392   for (i = 0; i < rank; i++)
5393     x[i] = 0;
5394
5395   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5396                                &source->where);
5397   if (source->ts.type == BT_DERIVED)
5398     result->ts.u.derived = source->ts.u.derived;
5399   result->rank = rank;
5400   result->shape = gfc_get_shape (rank);
5401   for (i = 0; i < rank; i++)
5402     mpz_init_set_ui (result->shape[i], shape[i]);
5403
5404   while (nsource > 0 || npad > 0)
5405     {
5406       /* Figure out which element to extract.  */
5407       mpz_set_ui (index, 0);
5408
5409       for (i = rank - 1; i >= 0; i--)
5410         {
5411           mpz_add_ui (index, index, x[order[i]]);
5412           if (i != 0)
5413             mpz_mul_ui (index, index, shape[order[i - 1]]);
5414         }
5415
5416       if (mpz_cmp_ui (index, INT_MAX) > 0)
5417         gfc_internal_error ("Reshaped array too large at %C");
5418
5419       j = mpz_get_ui (index);
5420
5421       if (j < nsource)
5422         e = gfc_constructor_lookup_expr (source->value.constructor, j);
5423       else
5424         {
5425           if (npad <= 0)
5426             {
5427               mpz_clear (index);
5428               return NULL;
5429             }
5430           j = j - nsource;
5431           j = j % npad;
5432           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5433         }
5434       gcc_assert (e);
5435
5436       gfc_constructor_append_expr (&result->value.constructor,
5437                                    gfc_copy_expr (e), &e->where);
5438
5439       /* Calculate the next element.  */
5440       i = 0;
5441
5442 inc:
5443       if (++x[i] < shape[i])
5444         continue;
5445       x[i++] = 0;
5446       if (i < rank)
5447         goto inc;
5448
5449       break;
5450     }
5451
5452   mpz_clear (index);
5453
5454   return result;
5455 }
5456
5457
5458 gfc_expr *
5459 gfc_simplify_rrspacing (gfc_expr *x)
5460 {
5461   gfc_expr *result;
5462   int i;
5463   long int e, p;
5464
5465   if (x->expr_type != EXPR_CONSTANT)
5466     return NULL;
5467
5468   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5469
5470   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5471
5472   /* RRSPACING(+/- 0.0) = 0.0  */
5473   if (mpfr_zero_p (x->value.real))
5474     {
5475       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5476       return result;
5477     }
5478
5479   /* RRSPACING(inf) = NaN  */
5480   if (mpfr_inf_p (x->value.real))
5481     {
5482       mpfr_set_nan (result->value.real);
5483       return result;
5484     }
5485
5486   /* RRSPACING(NaN) = same NaN  */
5487   if (mpfr_nan_p (x->value.real))
5488     {
5489       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
5490       return result;
5491     }
5492
5493   /* | x * 2**(-e) | * 2**p.  */
5494   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5495   e = - (long int) mpfr_get_exp (x->value.real);
5496   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5497
5498   p = (long int) gfc_real_kinds[i].digits;
5499   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5500
5501   return range_check (result, "RRSPACING");
5502 }
5503
5504
5505 gfc_expr *
5506 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5507 {
5508   int k, neg_flag, power, exp_range;
5509   mpfr_t scale, radix;
5510   gfc_expr *result;
5511
5512   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5513     return NULL;
5514
5515   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5516
5517   if (mpfr_zero_p (x->value.real))
5518     {
5519       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5520       return result;
5521     }
5522
5523   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5524
5525   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5526
5527   /* This check filters out values of i that would overflow an int.  */
5528   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5529       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5530     {
5531       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5532       gfc_free_expr (result);
5533       return &gfc_bad_expr;
5534     }
5535
5536   /* Compute scale = radix ** power.  */
5537   power = mpz_get_si (i->value.integer);
5538
5539   if (power >= 0)
5540     neg_flag = 0;
5541   else
5542     {
5543       neg_flag = 1;
5544       power = -power;
5545     }
5546
5547   gfc_set_model_kind (x->ts.kind);
5548   mpfr_init (scale);
5549   mpfr_init (radix);
5550   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5551   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5552
5553   if (neg_flag)
5554     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5555   else
5556     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5557
5558   mpfr_clears (scale, radix, NULL);
5559
5560   return range_check (result, "SCALE");
5561 }
5562
5563
5564 /* Variants of strspn and strcspn that operate on wide characters.  */
5565
5566 static size_t
5567 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5568 {
5569   size_t i = 0;
5570   const gfc_char_t *c;
5571
5572   while (s1[i])
5573     {
5574       for (c = s2; *c; c++)
5575         {
5576           if (s1[i] == *c)
5577             break;
5578         }
5579       if (*c == '\0')
5580         break;
5581       i++;
5582     }
5583
5584   return i;
5585 }
5586
5587 static size_t
5588 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5589 {
5590   size_t i = 0;
5591   const gfc_char_t *c;
5592
5593   while (s1[i])
5594     {
5595       for (c = s2; *c; c++)
5596         {
5597           if (s1[i] == *c)
5598             break;
5599         }
5600       if (*c)
5601         break;
5602       i++;
5603     }
5604
5605   return i;
5606 }
5607
5608
5609 gfc_expr *
5610 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5611 {
5612   gfc_expr *result;
5613   int back;
5614   size_t i;
5615   size_t indx, len, lenc;
5616   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5617
5618   if (k == -1)
5619     return &gfc_bad_expr;
5620
5621   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
5622       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
5623     return NULL;
5624
5625   if (b != NULL && b->value.logical != 0)
5626     back = 1;
5627   else
5628     back = 0;
5629
5630   len = e->value.character.length;
5631   lenc = c->value.character.length;
5632
5633   if (len == 0 || lenc == 0)
5634     {
5635       indx = 0;
5636     }
5637   else
5638     {
5639       if (back == 0)
5640         {
5641           indx = wide_strcspn (e->value.character.string,
5642                                c->value.character.string) + 1;
5643           if (indx > len)
5644             indx = 0;
5645         }
5646       else
5647         {
5648           i = 0;
5649           for (indx = len; indx > 0; indx--)
5650             {
5651               for (i = 0; i < lenc; i++)
5652                 {
5653                   if (c->value.character.string[i]
5654                       == e->value.character.string[indx - 1])
5655                     break;
5656                 }
5657               if (i < lenc)
5658                 break;
5659             }
5660         }
5661     }
5662
5663   result = gfc_get_int_expr (k, &e->where, indx);
5664   return range_check (result, "SCAN");
5665 }
5666
5667
5668 gfc_expr *
5669 gfc_simplify_selected_char_kind (gfc_expr *e)
5670 {
5671   int kind;
5672
5673   if (e->expr_type != EXPR_CONSTANT)
5674     return NULL;
5675
5676   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5677       || gfc_compare_with_Cstring (e, "default", false) == 0)
5678     kind = 1;
5679   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5680     kind = 4;
5681   else
5682     kind = -1;
5683
5684   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5685 }
5686
5687
5688 gfc_expr *
5689 gfc_simplify_selected_int_kind (gfc_expr *e)
5690 {
5691   int i, kind, range;
5692
5693   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
5694     return NULL;
5695
5696   kind = INT_MAX;
5697
5698   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5699     if (gfc_integer_kinds[i].range >= range
5700         && gfc_integer_kinds[i].kind < kind)
5701       kind = gfc_integer_kinds[i].kind;
5702
5703   if (kind == INT_MAX)
5704     kind = -1;
5705
5706   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5707 }
5708
5709
5710 gfc_expr *
5711 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5712 {
5713   int range, precision, radix, i, kind, found_precision, found_range,
5714       found_radix;
5715   locus *loc = &gfc_current_locus;
5716
5717   if (p == NULL)
5718     precision = 0;
5719   else
5720     {
5721       if (p->expr_type != EXPR_CONSTANT
5722           || gfc_extract_int (p, &precision))
5723         return NULL;
5724       loc = &p->where;
5725     }
5726
5727   if (q == NULL)
5728     range = 0;
5729   else
5730     {
5731       if (q->expr_type != EXPR_CONSTANT
5732           || gfc_extract_int (q, &range))
5733         return NULL;
5734
5735       if (!loc)
5736         loc = &q->where;
5737     }
5738
5739   if (rdx == NULL)
5740     radix = 0;
5741   else
5742     {
5743       if (rdx->expr_type != EXPR_CONSTANT
5744           || gfc_extract_int (rdx, &radix))
5745         return NULL;
5746
5747       if (!loc)
5748         loc = &rdx->where;
5749     }
5750
5751   kind = INT_MAX;
5752   found_precision = 0;
5753   found_range = 0;
5754   found_radix = 0;
5755
5756   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5757     {
5758       if (gfc_real_kinds[i].precision >= precision)
5759         found_precision = 1;
5760
5761       if (gfc_real_kinds[i].range >= range)
5762         found_range = 1;
5763
5764       if (radix == 0 || gfc_real_kinds[i].radix == radix)
5765         found_radix = 1;
5766
5767       if (gfc_real_kinds[i].precision >= precision
5768           && gfc_real_kinds[i].range >= range
5769           && (radix == 0 || gfc_real_kinds[i].radix == radix)
5770           && gfc_real_kinds[i].kind < kind)
5771         kind = gfc_real_kinds[i].kind;
5772     }
5773
5774   if (kind == INT_MAX)
5775     {
5776       if (found_radix && found_range && !found_precision)
5777         kind = -1;
5778       else if (found_radix && found_precision && !found_range)
5779         kind = -2;
5780       else if (found_radix && !found_precision && !found_range)
5781         kind = -3;
5782       else if (found_radix)
5783         kind = -4;
5784       else
5785         kind = -5;
5786     }
5787
5788   return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5789 }
5790
5791
5792 gfc_expr *
5793 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5794 {
5795   gfc_expr *result;
5796   mpfr_t exp, absv, log2, pow2, frac;
5797   unsigned long exp2;
5798
5799   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5800     return NULL;
5801
5802   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5803
5804   /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5805      SET_EXPONENT (NaN) = same NaN  */
5806   if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
5807     {
5808       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
5809       return result;
5810     }
5811
5812   /* SET_EXPONENT (inf) = NaN  */
5813   if (mpfr_inf_p (x->value.real))
5814     {
5815       mpfr_set_nan (result->value.real);
5816       return result;
5817     }
5818
5819   gfc_set_model_kind (x->ts.kind);
5820   mpfr_init (absv);
5821   mpfr_init (log2);
5822   mpfr_init (exp);
5823   mpfr_init (pow2);
5824   mpfr_init (frac);
5825
5826   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5827   mpfr_log2 (log2, absv, GFC_RND_MODE);
5828
5829   mpfr_trunc (log2, log2);
5830   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5831
5832   /* Old exponent value, and fraction.  */
5833   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5834
5835   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5836
5837   /* New exponent.  */
5838   exp2 = (unsigned long) mpz_get_d (i->value.integer);
5839   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5840
5841   mpfr_clears (absv, log2, pow2, frac, NULL);
5842
5843   return range_check (result, "SET_EXPONENT");
5844 }
5845
5846
5847 gfc_expr *
5848 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5849 {
5850   mpz_t shape[GFC_MAX_DIMENSIONS];
5851   gfc_expr *result, *e, *f;
5852   gfc_array_ref *ar;
5853   int n;
5854   bool t;
5855   int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5856
5857   if (source->rank == -1)
5858     return NULL;
5859
5860   result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5861
5862   if (source->rank == 0)
5863     return result;
5864
5865   if (source->expr_type == EXPR_VARIABLE)
5866     {
5867       ar = gfc_find_array_ref (source);
5868       t = gfc_array_ref_shape (ar, shape);
5869     }
5870   else if (source->shape)
5871     {
5872       t = true;
5873       for (n = 0; n < source->rank; n++)
5874         {
5875           mpz_init (shape[n]);
5876           mpz_set (shape[n], source->shape[n]);
5877         }
5878     }
5879   else
5880     t = false;
5881
5882   for (n = 0; n < source->rank; n++)
5883     {
5884       e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5885
5886       if (t)
5887         mpz_set (e->value.integer, shape[n]);
5888       else
5889         {
5890           mpz_set_ui (e->value.integer, n + 1);
5891
5892           f = simplify_size (source, e, k);
5893           gfc_free_expr (e);
5894           if (f == NULL)
5895             {
5896               gfc_free_expr (result);
5897               return NULL;
5898             }
5899           else
5900             e = f;
5901         }
5902
5903       if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
5904         {
5905           gfc_free_expr (result);
5906           if (t)
5907             gfc_clear_shape (shape, source->rank);
5908           return &gfc_bad_expr;
5909         }
5910
5911       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5912     }
5913
5914   if (t)
5915     gfc_clear_shape (shape, source->rank);
5916
5917   return result;
5918 }
5919
5920
5921 static gfc_expr *
5922 simplify_size (gfc_expr *array, gfc_expr *dim, int k)
5923 {
5924   mpz_t size;
5925   gfc_expr *return_value;
5926   int d;
5927
5928   /* For unary operations, the size of the result is given by the size
5929      of the operand.  For binary ones, it's the size of the first operand
5930      unless it is scalar, then it is the size of the second.  */
5931   if (array->expr_type == EXPR_OP && !array->value.op.uop)
5932     {
5933       gfc_expr* replacement;
5934       gfc_expr* simplified;
5935
5936       switch (array->value.op.op)
5937         {
5938           /* Unary operations.  */
5939           case INTRINSIC_NOT:
5940           case INTRINSIC_UPLUS:
5941           case INTRINSIC_UMINUS:
5942           case INTRINSIC_PARENTHESES:
5943             replacement = array->value.op.op1;
5944             break;
5945
5946           /* Binary operations.  If any one of the operands is scalar, take
5947              the other one's size.  If both of them are arrays, it does not
5948              matter -- try to find one with known shape, if possible.  */
5949           default:
5950             if (array->value.op.op1->rank == 0)
5951               replacement = array->value.op.op2;
5952             else if (array->value.op.op2->rank == 0)
5953               replacement = array->value.op.op1;
5954             else
5955               {
5956                 simplified = simplify_size (array->value.op.op1, dim, k);
5957                 if (simplified)
5958                   return simplified;
5959
5960                 replacement = array->value.op.op2;
5961               }
5962             break;
5963         }
5964
5965       /* Try to reduce it directly if possible.  */
5966       simplified = simplify_size (replacement, dim, k);
5967
5968       /* Otherwise, we build a new SIZE call.  This is hopefully at least
5969          simpler than the original one.  */
5970       if (!simplified)
5971         {
5972           gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
5973           simplified = gfc_build_intrinsic_call (gfc_current_ns,
5974                                                  GFC_ISYM_SIZE, "size",
5975                                                  array->where, 3,
5976                                                  gfc_copy_expr (replacement),
5977                                                  gfc_copy_expr (dim),
5978                                                  kind);
5979         }
5980       return simplified;
5981     }
5982
5983   if (dim == NULL)
5984     {
5985       if (!gfc_array_size (array, &size))
5986         return NULL;
5987     }
5988   else
5989     {
5990       if (dim->expr_type != EXPR_CONSTANT)
5991         return NULL;
5992
5993       d = mpz_get_ui (dim->value.integer) - 1;
5994       if (!gfc_array_dimen_size (array, d, &size))
5995         return NULL;
5996     }
5997
5998   return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
5999   mpz_set (return_value->value.integer, size);
6000   mpz_clear (size);
6001
6002   return return_value;
6003 }
6004
6005
6006 gfc_expr *
6007 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6008 {
6009   gfc_expr *result;
6010   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
6011
6012   if (k == -1)
6013     return &gfc_bad_expr;
6014
6015   result = simplify_size (array, dim, k);
6016   if (result == NULL || result == &gfc_bad_expr)
6017     return result;
6018
6019   return range_check (result, "SIZE");
6020 }
6021
6022
6023 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
6024    multiplied by the array size.  */
6025
6026 gfc_expr *
6027 gfc_simplify_sizeof (gfc_expr *x)
6028 {
6029   gfc_expr *result = NULL;
6030   mpz_t array_size;
6031
6032   if (x->ts.type == BT_CLASS || x->ts.deferred)
6033     return NULL;
6034
6035   if (x->ts.type == BT_CHARACTER
6036       && (!x->ts.u.cl || !x->ts.u.cl->length
6037           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6038     return NULL;
6039
6040   if (x->rank && x->expr_type != EXPR_ARRAY
6041       && !gfc_array_size (x, &array_size))
6042     return NULL;
6043
6044   result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
6045                                   &x->where);
6046   mpz_set_si (result->value.integer, gfc_target_expr_size (x));
6047
6048   return result;
6049 }
6050
6051
6052 /* STORAGE_SIZE returns the size in bits of a single array element.  */
6053
6054 gfc_expr *
6055 gfc_simplify_storage_size (gfc_expr *x,
6056                            gfc_expr *kind)
6057 {
6058   gfc_expr *result = NULL;
6059   int k;
6060
6061   if (x->ts.type == BT_CLASS || x->ts.deferred)
6062     return NULL;
6063
6064   if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
6065       && (!x->ts.u.cl || !x->ts.u.cl->length
6066           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6067     return NULL;
6068
6069   k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
6070   if (k == -1)
6071     return &gfc_bad_expr;
6072
6073   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
6074
6075   mpz_set_si (result->value.integer, gfc_element_size (x));
6076   mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
6077
6078   return range_check (result, "STORAGE_SIZE");
6079 }
6080
6081
6082 gfc_expr *
6083 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
6084 {
6085   gfc_expr *result;
6086
6087   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6088     return NULL;
6089
6090   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6091
6092   switch (x->ts.type)
6093     {
6094       case BT_INTEGER:
6095         mpz_abs (result->value.integer, x->value.integer);
6096         if (mpz_sgn (y->value.integer) < 0)
6097           mpz_neg (result->value.integer, result->value.integer);
6098         break;
6099
6100       case BT_REAL:
6101         if (flag_sign_zero)
6102           mpfr_copysign (result->value.real, x->value.real, y->value.real,
6103                         GFC_RND_MODE);
6104         else
6105           mpfr_setsign (result->value.real, x->value.real,
6106                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
6107         break;
6108
6109       default:
6110         gfc_internal_error ("Bad type in gfc_simplify_sign");
6111     }
6112
6113   return result;
6114 }
6115
6116
6117 gfc_expr *
6118 gfc_simplify_sin (gfc_expr *x)
6119 {
6120   gfc_expr *result;
6121
6122   if (x->expr_type != EXPR_CONSTANT)
6123     return NULL;
6124
6125   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6126
6127   switch (x->ts.type)
6128     {
6129       case BT_REAL:
6130         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
6131         break;
6132
6133       case BT_COMPLEX:
6134         gfc_set_model (x->value.real);
6135         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6136         break;
6137
6138       default:
6139         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6140     }
6141
6142   return range_check (result, "SIN");
6143 }
6144
6145
6146 gfc_expr *
6147 gfc_simplify_sinh (gfc_expr *x)
6148 {
6149   gfc_expr *result;
6150
6151   if (x->expr_type != EXPR_CONSTANT)
6152     return NULL;
6153
6154   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6155
6156   switch (x->ts.type)
6157     {
6158       case BT_REAL:
6159         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
6160         break;
6161
6162       case BT_COMPLEX:
6163         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6164         break;
6165
6166       default:
6167         gcc_unreachable ();
6168     }
6169
6170   return range_check (result, "SINH");
6171 }
6172
6173
6174 /* The argument is always a double precision real that is converted to
6175    single precision.  TODO: Rounding!  */
6176
6177 gfc_expr *
6178 gfc_simplify_sngl (gfc_expr *a)
6179 {
6180   gfc_expr *result;
6181
6182   if (a->expr_type != EXPR_CONSTANT)
6183     return NULL;
6184
6185   result = gfc_real2real (a, gfc_default_real_kind);
6186   return range_check (result, "SNGL");
6187 }
6188
6189
6190 gfc_expr *
6191 gfc_simplify_spacing (gfc_expr *x)
6192 {
6193   gfc_expr *result;
6194   int i;
6195   long int en, ep;
6196
6197   if (x->expr_type != EXPR_CONSTANT)
6198     return NULL;
6199
6200   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6201   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6202
6203   /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0)  */
6204   if (mpfr_zero_p (x->value.real))
6205     {
6206       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6207       return result;
6208     }
6209
6210   /* SPACING(inf) = NaN  */
6211   if (mpfr_inf_p (x->value.real))
6212     {
6213       mpfr_set_nan (result->value.real);
6214       return result;
6215     }
6216
6217   /* SPACING(NaN) = same NaN  */
6218   if (mpfr_nan_p (x->value.real))
6219     {
6220       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
6221       return result;
6222     }
6223
6224   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6225      are the radix, exponent of x, and precision.  This excludes the
6226      possibility of subnormal numbers.  Fortran 2003 states the result is
6227      b**max(e - p, emin - 1).  */
6228
6229   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
6230   en = (long int) gfc_real_kinds[i].min_exponent - 1;
6231   en = en > ep ? en : ep;
6232
6233   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
6234   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
6235
6236   return range_check (result, "SPACING");
6237 }
6238
6239
6240 gfc_expr *
6241 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
6242 {
6243   gfc_expr *result = NULL;
6244   int nelem, i, j, dim, ncopies;
6245   mpz_t size;
6246
6247   if ((!gfc_is_constant_expr (source)
6248        && !is_constant_array_expr (source))
6249       || !gfc_is_constant_expr (dim_expr)
6250       || !gfc_is_constant_expr (ncopies_expr))
6251     return NULL;
6252
6253   gcc_assert (dim_expr->ts.type == BT_INTEGER);
6254   gfc_extract_int (dim_expr, &dim);
6255   dim -= 1;   /* zero-base DIM */
6256
6257   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
6258   gfc_extract_int (ncopies_expr, &ncopies);
6259   ncopies = MAX (ncopies, 0);
6260
6261   /* Do not allow the array size to exceed the limit for an array
6262      constructor.  */
6263   if (source->expr_type == EXPR_ARRAY)
6264     {
6265       if (!gfc_array_size (source, &size))
6266         gfc_internal_error ("Failure getting length of a constant array.");
6267     }
6268   else
6269     mpz_init_set_ui (size, 1);
6270
6271   nelem = mpz_get_si (size) * ncopies;
6272   if (nelem > flag_max_array_constructor)
6273     {
6274       if (gfc_current_ns->sym_root->n.sym->attr.flavor == FL_PARAMETER)
6275         {
6276           gfc_error ("The number of elements (%d) in the array constructor "
6277                      "at %L requires an increase of the allowed %d upper "
6278                      "limit.  See %<-fmax-array-constructor%> option.",
6279                      nelem, &source->where, flag_max_array_constructor);
6280           return &gfc_bad_expr;
6281         }
6282       else
6283         return NULL;
6284     }
6285
6286   if (source->expr_type == EXPR_CONSTANT)
6287     {
6288       gcc_assert (dim == 0);
6289
6290       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6291                                    &source->where);
6292       if (source->ts.type == BT_DERIVED)
6293         result->ts.u.derived = source->ts.u.derived;
6294       result->rank = 1;
6295       result->shape = gfc_get_shape (result->rank);
6296       mpz_init_set_si (result->shape[0], ncopies);
6297
6298       for (i = 0; i < ncopies; ++i)
6299         gfc_constructor_append_expr (&result->value.constructor,
6300                                      gfc_copy_expr (source), NULL);
6301     }
6302   else if (source->expr_type == EXPR_ARRAY)
6303     {
6304       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
6305       gfc_constructor *source_ctor;
6306
6307       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
6308       gcc_assert (dim >= 0 && dim <= source->rank);
6309
6310       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6311                                    &source->where);
6312       if (source->ts.type == BT_DERIVED)
6313         result->ts.u.derived = source->ts.u.derived;
6314       result->rank = source->rank + 1;
6315       result->shape = gfc_get_shape (result->rank);
6316
6317       for (i = 0, j = 0; i < result->rank; ++i)
6318         {
6319           if (i != dim)
6320             mpz_init_set (result->shape[i], source->shape[j++]);
6321           else
6322             mpz_init_set_si (result->shape[i], ncopies);
6323
6324           extent[i] = mpz_get_si (result->shape[i]);
6325           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
6326         }
6327
6328       offset = 0;
6329       for (source_ctor = gfc_constructor_first (source->value.constructor);
6330            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
6331         {
6332           for (i = 0; i < ncopies; ++i)
6333             gfc_constructor_insert_expr (&result->value.constructor,
6334                                          gfc_copy_expr (source_ctor->expr),
6335                                          NULL, offset + i * rstride[dim]);
6336
6337           offset += (dim == 0 ? ncopies : 1);
6338         }
6339     }
6340   else
6341     {
6342       gfc_error ("Simplification of SPREAD at %C not yet implemented");
6343       return &gfc_bad_expr;
6344     }
6345
6346   if (source->ts.type == BT_CHARACTER)
6347     result->ts.u.cl = source->ts.u.cl;
6348
6349   return result;
6350 }
6351
6352
6353 gfc_expr *
6354 gfc_simplify_sqrt (gfc_expr *e)
6355 {
6356   gfc_expr *result = NULL;
6357
6358   if (e->expr_type != EXPR_CONSTANT)
6359     return NULL;
6360
6361   switch (e->ts.type)
6362     {
6363       case BT_REAL:
6364         if (mpfr_cmp_si (e->value.real, 0) < 0)
6365           {
6366             gfc_error ("Argument of SQRT at %L has a negative value",
6367                        &e->where);
6368             return &gfc_bad_expr;
6369           }
6370         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6371         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
6372         break;
6373
6374       case BT_COMPLEX:
6375         gfc_set_model (e->value.real);
6376
6377         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6378         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
6379         break;
6380
6381       default:
6382         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
6383     }
6384
6385   return range_check (result, "SQRT");
6386 }
6387
6388
6389 gfc_expr *
6390 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6391 {
6392   return simplify_transformation (array, dim, mask, 0, gfc_add);
6393 }
6394
6395
6396 gfc_expr *
6397 gfc_simplify_cotan (gfc_expr *x)
6398 {
6399   gfc_expr *result;
6400   mpc_t swp, *val;
6401
6402   if (x->expr_type != EXPR_CONSTANT)
6403     return NULL;
6404
6405   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6406
6407   switch (x->ts.type)
6408     {
6409     case BT_REAL:
6410       mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
6411       break;
6412
6413     case BT_COMPLEX:
6414       /* There is no builtin mpc_cot, so compute cot = cos / sin.  */
6415       val = &result->value.complex;
6416       mpc_init2 (swp, mpfr_get_default_prec ());
6417       mpc_cos (swp, x->value.complex, GFC_MPC_RND_MODE);
6418       mpc_sin (*val, x->value.complex, GFC_MPC_RND_MODE);
6419       mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
6420       mpc_clear (swp);
6421       break;
6422
6423     default:
6424       gcc_unreachable ();
6425     }
6426
6427   return range_check (result, "COTAN");
6428 }
6429
6430
6431 gfc_expr *
6432 gfc_simplify_tan (gfc_expr *x)
6433 {
6434   gfc_expr *result;
6435
6436   if (x->expr_type != EXPR_CONSTANT)
6437     return NULL;
6438
6439   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6440
6441   switch (x->ts.type)
6442     {
6443       case BT_REAL:
6444         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
6445         break;
6446
6447       case BT_COMPLEX:
6448         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6449         break;
6450
6451       default:
6452         gcc_unreachable ();
6453     }
6454
6455   return range_check (result, "TAN");
6456 }
6457
6458
6459 gfc_expr *
6460 gfc_simplify_tanh (gfc_expr *x)
6461 {
6462   gfc_expr *result;
6463
6464   if (x->expr_type != EXPR_CONSTANT)
6465     return NULL;
6466
6467   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6468
6469   switch (x->ts.type)
6470     {
6471       case BT_REAL:
6472         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
6473         break;
6474
6475       case BT_COMPLEX:
6476         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6477         break;
6478
6479       default:
6480         gcc_unreachable ();
6481     }
6482
6483   return range_check (result, "TANH");
6484 }
6485
6486
6487 gfc_expr *
6488 gfc_simplify_tiny (gfc_expr *e)
6489 {
6490   gfc_expr *result;
6491   int i;
6492
6493   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
6494
6495   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6496   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6497
6498   return result;
6499 }
6500
6501
6502 gfc_expr *
6503 gfc_simplify_trailz (gfc_expr *e)
6504 {
6505   unsigned long tz, bs;
6506   int i;
6507
6508   if (e->expr_type != EXPR_CONSTANT)
6509     return NULL;
6510
6511   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6512   bs = gfc_integer_kinds[i].bit_size;
6513   tz = mpz_scan1 (e->value.integer, 0);
6514
6515   return gfc_get_int_expr (gfc_default_integer_kind,
6516                            &e->where, MIN (tz, bs));
6517 }
6518
6519
6520 gfc_expr *
6521 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6522 {
6523   gfc_expr *result;
6524   gfc_expr *mold_element;
6525   size_t source_size;
6526   size_t result_size;
6527   size_t buffer_size;
6528   mpz_t tmp;
6529   unsigned char *buffer;
6530   size_t result_length;
6531
6532
6533   if (!gfc_is_constant_expr (source)
6534         || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
6535         || !gfc_is_constant_expr (size))
6536     return NULL;
6537
6538   if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6539                                      &result_size, &result_length))
6540     return NULL;
6541
6542   /* Calculate the size of the source.  */
6543   if (source->expr_type == EXPR_ARRAY
6544       && !gfc_array_size (source, &tmp))
6545     gfc_internal_error ("Failure getting length of a constant array.");
6546
6547   /* Create an empty new expression with the appropriate characteristics.  */
6548   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6549                                   &source->where);
6550   result->ts = mold->ts;
6551
6552   mold_element = mold->expr_type == EXPR_ARRAY
6553                  ? gfc_constructor_first (mold->value.constructor)->expr
6554                  : mold;
6555
6556   /* Set result character length, if needed.  Note that this needs to be
6557      set even for array expressions, in order to pass this information into
6558      gfc_target_interpret_expr.  */
6559   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6560     result->value.character.length = mold_element->value.character.length;
6561
6562   /* Set the number of elements in the result, and determine its size.  */
6563
6564   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6565     {
6566       result->expr_type = EXPR_ARRAY;
6567       result->rank = 1;
6568       result->shape = gfc_get_shape (1);
6569       mpz_init_set_ui (result->shape[0], result_length);
6570     }
6571   else
6572     result->rank = 0;
6573
6574   /* Allocate the buffer to store the binary version of the source.  */
6575   buffer_size = MAX (source_size, result_size);
6576   buffer = (unsigned char*)alloca (buffer_size);
6577   memset (buffer, 0, buffer_size);
6578
6579   /* Now write source to the buffer.  */
6580   gfc_target_encode_expr (source, buffer, buffer_size);
6581
6582   /* And read the buffer back into the new expression.  */
6583   gfc_target_interpret_expr (buffer, buffer_size, result, false);
6584
6585   return result;
6586 }
6587
6588
6589 gfc_expr *
6590 gfc_simplify_transpose (gfc_expr *matrix)
6591 {
6592   int row, matrix_rows, col, matrix_cols;
6593   gfc_expr *result;
6594
6595   if (!is_constant_array_expr (matrix))
6596     return NULL;
6597
6598   gcc_assert (matrix->rank == 2);
6599
6600   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6601                                &matrix->where);
6602   result->rank = 2;
6603   result->shape = gfc_get_shape (result->rank);
6604   mpz_set (result->shape[0], matrix->shape[1]);
6605   mpz_set (result->shape[1], matrix->shape[0]);
6606
6607   if (matrix->ts.type == BT_CHARACTER)
6608     result->ts.u.cl = matrix->ts.u.cl;
6609   else if (matrix->ts.type == BT_DERIVED)
6610     result->ts.u.derived = matrix->ts.u.derived;
6611
6612   matrix_rows = mpz_get_si (matrix->shape[0]);
6613   matrix_cols = mpz_get_si (matrix->shape[1]);
6614   for (row = 0; row < matrix_rows; ++row)
6615     for (col = 0; col < matrix_cols; ++col)
6616       {
6617         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6618                                                    col * matrix_rows + row);
6619         gfc_constructor_insert_expr (&result->value.constructor,
6620                                      gfc_copy_expr (e), &matrix->where,
6621                                      row * matrix_cols + col);
6622       }
6623
6624   return result;
6625 }
6626
6627
6628 gfc_expr *
6629 gfc_simplify_trim (gfc_expr *e)
6630 {
6631   gfc_expr *result;
6632   int count, i, len, lentrim;
6633
6634   if (e->expr_type != EXPR_CONSTANT)
6635     return NULL;
6636
6637   len = e->value.character.length;
6638   for (count = 0, i = 1; i <= len; ++i)
6639     {
6640       if (e->value.character.string[len - i] == ' ')
6641         count++;
6642       else
6643         break;
6644     }
6645
6646   lentrim = len - count;
6647
6648   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6649   for (i = 0; i < lentrim; i++)
6650     result->value.character.string[i] = e->value.character.string[i];
6651
6652   return result;
6653 }
6654
6655
6656 gfc_expr *
6657 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6658 {
6659   gfc_expr *result;
6660   gfc_ref *ref;
6661   gfc_array_spec *as;
6662   gfc_constructor *sub_cons;
6663   bool first_image;
6664   int d;
6665
6666   if (!is_constant_array_expr (sub))
6667     return NULL;
6668
6669   /* Follow any component references.  */
6670   as = coarray->symtree->n.sym->as;
6671   for (ref = coarray->ref; ref; ref = ref->next)
6672     if (ref->type == REF_COMPONENT)
6673       as = ref->u.ar.as;
6674
6675   if (as->type == AS_DEFERRED)
6676     return NULL;
6677
6678   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6679      the cosubscript addresses the first image.  */
6680
6681   sub_cons = gfc_constructor_first (sub->value.constructor);
6682   first_image = true;
6683
6684   for (d = 1; d <= as->corank; d++)
6685     {
6686       gfc_expr *ca_bound;
6687       int cmp;
6688
6689       gcc_assert (sub_cons != NULL);
6690
6691       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6692                                      NULL, true);
6693       if (ca_bound == NULL)
6694         return NULL;
6695
6696       if (ca_bound == &gfc_bad_expr)
6697         return ca_bound;
6698
6699       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6700
6701       if (cmp == 0)
6702         {
6703           gfc_free_expr (ca_bound);
6704           sub_cons = gfc_constructor_next (sub_cons);
6705           continue;
6706         }
6707
6708       first_image = false;
6709
6710       if (cmp > 0)
6711         {
6712           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6713                      "SUB has %ld and COARRAY lower bound is %ld)",
6714                      &coarray->where, d,
6715                      mpz_get_si (sub_cons->expr->value.integer),
6716                      mpz_get_si (ca_bound->value.integer));
6717           gfc_free_expr (ca_bound);
6718           return &gfc_bad_expr;
6719         }
6720
6721       gfc_free_expr (ca_bound);
6722
6723       /* Check whether upperbound is valid for the multi-images case.  */
6724       if (d < as->corank)
6725         {
6726           ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6727                                          NULL, true);
6728           if (ca_bound == &gfc_bad_expr)
6729             return ca_bound;
6730
6731           if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6732               && mpz_cmp (ca_bound->value.integer,
6733                           sub_cons->expr->value.integer) < 0)
6734           {
6735             gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6736                        "SUB has %ld and COARRAY upper bound is %ld)",
6737                        &coarray->where, d,
6738                        mpz_get_si (sub_cons->expr->value.integer),
6739                        mpz_get_si (ca_bound->value.integer));
6740             gfc_free_expr (ca_bound);
6741             return &gfc_bad_expr;
6742           }
6743
6744           if (ca_bound)
6745             gfc_free_expr (ca_bound);
6746         }
6747
6748       sub_cons = gfc_constructor_next (sub_cons);
6749     }
6750
6751   gcc_assert (sub_cons == NULL);
6752
6753   if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
6754     return NULL;
6755
6756   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6757                                   &gfc_current_locus);
6758   if (first_image)
6759     mpz_set_si (result->value.integer, 1);
6760   else
6761     mpz_set_si (result->value.integer, 0);
6762
6763   return result;
6764 }
6765
6766
6767 gfc_expr *
6768 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
6769                          gfc_expr *distance ATTRIBUTE_UNUSED)
6770 {
6771   if (flag_coarray != GFC_FCOARRAY_SINGLE)
6772     return NULL;
6773
6774   /* If no coarray argument has been passed or when the first argument
6775      is actually a distance argment.  */
6776   if (coarray == NULL || !gfc_is_coarray (coarray))
6777     {
6778       gfc_expr *result;
6779       /* FIXME: gfc_current_locus is wrong.  */
6780       result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6781                                       &gfc_current_locus);
6782       mpz_set_si (result->value.integer, 1);
6783       return result;
6784     }
6785
6786   /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
6787   return simplify_cobound (coarray, dim, NULL, 0);
6788 }
6789
6790
6791 gfc_expr *
6792 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6793 {
6794   return simplify_bound (array, dim, kind, 1);
6795 }
6796
6797 gfc_expr *
6798 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6799 {
6800   return simplify_cobound (array, dim, kind, 1);
6801 }
6802
6803
6804 gfc_expr *
6805 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6806 {
6807   gfc_expr *result, *e;
6808   gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6809
6810   if (!is_constant_array_expr (vector)
6811       || !is_constant_array_expr (mask)
6812       || (!gfc_is_constant_expr (field)
6813           && !is_constant_array_expr (field)))
6814     return NULL;
6815
6816   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6817                                &vector->where);
6818   if (vector->ts.type == BT_DERIVED)
6819     result->ts.u.derived = vector->ts.u.derived;
6820   result->rank = mask->rank;
6821   result->shape = gfc_copy_shape (mask->shape, mask->rank);
6822
6823   if (vector->ts.type == BT_CHARACTER)
6824     result->ts.u.cl = vector->ts.u.cl;
6825
6826   vector_ctor = gfc_constructor_first (vector->value.constructor);
6827   mask_ctor = gfc_constructor_first (mask->value.constructor);
6828   field_ctor
6829     = field->expr_type == EXPR_ARRAY
6830                             ? gfc_constructor_first (field->value.constructor)
6831                             : NULL;
6832
6833   while (mask_ctor)
6834     {
6835       if (mask_ctor->expr->value.logical)
6836         {
6837           gcc_assert (vector_ctor);
6838           e = gfc_copy_expr (vector_ctor->expr);
6839           vector_ctor = gfc_constructor_next (vector_ctor);
6840         }
6841       else if (field->expr_type == EXPR_ARRAY)
6842         e = gfc_copy_expr (field_ctor->expr);
6843       else
6844         e = gfc_copy_expr (field);
6845
6846       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6847
6848       mask_ctor = gfc_constructor_next (mask_ctor);
6849       field_ctor = gfc_constructor_next (field_ctor);
6850     }
6851
6852   return result;
6853 }
6854
6855
6856 gfc_expr *
6857 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6858 {
6859   gfc_expr *result;
6860   int back;
6861   size_t index, len, lenset;
6862   size_t i;
6863   int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6864
6865   if (k == -1)
6866     return &gfc_bad_expr;
6867
6868   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
6869       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
6870     return NULL;
6871
6872   if (b != NULL && b->value.logical != 0)
6873     back = 1;
6874   else
6875     back = 0;
6876
6877   result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6878
6879   len = s->value.character.length;
6880   lenset = set->value.character.length;
6881
6882   if (len == 0)
6883     {
6884       mpz_set_ui (result->value.integer, 0);
6885       return result;
6886     }
6887
6888   if (back == 0)
6889     {
6890       if (lenset == 0)
6891         {
6892           mpz_set_ui (result->value.integer, 1);
6893           return result;
6894         }
6895
6896       index = wide_strspn (s->value.character.string,
6897                            set->value.character.string) + 1;
6898       if (index > len)
6899         index = 0;
6900
6901     }
6902   else
6903     {
6904       if (lenset == 0)
6905         {
6906           mpz_set_ui (result->value.integer, len);
6907           return result;
6908         }
6909       for (index = len; index > 0; index --)
6910         {
6911           for (i = 0; i < lenset; i++)
6912             {
6913               if (s->value.character.string[index - 1]
6914                   == set->value.character.string[i])
6915                 break;
6916             }
6917           if (i == lenset)
6918             break;
6919         }
6920     }
6921
6922   mpz_set_ui (result->value.integer, index);
6923   return result;
6924 }
6925
6926
6927 gfc_expr *
6928 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6929 {
6930   gfc_expr *result;
6931   int kind;
6932
6933   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6934     return NULL;
6935
6936   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6937
6938   switch (x->ts.type)
6939     {
6940       case BT_INTEGER:
6941         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6942         mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6943         return range_check (result, "XOR");
6944
6945       case BT_LOGICAL:
6946         return gfc_get_logical_expr (kind, &x->where,
6947                                      (x->value.logical && !y->value.logical)
6948                                      || (!x->value.logical && y->value.logical));
6949
6950       default:
6951         gcc_unreachable ();
6952     }
6953 }
6954
6955
6956 /****************** Constant simplification *****************/
6957
6958 /* Master function to convert one constant to another.  While this is
6959    used as a simplification function, it requires the destination type
6960    and kind information which is supplied by a special case in
6961    do_simplify().  */
6962
6963 gfc_expr *
6964 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6965 {
6966   gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6967   gfc_constructor *c;
6968
6969   switch (e->ts.type)
6970     {
6971     case BT_INTEGER:
6972       switch (type)
6973         {
6974         case BT_INTEGER:
6975           f = gfc_int2int;
6976           break;
6977         case BT_REAL:
6978           f = gfc_int2real;
6979           break;
6980         case BT_COMPLEX:
6981           f = gfc_int2complex;
6982           break;
6983         case BT_LOGICAL:
6984           f = gfc_int2log;
6985           break;
6986         default:
6987           goto oops;
6988         }
6989       break;
6990
6991     case BT_REAL:
6992       switch (type)
6993         {
6994         case BT_INTEGER:
6995           f = gfc_real2int;
6996           break;
6997         case BT_REAL:
6998           f = gfc_real2real;
6999           break;
7000         case BT_COMPLEX:
7001           f = gfc_real2complex;
7002           break;
7003         default:
7004           goto oops;
7005         }
7006       break;
7007
7008     case BT_COMPLEX:
7009       switch (type)
7010         {
7011         case BT_INTEGER:
7012           f = gfc_complex2int;
7013           break;
7014         case BT_REAL:
7015           f = gfc_complex2real;
7016           break;
7017         case BT_COMPLEX:
7018           f = gfc_complex2complex;
7019           break;
7020
7021         default:
7022           goto oops;
7023         }
7024       break;
7025
7026     case BT_LOGICAL:
7027       switch (type)
7028         {
7029         case BT_INTEGER:
7030           f = gfc_log2int;
7031           break;
7032         case BT_LOGICAL:
7033           f = gfc_log2log;
7034           break;
7035         default:
7036           goto oops;
7037         }
7038       break;
7039
7040     case BT_HOLLERITH:
7041       switch (type)
7042         {
7043         case BT_INTEGER:
7044           f = gfc_hollerith2int;
7045           break;
7046
7047         case BT_REAL:
7048           f = gfc_hollerith2real;
7049           break;
7050
7051         case BT_COMPLEX:
7052           f = gfc_hollerith2complex;
7053           break;
7054
7055         case BT_CHARACTER:
7056           f = gfc_hollerith2character;
7057           break;
7058
7059         case BT_LOGICAL:
7060           f = gfc_hollerith2logical;
7061           break;
7062
7063         default:
7064           goto oops;
7065         }
7066       break;
7067
7068     default:
7069     oops:
7070       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
7071     }
7072
7073   result = NULL;
7074
7075   switch (e->expr_type)
7076     {
7077     case EXPR_CONSTANT:
7078       result = f (e, kind);
7079       if (result == NULL)
7080         return &gfc_bad_expr;
7081       break;
7082
7083     case EXPR_ARRAY:
7084       if (!gfc_is_constant_expr (e))
7085         break;
7086
7087       result = gfc_get_array_expr (type, kind, &e->where);
7088       result->shape = gfc_copy_shape (e->shape, e->rank);
7089       result->rank = e->rank;
7090
7091       for (c = gfc_constructor_first (e->value.constructor);
7092            c; c = gfc_constructor_next (c))
7093         {
7094           gfc_expr *tmp;
7095           if (c->iterator == NULL)
7096             tmp = f (c->expr, kind);
7097           else
7098             {
7099               g = gfc_convert_constant (c->expr, type, kind);
7100               if (g == &gfc_bad_expr)
7101                 {
7102                   gfc_free_expr (result);
7103                   return g;
7104                 }
7105               tmp = g;
7106             }
7107
7108           if (tmp == NULL)
7109             {
7110               gfc_free_expr (result);
7111               return NULL;
7112             }
7113
7114           gfc_constructor_append_expr (&result->value.constructor,
7115                                        tmp, &c->where);
7116         }
7117
7118       break;
7119
7120     default:
7121       break;
7122     }
7123
7124   return result;
7125 }
7126
7127
7128 /* Function for converting character constants.  */
7129 gfc_expr *
7130 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
7131 {
7132   gfc_expr *result;
7133   int i;
7134
7135   if (!gfc_is_constant_expr (e))
7136     return NULL;
7137
7138   if (e->expr_type == EXPR_CONSTANT)
7139     {
7140       /* Simple case of a scalar.  */
7141       result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
7142       if (result == NULL)
7143         return &gfc_bad_expr;
7144
7145       result->value.character.length = e->value.character.length;
7146       result->value.character.string
7147         = gfc_get_wide_string (e->value.character.length + 1);
7148       memcpy (result->value.character.string, e->value.character.string,
7149               (e->value.character.length + 1) * sizeof (gfc_char_t));
7150
7151       /* Check we only have values representable in the destination kind.  */
7152       for (i = 0; i < result->value.character.length; i++)
7153         if (!gfc_check_character_range (result->value.character.string[i],
7154                                         kind))
7155           {
7156             gfc_error ("Character %qs in string at %L cannot be converted "
7157                        "into character kind %d",
7158                        gfc_print_wide_char (result->value.character.string[i]),
7159                        &e->where, kind);
7160             gfc_free_expr (result);
7161             return &gfc_bad_expr;
7162           }
7163
7164       return result;
7165     }
7166   else if (e->expr_type == EXPR_ARRAY)
7167     {
7168       /* For an array constructor, we convert each constructor element.  */
7169       gfc_constructor *c;
7170
7171       result = gfc_get_array_expr (type, kind, &e->where);
7172       result->shape = gfc_copy_shape (e->shape, e->rank);
7173       result->rank = e->rank;
7174       result->ts.u.cl = e->ts.u.cl;
7175
7176       for (c = gfc_constructor_first (e->value.constructor);
7177            c; c = gfc_constructor_next (c))
7178         {
7179           gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
7180           if (tmp == &gfc_bad_expr)
7181             {
7182               gfc_free_expr (result);
7183               return &gfc_bad_expr;
7184             }
7185
7186           if (tmp == NULL)
7187             {
7188               gfc_free_expr (result);
7189               return NULL;
7190             }
7191
7192           gfc_constructor_append_expr (&result->value.constructor,
7193                                        tmp, &c->where);
7194         }
7195
7196       return result;
7197     }
7198   else
7199     return NULL;
7200 }
7201
7202
7203 gfc_expr *
7204 gfc_simplify_compiler_options (void)
7205 {
7206   char *str;
7207   gfc_expr *result;
7208
7209   str = gfc_get_option_string ();
7210   result = gfc_get_character_expr (gfc_default_character_kind,
7211                                    &gfc_current_locus, str, strlen (str));
7212   free (str);
7213   return result;
7214 }
7215
7216
7217 gfc_expr *
7218 gfc_simplify_compiler_version (void)
7219 {
7220   char *buffer;
7221   size_t len;
7222
7223   len = strlen ("GCC version ") + strlen (version_string);
7224   buffer = XALLOCAVEC (char, len + 1);
7225   snprintf (buffer, len + 1, "GCC version %s", version_string);
7226   return gfc_get_character_expr (gfc_default_character_kind,
7227                                 &gfc_current_locus, buffer, len);
7228 }
7229
7230 /* Simplification routines for intrinsics of IEEE modules.  */
7231
7232 gfc_expr *
7233 simplify_ieee_selected_real_kind (gfc_expr *expr)
7234 {
7235   gfc_actual_arglist *arg;
7236   gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
7237
7238   arg = expr->value.function.actual;
7239   p = arg->expr;
7240   if (arg->next)
7241     {
7242       q = arg->next->expr;
7243       if (arg->next->next)
7244         rdx = arg->next->next->expr;
7245     }
7246
7247   /* Currently, if IEEE is supported and this module is built, it means
7248      all our floating-point types conform to IEEE. Hence, we simply handle
7249      IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND.  */
7250   return gfc_simplify_selected_real_kind (p, q, rdx);
7251 }
7252
7253 gfc_expr *
7254 simplify_ieee_support (gfc_expr *expr)
7255 {
7256   /* We consider that if the IEEE modules are loaded, we have full support
7257      for flags, halting and rounding, which are the three functions
7258      (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7259      expressions. One day, we will need libgfortran to detect support and
7260      communicate it back to us, allowing for partial support.  */
7261
7262   return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
7263                                true);
7264 }
7265
7266 bool
7267 matches_ieee_function_name (gfc_symbol *sym, const char *name)
7268 {
7269   int n = strlen(name);
7270
7271   if (!strncmp(sym->name, name, n))
7272     return true;
7273
7274   /* If a generic was used and renamed, we need more work to find out.
7275      Compare the specific name.  */
7276   if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
7277     return true;
7278
7279   return false;
7280 }
7281
7282 gfc_expr *
7283 gfc_simplify_ieee_functions (gfc_expr *expr)
7284 {
7285   gfc_symbol* sym = expr->symtree->n.sym;
7286
7287   if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
7288     return simplify_ieee_selected_real_kind (expr);
7289   else if (matches_ieee_function_name(sym, "ieee_support_flag")
7290            || matches_ieee_function_name(sym, "ieee_support_halting")
7291            || matches_ieee_function_name(sym, "ieee_support_rounding"))
7292     return simplify_ieee_support (expr);
7293   else
7294     return NULL;
7295 }