gcc/fortran/arith.c

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