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