gcc/fortran/arith.c

   1 /* Compiler arithmetic
   2    Copyright (C) 2000-2014 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 /* Since target arithmetic must be done on the host, there has to
  22    be some way of evaluating arithmetic expressions as the host
  23    would evaluate them.  We use the GNU MP library and the MPFR
  24    library to do arithmetic, and this file provides the interface.  */
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "flags.h"
  30 #include "gfortran.h"
  31 #include "arith.h"
  32 #include "target-memory.h"
  33 #include "constructor.h"
  34
  35 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
  36    It's easily implemented with a few calls though.  */
  37
  38 void
  39 gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
  40 {
  41   mp_exp_t e;
  42
  43   if (mpfr_inf_p (x) || mpfr_nan_p (x))
  44     {
  45       gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
  46                  "to INTEGER", where);
  47       mpz_set_ui (z, 0);
  48       return;
  49     }
  50
  51   e = mpfr_get_z_exp (z, x);
  52
  53   if (e > 0)
  54     mpz_mul_2exp (z, z, e);
  55   else
  56     mpz_tdiv_q_2exp (z, z, -e);
  57 }
  58
  59
  60 /* Set the model number precision by the requested KIND.  */
  61
  62 void
  63 gfc_set_model_kind (int kind)
  64 {
  65   int index = gfc_validate_kind (BT_REAL, kind, false);
  66   int base2prec;
  67
  68   base2prec = gfc_real_kinds[index].digits;
  69   if (gfc_real_kinds[index].radix != 2)
  70     base2prec *= gfc_real_kinds[index].radix / 2;
  71   mpfr_set_default_prec (base2prec);
  72 }
  73
  74
  75 /* Set the model number precision from mpfr_t x.  */
  76
  77 void
  78 gfc_set_model (mpfr_t x)
  79 {
  80   mpfr_set_default_prec (mpfr_get_prec (x));
  81 }
  82
  83
  84 /* Given an arithmetic error code, return a pointer to a string that
  85    explains the error.  */
  86
  87 static const char *
  88 gfc_arith_error (arith code)
  89 {
  90   const char *p;
  91
  92   switch (code)
  93     {
  94     case ARITH_OK:
  95       p = _("Arithmetic OK at %L");
  96       break;
  97     case ARITH_OVERFLOW:
  98       p = _("Arithmetic overflow at %L");
  99       break;
 100     case ARITH_UNDERFLOW:
 101       p = _("Arithmetic underflow at %L");
 102       break;
 103     case ARITH_NAN:
 104       p = _("Arithmetic NaN at %L");
 105       break;
 106     case ARITH_DIV0:
 107       p = _("Division by zero at %L");
 108       break;
 109     case ARITH_INCOMMENSURATE:
 110       p = _("Array operands are incommensurate at %L");
 111       break;
 112     case ARITH_ASYMMETRIC:
 113       p =
 114         _("Integer outside symmetric range implied by Standard Fortran at %L");
 115       break;
 116     default:
 117       gfc_internal_error ("gfc_arith_error(): Bad error code");
 118     }
 119
 120   return p;
 121 }
 122
 123
 124 /* Get things ready to do math.  */
 125
 126 void
 127 gfc_arith_init_1 (void)
 128 {
 129   gfc_integer_info *int_info;
 130   gfc_real_info *real_info;
 131   mpfr_t a, b;
 132   int i;
 133
 134   mpfr_set_default_prec (128);
 135   mpfr_init (a);
 136
 137   /* Convert the minimum and maximum values for each kind into their
 138      GNU MP representation.  */
 139   for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
 140     {
 141       /* Huge  */
 142       mpz_init (int_info->huge);
 143       mpz_set_ui (int_info->huge, int_info->radix);
 144       mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
 145       mpz_sub_ui (int_info->huge, int_info->huge, 1);
 146
 147       /* These are the numbers that are actually representable by the
 148          target.  For bases other than two, this needs to be changed.  */
 149       if (int_info->radix != 2)
 150         gfc_internal_error ("Fix min_int calculation");
 151
 152       /* See PRs 13490 and 17912, related to integer ranges.
 153          The pedantic_min_int exists for range checking when a program
 154          is compiled with -pedantic, and reflects the belief that
 155          Standard Fortran requires integers to be symmetrical, i.e.
 156          every negative integer must have a representable positive
 157          absolute value, and vice versa.  */
 158
 159       mpz_init (int_info->pedantic_min_int);
 160       mpz_neg (int_info->pedantic_min_int, int_info->huge);
 161
 162       mpz_init (int_info->min_int);
 163       mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
 164
 165       /* Range  */
 166       mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
 167       mpfr_log10 (a, a, GFC_RND_MODE);
 168       mpfr_trunc (a, a);
 169       int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
 170     }
 171
 172   mpfr_clear (a);
 173
 174   for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
 175     {
 176       gfc_set_model_kind (real_info->kind);
 177
 178       mpfr_init (a);
 179       mpfr_init (b);
 180
 181       /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
 182       /* 1 - b**(-p)  */
 183       mpfr_init (real_info->huge);
 184       mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
 185       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
 186       mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
 187       mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
 188
 189       /* b**(emax-1)  */
 190       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
 191       mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
 192
 193       /* (1 - b**(-p)) * b**(emax-1)  */
 194       mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
 195
 196       /* (1 - b**(-p)) * b**(emax-1) * b  */
 197       mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
 198                    GFC_RND_MODE);
 199
 200       /* tiny(x) = b**(emin-1)  */
 201       mpfr_init (real_info->tiny);
 202       mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
 203       mpfr_pow_si (real_info->tiny, real_info->tiny,
 204                    real_info->min_exponent - 1, GFC_RND_MODE);
 205
 206       /* subnormal (x) = b**(emin - digit)  */
 207       mpfr_init (real_info->subnormal);
 208       mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
 209       mpfr_pow_si (real_info->subnormal, real_info->subnormal,
 210                    real_info->min_exponent - real_info->digits, GFC_RND_MODE);
 211
 212       /* epsilon(x) = b**(1-p)  */
 213       mpfr_init (real_info->epsilon);
 214       mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
 215       mpfr_pow_si (real_info->epsilon, real_info->epsilon,
 216                    1 - real_info->digits, GFC_RND_MODE);
 217
 218       /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
 219       mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
 220       mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
 221       mpfr_neg (b, b, GFC_RND_MODE);
 222
 223       /* a = min(a, b)  */
 224       mpfr_min (a, a, b, GFC_RND_MODE);
 225       mpfr_trunc (a, a);
 226       real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
 227
 228       /* precision(x) = int((p - 1) * log10(b)) + k  */
 229       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
 230       mpfr_log10 (a, a, GFC_RND_MODE);
 231       mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
 232       mpfr_trunc (a, a);
 233       real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
 234
 235       /* If the radix is an integral power of 10, add one to the precision.  */
 236       for (i = 10; i <= real_info->radix; i *= 10)
 237         if (i == real_info->radix)
 238           real_info->precision++;
 239
 240       mpfr_clears (a, b, NULL);
 241     }
 242 }
 243
 244
 245 /* Clean up, get rid of numeric constants.  */
 246
 247 void
 248 gfc_arith_done_1 (void)
 249 {
 250   gfc_integer_info *ip;
 251   gfc_real_info *rp;
 252
 253   for (ip = gfc_integer_kinds; ip->kind; ip++)
 254     {
 255       mpz_clear (ip->min_int);
 256       mpz_clear (ip->pedantic_min_int);
 257       mpz_clear (ip->huge);
 258     }
 259
 260   for (rp = gfc_real_kinds; rp->kind; rp++)
 261     mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
 262
 263   mpfr_free_cache ();
 264 }
 265
 266
 267 /* Given a wide character value and a character kind, determine whether
 268    the character is representable for that kind.  */
 269 bool
 270 gfc_check_character_range (gfc_char_t c, int kind)
 271 {
 272   /* As wide characters are stored as 32-bit values, they're all
 273      representable in UCS=4.  */
 274   if (kind == 4)
 275     return true;
 276
 277   if (kind == 1)
 278     return c <= 255 ? true : false;
 279
 280   gcc_unreachable ();
 281 }
 282
 283
 284 /* Given an integer and a kind, make sure that the integer lies within
 285    the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
 286    ARITH_OVERFLOW.  */
 287
 288 arith
 289 gfc_check_integer_range (mpz_t p, int kind)
 290 {
 291   arith result;
 292   int i;
 293
 294   i = gfc_validate_kind (BT_INTEGER, kind, false);
 295   result = ARITH_OK;
 296
 297   if (pedantic)
 298     {
 299       if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
 300         result = ARITH_ASYMMETRIC;
 301     }
 302
 303
 304   if (gfc_option.flag_range_check == 0)
 305     return result;
 306
 307   if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
 308       || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
 309     result = ARITH_OVERFLOW;
 310
 311   return result;
 312 }
 313
 314
 315 /* Given a real and a kind, make sure that the real lies within the
 316    range of the kind.  Returns ARITH_OK, ARITH_OVERFLOW or
 317    ARITH_UNDERFLOW.  */
 318
 319 static arith
 320 gfc_check_real_range (mpfr_t p, int kind)
 321 {
 322   arith retval;
 323   mpfr_t q;
 324   int i;
 325
 326   i = gfc_validate_kind (BT_REAL, kind, false);
 327
 328   gfc_set_model (p);
 329   mpfr_init (q);
 330   mpfr_abs (q, p, GFC_RND_MODE);
 331
 332   retval = ARITH_OK;
 333
 334   if (mpfr_inf_p (p))
 335     {
 336       if (gfc_option.flag_range_check != 0)
 337         retval = ARITH_OVERFLOW;
 338     }
 339   else if (mpfr_nan_p (p))
 340     {
 341       if (gfc_option.flag_range_check != 0)
 342         retval = ARITH_NAN;
 343     }
 344   else if (mpfr_sgn (q) == 0)
 345     {
 346       mpfr_clear (q);
 347       return retval;
 348     }
 349   else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
 350     {
 351       if (gfc_option.flag_range_check == 0)
 352         mpfr_set_inf (p, mpfr_sgn (p));
 353       else
 354         retval = ARITH_OVERFLOW;
 355     }
 356   else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
 357     {
 358       if (gfc_option.flag_range_check == 0)
 359         {
 360           if (mpfr_sgn (p) < 0)
 361             {
 362               mpfr_set_ui (p, 0, GFC_RND_MODE);
 363               mpfr_set_si (q, -1, GFC_RND_MODE);
 364               mpfr_copysign (p, p, q, GFC_RND_MODE);
 365             }
 366           else
 367             mpfr_set_ui (p, 0, GFC_RND_MODE);
 368         }
 369       else
 370         retval = ARITH_UNDERFLOW;
 371     }
 372   else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
 373     {
 374       mp_exp_t emin, emax;
 375       int en;
 376
 377       /* Save current values of emin and emax.  */
 378       emin = mpfr_get_emin ();
 379       emax = mpfr_get_emax ();
 380
 381       /* Set emin and emax for the current model number.  */
 382       en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
 383       mpfr_set_emin ((mp_exp_t) en);
 384       mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
 385       mpfr_check_range (q, 0, GFC_RND_MODE);
 386       mpfr_subnormalize (q, 0, GFC_RND_MODE);
 387
 388       /* Reset emin and emax.  */
 389       mpfr_set_emin (emin);
 390       mpfr_set_emax (emax);
 391
 392       /* Copy sign if needed.  */
 393       if (mpfr_sgn (p) < 0)
 394         mpfr_neg (p, q, GMP_RNDN);
 395       else
 396         mpfr_set (p, q, GMP_RNDN);
 397     }
 398
 399   mpfr_clear (q);
 400
 401   return retval;
 402 }
 403
 404
 405 /* Low-level arithmetic functions.  All of these subroutines assume
 406    that all operands are of the same type and return an operand of the
 407    same type.  The other thing about these subroutines is that they
 408    can fail in various ways -- overflow, underflow, division by zero,
 409    zero raised to the zero, etc.  */
 410
 411 static arith
 412 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
 413 {
 414   gfc_expr *result;
 415
 416   result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
 417   result->value.logical = !op1->value.logical;
 418   *resultp = result;
 419
 420   return ARITH_OK;
 421 }
 422
 423
 424 static arith
 425 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 426 {
 427   gfc_expr *result;
 428
 429   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 430                                   &op1->where);
 431   result->value.logical = op1->value.logical && op2->value.logical;
 432   *resultp = result;
 433
 434   return ARITH_OK;
 435 }
 436
 437
 438 static arith
 439 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 440 {
 441   gfc_expr *result;
 442
 443   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 444                                   &op1->where);
 445   result->value.logical = op1->value.logical || op2->value.logical;
 446   *resultp = result;
 447
 448   return ARITH_OK;
 449 }
 450
 451
 452 static arith
 453 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 454 {
 455   gfc_expr *result;
 456
 457   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 458                                   &op1->where);
 459   result->value.logical = op1->value.logical == op2->value.logical;
 460   *resultp = result;
 461
 462   return ARITH_OK;
 463 }
 464
 465
 466 static arith
 467 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 468 {
 469   gfc_expr *result;
 470
 471   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 472                                   &op1->where);
 473   result->value.logical = op1->value.logical != op2->value.logical;
 474   *resultp = result;
 475
 476   return ARITH_OK;
 477 }
 478
 479
 480 /* Make sure a constant numeric expression is within the range for
 481    its type and kind.  Note that there's also a gfc_check_range(),
 482    but that one deals with the intrinsic RANGE function.  */
 483
 484 arith
 485 gfc_range_check (gfc_expr *e)
 486 {
 487   arith rc;
 488   arith rc2;
 489
 490   switch (e->ts.type)
 491     {
 492     case BT_INTEGER:
 493       rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
 494       break;
 495
 496     case BT_REAL:
 497       rc = gfc_check_real_range (e->value.real, e->ts.kind);
 498       if (rc == ARITH_UNDERFLOW)
 499         mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
 500       if (rc == ARITH_OVERFLOW)
 501         mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
 502       if (rc == ARITH_NAN)
 503         mpfr_set_nan (e->value.real);
 504       break;
 505
 506     case BT_COMPLEX:
 507       rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
 508       if (rc == ARITH_UNDERFLOW)
 509         mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
 510       if (rc == ARITH_OVERFLOW)
 511         mpfr_set_inf (mpc_realref (e->value.complex),
 512                       mpfr_sgn (mpc_realref (e->value.complex)));
 513       if (rc == ARITH_NAN)
 514         mpfr_set_nan (mpc_realref (e->value.complex));
 515
 516       rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
 517       if (rc == ARITH_UNDERFLOW)
 518         mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
 519       if (rc == ARITH_OVERFLOW)
 520         mpfr_set_inf (mpc_imagref (e->value.complex),
 521                       mpfr_sgn (mpc_imagref (e->value.complex)));
 522       if (rc == ARITH_NAN)
 523         mpfr_set_nan (mpc_imagref (e->value.complex));
 524
 525       if (rc == ARITH_OK)
 526         rc = rc2;
 527       break;
 528
 529     default:
 530       gfc_internal_error ("gfc_range_check(): Bad type");
 531     }
 532
 533   return rc;
 534 }
 535
 536
 537 /* Several of the following routines use the same set of statements to
 538    check the validity of the result.  Encapsulate the checking here.  */
 539
 540 static arith
 541 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
 542 {
 543   arith val = rc;
 544
 545   if (val == ARITH_UNDERFLOW)
 546     {
 547       if (gfc_option.warn_underflow)
 548         gfc_warning (gfc_arith_error (val), &x->where);
 549       val = ARITH_OK;
 550     }
 551
 552   if (val == ARITH_ASYMMETRIC)
 553     {
 554       gfc_warning (gfc_arith_error (val), &x->where);
 555       val = ARITH_OK;
 556     }
 557
 558   if (val != ARITH_OK)
 559     gfc_free_expr (r);
 560   else
 561     *rp = r;
 562
 563   return val;
 564 }
 565
 566
 567 /* It may seem silly to have a subroutine that actually computes the
 568    unary plus of a constant, but it prevents us from making exceptions
 569    in the code elsewhere.  Used for unary plus and parenthesized
 570    expressions.  */
 571
 572 static arith
 573 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
 574 {
 575   *resultp = gfc_copy_expr (op1);
 576   return ARITH_OK;
 577 }
 578
 579
 580 static arith
 581 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
 582 {
 583   gfc_expr *result;
 584   arith rc;
 585
 586   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 587
 588   switch (op1->ts.type)
 589     {
 590     case BT_INTEGER:
 591       mpz_neg (result->value.integer, op1->value.integer);
 592       break;
 593
 594     case BT_REAL:
 595       mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
 596       break;
 597
 598     case BT_COMPLEX:
 599       mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
 600       break;
 601
 602     default:
 603       gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
 604     }
 605
 606   rc = gfc_range_check (result);
 607
 608   return check_result (rc, op1, result, resultp);
 609 }
 610
 611
 612 static arith
 613 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 614 {
 615   gfc_expr *result;
 616   arith rc;
 617
 618   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 619
 620   switch (op1->ts.type)
 621     {
 622     case BT_INTEGER:
 623       mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
 624       break;
 625
 626     case BT_REAL:
 627       mpfr_add (result->value.real, op1->value.real, op2->value.real,
 628                GFC_RND_MODE);
 629       break;
 630
 631     case BT_COMPLEX:
 632       mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
 633                GFC_MPC_RND_MODE);
 634       break;
 635
 636     default:
 637       gfc_internal_error ("gfc_arith_plus(): Bad basic type");
 638     }
 639
 640   rc = gfc_range_check (result);
 641
 642   return check_result (rc, op1, result, resultp);
 643 }
 644
 645
 646 static arith
 647 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 648 {
 649   gfc_expr *result;
 650   arith rc;
 651
 652   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 653
 654   switch (op1->ts.type)
 655     {
 656     case BT_INTEGER:
 657       mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
 658       break;
 659
 660     case BT_REAL:
 661       mpfr_sub (result->value.real, op1->value.real, op2->value.real,
 662                 GFC_RND_MODE);
 663       break;
 664
 665     case BT_COMPLEX:
 666       mpc_sub (result->value.complex, op1->value.complex,
 667                op2->value.complex, GFC_MPC_RND_MODE);
 668       break;
 669
 670     default:
 671       gfc_internal_error ("gfc_arith_minus(): Bad basic type");
 672     }
 673
 674   rc = gfc_range_check (result);
 675
 676   return check_result (rc, op1, result, resultp);
 677 }
 678
 679
 680 static arith
 681 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 682 {
 683   gfc_expr *result;
 684   arith rc;
 685
 686   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 687
 688   switch (op1->ts.type)
 689     {
 690     case BT_INTEGER:
 691       mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
 692       break;
 693
 694     case BT_REAL:
 695       mpfr_mul (result->value.real, op1->value.real, op2->value.real,
 696                GFC_RND_MODE);
 697       break;
 698
 699     case BT_COMPLEX:
 700       gfc_set_model (mpc_realref (op1->value.complex));
 701       mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
 702                GFC_MPC_RND_MODE);
 703       break;
 704
 705     default:
 706       gfc_internal_error ("gfc_arith_times(): Bad basic type");
 707     }
 708
 709   rc = gfc_range_check (result);
 710
 711   return check_result (rc, op1, result, resultp);
 712 }
 713
 714
 715 static arith
 716 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 717 {
 718   gfc_expr *result;
 719   arith rc;
 720
 721   rc = ARITH_OK;
 722
 723   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 724
 725   switch (op1->ts.type)
 726     {
 727     case BT_INTEGER:
 728       if (mpz_sgn (op2->value.integer) == 0)
 729         {
 730           rc = ARITH_DIV0;
 731           break;
 732         }
 733
 734       mpz_tdiv_q (result->value.integer, op1->value.integer,
 735                   op2->value.integer);
 736       break;
 737
 738     case BT_REAL:
 739       if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
 740         {
 741           rc = ARITH_DIV0;
 742           break;
 743         }
 744
 745       mpfr_div (result->value.real, op1->value.real, op2->value.real,
 746                GFC_RND_MODE);
 747       break;
 748
 749     case BT_COMPLEX:
 750       if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
 751           && gfc_option.flag_range_check == 1)
 752         {
 753           rc = ARITH_DIV0;
 754           break;
 755         }
 756
 757       gfc_set_model (mpc_realref (op1->value.complex));
 758       if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
 759       {
 760         /* In Fortran, return (NaN + NaN I) for any zero divisor.  See
 761            PR 40318. */
 762         mpfr_set_nan (mpc_realref (result->value.complex));
 763         mpfr_set_nan (mpc_imagref (result->value.complex));
 764       }
 765       else
 766         mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
 767                  GFC_MPC_RND_MODE);
 768       break;
 769
 770     default:
 771       gfc_internal_error ("gfc_arith_divide(): Bad basic type");
 772     }
 773
 774   if (rc == ARITH_OK)
 775     rc = gfc_range_check (result);
 776
 777   return check_result (rc, op1, result, resultp);
 778 }
 779
 780 /* Raise a number to a power.  */
 781
 782 static arith
 783 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 784 {
 785   int power_sign;
 786   gfc_expr *result;
 787   arith rc;
 788
 789   rc = ARITH_OK;
 790   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 791
 792   switch (op2->ts.type)
 793     {
 794     case BT_INTEGER:
 795       power_sign = mpz_sgn (op2->value.integer);
 796
 797       if (power_sign == 0)
 798         {
 799           /* Handle something to the zeroth power.  Since we're dealing
 800              with integral exponents, there is no ambiguity in the
 801              limiting procedure used to determine the value of 0**0.  */
 802           switch (op1->ts.type)
 803             {
 804             case BT_INTEGER:
 805               mpz_set_ui (result->value.integer, 1);
 806               break;
 807
 808             case BT_REAL:
 809               mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
 810               break;
 811
 812             case BT_COMPLEX:
 813               mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
 814               break;
 815
 816             default:
 817               gfc_internal_error ("arith_power(): Bad base");
 818             }
 819         }
 820       else
 821         {
 822           switch (op1->ts.type)
 823             {
 824             case BT_INTEGER:
 825               {
 826                 int power;
 827
 828                 /* First, we simplify the cases of op1 == 1, 0 or -1.  */
 829                 if (mpz_cmp_si (op1->value.integer, 1) == 0)
 830                   {
 831                     /* 1**op2 == 1 */
 832                     mpz_set_si (result->value.integer, 1);
 833                   }
 834                 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
 835                   {
 836                     /* 0**op2 == 0, if op2 > 0
 837                        0**op2 overflow, if op2 < 0 ; in that case, we
 838                        set the result to 0 and return ARITH_DIV0.  */
 839                     mpz_set_si (result->value.integer, 0);
 840                     if (mpz_cmp_si (op2->value.integer, 0) < 0)
 841                       rc = ARITH_DIV0;
 842                   }
 843                 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
 844                   {
 845                     /* (-1)**op2 == (-1)**(mod(op2,2)) */
 846                     unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
 847                     if (odd)
 848                       mpz_set_si (result->value.integer, -1);
 849                     else
 850                       mpz_set_si (result->value.integer, 1);
 851                   }
 852                 /* Then, we take care of op2 < 0.  */
 853                 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
 854                   {
 855                     /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
 856                     mpz_set_si (result->value.integer, 0);
 857                   }
 858                 else if (gfc_extract_int (op2, &power) != NULL)
 859                   {
 860                     /* If op2 doesn't fit in an int, the exponentiation will
 861                        overflow, because op2 > 0 and abs(op1) > 1.  */
 862                     mpz_t max;
 863                     int i;
 864                     i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
 865
 866                     if (gfc_option.flag_range_check)
 867                       rc = ARITH_OVERFLOW;
 868
 869                     /* Still, we want to give the same value as the
 870                        processor.  */
 871                     mpz_init (max);
 872                     mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
 873                     mpz_mul_ui (max, max, 2);
 874                     mpz_powm (result->value.integer, op1->value.integer,
 875                               op2->value.integer, max);
 876                     mpz_clear (max);
 877                   }
 878                 else
 879                   mpz_pow_ui (result->value.integer, op1->value.integer,
 880                               power);
 881               }
 882               break;
 883
 884             case BT_REAL:
 885               mpfr_pow_z (result->value.real, op1->value.real,
 886                           op2->value.integer, GFC_RND_MODE);
 887               break;
 888
 889             case BT_COMPLEX:
 890               mpc_pow_z (result->value.complex, op1->value.complex,
 891                          op2->value.integer, GFC_MPC_RND_MODE);
 892               break;
 893
 894             default:
 895               break;
 896             }
 897         }
 898       break;
 899
 900     case BT_REAL:
 901
 902       if (gfc_init_expr_flag)
 903         {
 904           if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
 905                                "exponent in an initialization "
 906                                "expression at %L", &op2->where))
 907             {
 908               gfc_free_expr (result);
 909               return ARITH_PROHIBIT;
 910             }
 911         }
 912
 913       if (mpfr_cmp_si (op1->value.real, 0) < 0)
 914         {
 915           gfc_error ("Raising a negative REAL at %L to "
 916                      "a REAL power is prohibited", &op1->where);
 917           gfc_free_expr (result);
 918           return ARITH_PROHIBIT;
 919         }
 920
 921         mpfr_pow (result->value.real, op1->value.real, op2->value.real,
 922                   GFC_RND_MODE);
 923       break;
 924
 925     case BT_COMPLEX:
 926       {
 927         if (gfc_init_expr_flag)
 928           {
 929             if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
 930                                  "exponent in an initialization "
 931                                  "expression at %L", &op2->where))
 932               {
 933                 gfc_free_expr (result);
 934                 return ARITH_PROHIBIT;
 935               }
 936           }
 937
 938         mpc_pow (result->value.complex, op1->value.complex,
 939                  op2->value.complex, GFC_MPC_RND_MODE);
 940       }
 941       break;
 942     default:
 943       gfc_internal_error ("arith_power(): unknown type");
 944     }
 945
 946   if (rc == ARITH_OK)
 947     rc = gfc_range_check (result);
 948
 949   return check_result (rc, op1, result, resultp);
 950 }
 951
 952
 953 /* Concatenate two string constants.  */
 954
 955 static arith
 956 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 957 {
 958   gfc_expr *result;
 959   int len;
 960
 961   gcc_assert (op1->ts.kind == op2->ts.kind);
 962   result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
 963                                   &op1->where);
 964
 965   len = op1->value.character.length + op2->value.character.length;
 966
 967   result->value.character.string = gfc_get_wide_string (len + 1);
 968   result->value.character.length = len;
 969
 970   memcpy (result->value.character.string, op1->value.character.string,
 971           op1->value.character.length * sizeof (gfc_char_t));
 972
 973   memcpy (&result->value.character.string[op1->value.character.length],
 974           op2->value.character.string,
 975           op2->value.character.length * sizeof (gfc_char_t));
 976
 977   result->value.character.string[len] = '\0';
 978
 979   *resultp = result;
 980
 981   return ARITH_OK;
 982 }
 983
 984 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
 985    This function mimics mpfr_cmp but takes NaN into account.  */
 986
 987 static int
 988 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
 989 {
 990   int rc;
 991   switch (op)
 992     {
 993       case INTRINSIC_EQ:
 994         rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
 995         break;
 996       case INTRINSIC_GT:
 997         rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
 998         break;
 999       case INTRINSIC_GE:
1000         rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1001         break;
1002       case INTRINSIC_LT:
1003         rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1004         break;
1005       case INTRINSIC_LE:
1006         rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1007         break;
1008       default:
1009         gfc_internal_error ("compare_real(): Bad operator");
1010     }
1011
1012   return rc;
1013 }
1014
1015 /* Comparison operators.  Assumes that the two expression nodes
1016    contain two constants of the same type. The op argument is
1017    needed to handle NaN correctly.  */
1018
1019 int
1020 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1021 {
1022   int rc;
1023
1024   switch (op1->ts.type)
1025     {
1026     case BT_INTEGER:
1027       rc = mpz_cmp (op1->value.integer, op2->value.integer);
1028       break;
1029
1030     case BT_REAL:
1031       rc = compare_real (op1, op2, op);
1032       break;
1033
1034     case BT_CHARACTER:
1035       rc = gfc_compare_string (op1, op2);
1036       break;
1037
1038     case BT_LOGICAL:
1039       rc = ((!op1->value.logical && op2->value.logical)
1040             || (op1->value.logical && !op2->value.logical));
1041       break;
1042
1043     default:
1044       gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1045     }
1046
1047   return rc;
1048 }
1049
1050
1051 /* Compare a pair of complex numbers.  Naturally, this is only for
1052    equality and inequality.  */
1053
1054 static int
1055 compare_complex (gfc_expr *op1, gfc_expr *op2)
1056 {
1057   return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1058 }
1059
1060
1061 /* Given two constant strings and the inverse collating sequence, compare the
1062    strings.  We return -1 for a < b, 0 for a == b and 1 for a > b.
1063    We use the processor's default collating sequence.  */
1064
1065 int
1066 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1067 {
1068   int len, alen, blen, i;
1069   gfc_char_t ac, bc;
1070
1071   alen = a->value.character.length;
1072   blen = b->value.character.length;
1073
1074   len = MAX(alen, blen);
1075
1076   for (i = 0; i < len; i++)
1077     {
1078       ac = ((i < alen) ? a->value.character.string[i] : ' ');
1079       bc = ((i < blen) ? b->value.character.string[i] : ' ');
1080
1081       if (ac < bc)
1082         return -1;
1083       if (ac > bc)
1084         return 1;
1085     }
1086
1087   /* Strings are equal */
1088   return 0;
1089 }
1090
1091
1092 int
1093 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1094 {
1095   int len, alen, blen, i;
1096   gfc_char_t ac, bc;
1097
1098   alen = a->value.character.length;
1099   blen = strlen (b);
1100
1101   len = MAX(alen, blen);
1102
1103   for (i = 0; i < len; i++)
1104     {
1105       ac = ((i < alen) ? a->value.character.string[i] : ' ');
1106       bc = ((i < blen) ? b[i] : ' ');
1107
1108       if (!case_sensitive)
1109         {
1110           ac = TOLOWER (ac);
1111           bc = TOLOWER (bc);
1112         }
1113
1114       if (ac < bc)
1115         return -1;
1116       if (ac > bc)
1117         return 1;
1118     }
1119
1120   /* Strings are equal */
1121   return 0;
1122 }
1123
1124
1125 /* Specific comparison subroutines.  */
1126
1127 static arith
1128 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1129 {
1130   gfc_expr *result;
1131
1132   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1133                                   &op1->where);
1134   result->value.logical = (op1->ts.type == BT_COMPLEX)
1135                         ? compare_complex (op1, op2)
1136                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1137
1138   *resultp = result;
1139   return ARITH_OK;
1140 }
1141
1142
1143 static arith
1144 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1145 {
1146   gfc_expr *result;
1147
1148   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1149                                   &op1->where);
1150   result->value.logical = (op1->ts.type == BT_COMPLEX)
1151                         ? !compare_complex (op1, op2)
1152                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1153
1154   *resultp = result;
1155   return ARITH_OK;
1156 }
1157
1158
1159 static arith
1160 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1161 {
1162   gfc_expr *result;
1163
1164   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1165                                   &op1->where);
1166   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1167   *resultp = result;
1168
1169   return ARITH_OK;
1170 }
1171
1172
1173 static arith
1174 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1175 {
1176   gfc_expr *result;
1177
1178   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1179                                   &op1->where);
1180   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1181   *resultp = result;
1182
1183   return ARITH_OK;
1184 }
1185
1186
1187 static arith
1188 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1189 {
1190   gfc_expr *result;
1191
1192   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1193                                   &op1->where);
1194   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1195   *resultp = result;
1196
1197   return ARITH_OK;
1198 }
1199
1200
1201 static arith
1202 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1203 {
1204   gfc_expr *result;
1205
1206   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1207                                   &op1->where);
1208   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1209   *resultp = result;
1210
1211   return ARITH_OK;
1212 }
1213
1214
1215 static arith
1216 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1217               gfc_expr **result)
1218 {
1219   gfc_constructor_base head;
1220   gfc_constructor *c;
1221   gfc_expr *r;
1222   arith rc;
1223
1224   if (op->expr_type == EXPR_CONSTANT)
1225     return eval (op, result);
1226
1227   rc = ARITH_OK;
1228   head = gfc_constructor_copy (op->value.constructor);
1229   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1230     {
1231       rc = reduce_unary (eval, c->expr, &r);
1232
1233       if (rc != ARITH_OK)
1234         break;
1235
1236       gfc_replace_expr (c->expr, r);
1237     }
1238
1239   if (rc != ARITH_OK)
1240     gfc_constructor_free (head);
1241   else
1242     {
1243       gfc_constructor *c = gfc_constructor_first (head);
1244       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1245                               &op->where);
1246       r->shape = gfc_copy_shape (op->shape, op->rank);
1247       r->rank = op->rank;
1248       r->value.constructor = head;
1249       *result = r;
1250     }
1251
1252   return rc;
1253 }
1254
1255
1256 static arith
1257 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1258                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1259 {
1260   gfc_constructor_base head;
1261   gfc_constructor *c;
1262   gfc_expr *r;
1263   arith rc = ARITH_OK;
1264
1265   head = gfc_constructor_copy (op1->value.constructor);
1266   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1267     {
1268       if (c->expr->expr_type == EXPR_CONSTANT)
1269         rc = eval (c->expr, op2, &r);
1270       else
1271         rc = reduce_binary_ac (eval, c->expr, op2, &r);
1272
1273       if (rc != ARITH_OK)
1274         break;
1275
1276       gfc_replace_expr (c->expr, r);
1277     }
1278
1279   if (rc != ARITH_OK)
1280     gfc_constructor_free (head);
1281   else
1282     {
1283       gfc_constructor *c = gfc_constructor_first (head);
1284       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1285                               &op1->where);
1286       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1287       r->rank = op1->rank;
1288       r->value.constructor = head;
1289       *result = r;
1290     }
1291
1292   return rc;
1293 }
1294
1295
1296 static arith
1297 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1298                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1299 {
1300   gfc_constructor_base head;
1301   gfc_constructor *c;
1302   gfc_expr *r;
1303   arith rc = ARITH_OK;
1304
1305   head = gfc_constructor_copy (op2->value.constructor);
1306   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1307     {
1308       if (c->expr->expr_type == EXPR_CONSTANT)
1309         rc = eval (op1, c->expr, &r);
1310       else
1311         rc = reduce_binary_ca (eval, op1, c->expr, &r);
1312
1313       if (rc != ARITH_OK)
1314         break;
1315
1316       gfc_replace_expr (c->expr, r);
1317     }
1318
1319   if (rc != ARITH_OK)
1320     gfc_constructor_free (head);
1321   else
1322     {
1323       gfc_constructor *c = gfc_constructor_first (head);
1324       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1325                               &op2->where);
1326       r->shape = gfc_copy_shape (op2->shape, op2->rank);
1327       r->rank = op2->rank;
1328       r->value.constructor = head;
1329       *result = r;
1330     }
1331
1332   return rc;
1333 }
1334
1335
1336 /* We need a forward declaration of reduce_binary.  */
1337 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1338                             gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1339
1340
1341 static arith
1342 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1343                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1344 {
1345   gfc_constructor_base head;
1346   gfc_constructor *c, *d;
1347   gfc_expr *r;
1348   arith rc = ARITH_OK;
1349
1350   if (!gfc_check_conformance (op1, op2, "elemental binary operation"))
1351     return ARITH_INCOMMENSURATE;
1352
1353   head = gfc_constructor_copy (op1->value.constructor);
1354   for (c = gfc_constructor_first (head),
1355        d = gfc_constructor_first (op2->value.constructor);
1356        c && d;
1357        c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1358     {
1359         rc = reduce_binary (eval, c->expr, d->expr, &r);
1360         if (rc != ARITH_OK)
1361           break;
1362
1363         gfc_replace_expr (c->expr, r);
1364     }
1365
1366   if (c || d)
1367     rc = ARITH_INCOMMENSURATE;
1368
1369   if (rc != ARITH_OK)
1370     gfc_constructor_free (head);
1371   else
1372     {
1373       gfc_constructor *c = gfc_constructor_first (head);
1374       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1375                               &op1->where);
1376       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1377       r->rank = op1->rank;
1378       r->value.constructor = head;
1379       *result = r;
1380     }
1381
1382   return rc;
1383 }
1384
1385
1386 static arith
1387 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1388                gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1389 {
1390   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1391     return eval (op1, op2, result);
1392
1393   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1394     return reduce_binary_ca (eval, op1, op2, result);
1395
1396   if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1397     return reduce_binary_ac (eval, op1, op2, result);
1398
1399   return reduce_binary_aa (eval, op1, op2, result);
1400 }
1401
1402
1403 typedef union
1404 {
1405   arith (*f2)(gfc_expr *, gfc_expr **);
1406   arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1407 }
1408 eval_f;
1409
1410 /* High level arithmetic subroutines.  These subroutines go into
1411    eval_intrinsic(), which can do one of several things to its
1412    operands.  If the operands are incompatible with the intrinsic
1413    operation, we return a node pointing to the operands and hope that
1414    an operator interface is found during resolution.
1415
1416    If the operands are compatible and are constants, then we try doing
1417    the arithmetic.  We also handle the cases where either or both
1418    operands are array constructors.  */
1419
1420 static gfc_expr *
1421 eval_intrinsic (gfc_intrinsic_op op,
1422                 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1423 {
1424   gfc_expr temp, *result;
1425   int unary;
1426   arith rc;
1427
1428   gfc_clear_ts (&temp.ts);
1429
1430   switch (op)
1431     {
1432     /* Logical unary  */
1433     case INTRINSIC_NOT:
1434       if (op1->ts.type != BT_LOGICAL)
1435         goto runtime;
1436
1437       temp.ts.type = BT_LOGICAL;
1438       temp.ts.kind = gfc_default_logical_kind;
1439       unary = 1;
1440       break;
1441
1442     /* Logical binary operators  */
1443     case INTRINSIC_OR:
1444     case INTRINSIC_AND:
1445     case INTRINSIC_NEQV:
1446     case INTRINSIC_EQV:
1447       if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1448         goto runtime;
1449
1450       temp.ts.type = BT_LOGICAL;
1451       temp.ts.kind = gfc_default_logical_kind;
1452       unary = 0;
1453       break;
1454
1455     /* Numeric unary  */
1456     case INTRINSIC_UPLUS:
1457     case INTRINSIC_UMINUS:
1458       if (!gfc_numeric_ts (&op1->ts))
1459         goto runtime;
1460
1461       temp.ts = op1->ts;
1462       unary = 1;
1463       break;
1464
1465     case INTRINSIC_PARENTHESES:
1466       temp.ts = op1->ts;
1467       unary = 1;
1468       break;
1469
1470     /* Additional restrictions for ordering relations.  */
1471     case INTRINSIC_GE:
1472     case INTRINSIC_GE_OS:
1473     case INTRINSIC_LT:
1474     case INTRINSIC_LT_OS:
1475     case INTRINSIC_LE:
1476     case INTRINSIC_LE_OS:
1477     case INTRINSIC_GT:
1478     case INTRINSIC_GT_OS:
1479       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1480         {
1481           temp.ts.type = BT_LOGICAL;
1482           temp.ts.kind = gfc_default_logical_kind;
1483           goto runtime;
1484         }
1485
1486     /* Fall through  */
1487     case INTRINSIC_EQ:
1488     case INTRINSIC_EQ_OS:
1489     case INTRINSIC_NE:
1490     case INTRINSIC_NE_OS:
1491       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1492         {
1493           unary = 0;
1494           temp.ts.type = BT_LOGICAL;
1495           temp.ts.kind = gfc_default_logical_kind;
1496
1497           /* If kind mismatch, exit and we'll error out later.  */
1498           if (op1->ts.kind != op2->ts.kind)
1499             goto runtime;
1500
1501           break;
1502         }
1503
1504     /* Fall through  */
1505     /* Numeric binary  */
1506     case INTRINSIC_PLUS:
1507     case INTRINSIC_MINUS:
1508     case INTRINSIC_TIMES:
1509     case INTRINSIC_DIVIDE:
1510     case INTRINSIC_POWER:
1511       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1512         goto runtime;
1513
1514       /* Insert any necessary type conversions to make the operands
1515          compatible.  */
1516
1517       temp.expr_type = EXPR_OP;
1518       gfc_clear_ts (&temp.ts);
1519       temp.value.op.op = op;
1520
1521       temp.value.op.op1 = op1;
1522       temp.value.op.op2 = op2;
1523
1524       gfc_type_convert_binary (&temp, 0);
1525
1526       if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1527           || op == INTRINSIC_GE || op == INTRINSIC_GT
1528           || op == INTRINSIC_LE || op == INTRINSIC_LT
1529           || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1530           || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1531           || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1532         {
1533           temp.ts.type = BT_LOGICAL;
1534           temp.ts.kind = gfc_default_logical_kind;
1535         }
1536
1537       unary = 0;
1538       break;
1539
1540     /* Character binary  */
1541     case INTRINSIC_CONCAT:
1542       if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1543           || op1->ts.kind != op2->ts.kind)
1544         goto runtime;
1545
1546       temp.ts.type = BT_CHARACTER;
1547       temp.ts.kind = op1->ts.kind;
1548       unary = 0;
1549       break;
1550
1551     case INTRINSIC_USER:
1552       goto runtime;
1553
1554     default:
1555       gfc_internal_error ("eval_intrinsic(): Bad operator");
1556     }
1557
1558   if (op1->expr_type != EXPR_CONSTANT
1559       && (op1->expr_type != EXPR_ARRAY
1560           || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1561     goto runtime;
1562
1563   if (op2 != NULL
1564       && op2->expr_type != EXPR_CONSTANT
1565          && (op2->expr_type != EXPR_ARRAY
1566              || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1567     goto runtime;
1568
1569   if (unary)
1570     rc = reduce_unary (eval.f2, op1, &result);
1571   else
1572     rc = reduce_binary (eval.f3, op1, op2, &result);
1573
1574
1575   /* Something went wrong.  */
1576   if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1577     return NULL;
1578
1579   if (rc != ARITH_OK)
1580     {
1581       gfc_error (gfc_arith_error (rc), &op1->where);
1582       return NULL;
1583     }
1584
1585   gfc_free_expr (op1);
1586   gfc_free_expr (op2);
1587   return result;
1588
1589 runtime:
1590   /* Create a run-time expression.  */
1591   result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1592   result->ts = temp.ts;
1593
1594   return result;
1595 }
1596
1597
1598 /* Modify type of expression for zero size array.  */
1599
1600 static gfc_expr *
1601 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1602 {
1603   if (op == NULL)
1604     gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1605
1606   switch (iop)
1607     {
1608     case INTRINSIC_GE:
1609     case INTRINSIC_GE_OS:
1610     case INTRINSIC_LT:
1611     case INTRINSIC_LT_OS:
1612     case INTRINSIC_LE:
1613     case INTRINSIC_LE_OS:
1614     case INTRINSIC_GT:
1615     case INTRINSIC_GT_OS:
1616     case INTRINSIC_EQ:
1617     case INTRINSIC_EQ_OS:
1618     case INTRINSIC_NE:
1619     case INTRINSIC_NE_OS:
1620       op->ts.type = BT_LOGICAL;
1621       op->ts.kind = gfc_default_logical_kind;
1622       break;
1623
1624     default:
1625       break;
1626     }
1627
1628   return op;
1629 }
1630
1631
1632 /* Return nonzero if the expression is a zero size array.  */
1633
1634 static int
1635 gfc_zero_size_array (gfc_expr *e)
1636 {
1637   if (e->expr_type != EXPR_ARRAY)
1638     return 0;
1639
1640   return e->value.constructor == NULL;
1641 }
1642
1643
1644 /* Reduce a binary expression where at least one of the operands
1645    involves a zero-length array.  Returns NULL if neither of the
1646    operands is a zero-length array.  */
1647
1648 static gfc_expr *
1649 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1650 {
1651   if (gfc_zero_size_array (op1))
1652     {
1653       gfc_free_expr (op2);
1654       return op1;
1655     }
1656
1657   if (gfc_zero_size_array (op2))
1658     {
1659       gfc_free_expr (op1);
1660       return op2;
1661     }
1662
1663   return NULL;
1664 }
1665
1666
1667 static gfc_expr *
1668 eval_intrinsic_f2 (gfc_intrinsic_op op,
1669                    arith (*eval) (gfc_expr *, gfc_expr **),
1670                    gfc_expr *op1, gfc_expr *op2)
1671 {
1672   gfc_expr *result;
1673   eval_f f;
1674
1675   if (op2 == NULL)
1676     {
1677       if (gfc_zero_size_array (op1))
1678         return eval_type_intrinsic0 (op, op1);
1679     }
1680   else
1681     {
1682       result = reduce_binary0 (op1, op2);
1683       if (result != NULL)
1684         return eval_type_intrinsic0 (op, result);
1685     }
1686
1687   f.f2 = eval;
1688   return eval_intrinsic (op, f, op1, op2);
1689 }
1690
1691
1692 static gfc_expr *
1693 eval_intrinsic_f3 (gfc_intrinsic_op op,
1694                    arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1695                    gfc_expr *op1, gfc_expr *op2)
1696 {
1697   gfc_expr *result;
1698   eval_f f;
1699
1700   result = reduce_binary0 (op1, op2);
1701   if (result != NULL)
1702     return eval_type_intrinsic0(op, result);
1703
1704   f.f3 = eval;
1705   return eval_intrinsic (op, f, op1, op2);
1706 }
1707
1708
1709 gfc_expr *
1710 gfc_parentheses (gfc_expr *op)
1711 {
1712   if (gfc_is_constant_expr (op))
1713     return op;
1714
1715   return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1716                             op, NULL);
1717 }
1718
1719 gfc_expr *
1720 gfc_uplus (gfc_expr *op)
1721 {
1722   return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1723 }
1724
1725
1726 gfc_expr *
1727 gfc_uminus (gfc_expr *op)
1728 {
1729   return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1730 }
1731
1732
1733 gfc_expr *
1734 gfc_add (gfc_expr *op1, gfc_expr *op2)
1735 {
1736   return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1737 }
1738
1739
1740 gfc_expr *
1741 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1742 {
1743   return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1744 }
1745
1746
1747 gfc_expr *
1748 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1749 {
1750   return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1751 }
1752
1753
1754 gfc_expr *
1755 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1756 {
1757   return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1758 }
1759
1760
1761 gfc_expr *
1762 gfc_power (gfc_expr *op1, gfc_expr *op2)
1763 {
1764   return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1765 }
1766
1767
1768 gfc_expr *
1769 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1770 {
1771   return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1772 }
1773
1774
1775 gfc_expr *
1776 gfc_and (gfc_expr *op1, gfc_expr *op2)
1777 {
1778   return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1779 }
1780
1781
1782 gfc_expr *
1783 gfc_or (gfc_expr *op1, gfc_expr *op2)
1784 {
1785   return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1786 }
1787
1788
1789 gfc_expr *
1790 gfc_not (gfc_expr *op1)
1791 {
1792   return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1793 }
1794
1795
1796 gfc_expr *
1797 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1798 {
1799   return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1800 }
1801
1802
1803 gfc_expr *
1804 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1805 {
1806   return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1807 }
1808
1809
1810 gfc_expr *
1811 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1812 {
1813   return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1814 }
1815
1816
1817 gfc_expr *
1818 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1819 {
1820   return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1821 }
1822
1823
1824 gfc_expr *
1825 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1826 {
1827   return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1828 }
1829
1830
1831 gfc_expr *
1832 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1833 {
1834   return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1835 }
1836
1837
1838 gfc_expr *
1839 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1840 {
1841   return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1842 }
1843
1844
1845 gfc_expr *
1846 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1847 {
1848   return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1849 }
1850
1851
1852 /* Convert an integer string to an expression node.  */
1853
1854 gfc_expr *
1855 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1856 {
1857   gfc_expr *e;
1858   const char *t;
1859
1860   e = gfc_get_constant_expr (BT_INTEGER, kind, where);
1861   /* A leading plus is allowed, but not by mpz_set_str.  */
1862   if (buffer[0] == '+')
1863     t = buffer + 1;
1864   else
1865     t = buffer;
1866   mpz_set_str (e->value.integer, t, radix);
1867
1868   return e;
1869 }
1870
1871
1872 /* Convert a real string to an expression node.  */
1873
1874 gfc_expr *
1875 gfc_convert_real (const char *buffer, int kind, locus *where)
1876 {
1877   gfc_expr *e;
1878
1879   e = gfc_get_constant_expr (BT_REAL, kind, where);
1880   mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1881
1882   return e;
1883 }
1884
1885
1886 /* Convert a pair of real, constant expression nodes to a single
1887    complex expression node.  */
1888
1889 gfc_expr *
1890 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1891 {
1892   gfc_expr *e;
1893
1894   e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
1895   mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1896                  GFC_MPC_RND_MODE);
1897
1898   return e;
1899 }
1900
1901
1902 /******* Simplification of intrinsic functions with constant arguments *****/
1903
1904
1905 /* Deal with an arithmetic error.  */
1906
1907 static void
1908 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1909 {
1910   switch (rc)
1911     {
1912     case ARITH_OK:
1913       gfc_error ("Arithmetic OK converting %s to %s at %L",
1914                  gfc_typename (from), gfc_typename (to), where);
1915       break;
1916     case ARITH_OVERFLOW:
1917       gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1918                  "can be disabled with the option -fno-range-check",
1919                  gfc_typename (from), gfc_typename (to), where);
1920       break;
1921     case ARITH_UNDERFLOW:
1922       gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1923                  "can be disabled with the option -fno-range-check",
1924                  gfc_typename (from), gfc_typename (to), where);
1925       break;
1926     case ARITH_NAN:
1927       gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1928                  "can be disabled with the option -fno-range-check",
1929                  gfc_typename (from), gfc_typename (to), where);
1930       break;
1931     case ARITH_DIV0:
1932       gfc_error ("Division by zero converting %s to %s at %L",
1933                  gfc_typename (from), gfc_typename (to), where);
1934       break;
1935     case ARITH_INCOMMENSURATE:
1936       gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1937                  gfc_typename (from), gfc_typename (to), where);
1938       break;
1939     case ARITH_ASYMMETRIC:
1940       gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1941                  " converting %s to %s at %L",
1942                  gfc_typename (from), gfc_typename (to), where);
1943       break;
1944     default:
1945       gfc_internal_error ("gfc_arith_error(): Bad error code");
1946     }
1947
1948   /* TODO: Do something about the error, i.e., throw exception, return
1949      NaN, etc.  */
1950 }
1951
1952
1953 /* Convert integers to integers.  */
1954
1955 gfc_expr *
1956 gfc_int2int (gfc_expr *src, int kind)
1957 {
1958   gfc_expr *result;
1959   arith rc;
1960
1961   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
1962
1963   mpz_set (result->value.integer, src->value.integer);
1964
1965   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1966     {
1967       if (rc == ARITH_ASYMMETRIC)
1968         {
1969           gfc_warning (gfc_arith_error (rc), &src->where);
1970         }
1971       else
1972         {
1973           arith_error (rc, &src->ts, &result->ts, &src->where);
1974           gfc_free_expr (result);
1975           return NULL;
1976         }
1977     }
1978
1979   /*  If we do not trap numeric overflow, we need to convert the number to
1980       signed, throwing away high-order bits if necessary.  */
1981   if (gfc_option.flag_range_check == 0)
1982     {
1983       int k;
1984
1985       k = gfc_validate_kind (BT_INTEGER, kind, false);
1986       gfc_convert_mpz_to_signed (result->value.integer,
1987                                  gfc_integer_kinds[k].bit_size);
1988     }
1989
1990   return result;
1991 }
1992
1993
1994 /* Convert integers to reals.  */
1995
1996 gfc_expr *
1997 gfc_int2real (gfc_expr *src, int kind)
1998 {
1999   gfc_expr *result;
2000   arith rc;
2001
2002   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2003
2004   mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2005
2006   if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2007     {
2008       arith_error (rc, &src->ts, &result->ts, &src->where);
2009       gfc_free_expr (result);
2010       return NULL;
2011     }
2012
2013   return result;
2014 }
2015
2016
2017 /* Convert default integer to default complex.  */
2018
2019 gfc_expr *
2020 gfc_int2complex (gfc_expr *src, int kind)
2021 {
2022   gfc_expr *result;
2023   arith rc;
2024
2025   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2026
2027   mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2028
2029   if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2030       != ARITH_OK)
2031     {
2032       arith_error (rc, &src->ts, &result->ts, &src->where);
2033       gfc_free_expr (result);
2034       return NULL;
2035     }
2036
2037   return result;
2038 }
2039
2040
2041 /* Convert default real to default integer.  */
2042
2043 gfc_expr *
2044 gfc_real2int (gfc_expr *src, int kind)
2045 {
2046   gfc_expr *result;
2047   arith rc;
2048
2049   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2050
2051   gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2052
2053   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2054     {
2055       arith_error (rc, &src->ts, &result->ts, &src->where);
2056       gfc_free_expr (result);
2057       return NULL;
2058     }
2059
2060   return result;
2061 }
2062
2063
2064 /* Convert real to real.  */
2065
2066 gfc_expr *
2067 gfc_real2real (gfc_expr *src, int kind)
2068 {
2069   gfc_expr *result;
2070   arith rc;
2071
2072   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2073
2074   mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2075
2076   rc = gfc_check_real_range (result->value.real, kind);
2077
2078   if (rc == ARITH_UNDERFLOW)
2079     {
2080       if (gfc_option.warn_underflow)
2081         gfc_warning (gfc_arith_error (rc), &src->where);
2082       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2083     }
2084   else if (rc != ARITH_OK)
2085     {
2086       arith_error (rc, &src->ts, &result->ts, &src->where);
2087       gfc_free_expr (result);
2088       return NULL;
2089     }
2090
2091   return result;
2092 }
2093
2094
2095 /* Convert real to complex.  */
2096
2097 gfc_expr *
2098 gfc_real2complex (gfc_expr *src, int kind)
2099 {
2100   gfc_expr *result;
2101   arith rc;
2102
2103   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2104
2105   mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2106
2107   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2108
2109   if (rc == ARITH_UNDERFLOW)
2110     {
2111       if (gfc_option.warn_underflow)
2112         gfc_warning (gfc_arith_error (rc), &src->where);
2113       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2114     }
2115   else if (rc != ARITH_OK)
2116     {
2117       arith_error (rc, &src->ts, &result->ts, &src->where);
2118       gfc_free_expr (result);
2119       return NULL;
2120     }
2121
2122   return result;
2123 }
2124
2125
2126 /* Convert complex to integer.  */
2127
2128 gfc_expr *
2129 gfc_complex2int (gfc_expr *src, int kind)
2130 {
2131   gfc_expr *result;
2132   arith rc;
2133
2134   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2135
2136   gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2137                    &src->where);
2138
2139   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2140     {
2141       arith_error (rc, &src->ts, &result->ts, &src->where);
2142       gfc_free_expr (result);
2143       return NULL;
2144     }
2145
2146   return result;
2147 }
2148
2149
2150 /* Convert complex to real.  */
2151
2152 gfc_expr *
2153 gfc_complex2real (gfc_expr *src, int kind)
2154 {
2155   gfc_expr *result;
2156   arith rc;
2157
2158   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2159
2160   mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2161
2162   rc = gfc_check_real_range (result->value.real, kind);
2163
2164   if (rc == ARITH_UNDERFLOW)
2165     {
2166       if (gfc_option.warn_underflow)
2167         gfc_warning (gfc_arith_error (rc), &src->where);
2168       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2169     }
2170   if (rc != ARITH_OK)
2171     {
2172       arith_error (rc, &src->ts, &result->ts, &src->where);
2173       gfc_free_expr (result);
2174       return NULL;
2175     }
2176
2177   return result;
2178 }
2179
2180
2181 /* Convert complex to complex.  */
2182
2183 gfc_expr *
2184 gfc_complex2complex (gfc_expr *src, int kind)
2185 {
2186   gfc_expr *result;
2187   arith rc;
2188
2189   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2190
2191   mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2192
2193   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2194
2195   if (rc == ARITH_UNDERFLOW)
2196     {
2197       if (gfc_option.warn_underflow)
2198         gfc_warning (gfc_arith_error (rc), &src->where);
2199       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2200     }
2201   else if (rc != ARITH_OK)
2202     {
2203       arith_error (rc, &src->ts, &result->ts, &src->where);
2204       gfc_free_expr (result);
2205       return NULL;
2206     }
2207
2208   rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2209
2210   if (rc == ARITH_UNDERFLOW)
2211     {
2212       if (gfc_option.warn_underflow)
2213         gfc_warning (gfc_arith_error (rc), &src->where);
2214       mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2215     }
2216   else if (rc != ARITH_OK)
2217     {
2218       arith_error (rc, &src->ts, &result->ts, &src->where);
2219       gfc_free_expr (result);
2220       return NULL;
2221     }
2222
2223   return result;
2224 }
2225
2226
2227 /* Logical kind conversion.  */
2228
2229 gfc_expr *
2230 gfc_log2log (gfc_expr *src, int kind)
2231 {
2232   gfc_expr *result;
2233
2234   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2235   result->value.logical = src->value.logical;
2236
2237   return result;
2238 }
2239
2240
2241 /* Convert logical to integer.  */
2242
2243 gfc_expr *
2244 gfc_log2int (gfc_expr *src, int kind)
2245 {
2246   gfc_expr *result;
2247
2248   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2249   mpz_set_si (result->value.integer, src->value.logical);
2250
2251   return result;
2252 }
2253
2254
2255 /* Convert integer to logical.  */
2256
2257 gfc_expr *
2258 gfc_int2log (gfc_expr *src, int kind)
2259 {
2260   gfc_expr *result;
2261
2262   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2263   result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2264
2265   return result;
2266 }
2267
2268
2269 /* Helper function to set the representation in a Hollerith conversion.
2270    This assumes that the ts.type and ts.kind of the result have already
2271    been set.  */
2272
2273 static void
2274 hollerith2representation (gfc_expr *result, gfc_expr *src)
2275 {
2276   int src_len, result_len;
2277
2278   src_len = src->representation.length - src->ts.u.pad;
2279   result_len = gfc_target_expr_size (result);
2280
2281   if (src_len > result_len)
2282     {
2283       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2284                    &src->where, gfc_typename(&result->ts));
2285     }
2286
2287   result->representation.string = XCNEWVEC (char, result_len + 1);
2288   memcpy (result->representation.string, src->representation.string,
2289           MIN (result_len, src_len));
2290
2291   if (src_len < result_len)
2292     memset (&result->representation.string[src_len], ' ', result_len - src_len);
2293
2294   result->representation.string[result_len] = '\0'; /* For debugger  */
2295   result->representation.length = result_len;
2296 }
2297
2298
2299 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
2300
2301 gfc_expr *
2302 gfc_hollerith2int (gfc_expr *src, int kind)
2303 {
2304   gfc_expr *result;
2305   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2306
2307   hollerith2representation (result, src);
2308   gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2309                          result->representation.length, result->value.integer);
2310
2311   return result;
2312 }
2313
2314
2315 /* Convert Hollerith to real. The constant will be padded or truncated.  */
2316
2317 gfc_expr *
2318 gfc_hollerith2real (gfc_expr *src, int kind)
2319 {
2320   gfc_expr *result;
2321   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2322
2323   hollerith2representation (result, src);
2324   gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2325                        result->representation.length, result->value.real);
2326
2327   return result;
2328 }
2329
2330
2331 /* Convert Hollerith to complex. The constant will be padded or truncated.  */
2332
2333 gfc_expr *
2334 gfc_hollerith2complex (gfc_expr *src, int kind)
2335 {
2336   gfc_expr *result;
2337   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2338
2339   hollerith2representation (result, src);
2340   gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2341                          result->representation.length, result->value.complex);
2342
2343   return result;
2344 }
2345
2346
2347 /* Convert Hollerith to character. */
2348
2349 gfc_expr *
2350 gfc_hollerith2character (gfc_expr *src, int kind)
2351 {
2352   gfc_expr *result;
2353
2354   result = gfc_copy_expr (src);
2355   result->ts.type = BT_CHARACTER;
2356   result->ts.kind = kind;
2357
2358   result->value.character.length = result->representation.length;
2359   result->value.character.string
2360     = gfc_char_to_widechar (result->representation.string);
2361
2362   return result;
2363 }
2364
2365
2366 /* Convert Hollerith to logical. The constant will be padded or truncated.  */
2367
2368 gfc_expr *
2369 gfc_hollerith2logical (gfc_expr *src, int kind)
2370 {
2371   gfc_expr *result;
2372   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2373
2374   hollerith2representation (result, src);
2375   gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2376                          result->representation.length, &result->value.logical);
2377
2378   return result;
2379 }