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
 788   rc = ARITH_OK;
 789   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 790
 791   switch (op2->ts.type)
 792     {
 793     case BT_INTEGER:
 794       power_sign = mpz_sgn (op2->value.integer);
 795
 796       if (power_sign == 0)
 797         {
 798           /* Handle something to the zeroth power.  Since we're dealing
 799              with integral exponents, there is no ambiguity in the
 800              limiting procedure used to determine the value of 0**0.  */
 801           switch (op1->ts.type)
 802             {
 803             case BT_INTEGER:
 804               mpz_set_ui (result->value.integer, 1);
 805               break;
 806
 807             case BT_REAL:
 808               mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
 809               break;
 810
 811             case BT_COMPLEX:
 812               mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
 813               break;
 814
 815             default:
 816               gfc_internal_error ("arith_power(): Bad base");
 817             }
 818         }
 819       else
 820         {
 821           switch (op1->ts.type)
 822             {
 823             case BT_INTEGER:
 824               {
 825                 int power;
 826
 827                 /* First, we simplify the cases of op1 == 1, 0 or -1.  */
 828                 if (mpz_cmp_si (op1->value.integer, 1) == 0)
 829                   {
 830                     /* 1**op2 == 1 */
 831                     mpz_set_si (result->value.integer, 1);
 832                   }
 833                 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
 834                   {
 835                     /* 0**op2 == 0, if op2 > 0
 836                        0**op2 overflow, if op2 < 0 ; in that case, we
 837                        set the result to 0 and return ARITH_DIV0.  */
 838                     mpz_set_si (result->value.integer, 0);
 839                     if (mpz_cmp_si (op2->value.integer, 0) < 0)
 840                       rc = ARITH_DIV0;
 841                   }
 842                 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
 843                   {
 844                     /* (-1)**op2 == (-1)**(mod(op2,2)) */
 845                     unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
 846                     if (odd)
 847                       mpz_set_si (result->value.integer, -1);
 848                     else
 849                       mpz_set_si (result->value.integer, 1);
 850                   }
 851                 /* Then, we take care of op2 < 0.  */
 852                 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
 853                   {
 854                     /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
 855                     mpz_set_si (result->value.integer, 0);
 856                   }
 857                 else if (gfc_extract_int (op2, &power) != NULL)
 858                   {
 859                     /* If op2 doesn't fit in an int, the exponentiation will
 860                        overflow, because op2 > 0 and abs(op1) > 1.  */
 861                     mpz_t max;
 862                     int i;
 863                     i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
 864
 865                     if (gfc_option.flag_range_check)
 866                       rc = ARITH_OVERFLOW;
 867
 868                     /* Still, we want to give the same value as the
 869                        processor.  */
 870                     mpz_init (max);
 871                     mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
 872                     mpz_mul_ui (max, max, 2);
 873                     mpz_powm (result->value.integer, op1->value.integer,
 874                               op2->value.integer, max);
 875                     mpz_clear (max);
 876                   }
 877                 else
 878                   mpz_pow_ui (result->value.integer, op1->value.integer,
 879                               power);
 880               }
 881               break;
 882
 883             case BT_REAL:
 884               mpfr_pow_z (result->value.real, op1->value.real,
 885                           op2->value.integer, GFC_RND_MODE);
 886               break;
 887
 888             case BT_COMPLEX:
 889               mpc_pow_z (result->value.complex, op1->value.complex,
 890                          op2->value.integer, GFC_MPC_RND_MODE);
 891               break;
 892
 893             default:
 894               break;
 895             }
 896         }
 897       break;
 898
 899     case BT_REAL:
 900
 901       if (gfc_init_expr_flag)
 902         {
 903           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
 904                               "exponent in an initialization "
 905                               "expression at %L", &op2->where) == FAILURE)
 906             return ARITH_PROHIBIT;
 907         }
 908
 909       if (mpfr_cmp_si (op1->value.real, 0) < 0)
 910         {
 911           gfc_error ("Raising a negative REAL at %L to "
 912                      "a REAL power is prohibited", &op1->where);
 913           gfc_free (result);
 914           return ARITH_PROHIBIT;
 915         }
 916
 917         mpfr_pow (result->value.real, op1->value.real, op2->value.real,
 918                   GFC_RND_MODE);
 919       break;
 920
 921     case BT_COMPLEX:
 922       {
 923         if (gfc_init_expr_flag)
 924           {
 925             if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
 926                                 "exponent in an initialization "
 927                                 "expression at %L", &op2->where) == FAILURE)
 928               return ARITH_PROHIBIT;
 929           }
 930
 931         mpc_pow (result->value.complex, op1->value.complex,
 932                  op2->value.complex, GFC_MPC_RND_MODE);
 933       }
 934       break;
 935     default:
 936       gfc_internal_error ("arith_power(): unknown type");
 937     }
 938
 939   if (rc == ARITH_OK)
 940     rc = gfc_range_check (result);
 941
 942   return check_result (rc, op1, result, resultp);
 943 }
 944
 945
 946 /* Concatenate two string constants.  */
 947
 948 static arith
 949 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 950 {
 951   gfc_expr *result;
 952   int len;
 953
 954   gcc_assert (op1->ts.kind == op2->ts.kind);
 955   result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
 956                                   &op1->where);
 957
 958   len = op1->value.character.length + op2->value.character.length;
 959
 960   result->value.character.string = gfc_get_wide_string (len + 1);
 961   result->value.character.length = len;
 962
 963   memcpy (result->value.character.string, op1->value.character.string,
 964           op1->value.character.length * sizeof (gfc_char_t));
 965
 966   memcpy (&result->value.character.string[op1->value.character.length],
 967           op2->value.character.string,
 968           op2->value.character.length * sizeof (gfc_char_t));
 969
 970   result->value.character.string[len] = '\0';
 971
 972   *resultp = result;
 973
 974   return ARITH_OK;
 975 }
 976
 977 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
 978    This function mimics mpfr_cmp but takes NaN into account.  */
 979
 980 static int
 981 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
 982 {
 983   int rc;
 984   switch (op)
 985     {
 986       case INTRINSIC_EQ:
 987         rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
 988         break;
 989       case INTRINSIC_GT:
 990         rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
 991         break;
 992       case INTRINSIC_GE:
 993         rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
 994         break;
 995       case INTRINSIC_LT:
 996         rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
 997         break;
 998       case INTRINSIC_LE:
 999         rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1000         break;
1001       default:
1002         gfc_internal_error ("compare_real(): Bad operator");
1003     }
1004
1005   return rc;
1006 }
1007
1008 /* Comparison operators.  Assumes that the two expression nodes
1009    contain two constants of the same type. The op argument is
1010    needed to handle NaN correctly.  */
1011
1012 int
1013 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1014 {
1015   int rc;
1016
1017   switch (op1->ts.type)
1018     {
1019     case BT_INTEGER:
1020       rc = mpz_cmp (op1->value.integer, op2->value.integer);
1021       break;
1022
1023     case BT_REAL:
1024       rc = compare_real (op1, op2, op);
1025       break;
1026
1027     case BT_CHARACTER:
1028       rc = gfc_compare_string (op1, op2);
1029       break;
1030
1031     case BT_LOGICAL:
1032       rc = ((!op1->value.logical && op2->value.logical)
1033             || (op1->value.logical && !op2->value.logical));
1034       break;
1035
1036     default:
1037       gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1038     }
1039
1040   return rc;
1041 }
1042
1043
1044 /* Compare a pair of complex numbers.  Naturally, this is only for
1045    equality and inequality.  */
1046
1047 static int
1048 compare_complex (gfc_expr *op1, gfc_expr *op2)
1049 {
1050   return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1051 }
1052
1053
1054 /* Given two constant strings and the inverse collating sequence, compare the
1055    strings.  We return -1 for a < b, 0 for a == b and 1 for a > b.
1056    We use the processor's default collating sequence.  */
1057
1058 int
1059 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1060 {
1061   int len, alen, blen, i;
1062   gfc_char_t ac, bc;
1063
1064   alen = a->value.character.length;
1065   blen = b->value.character.length;
1066
1067   len = MAX(alen, blen);
1068
1069   for (i = 0; i < len; i++)
1070     {
1071       ac = ((i < alen) ? a->value.character.string[i] : ' ');
1072       bc = ((i < blen) ? b->value.character.string[i] : ' ');
1073
1074       if (ac < bc)
1075         return -1;
1076       if (ac > bc)
1077         return 1;
1078     }
1079
1080   /* Strings are equal */
1081   return 0;
1082 }
1083
1084
1085 int
1086 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1087 {
1088   int len, alen, blen, i;
1089   gfc_char_t ac, bc;
1090
1091   alen = a->value.character.length;
1092   blen = strlen (b);
1093
1094   len = MAX(alen, blen);
1095
1096   for (i = 0; i < len; i++)
1097     {
1098       ac = ((i < alen) ? a->value.character.string[i] : ' ');
1099       bc = ((i < blen) ? b[i] : ' ');
1100
1101       if (!case_sensitive)
1102         {
1103           ac = TOLOWER (ac);
1104           bc = TOLOWER (bc);
1105         }
1106
1107       if (ac < bc)
1108         return -1;
1109       if (ac > bc)
1110         return 1;
1111     }
1112
1113   /* Strings are equal */
1114   return 0;
1115 }
1116
1117
1118 /* Specific comparison subroutines.  */
1119
1120 static arith
1121 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1122 {
1123   gfc_expr *result;
1124
1125   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1126                                   &op1->where);
1127   result->value.logical = (op1->ts.type == BT_COMPLEX)
1128                         ? compare_complex (op1, op2)
1129                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1130
1131   *resultp = result;
1132   return ARITH_OK;
1133 }
1134
1135
1136 static arith
1137 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1138 {
1139   gfc_expr *result;
1140
1141   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1142                                   &op1->where);
1143   result->value.logical = (op1->ts.type == BT_COMPLEX)
1144                         ? !compare_complex (op1, op2)
1145                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1146
1147   *resultp = result;
1148   return ARITH_OK;
1149 }
1150
1151
1152 static arith
1153 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1154 {
1155   gfc_expr *result;
1156
1157   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1158                                   &op1->where);
1159   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1160   *resultp = result;
1161
1162   return ARITH_OK;
1163 }
1164
1165
1166 static arith
1167 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1168 {
1169   gfc_expr *result;
1170
1171   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1172                                   &op1->where);
1173   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1174   *resultp = result;
1175
1176   return ARITH_OK;
1177 }
1178
1179
1180 static arith
1181 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1182 {
1183   gfc_expr *result;
1184
1185   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1186                                   &op1->where);
1187   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1188   *resultp = result;
1189
1190   return ARITH_OK;
1191 }
1192
1193
1194 static arith
1195 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1196 {
1197   gfc_expr *result;
1198
1199   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1200                                   &op1->where);
1201   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1202   *resultp = result;
1203
1204   return ARITH_OK;
1205 }
1206
1207
1208 static arith
1209 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1210               gfc_expr **result)
1211 {
1212   gfc_constructor_base head;
1213   gfc_constructor *c;
1214   gfc_expr *r;
1215   arith rc;
1216
1217   if (op->expr_type == EXPR_CONSTANT)
1218     return eval (op, result);
1219
1220   rc = ARITH_OK;
1221   head = gfc_constructor_copy (op->value.constructor);
1222   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1223     {
1224       rc = reduce_unary (eval, c->expr, &r);
1225
1226       if (rc != ARITH_OK)
1227         break;
1228
1229       gfc_replace_expr (c->expr, r);
1230     }
1231
1232   if (rc != ARITH_OK)
1233     gfc_constructor_free (head);
1234   else
1235     {
1236       gfc_constructor *c = gfc_constructor_first (head);
1237       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1238                               &op->where);
1239       r->shape = gfc_copy_shape (op->shape, op->rank);
1240       r->rank = op->rank;
1241       r->value.constructor = head;
1242       *result = r;
1243     }
1244
1245   return rc;
1246 }
1247
1248
1249 static arith
1250 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1251                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1252 {
1253   gfc_constructor_base head;
1254   gfc_constructor *c;
1255   gfc_expr *r;
1256   arith rc = ARITH_OK;
1257
1258   head = gfc_constructor_copy (op1->value.constructor);
1259   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1260     {
1261       if (c->expr->expr_type == EXPR_CONSTANT)
1262         rc = eval (c->expr, op2, &r);
1263       else
1264         rc = reduce_binary_ac (eval, c->expr, op2, &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_constructor_free (head);
1274   else
1275     {
1276       gfc_constructor *c = gfc_constructor_first (head);
1277       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1278                               &op1->where);
1279       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1280       r->rank = op1->rank;
1281       r->value.constructor = head;
1282       *result = r;
1283     }
1284
1285   return rc;
1286 }
1287
1288
1289 static arith
1290 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1291                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1292 {
1293   gfc_constructor_base head;
1294   gfc_constructor *c;
1295   gfc_expr *r;
1296   arith rc = ARITH_OK;
1297
1298   head = gfc_constructor_copy (op2->value.constructor);
1299   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1300     {
1301       if (c->expr->expr_type == EXPR_CONSTANT)
1302         rc = eval (op1, c->expr, &r);
1303       else
1304         rc = reduce_binary_ca (eval, op1, c->expr, &r);
1305
1306       if (rc != ARITH_OK)
1307         break;
1308
1309       gfc_replace_expr (c->expr, r);
1310     }
1311
1312   if (rc != ARITH_OK)
1313     gfc_constructor_free (head);
1314   else
1315     {
1316       gfc_constructor *c = gfc_constructor_first (head);
1317       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1318                               &op2->where);
1319       r->shape = gfc_copy_shape (op2->shape, op2->rank);
1320       r->rank = op2->rank;
1321       r->value.constructor = head;
1322       *result = r;
1323     }
1324
1325   return rc;
1326 }
1327
1328
1329 /* We need a forward declaration of reduce_binary.  */
1330 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1331                             gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1332
1333
1334 static arith
1335 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1336                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1337 {
1338   gfc_constructor_base head;
1339   gfc_constructor *c, *d;
1340   gfc_expr *r;
1341   arith rc = ARITH_OK;
1342
1343   if (gfc_check_conformance (op1, op2,
1344                              "elemental binary operation") != SUCCESS)
1345     return ARITH_INCOMMENSURATE;
1346
1347   head = gfc_constructor_copy (op1->value.constructor);
1348   for (c = gfc_constructor_first (head),
1349        d = gfc_constructor_first (op2->value.constructor);
1350        c && d;
1351        c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1352     {
1353         rc = reduce_binary (eval, c->expr, d->expr, &r);
1354         if (rc != ARITH_OK)
1355           break;
1356
1357         gfc_replace_expr (c->expr, r);
1358     }
1359
1360   if (c || d)
1361     rc = ARITH_INCOMMENSURATE;
1362
1363   if (rc != ARITH_OK)
1364     gfc_constructor_free (head);
1365   else
1366     {
1367       gfc_constructor *c = gfc_constructor_first (head);
1368       r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1369                               &op1->where);
1370       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1371       r->rank = op1->rank;
1372       r->value.constructor = head;
1373       *result = r;
1374     }
1375
1376   return rc;
1377 }
1378
1379
1380 static arith
1381 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1382                gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1383 {
1384   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1385     return eval (op1, op2, result);
1386
1387   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1388     return reduce_binary_ca (eval, op1, op2, result);
1389
1390   if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1391     return reduce_binary_ac (eval, op1, op2, result);
1392
1393   return reduce_binary_aa (eval, op1, op2, result);
1394 }
1395
1396
1397 typedef union
1398 {
1399   arith (*f2)(gfc_expr *, gfc_expr **);
1400   arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1401 }
1402 eval_f;
1403
1404 /* High level arithmetic subroutines.  These subroutines go into
1405    eval_intrinsic(), which can do one of several things to its
1406    operands.  If the operands are incompatible with the intrinsic
1407    operation, we return a node pointing to the operands and hope that
1408    an operator interface is found during resolution.
1409
1410    If the operands are compatible and are constants, then we try doing
1411    the arithmetic.  We also handle the cases where either or both
1412    operands are array constructors.  */
1413
1414 static gfc_expr *
1415 eval_intrinsic (gfc_intrinsic_op op,
1416                 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1417 {
1418   gfc_expr temp, *result;
1419   int unary;
1420   arith rc;
1421
1422   gfc_clear_ts (&temp.ts);
1423
1424   switch (op)
1425     {
1426     /* Logical unary  */
1427     case INTRINSIC_NOT:
1428       if (op1->ts.type != BT_LOGICAL)
1429         goto runtime;
1430
1431       temp.ts.type = BT_LOGICAL;
1432       temp.ts.kind = gfc_default_logical_kind;
1433       unary = 1;
1434       break;
1435
1436     /* Logical binary operators  */
1437     case INTRINSIC_OR:
1438     case INTRINSIC_AND:
1439     case INTRINSIC_NEQV:
1440     case INTRINSIC_EQV:
1441       if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1442         goto runtime;
1443
1444       temp.ts.type = BT_LOGICAL;
1445       temp.ts.kind = gfc_default_logical_kind;
1446       unary = 0;
1447       break;
1448
1449     /* Numeric unary  */
1450     case INTRINSIC_UPLUS:
1451     case INTRINSIC_UMINUS:
1452       if (!gfc_numeric_ts (&op1->ts))
1453         goto runtime;
1454
1455       temp.ts = op1->ts;
1456       unary = 1;
1457       break;
1458
1459     case INTRINSIC_PARENTHESES:
1460       temp.ts = op1->ts;
1461       unary = 1;
1462       break;
1463
1464     /* Additional restrictions for ordering relations.  */
1465     case INTRINSIC_GE:
1466     case INTRINSIC_GE_OS:
1467     case INTRINSIC_LT:
1468     case INTRINSIC_LT_OS:
1469     case INTRINSIC_LE:
1470     case INTRINSIC_LE_OS:
1471     case INTRINSIC_GT:
1472     case INTRINSIC_GT_OS:
1473       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1474         {
1475           temp.ts.type = BT_LOGICAL;
1476           temp.ts.kind = gfc_default_logical_kind;
1477           goto runtime;
1478         }
1479
1480     /* Fall through  */
1481     case INTRINSIC_EQ:
1482     case INTRINSIC_EQ_OS:
1483     case INTRINSIC_NE:
1484     case INTRINSIC_NE_OS:
1485       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1486         {
1487           unary = 0;
1488           temp.ts.type = BT_LOGICAL;
1489           temp.ts.kind = gfc_default_logical_kind;
1490
1491           /* If kind mismatch, exit and we'll error out later.  */
1492           if (op1->ts.kind != op2->ts.kind)
1493             goto runtime;
1494
1495           break;
1496         }
1497
1498     /* Fall through  */
1499     /* Numeric binary  */
1500     case INTRINSIC_PLUS:
1501     case INTRINSIC_MINUS:
1502     case INTRINSIC_TIMES:
1503     case INTRINSIC_DIVIDE:
1504     case INTRINSIC_POWER:
1505       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1506         goto runtime;
1507
1508       /* Insert any necessary type conversions to make the operands
1509          compatible.  */
1510
1511       temp.expr_type = EXPR_OP;
1512       gfc_clear_ts (&temp.ts);
1513       temp.value.op.op = op;
1514
1515       temp.value.op.op1 = op1;
1516       temp.value.op.op2 = op2;
1517
1518       gfc_type_convert_binary (&temp, 0);
1519
1520       if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1521           || op == INTRINSIC_GE || op == INTRINSIC_GT
1522           || op == INTRINSIC_LE || op == INTRINSIC_LT
1523           || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1524           || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1525           || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1526         {
1527           temp.ts.type = BT_LOGICAL;
1528           temp.ts.kind = gfc_default_logical_kind;
1529         }
1530
1531       unary = 0;
1532       break;
1533
1534     /* Character binary  */
1535     case INTRINSIC_CONCAT:
1536       if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1537           || op1->ts.kind != op2->ts.kind)
1538         goto runtime;
1539
1540       temp.ts.type = BT_CHARACTER;
1541       temp.ts.kind = op1->ts.kind;
1542       unary = 0;
1543       break;
1544
1545     case INTRINSIC_USER:
1546       goto runtime;
1547
1548     default:
1549       gfc_internal_error ("eval_intrinsic(): Bad operator");
1550     }
1551
1552   if (op1->expr_type != EXPR_CONSTANT
1553       && (op1->expr_type != EXPR_ARRAY
1554           || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1555     goto runtime;
1556
1557   if (op2 != NULL
1558       && op2->expr_type != EXPR_CONSTANT
1559          && (op2->expr_type != EXPR_ARRAY
1560              || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1561     goto runtime;
1562
1563   if (unary)
1564     rc = reduce_unary (eval.f2, op1, &result);
1565   else
1566     rc = reduce_binary (eval.f3, op1, op2, &result);
1567
1568
1569   /* Something went wrong.  */
1570   if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1571     return NULL;
1572
1573   if (rc != ARITH_OK)
1574     {
1575       gfc_error (gfc_arith_error (rc), &op1->where);
1576       return NULL;
1577     }
1578
1579   gfc_free_expr (op1);
1580   gfc_free_expr (op2);
1581   return result;
1582
1583 runtime:
1584   /* Create a run-time expression.  */
1585   result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1586   result->ts = temp.ts;
1587
1588   return result;
1589 }
1590
1591
1592 /* Modify type of expression for zero size array.  */
1593
1594 static gfc_expr *
1595 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1596 {
1597   if (op == NULL)
1598     gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1599
1600   switch (iop)
1601     {
1602     case INTRINSIC_GE:
1603     case INTRINSIC_GE_OS:
1604     case INTRINSIC_LT:
1605     case INTRINSIC_LT_OS:
1606     case INTRINSIC_LE:
1607     case INTRINSIC_LE_OS:
1608     case INTRINSIC_GT:
1609     case INTRINSIC_GT_OS:
1610     case INTRINSIC_EQ:
1611     case INTRINSIC_EQ_OS:
1612     case INTRINSIC_NE:
1613     case INTRINSIC_NE_OS:
1614       op->ts.type = BT_LOGICAL;
1615       op->ts.kind = gfc_default_logical_kind;
1616       break;
1617
1618     default:
1619       break;
1620     }
1621
1622   return op;
1623 }
1624
1625
1626 /* Return nonzero if the expression is a zero size array.  */
1627
1628 static int
1629 gfc_zero_size_array (gfc_expr *e)
1630 {
1631   if (e->expr_type != EXPR_ARRAY)
1632     return 0;
1633
1634   return e->value.constructor == NULL;
1635 }
1636
1637
1638 /* Reduce a binary expression where at least one of the operands
1639    involves a zero-length array.  Returns NULL if neither of the
1640    operands is a zero-length array.  */
1641
1642 static gfc_expr *
1643 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1644 {
1645   if (gfc_zero_size_array (op1))
1646     {
1647       gfc_free_expr (op2);
1648       return op1;
1649     }
1650
1651   if (gfc_zero_size_array (op2))
1652     {
1653       gfc_free_expr (op1);
1654       return op2;
1655     }
1656
1657   return NULL;
1658 }
1659
1660
1661 static gfc_expr *
1662 eval_intrinsic_f2 (gfc_intrinsic_op op,
1663                    arith (*eval) (gfc_expr *, gfc_expr **),
1664                    gfc_expr *op1, gfc_expr *op2)
1665 {
1666   gfc_expr *result;
1667   eval_f f;
1668
1669   if (op2 == NULL)
1670     {
1671       if (gfc_zero_size_array (op1))
1672         return eval_type_intrinsic0 (op, op1);
1673     }
1674   else
1675     {
1676       result = reduce_binary0 (op1, op2);
1677       if (result != NULL)
1678         return eval_type_intrinsic0 (op, result);
1679     }
1680
1681   f.f2 = eval;
1682   return eval_intrinsic (op, f, op1, op2);
1683 }
1684
1685
1686 static gfc_expr *
1687 eval_intrinsic_f3 (gfc_intrinsic_op op,
1688                    arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1689                    gfc_expr *op1, gfc_expr *op2)
1690 {
1691   gfc_expr *result;
1692   eval_f f;
1693
1694   result = reduce_binary0 (op1, op2);
1695   if (result != NULL)
1696     return eval_type_intrinsic0(op, result);
1697
1698   f.f3 = eval;
1699   return eval_intrinsic (op, f, op1, op2);
1700 }
1701
1702
1703 gfc_expr *
1704 gfc_parentheses (gfc_expr *op)
1705 {
1706   if (gfc_is_constant_expr (op))
1707     return op;
1708
1709   return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1710                             op, NULL);
1711 }
1712
1713 gfc_expr *
1714 gfc_uplus (gfc_expr *op)
1715 {
1716   return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1717 }
1718
1719
1720 gfc_expr *
1721 gfc_uminus (gfc_expr *op)
1722 {
1723   return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1724 }
1725
1726
1727 gfc_expr *
1728 gfc_add (gfc_expr *op1, gfc_expr *op2)
1729 {
1730   return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1731 }
1732
1733
1734 gfc_expr *
1735 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1736 {
1737   return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1738 }
1739
1740
1741 gfc_expr *
1742 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1743 {
1744   return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1745 }
1746
1747
1748 gfc_expr *
1749 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1750 {
1751   return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1752 }
1753
1754
1755 gfc_expr *
1756 gfc_power (gfc_expr *op1, gfc_expr *op2)
1757 {
1758   return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1759 }
1760
1761
1762 gfc_expr *
1763 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1764 {
1765   return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1766 }
1767
1768
1769 gfc_expr *
1770 gfc_and (gfc_expr *op1, gfc_expr *op2)
1771 {
1772   return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1773 }
1774
1775
1776 gfc_expr *
1777 gfc_or (gfc_expr *op1, gfc_expr *op2)
1778 {
1779   return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1780 }
1781
1782
1783 gfc_expr *
1784 gfc_not (gfc_expr *op1)
1785 {
1786   return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1787 }
1788
1789
1790 gfc_expr *
1791 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1792 {
1793   return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1794 }
1795
1796
1797 gfc_expr *
1798 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1799 {
1800   return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1801 }
1802
1803
1804 gfc_expr *
1805 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1806 {
1807   return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1808 }
1809
1810
1811 gfc_expr *
1812 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1813 {
1814   return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1815 }
1816
1817
1818 gfc_expr *
1819 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1820 {
1821   return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1822 }
1823
1824
1825 gfc_expr *
1826 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1827 {
1828   return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1829 }
1830
1831
1832 gfc_expr *
1833 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1834 {
1835   return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1836 }
1837
1838
1839 gfc_expr *
1840 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1841 {
1842   return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1843 }
1844
1845
1846 /* Convert an integer string to an expression node.  */
1847
1848 gfc_expr *
1849 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1850 {
1851   gfc_expr *e;
1852   const char *t;
1853
1854   e = gfc_get_constant_expr (BT_INTEGER, kind, where);
1855   /* A leading plus is allowed, but not by mpz_set_str.  */
1856   if (buffer[0] == '+')
1857     t = buffer + 1;
1858   else
1859     t = buffer;
1860   mpz_set_str (e->value.integer, t, radix);
1861
1862   return e;
1863 }
1864
1865
1866 /* Convert a real string to an expression node.  */
1867
1868 gfc_expr *
1869 gfc_convert_real (const char *buffer, int kind, locus *where)
1870 {
1871   gfc_expr *e;
1872
1873   e = gfc_get_constant_expr (BT_REAL, kind, where);
1874   mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1875
1876   return e;
1877 }
1878
1879
1880 /* Convert a pair of real, constant expression nodes to a single
1881    complex expression node.  */
1882
1883 gfc_expr *
1884 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1885 {
1886   gfc_expr *e;
1887
1888   e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
1889   mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1890                  GFC_MPC_RND_MODE);
1891
1892   return e;
1893 }
1894
1895
1896 /******* Simplification of intrinsic functions with constant arguments *****/
1897
1898
1899 /* Deal with an arithmetic error.  */
1900
1901 static void
1902 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1903 {
1904   switch (rc)
1905     {
1906     case ARITH_OK:
1907       gfc_error ("Arithmetic OK converting %s to %s at %L",
1908                  gfc_typename (from), gfc_typename (to), where);
1909       break;
1910     case ARITH_OVERFLOW:
1911       gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1912                  "can be disabled with the option -fno-range-check",
1913                  gfc_typename (from), gfc_typename (to), where);
1914       break;
1915     case ARITH_UNDERFLOW:
1916       gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1917                  "can be disabled with the option -fno-range-check",
1918                  gfc_typename (from), gfc_typename (to), where);
1919       break;
1920     case ARITH_NAN:
1921       gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1922                  "can be disabled with the option -fno-range-check",
1923                  gfc_typename (from), gfc_typename (to), where);
1924       break;
1925     case ARITH_DIV0:
1926       gfc_error ("Division by zero converting %s to %s at %L",
1927                  gfc_typename (from), gfc_typename (to), where);
1928       break;
1929     case ARITH_INCOMMENSURATE:
1930       gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1931                  gfc_typename (from), gfc_typename (to), where);
1932       break;
1933     case ARITH_ASYMMETRIC:
1934       gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1935                  " converting %s to %s at %L",
1936                  gfc_typename (from), gfc_typename (to), where);
1937       break;
1938     default:
1939       gfc_internal_error ("gfc_arith_error(): Bad error code");
1940     }
1941
1942   /* TODO: Do something about the error, i.e., throw exception, return
1943      NaN, etc.  */
1944 }
1945
1946
1947 /* Convert integers to integers.  */
1948
1949 gfc_expr *
1950 gfc_int2int (gfc_expr *src, int kind)
1951 {
1952   gfc_expr *result;
1953   arith rc;
1954
1955   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
1956
1957   mpz_set (result->value.integer, src->value.integer);
1958
1959   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1960     {
1961       if (rc == ARITH_ASYMMETRIC)
1962         {
1963           gfc_warning (gfc_arith_error (rc), &src->where);
1964         }
1965       else
1966         {
1967           arith_error (rc, &src->ts, &result->ts, &src->where);
1968           gfc_free_expr (result);
1969           return NULL;
1970         }
1971     }
1972
1973   return result;
1974 }
1975
1976
1977 /* Convert integers to reals.  */
1978
1979 gfc_expr *
1980 gfc_int2real (gfc_expr *src, int kind)
1981 {
1982   gfc_expr *result;
1983   arith rc;
1984
1985   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
1986
1987   mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1988
1989   if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1990     {
1991       arith_error (rc, &src->ts, &result->ts, &src->where);
1992       gfc_free_expr (result);
1993       return NULL;
1994     }
1995
1996   return result;
1997 }
1998
1999
2000 /* Convert default integer to default complex.  */
2001
2002 gfc_expr *
2003 gfc_int2complex (gfc_expr *src, int kind)
2004 {
2005   gfc_expr *result;
2006   arith rc;
2007
2008   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2009
2010   mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2011
2012   if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2013       != ARITH_OK)
2014     {
2015       arith_error (rc, &src->ts, &result->ts, &src->where);
2016       gfc_free_expr (result);
2017       return NULL;
2018     }
2019
2020   return result;
2021 }
2022
2023
2024 /* Convert default real to default integer.  */
2025
2026 gfc_expr *
2027 gfc_real2int (gfc_expr *src, int kind)
2028 {
2029   gfc_expr *result;
2030   arith rc;
2031
2032   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2033
2034   gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2035
2036   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2037     {
2038       arith_error (rc, &src->ts, &result->ts, &src->where);
2039       gfc_free_expr (result);
2040       return NULL;
2041     }
2042
2043   return result;
2044 }
2045
2046
2047 /* Convert real to real.  */
2048
2049 gfc_expr *
2050 gfc_real2real (gfc_expr *src, int kind)
2051 {
2052   gfc_expr *result;
2053   arith rc;
2054
2055   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2056
2057   mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2058
2059   rc = gfc_check_real_range (result->value.real, kind);
2060
2061   if (rc == ARITH_UNDERFLOW)
2062     {
2063       if (gfc_option.warn_underflow)
2064         gfc_warning (gfc_arith_error (rc), &src->where);
2065       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2066     }
2067   else if (rc != ARITH_OK)
2068     {
2069       arith_error (rc, &src->ts, &result->ts, &src->where);
2070       gfc_free_expr (result);
2071       return NULL;
2072     }
2073
2074   return result;
2075 }
2076
2077
2078 /* Convert real to complex.  */
2079
2080 gfc_expr *
2081 gfc_real2complex (gfc_expr *src, int kind)
2082 {
2083   gfc_expr *result;
2084   arith rc;
2085
2086   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2087
2088   mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2089
2090   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2091
2092   if (rc == ARITH_UNDERFLOW)
2093     {
2094       if (gfc_option.warn_underflow)
2095         gfc_warning (gfc_arith_error (rc), &src->where);
2096       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2097     }
2098   else if (rc != ARITH_OK)
2099     {
2100       arith_error (rc, &src->ts, &result->ts, &src->where);
2101       gfc_free_expr (result);
2102       return NULL;
2103     }
2104
2105   return result;
2106 }
2107
2108
2109 /* Convert complex to integer.  */
2110
2111 gfc_expr *
2112 gfc_complex2int (gfc_expr *src, int kind)
2113 {
2114   gfc_expr *result;
2115   arith rc;
2116
2117   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2118
2119   gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2120                    &src->where);
2121
2122   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2123     {
2124       arith_error (rc, &src->ts, &result->ts, &src->where);
2125       gfc_free_expr (result);
2126       return NULL;
2127     }
2128
2129   return result;
2130 }
2131
2132
2133 /* Convert complex to real.  */
2134
2135 gfc_expr *
2136 gfc_complex2real (gfc_expr *src, int kind)
2137 {
2138   gfc_expr *result;
2139   arith rc;
2140
2141   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2142
2143   mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2144
2145   rc = gfc_check_real_range (result->value.real, kind);
2146
2147   if (rc == ARITH_UNDERFLOW)
2148     {
2149       if (gfc_option.warn_underflow)
2150         gfc_warning (gfc_arith_error (rc), &src->where);
2151       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2152     }
2153   if (rc != ARITH_OK)
2154     {
2155       arith_error (rc, &src->ts, &result->ts, &src->where);
2156       gfc_free_expr (result);
2157       return NULL;
2158     }
2159
2160   return result;
2161 }
2162
2163
2164 /* Convert complex to complex.  */
2165
2166 gfc_expr *
2167 gfc_complex2complex (gfc_expr *src, int kind)
2168 {
2169   gfc_expr *result;
2170   arith rc;
2171
2172   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2173
2174   mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2175
2176   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2177
2178   if (rc == ARITH_UNDERFLOW)
2179     {
2180       if (gfc_option.warn_underflow)
2181         gfc_warning (gfc_arith_error (rc), &src->where);
2182       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2183     }
2184   else if (rc != ARITH_OK)
2185     {
2186       arith_error (rc, &src->ts, &result->ts, &src->where);
2187       gfc_free_expr (result);
2188       return NULL;
2189     }
2190
2191   rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2192
2193   if (rc == ARITH_UNDERFLOW)
2194     {
2195       if (gfc_option.warn_underflow)
2196         gfc_warning (gfc_arith_error (rc), &src->where);
2197       mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2198     }
2199   else if (rc != ARITH_OK)
2200     {
2201       arith_error (rc, &src->ts, &result->ts, &src->where);
2202       gfc_free_expr (result);
2203       return NULL;
2204     }
2205
2206   return result;
2207 }
2208
2209
2210 /* Logical kind conversion.  */
2211
2212 gfc_expr *
2213 gfc_log2log (gfc_expr *src, int kind)
2214 {
2215   gfc_expr *result;
2216
2217   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2218   result->value.logical = src->value.logical;
2219
2220   return result;
2221 }
2222
2223
2224 /* Convert logical to integer.  */
2225
2226 gfc_expr *
2227 gfc_log2int (gfc_expr *src, int kind)
2228 {
2229   gfc_expr *result;
2230
2231   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2232   mpz_set_si (result->value.integer, src->value.logical);
2233
2234   return result;
2235 }
2236
2237
2238 /* Convert integer to logical.  */
2239
2240 gfc_expr *
2241 gfc_int2log (gfc_expr *src, int kind)
2242 {
2243   gfc_expr *result;
2244
2245   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2246   result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2247
2248   return result;
2249 }
2250
2251
2252 /* Helper function to set the representation in a Hollerith conversion.
2253    This assumes that the ts.type and ts.kind of the result have already
2254    been set.  */
2255
2256 static void
2257 hollerith2representation (gfc_expr *result, gfc_expr *src)
2258 {
2259   int src_len, result_len;
2260
2261   src_len = src->representation.length;
2262   result_len = gfc_target_expr_size (result);
2263
2264   if (src_len > result_len)
2265     {
2266       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2267                    &src->where, gfc_typename(&result->ts));
2268     }
2269
2270   result->representation.string = XCNEWVEC (char, result_len + 1);
2271   memcpy (result->representation.string, src->representation.string,
2272           MIN (result_len, src_len));
2273
2274   if (src_len < result_len)
2275     memset (&result->representation.string[src_len], ' ', result_len - src_len);
2276
2277   result->representation.string[result_len] = '\0'; /* For debugger  */
2278   result->representation.length = result_len;
2279 }
2280
2281
2282 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
2283
2284 gfc_expr *
2285 gfc_hollerith2int (gfc_expr *src, int kind)
2286 {
2287   gfc_expr *result;
2288   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2289
2290   hollerith2representation (result, src);
2291   gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2292                          result->representation.length, result->value.integer);
2293
2294   return result;
2295 }
2296
2297
2298 /* Convert Hollerith to real. The constant will be padded or truncated.  */
2299
2300 gfc_expr *
2301 gfc_hollerith2real (gfc_expr *src, int kind)
2302 {
2303   gfc_expr *result;
2304   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2305
2306   hollerith2representation (result, src);
2307   gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2308                        result->representation.length, result->value.real);
2309
2310   return result;
2311 }
2312
2313
2314 /* Convert Hollerith to complex. The constant will be padded or truncated.  */
2315
2316 gfc_expr *
2317 gfc_hollerith2complex (gfc_expr *src, int kind)
2318 {
2319   gfc_expr *result;
2320   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2321
2322   hollerith2representation (result, src);
2323   gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2324                          result->representation.length, result->value.complex);
2325
2326   return result;
2327 }
2328
2329
2330 /* Convert Hollerith to character. */
2331
2332 gfc_expr *
2333 gfc_hollerith2character (gfc_expr *src, int kind)
2334 {
2335   gfc_expr *result;
2336
2337   result = gfc_copy_expr (src);
2338   result->ts.type = BT_CHARACTER;
2339   result->ts.kind = kind;
2340
2341   result->value.character.length = result->representation.length;
2342   result->value.character.string
2343     = gfc_char_to_widechar (result->representation.string);
2344
2345   return result;
2346 }
2347
2348
2349 /* Convert Hollerith to logical. The constant will be padded or truncated.  */
2350
2351 gfc_expr *
2352 gfc_hollerith2logical (gfc_expr *src, int kind)
2353 {
2354   gfc_expr *result;
2355   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2356
2357   hollerith2representation (result, src);
2358   gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2359                          result->representation.length, &result->value.logical);
2360
2361   return result;
2362 }