gcc/fortran/arith.c

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