gcc/fortran/arith.c

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