gcc/fortran/arith.c

   1 /* Compiler arithmetic
   2    Copyright (C) 2000-2013 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   return result;
1980 }
1981
1982
1983 /* Convert integers to reals.  */
1984
1985 gfc_expr *
1986 gfc_int2real (gfc_expr *src, int kind)
1987 {
1988   gfc_expr *result;
1989   arith rc;
1990
1991   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
1992
1993   mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1994
1995   if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1996     {
1997       arith_error (rc, &src->ts, &result->ts, &src->where);
1998       gfc_free_expr (result);
1999       return NULL;
2000     }
2001
2002   return result;
2003 }
2004
2005
2006 /* Convert default integer to default complex.  */
2007
2008 gfc_expr *
2009 gfc_int2complex (gfc_expr *src, int kind)
2010 {
2011   gfc_expr *result;
2012   arith rc;
2013
2014   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2015
2016   mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2017
2018   if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2019       != ARITH_OK)
2020     {
2021       arith_error (rc, &src->ts, &result->ts, &src->where);
2022       gfc_free_expr (result);
2023       return NULL;
2024     }
2025
2026   return result;
2027 }
2028
2029
2030 /* Convert default real to default integer.  */
2031
2032 gfc_expr *
2033 gfc_real2int (gfc_expr *src, int kind)
2034 {
2035   gfc_expr *result;
2036   arith rc;
2037
2038   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2039
2040   gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2041
2042   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2043     {
2044       arith_error (rc, &src->ts, &result->ts, &src->where);
2045       gfc_free_expr (result);
2046       return NULL;
2047     }
2048
2049   return result;
2050 }
2051
2052
2053 /* Convert real to real.  */
2054
2055 gfc_expr *
2056 gfc_real2real (gfc_expr *src, int kind)
2057 {
2058   gfc_expr *result;
2059   arith rc;
2060
2061   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2062
2063   mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2064
2065   rc = gfc_check_real_range (result->value.real, kind);
2066
2067   if (rc == ARITH_UNDERFLOW)
2068     {
2069       if (gfc_option.warn_underflow)
2070         gfc_warning (gfc_arith_error (rc), &src->where);
2071       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2072     }
2073   else if (rc != ARITH_OK)
2074     {
2075       arith_error (rc, &src->ts, &result->ts, &src->where);
2076       gfc_free_expr (result);
2077       return NULL;
2078     }
2079
2080   return result;
2081 }
2082
2083
2084 /* Convert real to complex.  */
2085
2086 gfc_expr *
2087 gfc_real2complex (gfc_expr *src, int kind)
2088 {
2089   gfc_expr *result;
2090   arith rc;
2091
2092   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2093
2094   mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2095
2096   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2097
2098   if (rc == ARITH_UNDERFLOW)
2099     {
2100       if (gfc_option.warn_underflow)
2101         gfc_warning (gfc_arith_error (rc), &src->where);
2102       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2103     }
2104   else if (rc != ARITH_OK)
2105     {
2106       arith_error (rc, &src->ts, &result->ts, &src->where);
2107       gfc_free_expr (result);
2108       return NULL;
2109     }
2110
2111   return result;
2112 }
2113
2114
2115 /* Convert complex to integer.  */
2116
2117 gfc_expr *
2118 gfc_complex2int (gfc_expr *src, int kind)
2119 {
2120   gfc_expr *result;
2121   arith rc;
2122
2123   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2124
2125   gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2126                    &src->where);
2127
2128   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2129     {
2130       arith_error (rc, &src->ts, &result->ts, &src->where);
2131       gfc_free_expr (result);
2132       return NULL;
2133     }
2134
2135   return result;
2136 }
2137
2138
2139 /* Convert complex to real.  */
2140
2141 gfc_expr *
2142 gfc_complex2real (gfc_expr *src, int kind)
2143 {
2144   gfc_expr *result;
2145   arith rc;
2146
2147   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2148
2149   mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2150
2151   rc = gfc_check_real_range (result->value.real, kind);
2152
2153   if (rc == ARITH_UNDERFLOW)
2154     {
2155       if (gfc_option.warn_underflow)
2156         gfc_warning (gfc_arith_error (rc), &src->where);
2157       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2158     }
2159   if (rc != ARITH_OK)
2160     {
2161       arith_error (rc, &src->ts, &result->ts, &src->where);
2162       gfc_free_expr (result);
2163       return NULL;
2164     }
2165
2166   return result;
2167 }
2168
2169
2170 /* Convert complex to complex.  */
2171
2172 gfc_expr *
2173 gfc_complex2complex (gfc_expr *src, int kind)
2174 {
2175   gfc_expr *result;
2176   arith rc;
2177
2178   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2179
2180   mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2181
2182   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2183
2184   if (rc == ARITH_UNDERFLOW)
2185     {
2186       if (gfc_option.warn_underflow)
2187         gfc_warning (gfc_arith_error (rc), &src->where);
2188       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2189     }
2190   else if (rc != ARITH_OK)
2191     {
2192       arith_error (rc, &src->ts, &result->ts, &src->where);
2193       gfc_free_expr (result);
2194       return NULL;
2195     }
2196
2197   rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2198
2199   if (rc == ARITH_UNDERFLOW)
2200     {
2201       if (gfc_option.warn_underflow)
2202         gfc_warning (gfc_arith_error (rc), &src->where);
2203       mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2204     }
2205   else if (rc != ARITH_OK)
2206     {
2207       arith_error (rc, &src->ts, &result->ts, &src->where);
2208       gfc_free_expr (result);
2209       return NULL;
2210     }
2211
2212   return result;
2213 }
2214
2215
2216 /* Logical kind conversion.  */
2217
2218 gfc_expr *
2219 gfc_log2log (gfc_expr *src, int kind)
2220 {
2221   gfc_expr *result;
2222
2223   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2224   result->value.logical = src->value.logical;
2225
2226   return result;
2227 }
2228
2229
2230 /* Convert logical to integer.  */
2231
2232 gfc_expr *
2233 gfc_log2int (gfc_expr *src, int kind)
2234 {
2235   gfc_expr *result;
2236
2237   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2238   mpz_set_si (result->value.integer, src->value.logical);
2239
2240   return result;
2241 }
2242
2243
2244 /* Convert integer to logical.  */
2245
2246 gfc_expr *
2247 gfc_int2log (gfc_expr *src, int kind)
2248 {
2249   gfc_expr *result;
2250
2251   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2252   result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2253
2254   return result;
2255 }
2256
2257
2258 /* Helper function to set the representation in a Hollerith conversion.
2259    This assumes that the ts.type and ts.kind of the result have already
2260    been set.  */
2261
2262 static void
2263 hollerith2representation (gfc_expr *result, gfc_expr *src)
2264 {
2265   int src_len, result_len;
2266
2267   src_len = src->representation.length - src->ts.u.pad;
2268   result_len = gfc_target_expr_size (result);
2269
2270   if (src_len > result_len)
2271     {
2272       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2273                    &src->where, gfc_typename(&result->ts));
2274     }
2275
2276   result->representation.string = XCNEWVEC (char, result_len + 1);
2277   memcpy (result->representation.string, src->representation.string,
2278           MIN (result_len, src_len));
2279
2280   if (src_len < result_len)
2281     memset (&result->representation.string[src_len], ' ', result_len - src_len);
2282
2283   result->representation.string[result_len] = '\0'; /* For debugger  */
2284   result->representation.length = result_len;
2285 }
2286
2287
2288 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
2289
2290 gfc_expr *
2291 gfc_hollerith2int (gfc_expr *src, int kind)
2292 {
2293   gfc_expr *result;
2294   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2295
2296   hollerith2representation (result, src);
2297   gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2298                          result->representation.length, result->value.integer);
2299
2300   return result;
2301 }
2302
2303
2304 /* Convert Hollerith to real. The constant will be padded or truncated.  */
2305
2306 gfc_expr *
2307 gfc_hollerith2real (gfc_expr *src, int kind)
2308 {
2309   gfc_expr *result;
2310   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2311
2312   hollerith2representation (result, src);
2313   gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2314                        result->representation.length, result->value.real);
2315
2316   return result;
2317 }
2318
2319
2320 /* Convert Hollerith to complex. The constant will be padded or truncated.  */
2321
2322 gfc_expr *
2323 gfc_hollerith2complex (gfc_expr *src, int kind)
2324 {
2325   gfc_expr *result;
2326   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2327
2328   hollerith2representation (result, src);
2329   gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2330                          result->representation.length, result->value.complex);
2331
2332   return result;
2333 }
2334
2335
2336 /* Convert Hollerith to character. */
2337
2338 gfc_expr *
2339 gfc_hollerith2character (gfc_expr *src, int kind)
2340 {
2341   gfc_expr *result;
2342
2343   result = gfc_copy_expr (src);
2344   result->ts.type = BT_CHARACTER;
2345   result->ts.kind = kind;
2346
2347   result->value.character.length = result->representation.length;
2348   result->value.character.string
2349     = gfc_char_to_widechar (result->representation.string);
2350
2351   return result;
2352 }
2353
2354
2355 /* Convert Hollerith to logical. The constant will be padded or truncated.  */
2356
2357 gfc_expr *
2358 gfc_hollerith2logical (gfc_expr *src, int kind)
2359 {
2360   gfc_expr *result;
2361   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2362
2363   hollerith2representation (result, src);
2364   gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2365                          result->representation.length, &result->value.logical);
2366
2367   return result;
2368 }