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