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