gcc/fortran/arith.c

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