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, NULL);
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.  If the
1087    xcoll_table is NULL, we use the processor's default collating sequence.  */
1088
1089 int
1090 gfc_compare_string (gfc_expr *a, gfc_expr *b, const int *xcoll_table)
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 (xcoll_table != NULL)
1107         {
1108           ac = xcoll_table[ac];
1109           bc = xcoll_table[bc];
1110         }
1111
1112       if (ac < bc)
1113         return -1;
1114       if (ac > bc)
1115         return 1;
1116     }
1117
1118   /* Strings are equal */
1119
1120   return 0;
1121 }
1122
1123
1124 /* Specific comparison subroutines.  */
1125
1126 static arith
1127 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1128 {
1129   gfc_expr *result;
1130
1131   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1132                                 &op1->where);
1133   result->value.logical = (op1->ts.type == BT_COMPLEX)
1134                         ? compare_complex (op1, op2)
1135                         : (gfc_compare_expr (op1, op2) == 0);
1136
1137   *resultp = result;
1138   return ARITH_OK;
1139 }
1140
1141
1142 static arith
1143 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1144 {
1145   gfc_expr *result;
1146
1147   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1148                                 &op1->where);
1149   result->value.logical = (op1->ts.type == BT_COMPLEX)
1150                         ? !compare_complex (op1, op2)
1151                         : (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, gfc_expr **result)
1260 {
1261   gfc_constructor *c, *head;
1262   gfc_expr *r;
1263   arith rc;
1264
1265   head = gfc_copy_constructor (op1->value.constructor);
1266   rc = ARITH_OK;
1267
1268   for (c = head; c; c = c->next)
1269     {
1270       rc = eval (c->expr, op2, &r);
1271       if (rc != ARITH_OK)
1272         break;
1273
1274       gfc_replace_expr (c->expr, r);
1275     }
1276
1277   if (rc != ARITH_OK)
1278     gfc_free_constructor (head);
1279   else
1280     {
1281       r = gfc_get_expr ();
1282       r->expr_type = EXPR_ARRAY;
1283       r->value.constructor = head;
1284       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1285
1286       r->ts = head->expr->ts;
1287       r->where = op1->where;
1288       r->rank = op1->rank;
1289
1290       *result = r;
1291     }
1292
1293   return rc;
1294 }
1295
1296
1297 static arith
1298 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1299                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1300 {
1301   gfc_constructor *c, *head;
1302   gfc_expr *r;
1303   arith rc;
1304
1305   head = gfc_copy_constructor (op2->value.constructor);
1306   rc = ARITH_OK;
1307
1308   for (c = head; c; c = c->next)
1309     {
1310       rc = eval (op1, c->expr, &r);
1311       if (rc != ARITH_OK)
1312         break;
1313
1314       gfc_replace_expr (c->expr, r);
1315     }
1316
1317   if (rc != ARITH_OK)
1318     gfc_free_constructor (head);
1319   else
1320     {
1321       r = gfc_get_expr ();
1322       r->expr_type = EXPR_ARRAY;
1323       r->value.constructor = head;
1324       r->shape = gfc_copy_shape (op2->shape, op2->rank);
1325
1326       r->ts = head->expr->ts;
1327       r->where = op2->where;
1328       r->rank = op2->rank;
1329
1330       *result = r;
1331     }
1332
1333   return rc;
1334 }
1335
1336
1337 static arith
1338 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1339                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1340 {
1341   gfc_constructor *c, *d, *head;
1342   gfc_expr *r;
1343   arith rc;
1344
1345   head = gfc_copy_constructor (op1->value.constructor);
1346
1347   rc = ARITH_OK;
1348   d = op2->value.constructor;
1349
1350   if (gfc_check_conformance ("Elemental binary operation", op1, op2)
1351       != SUCCESS)
1352     rc = ARITH_INCOMMENSURATE;
1353   else
1354     {
1355       for (c = head; c; c = c->next, d = d->next)
1356         {
1357           if (d == NULL)
1358             {
1359               rc = ARITH_INCOMMENSURATE;
1360               break;
1361             }
1362
1363           rc = eval (c->expr, d->expr, &r);
1364           if (rc != ARITH_OK)
1365             break;
1366
1367           gfc_replace_expr (c->expr, r);
1368         }
1369
1370       if (d != NULL)
1371         rc = ARITH_INCOMMENSURATE;
1372     }
1373
1374   if (rc != ARITH_OK)
1375     gfc_free_constructor (head);
1376   else
1377     {
1378       r = gfc_get_expr ();
1379       r->expr_type = EXPR_ARRAY;
1380       r->value.constructor = head;
1381       r->shape = gfc_copy_shape (op1->shape, op1->rank);
1382
1383       r->ts = head->expr->ts;
1384       r->where = op1->where;
1385       r->rank = op1->rank;
1386
1387       *result = r;
1388     }
1389
1390   return rc;
1391 }
1392
1393
1394 static arith
1395 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1396                gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1397 {
1398   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1399     return eval (op1, op2, result);
1400
1401   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1402     return reduce_binary_ca (eval, op1, op2, result);
1403
1404   if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1405     return reduce_binary_ac (eval, op1, op2, result);
1406
1407   return reduce_binary_aa (eval, op1, op2, result);
1408 }
1409
1410
1411 typedef union
1412 {
1413   arith (*f2)(gfc_expr *, gfc_expr **);
1414   arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1415 }
1416 eval_f;
1417
1418 /* High level arithmetic subroutines.  These subroutines go into
1419    eval_intrinsic(), which can do one of several things to its
1420    operands.  If the operands are incompatible with the intrinsic
1421    operation, we return a node pointing to the operands and hope that
1422    an operator interface is found during resolution.
1423
1424    If the operands are compatible and are constants, then we try doing
1425    the arithmetic.  We also handle the cases where either or both
1426    operands are array constructors.  */
1427
1428 static gfc_expr *
1429 eval_intrinsic (gfc_intrinsic_op operator,
1430                 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1431 {
1432   gfc_expr temp, *result;
1433   int unary;
1434   arith rc;
1435
1436   gfc_clear_ts (&temp.ts);
1437
1438   switch (operator)
1439     {
1440     /* Logical unary  */
1441     case INTRINSIC_NOT:
1442       if (op1->ts.type != BT_LOGICAL)
1443         goto runtime;
1444
1445       temp.ts.type = BT_LOGICAL;
1446       temp.ts.kind = gfc_default_logical_kind;
1447       unary = 1;
1448       break;
1449
1450     /* Logical binary operators  */
1451     case INTRINSIC_OR:
1452     case INTRINSIC_AND:
1453     case INTRINSIC_NEQV:
1454     case INTRINSIC_EQV:
1455       if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1456         goto runtime;
1457
1458       temp.ts.type = BT_LOGICAL;
1459       temp.ts.kind = gfc_default_logical_kind;
1460       unary = 0;
1461       break;
1462
1463     /* Numeric unary  */
1464     case INTRINSIC_UPLUS:
1465     case INTRINSIC_UMINUS:
1466       if (!gfc_numeric_ts (&op1->ts))
1467         goto runtime;
1468
1469       temp.ts = op1->ts;
1470       unary = 1;
1471       break;
1472
1473     case INTRINSIC_PARENTHESES:
1474       temp.ts = op1->ts;
1475       unary = 1;
1476       break;
1477
1478     /* Additional restrictions for ordering relations.  */
1479     case INTRINSIC_GE:
1480     case INTRINSIC_LT:
1481     case INTRINSIC_LE:
1482     case INTRINSIC_GT:
1483       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1484         {
1485           temp.ts.type = BT_LOGICAL;
1486           temp.ts.kind = gfc_default_logical_kind;
1487           goto runtime;
1488         }
1489
1490     /* Fall through  */
1491     case INTRINSIC_EQ:
1492     case INTRINSIC_NE:
1493       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1494         {
1495           unary = 0;
1496           temp.ts.type = BT_LOGICAL;
1497           temp.ts.kind = gfc_default_logical_kind;
1498           break;
1499         }
1500
1501     /* Fall through  */
1502     /* Numeric binary  */
1503     case INTRINSIC_PLUS:
1504     case INTRINSIC_MINUS:
1505     case INTRINSIC_TIMES:
1506     case INTRINSIC_DIVIDE:
1507     case INTRINSIC_POWER:
1508       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1509         goto runtime;
1510
1511       /* Insert any necessary type conversions to make the operands
1512          compatible.  */
1513
1514       temp.expr_type = EXPR_OP;
1515       gfc_clear_ts (&temp.ts);
1516       temp.value.op.operator = operator;
1517
1518       temp.value.op.op1 = op1;
1519       temp.value.op.op2 = op2;
1520
1521       gfc_type_convert_binary (&temp);
1522
1523       if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
1524           || operator == INTRINSIC_GE || operator == INTRINSIC_GT
1525           || operator == INTRINSIC_LE || operator == INTRINSIC_LT)
1526         {
1527           temp.ts.type = BT_LOGICAL;
1528           temp.ts.kind = gfc_default_logical_kind;
1529         }
1530
1531       unary = 0;
1532       break;
1533
1534     /* Character binary  */
1535     case INTRINSIC_CONCAT:
1536       if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
1537         goto runtime;
1538
1539       temp.ts.type = BT_CHARACTER;
1540       temp.ts.kind = gfc_default_character_kind;
1541       unary = 0;
1542       break;
1543
1544     case INTRINSIC_USER:
1545       goto runtime;
1546
1547     default:
1548       gfc_internal_error ("eval_intrinsic(): Bad operator");
1549     }
1550
1551   /* Try to combine the operators.  */
1552   if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
1553     goto runtime;
1554
1555   if (op1->from_H
1556       || (op1->expr_type != EXPR_CONSTANT
1557           && (op1->expr_type != EXPR_ARRAY
1558               || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))))
1559     goto runtime;
1560
1561   if (op2 != NULL
1562       && (op2->from_H
1563           || (op2->expr_type != EXPR_CONSTANT
1564               && (op2->expr_type != EXPR_ARRAY
1565                   || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))))
1566     goto runtime;
1567
1568   if (unary)
1569     rc = reduce_unary (eval.f2, op1, &result);
1570   else
1571     rc = reduce_binary (eval.f3, op1, op2, &result);
1572
1573   if (rc != ARITH_OK)
1574     { /* Something went wrong.  */
1575       gfc_error (gfc_arith_error (rc), &op1->where);
1576       return NULL;
1577     }
1578
1579   gfc_free_expr (op1);
1580   gfc_free_expr (op2);
1581   return result;
1582
1583 runtime:
1584   /* Create a run-time expression.  */
1585   result = gfc_get_expr ();
1586   result->ts = temp.ts;
1587
1588   result->expr_type = EXPR_OP;
1589   result->value.op.operator = operator;
1590
1591   result->value.op.op1 = op1;
1592   result->value.op.op2 = op2;
1593
1594   result->where = op1->where;
1595
1596   return result;
1597 }
1598
1599
1600 /* Modify type of expression for zero size array.  */
1601
1602 static gfc_expr *
1603 eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
1604 {
1605   if (op == NULL)
1606     gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1607
1608   switch (operator)
1609     {
1610     case INTRINSIC_GE:
1611     case INTRINSIC_LT:
1612     case INTRINSIC_LE:
1613     case INTRINSIC_GT:
1614     case INTRINSIC_EQ:
1615     case INTRINSIC_NE:
1616       op->ts.type = BT_LOGICAL;
1617       op->ts.kind = gfc_default_logical_kind;
1618       break;
1619
1620     default:
1621       break;
1622     }
1623
1624   return op;
1625 }
1626
1627
1628 /* Return nonzero if the expression is a zero size array.  */
1629
1630 static int
1631 gfc_zero_size_array (gfc_expr *e)
1632 {
1633   if (e->expr_type != EXPR_ARRAY)
1634     return 0;
1635
1636   return e->value.constructor == NULL;
1637 }
1638
1639
1640 /* Reduce a binary expression where at least one of the operands
1641    involves a zero-length array.  Returns NULL if neither of the
1642    operands is a zero-length array.  */
1643
1644 static gfc_expr *
1645 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1646 {
1647   if (gfc_zero_size_array (op1))
1648     {
1649       gfc_free_expr (op2);
1650       return op1;
1651     }
1652
1653   if (gfc_zero_size_array (op2))
1654     {
1655       gfc_free_expr (op1);
1656       return op2;
1657     }
1658
1659   return NULL;
1660 }
1661
1662
1663 static gfc_expr *
1664 eval_intrinsic_f2 (gfc_intrinsic_op operator,
1665                    arith (*eval) (gfc_expr *, gfc_expr **),
1666                    gfc_expr *op1, gfc_expr *op2)
1667 {
1668   gfc_expr *result;
1669   eval_f f;
1670
1671   if (op2 == NULL)
1672     {
1673       if (gfc_zero_size_array (op1))
1674         return eval_type_intrinsic0 (operator, op1);
1675     }
1676   else
1677     {
1678       result = reduce_binary0 (op1, op2);
1679       if (result != NULL)
1680         return eval_type_intrinsic0 (operator, result);
1681     }
1682
1683   f.f2 = eval;
1684   return eval_intrinsic (operator, f, op1, op2);
1685 }
1686
1687
1688 static gfc_expr *
1689 eval_intrinsic_f3 (gfc_intrinsic_op operator,
1690                    arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1691                    gfc_expr *op1, gfc_expr *op2)
1692 {
1693   gfc_expr *result;
1694   eval_f f;
1695
1696   result = reduce_binary0 (op1, op2);
1697   if (result != NULL)
1698     return eval_type_intrinsic0(operator, result);
1699
1700   f.f3 = eval;
1701   return eval_intrinsic (operator, f, op1, op2);
1702 }
1703
1704
1705 gfc_expr *
1706 gfc_uplus (gfc_expr *op)
1707 {
1708   return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_uplus, op, NULL);
1709 }
1710
1711
1712 gfc_expr *
1713 gfc_uminus (gfc_expr *op)
1714 {
1715   return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1716 }
1717
1718
1719 gfc_expr *
1720 gfc_add (gfc_expr *op1, gfc_expr *op2)
1721 {
1722   return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1723 }
1724
1725
1726 gfc_expr *
1727 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1728 {
1729   return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1730 }
1731
1732
1733 gfc_expr *
1734 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1735 {
1736   return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1737 }
1738
1739
1740 gfc_expr *
1741 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1742 {
1743   return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1744 }
1745
1746
1747 gfc_expr *
1748 gfc_power (gfc_expr *op1, gfc_expr *op2)
1749 {
1750   return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
1751 }
1752
1753
1754 gfc_expr *
1755 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1756 {
1757   return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1758 }
1759
1760
1761 gfc_expr *
1762 gfc_and (gfc_expr *op1, gfc_expr *op2)
1763 {
1764   return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1765 }
1766
1767
1768 gfc_expr *
1769 gfc_or (gfc_expr *op1, gfc_expr *op2)
1770 {
1771   return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1772 }
1773
1774
1775 gfc_expr *
1776 gfc_not (gfc_expr *op1)
1777 {
1778   return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1779 }
1780
1781
1782 gfc_expr *
1783 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1784 {
1785   return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1786 }
1787
1788
1789 gfc_expr *
1790 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1791 {
1792   return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1793 }
1794
1795
1796 gfc_expr *
1797 gfc_eq (gfc_expr *op1, gfc_expr *op2)
1798 {
1799   return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
1800 }
1801
1802
1803 gfc_expr *
1804 gfc_ne (gfc_expr *op1, gfc_expr *op2)
1805 {
1806   return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
1807 }
1808
1809
1810 gfc_expr *
1811 gfc_gt (gfc_expr *op1, gfc_expr *op2)
1812 {
1813   return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
1814 }
1815
1816
1817 gfc_expr *
1818 gfc_ge (gfc_expr *op1, gfc_expr *op2)
1819 {
1820   return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
1821 }
1822
1823
1824 gfc_expr *
1825 gfc_lt (gfc_expr *op1, gfc_expr *op2)
1826 {
1827   return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
1828 }
1829
1830
1831 gfc_expr *
1832 gfc_le (gfc_expr *op1, gfc_expr *op2)
1833 {
1834   return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
1835 }
1836
1837
1838 /* Convert an integer string to an expression node.  */
1839
1840 gfc_expr *
1841 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1842 {
1843   gfc_expr *e;
1844   const char *t;
1845
1846   e = gfc_constant_result (BT_INTEGER, kind, where);
1847   /* A leading plus is allowed, but not by mpz_set_str.  */
1848   if (buffer[0] == '+')
1849     t = buffer + 1;
1850   else
1851     t = buffer;
1852   mpz_set_str (e->value.integer, t, radix);
1853
1854   return e;
1855 }
1856
1857
1858 /* Convert a real string to an expression node.  */
1859
1860 gfc_expr *
1861 gfc_convert_real (const char *buffer, int kind, locus *where)
1862 {
1863   gfc_expr *e;
1864
1865   e = gfc_constant_result (BT_REAL, kind, where);
1866   mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1867
1868   return e;
1869 }
1870
1871
1872 /* Convert a pair of real, constant expression nodes to a single
1873    complex expression node.  */
1874
1875 gfc_expr *
1876 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1877 {
1878   gfc_expr *e;
1879
1880   e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1881   mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
1882   mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
1883
1884   return e;
1885 }
1886
1887
1888 /******* Simplification of intrinsic functions with constant arguments *****/
1889
1890
1891 /* Deal with an arithmetic error.  */
1892
1893 static void
1894 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1895 {
1896   switch (rc)
1897     {
1898     case ARITH_OK:
1899       gfc_error ("Arithmetic OK converting %s to %s at %L",
1900                  gfc_typename (from), gfc_typename (to), where);
1901       break;
1902     case ARITH_OVERFLOW:
1903       gfc_error ("Arithmetic overflow converting %s to %s at %L",
1904                  gfc_typename (from), gfc_typename (to), where);
1905       break;
1906     case ARITH_UNDERFLOW:
1907       gfc_error ("Arithmetic underflow converting %s to %s at %L",
1908                  gfc_typename (from), gfc_typename (to), where);
1909       break;
1910     case ARITH_NAN:
1911       gfc_error ("Arithmetic NaN converting %s to %s at %L",
1912                  gfc_typename (from), gfc_typename (to), where);
1913       break;
1914     case ARITH_DIV0:
1915       gfc_error ("Division by zero converting %s to %s at %L",
1916                  gfc_typename (from), gfc_typename (to), where);
1917       break;
1918     case ARITH_INCOMMENSURATE:
1919       gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1920                  gfc_typename (from), gfc_typename (to), where);
1921       break;
1922     case ARITH_ASYMMETRIC:
1923       gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1924                  " converting %s to %s at %L",
1925                  gfc_typename (from), gfc_typename (to), where);
1926       break;
1927     default:
1928       gfc_internal_error ("gfc_arith_error(): Bad error code");
1929     }
1930
1931   /* TODO: Do something about the error, ie, throw exception, return
1932      NaN, etc.  */
1933 }
1934
1935
1936 /* Convert integers to integers.  */
1937
1938 gfc_expr *
1939 gfc_int2int (gfc_expr *src, int kind)
1940 {
1941   gfc_expr *result;
1942   arith rc;
1943
1944   result = gfc_constant_result (BT_INTEGER, kind, &src->where);
1945
1946   mpz_set (result->value.integer, src->value.integer);
1947
1948   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1949     {
1950       if (rc == ARITH_ASYMMETRIC)
1951         {
1952           gfc_warning (gfc_arith_error (rc), &src->where);
1953         }
1954       else
1955         {
1956           arith_error (rc, &src->ts, &result->ts, &src->where);
1957           gfc_free_expr (result);
1958           return NULL;
1959         }
1960     }
1961
1962   return result;
1963 }
1964
1965
1966 /* Convert integers to reals.  */
1967
1968 gfc_expr *
1969 gfc_int2real (gfc_expr *src, int kind)
1970 {
1971   gfc_expr *result;
1972   arith rc;
1973
1974   result = gfc_constant_result (BT_REAL, kind, &src->where);
1975
1976   mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1977
1978   if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1979     {
1980       arith_error (rc, &src->ts, &result->ts, &src->where);
1981       gfc_free_expr (result);
1982       return NULL;
1983     }
1984
1985   return result;
1986 }
1987
1988
1989 /* Convert default integer to default complex.  */
1990
1991 gfc_expr *
1992 gfc_int2complex (gfc_expr *src, int kind)
1993 {
1994   gfc_expr *result;
1995   arith rc;
1996
1997   result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
1998
1999   mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
2000   mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2001
2002   if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
2003     {
2004       arith_error (rc, &src->ts, &result->ts, &src->where);
2005       gfc_free_expr (result);
2006       return NULL;
2007     }
2008
2009   return result;
2010 }
2011
2012
2013 /* Convert default real to default integer.  */
2014
2015 gfc_expr *
2016 gfc_real2int (gfc_expr *src, int kind)
2017 {
2018   gfc_expr *result;
2019   arith rc;
2020
2021   result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2022
2023   gfc_mpfr_to_mpz (result->value.integer, src->value.real);
2024
2025   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2026     {
2027       arith_error (rc, &src->ts, &result->ts, &src->where);
2028       gfc_free_expr (result);
2029       return NULL;
2030     }
2031
2032   return result;
2033 }
2034
2035
2036 /* Convert real to real.  */
2037
2038 gfc_expr *
2039 gfc_real2real (gfc_expr *src, int kind)
2040 {
2041   gfc_expr *result;
2042   arith rc;
2043
2044   result = gfc_constant_result (BT_REAL, kind, &src->where);
2045
2046   mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2047
2048   rc = gfc_check_real_range (result->value.real, kind);
2049
2050   if (rc == ARITH_UNDERFLOW)
2051     {
2052       if (gfc_option.warn_underflow)
2053         gfc_warning (gfc_arith_error (rc), &src->where);
2054       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2055     }
2056   else if (rc != ARITH_OK)
2057     {
2058       arith_error (rc, &src->ts, &result->ts, &src->where);
2059       gfc_free_expr (result);
2060       return NULL;
2061     }
2062
2063   return result;
2064 }
2065
2066
2067 /* Convert real to complex.  */
2068
2069 gfc_expr *
2070 gfc_real2complex (gfc_expr *src, int kind)
2071 {
2072   gfc_expr *result;
2073   arith rc;
2074
2075   result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2076
2077   mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
2078   mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2079
2080   rc = gfc_check_real_range (result->value.complex.r, kind);
2081
2082   if (rc == ARITH_UNDERFLOW)
2083     {
2084       if (gfc_option.warn_underflow)
2085         gfc_warning (gfc_arith_error (rc), &src->where);
2086       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2087     }
2088   else if (rc != ARITH_OK)
2089     {
2090       arith_error (rc, &src->ts, &result->ts, &src->where);
2091       gfc_free_expr (result);
2092       return NULL;
2093     }
2094
2095   return result;
2096 }
2097
2098
2099 /* Convert complex to integer.  */
2100
2101 gfc_expr *
2102 gfc_complex2int (gfc_expr *src, int kind)
2103 {
2104   gfc_expr *result;
2105   arith rc;
2106
2107   result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2108
2109   gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
2110
2111   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2112     {
2113       arith_error (rc, &src->ts, &result->ts, &src->where);
2114       gfc_free_expr (result);
2115       return NULL;
2116     }
2117
2118   return result;
2119 }
2120
2121
2122 /* Convert complex to real.  */
2123
2124 gfc_expr *
2125 gfc_complex2real (gfc_expr *src, int kind)
2126 {
2127   gfc_expr *result;
2128   arith rc;
2129
2130   result = gfc_constant_result (BT_REAL, kind, &src->where);
2131
2132   mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
2133
2134   rc = gfc_check_real_range (result->value.real, kind);
2135
2136   if (rc == ARITH_UNDERFLOW)
2137     {
2138       if (gfc_option.warn_underflow)
2139         gfc_warning (gfc_arith_error (rc), &src->where);
2140       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2141     }
2142   if (rc != ARITH_OK)
2143     {
2144       arith_error (rc, &src->ts, &result->ts, &src->where);
2145       gfc_free_expr (result);
2146       return NULL;
2147     }
2148
2149   return result;
2150 }
2151
2152
2153 /* Convert complex to complex.  */
2154
2155 gfc_expr *
2156 gfc_complex2complex (gfc_expr *src, int kind)
2157 {
2158   gfc_expr *result;
2159   arith rc;
2160
2161   result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2162
2163   mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
2164   mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
2165
2166   rc = gfc_check_real_range (result->value.complex.r, kind);
2167
2168   if (rc == ARITH_UNDERFLOW)
2169     {
2170       if (gfc_option.warn_underflow)
2171         gfc_warning (gfc_arith_error (rc), &src->where);
2172       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2173     }
2174   else if (rc != ARITH_OK)
2175     {
2176       arith_error (rc, &src->ts, &result->ts, &src->where);
2177       gfc_free_expr (result);
2178       return NULL;
2179     }
2180
2181   rc = gfc_check_real_range (result->value.complex.i, 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.i, 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   return result;
2197 }
2198
2199
2200 /* Logical kind conversion.  */
2201
2202 gfc_expr *
2203 gfc_log2log (gfc_expr *src, int kind)
2204 {
2205   gfc_expr *result;
2206
2207   result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2208   result->value.logical = src->value.logical;
2209
2210   return result;
2211 }
2212
2213
2214 /* Convert logical to integer.  */
2215
2216 gfc_expr *
2217 gfc_log2int (gfc_expr *src, int kind)
2218 {
2219   gfc_expr *result;
2220
2221   result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2222   mpz_set_si (result->value.integer, src->value.logical);
2223
2224   return result;
2225 }
2226
2227
2228 /* Convert integer to logical.  */
2229
2230 gfc_expr *
2231 gfc_int2log (gfc_expr *src, int kind)
2232 {
2233   gfc_expr *result;
2234
2235   result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2236   result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2237
2238   return result;
2239 }
2240
2241
2242 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
2243
2244 gfc_expr *
2245 gfc_hollerith2int (gfc_expr *src, int kind)
2246 {
2247   gfc_expr *result;
2248   int len;
2249
2250   len = src->value.character.length;
2251
2252   result = gfc_get_expr ();
2253   result->expr_type = EXPR_CONSTANT;
2254   result->ts.type = BT_INTEGER;
2255   result->ts.kind = kind;
2256   result->where = src->where;
2257   result->from_H = 1;
2258
2259   if (len > kind)
2260     {
2261       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2262                    &src->where, gfc_typename(&result->ts));
2263     }
2264   result->value.character.string = gfc_getmem (kind + 1);
2265   memcpy (result->value.character.string, src->value.character.string,
2266         MIN (kind, len));
2267
2268   if (len < kind)
2269     memset (&result->value.character.string[len], ' ', kind - len);
2270
2271   result->value.character.string[kind] = '\0'; /* For debugger  */
2272   result->value.character.length = kind;
2273
2274   return result;
2275 }
2276
2277
2278 /* Convert Hollerith to real. The constant will be padded or truncated.  */
2279
2280 gfc_expr *
2281 gfc_hollerith2real (gfc_expr *src, int kind)
2282 {
2283   gfc_expr *result;
2284   int len;
2285
2286   len = src->value.character.length;
2287
2288   result = gfc_get_expr ();
2289   result->expr_type = EXPR_CONSTANT;
2290   result->ts.type = BT_REAL;
2291   result->ts.kind = kind;
2292   result->where = src->where;
2293   result->from_H = 1;
2294
2295   if (len > kind)
2296     {
2297       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2298                    &src->where, gfc_typename(&result->ts));
2299     }
2300   result->value.character.string = gfc_getmem (kind + 1);
2301   memcpy (result->value.character.string, src->value.character.string,
2302         MIN (kind, len));
2303
2304   if (len < kind)
2305     memset (&result->value.character.string[len], ' ', kind - len);
2306
2307   result->value.character.string[kind] = '\0'; /* For debugger.  */
2308   result->value.character.length = kind;
2309
2310   return result;
2311 }
2312
2313
2314 /* Convert Hollerith to complex. The constant will be padded or truncated.  */
2315
2316 gfc_expr *
2317 gfc_hollerith2complex (gfc_expr *src, int kind)
2318 {
2319   gfc_expr *result;
2320   int len;
2321
2322   len = src->value.character.length;
2323
2324   result = gfc_get_expr ();
2325   result->expr_type = EXPR_CONSTANT;
2326   result->ts.type = BT_COMPLEX;
2327   result->ts.kind = kind;
2328   result->where = src->where;
2329   result->from_H = 1;
2330
2331   kind = kind * 2;
2332
2333   if (len > kind)
2334     {
2335       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2336                    &src->where, gfc_typename(&result->ts));
2337     }
2338   result->value.character.string = gfc_getmem (kind + 1);
2339   memcpy (result->value.character.string, src->value.character.string,
2340           MIN (kind, len));
2341
2342   if (len < kind)
2343     memset (&result->value.character.string[len], ' ', kind - len);
2344
2345   result->value.character.string[kind] = '\0'; /* For debugger  */
2346   result->value.character.length = kind;
2347
2348   return result;
2349 }
2350
2351
2352 /* Convert Hollerith to character. */
2353
2354 gfc_expr *
2355 gfc_hollerith2character (gfc_expr *src, int kind)
2356 {
2357   gfc_expr *result;
2358
2359   result = gfc_copy_expr (src);
2360   result->ts.type = BT_CHARACTER;
2361   result->ts.kind = kind;
2362   result->from_H = 1;
2363
2364   return result;
2365 }
2366
2367
2368 /* Convert Hollerith to logical. The constant will be padded or truncated.  */
2369
2370 gfc_expr *
2371 gfc_hollerith2logical (gfc_expr *src, int kind)
2372 {
2373   gfc_expr *result;
2374   int len;
2375
2376   len = src->value.character.length;
2377
2378   result = gfc_get_expr ();
2379   result->expr_type = EXPR_CONSTANT;
2380   result->ts.type = BT_LOGICAL;
2381   result->ts.kind = kind;
2382   result->where = src->where;
2383   result->from_H = 1;
2384
2385   if (len > kind)
2386     {
2387       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2388                    &src->where, gfc_typename(&result->ts));
2389     }
2390   result->value.character.string = gfc_getmem (kind + 1);
2391   memcpy (result->value.character.string, src->value.character.string,
2392         MIN (kind, len));
2393
2394   if (len < kind)
2395     memset (&result->value.character.string[len], ' ', kind - len);
2396
2397   result->value.character.string[kind] = '\0'; /* For debugger  */
2398   result->value.character.length = kind;
2399
2400   return result;
2401 }
2402
2403
2404 /* Returns an initializer whose value is one higher than the value of the
2405    LAST_INITIALIZER argument.  If the argument is NULL, the
2406    initializers value will be set to zero.  The initializer's kind
2407    will be set to gfc_c_int_kind.
2408
2409    If -fshort-enums is given, the appropriate kind will be selected
2410    later after all enumerators have been parsed.  A warning is issued
2411    here if an initializer exceeds gfc_c_int_kind.  */
2412
2413 gfc_expr *
2414 gfc_enum_initializer (gfc_expr *last_initializer, locus where)
2415 {
2416   gfc_expr *result;
2417
2418   result = gfc_get_expr ();
2419   result->expr_type = EXPR_CONSTANT;
2420   result->ts.type = BT_INTEGER;
2421   result->ts.kind = gfc_c_int_kind;
2422   result->where = where;
2423
2424   mpz_init (result->value.integer);
2425
2426   if (last_initializer != NULL)
2427     {
2428       mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
2429       result->where = last_initializer->where;
2430
2431       if (gfc_check_integer_range (result->value.integer,
2432              gfc_c_int_kind) != ARITH_OK)
2433         {
2434           gfc_error ("Enumerator exceeds the C integer type at %C");
2435           return NULL;
2436         }
2437     }
2438   else
2439     {
2440       /* Control comes here, if it's the very first enumerator and no
2441          initializer has been given.  It will be initialized to zero.  */
2442       mpz_set_si (result->value.integer, 0);
2443     }
2444
2445   return result;
2446 }