gcc/fortran/arith.c

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