gcc/fortran/arith.c

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