gcc/fortran/simplify.c

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