gcc/fortran/arith.c

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