2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
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
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
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, 59 Temple Place - Suite 330, Boston, MA
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. */
34 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
35 It's easily implemented with a few calls though. */
38 gfc_mpfr_to_mpz (mpz_t z, mpfr_t x)
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))
49 mpz_mul_2exp (z, z, e);
51 mpz_tdiv_q_2exp (z, z, -e);
55 /* Set the model number precision by the requested KIND. */
58 gfc_set_model_kind (int kind)
60 int index = gfc_validate_kind (BT_REAL, kind, false);
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);
70 /* Set the model number precision from mpfr_t x. */
73 gfc_set_model (mpfr_t x)
75 mpfr_set_default_prec (mpfr_get_prec (x));
78 /* Calculate atan2 (y, x)
80 atan2(y, x) = atan(y/x) if x > 0,
81 sign(y)*(pi - atan(|y/x|)) if x < 0,
83 sign(y)*pi/2 if x = 0 && y != 0.
87 arctangent2 (mpfr_t y, mpfr_t x, mpfr_t result)
99 mpfr_div (t, y, x, GFC_RND_MODE);
100 mpfr_atan (result, t, GFC_RND_MODE);
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);
114 if (mpfr_sgn (y) == 0)
115 mpfr_set_ui (result, 0, GFC_RND_MODE);
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);
130 /* Given an arithmetic error code, return a pointer to a string that
131 explains the error. */
134 gfc_arith_error (arith code)
144 p = "Arithmetic overflow";
146 case ARITH_UNDERFLOW:
147 p = "Arithmetic underflow";
150 p = "Arithmetic NaN";
153 p = "Division by zero";
155 case ARITH_INCOMMENSURATE:
156 p = "Array operands are incommensurate";
158 case ARITH_ASYMMETRIC:
159 p = "Integer outside symmetric range implied by Standard Fortran";
162 gfc_internal_error ("gfc_arith_error(): Bad error code");
169 /* Get things ready to do math. */
172 gfc_arith_init_1 (void)
174 gfc_integer_info *int_info;
175 gfc_real_info *real_info;
180 mpfr_set_default_prec (128);
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++)
189 mpz_set_ui (r, int_info->radix);
190 mpz_pow_ui (r, r, int_info->digits);
192 mpz_init (int_info->huge);
193 mpz_sub_ui (int_info->huge, r, 1);
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");
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. */
207 mpz_init (int_info->pedantic_min_int);
208 mpz_neg (int_info->pedantic_min_int, int_info->huge);
210 mpz_init (int_info->min_int);
211 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
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);
218 mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
219 mpfr_log10 (a, a, GFC_RND_MODE);
221 gfc_mpfr_to_mpz (r, a);
222 int_info->range = mpz_get_si (r);
227 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
229 gfc_set_model_kind (real_info->kind);
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);
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);
246 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
247 mpfr_mul (a, a, c, GFC_RND_MODE);
249 /* a = (1 - b**(-p)) * b**(emax-1) * b */
250 mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
252 mpfr_init (real_info->huge);
253 mpfr_set (real_info->huge, a, GFC_RND_MODE);
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);
259 mpfr_init (real_info->tiny);
260 mpfr_set (real_info->tiny, b, GFC_RND_MODE);
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,
267 mpfr_init (real_info->subnormal);
268 mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
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);
274 mpfr_init (real_info->epsilon);
275 mpfr_set (real_info->epsilon, b, GFC_RND_MODE);
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);
282 if (mpfr_cmp (a, b) > 0)
283 mpfr_set (a, b, GFC_RND_MODE); /* a = min(a, b) */
286 gfc_mpfr_to_mpz (r, a);
287 real_info->range = mpz_get_si (r);
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);
293 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
295 gfc_mpfr_to_mpz (r, a);
296 real_info->precision = mpz_get_si (r);
298 /* If the radix is an integral power of 10, add one to the
300 for (i = 10; i <= real_info->radix; i *= 10)
301 if (i == real_info->radix)
302 real_info->precision++;
313 /* Clean up, get rid of numeric constants. */
316 gfc_arith_done_1 (void)
318 gfc_integer_info *ip;
321 for (ip = gfc_integer_kinds; ip->kind; ip++)
323 mpz_clear (ip->min_int);
324 mpz_clear (ip->max_int);
325 mpz_clear (ip->huge);
328 for (rp = gfc_real_kinds; rp->kind; rp++)
330 mpfr_clear (rp->epsilon);
331 mpfr_clear (rp->huge);
332 mpfr_clear (rp->tiny);
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
342 gfc_check_integer_range (mpz_t p, int kind)
347 i = gfc_validate_kind (BT_INTEGER, kind, false);
352 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
353 result = ARITH_ASYMMETRIC;
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;
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
369 gfc_check_real_range (mpfr_t p, int kind)
375 i = gfc_validate_kind (BT_REAL, kind, false);
379 mpfr_abs (q, p, GFC_RND_MODE);
381 if (mpfr_sgn (q) == 0)
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)
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. */
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++)
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);
410 if (mpfr_sgn (p) < 0)
411 mpfr_neg (p, q, GMP_RNDN);
413 mpfr_set (p, q, GMP_RNDN);
429 /* Function to return a constant expression node of a given type and
433 gfc_constant_result (bt type, int kind, locus * where)
439 ("gfc_constant_result(): locus 'where' cannot be NULL");
441 result = gfc_get_expr ();
443 result->expr_type = EXPR_CONSTANT;
444 result->ts.type = type;
445 result->ts.kind = kind;
446 result->where = *where;
451 mpz_init (result->value.integer);
455 gfc_set_model_kind (kind);
456 mpfr_init (result->value.real);
460 gfc_set_model_kind (kind);
461 mpfr_init (result->value.complex.r);
462 mpfr_init (result->value.complex.i);
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. */
480 gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp)
484 result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
485 result->value.logical = !op1->value.logical;
493 gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
497 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
499 result->value.logical = op1->value.logical && op2->value.logical;
507 gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
511 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
513 result->value.logical = op1->value.logical || op2->value.logical;
521 gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
525 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
527 result->value.logical = op1->value.logical == op2->value.logical;
535 gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
539 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
541 result->value.logical = op1->value.logical != op2->value.logical;
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. */
553 gfc_range_check (gfc_expr * e)
560 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
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);
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)
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);
583 gfc_internal_error ("gfc_range_check(): Bad type");
590 /* Several of the following routines use the same set of statements to
591 check the validity of the result. Encapsulate the checking here. */
594 check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
598 if (val == ARITH_UNDERFLOW)
600 if (gfc_option.warn_underflow)
601 gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
605 if (val == ARITH_ASYMMETRIC)
607 gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
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. */
625 gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
627 *resultp = gfc_copy_expr (op1);
633 gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp)
638 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
640 switch (op1->ts.type)
643 mpz_neg (result->value.integer, op1->value.integer);
647 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
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);
656 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
659 rc = gfc_range_check (result);
661 return check_result (rc, op1, result, resultp);
666 gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
671 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
673 switch (op1->ts.type)
676 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
680 mpfr_add (result->value.real, op1->value.real, op2->value.real,
685 mpfr_add (result->value.complex.r, op1->value.complex.r,
686 op2->value.complex.r, GFC_RND_MODE);
688 mpfr_add (result->value.complex.i, op1->value.complex.i,
689 op2->value.complex.i, GFC_RND_MODE);
693 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
696 rc = gfc_range_check (result);
698 return check_result (rc, op1, result, resultp);
703 gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
708 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
710 switch (op1->ts.type)
713 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
717 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
722 mpfr_sub (result->value.complex.r, op1->value.complex.r,
723 op2->value.complex.r, GFC_RND_MODE);
725 mpfr_sub (result->value.complex.i, op1->value.complex.i,
726 op2->value.complex.i, GFC_RND_MODE);
730 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
733 rc = gfc_range_check (result);
735 return check_result (rc, op1, result, resultp);
740 gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
746 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
748 switch (op1->ts.type)
751 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
755 mpfr_mul (result->value.real, op1->value.real, op2->value.real,
761 /* FIXME: possible numericals problem. */
763 gfc_set_model (op1->value.complex.r);
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);
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);
781 gfc_internal_error ("gfc_arith_times(): Bad basic type");
784 rc = gfc_range_check (result);
786 return check_result (rc, op1, result, resultp);
791 gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
799 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
801 switch (op1->ts.type)
804 if (mpz_sgn (op2->value.integer) == 0)
810 mpz_tdiv_q (result->value.integer, op1->value.integer,
815 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
816 if (mpfr_sgn (op2->value.real) == 0)
822 mpfr_div (result->value.real, op1->value.real, op2->value.real,
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)
835 gfc_set_model (op1->value.complex.r);
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);
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,
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,
864 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
868 rc = gfc_range_check (result);
870 return check_result (rc, op1, result, resultp);
874 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
877 complex_reciprocal (gfc_expr * op)
879 mpfr_t mod, a, re, im;
881 gfc_set_model (op->value.complex.r);
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);
892 mpfr_div (re, op->value.complex.r, mod, GFC_RND_MODE);
894 mpfr_neg (im, op->value.complex.i, GFC_RND_MODE);
895 mpfr_div (im, im, mod, GFC_RND_MODE);
897 mpfr_set (op->value.complex.r, re, GFC_RND_MODE);
898 mpfr_set (op->value.complex.i, im, GFC_RND_MODE);
907 /* Raise a complex number to positive power. */
910 complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
914 gfc_set_model (base->value.complex.r);
919 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
920 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
922 for (; power > 0; power--)
924 mpfr_mul (re, base->value.complex.r, result->value.complex.r,
926 mpfr_mul (a, base->value.complex.i, result->value.complex.i,
928 mpfr_sub (re, re, a, GFC_RND_MODE);
930 mpfr_mul (im, base->value.complex.r, result->value.complex.i,
932 mpfr_mul (a, base->value.complex.i, result->value.complex.r,
934 mpfr_add (im, im, a, GFC_RND_MODE);
936 mpfr_set (result->value.complex.r, re, GFC_RND_MODE);
937 mpfr_set (result->value.complex.i, im, GFC_RND_MODE);
946 /* Raise a number to an integer power. */
949 gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
959 if (gfc_extract_int (op2, &power) != NULL)
960 gfc_internal_error ("gfc_arith_power(): Bad exponent");
962 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
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)
972 mpz_set_ui (result->value.integer, 1);
976 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
980 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
981 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
985 gfc_internal_error ("gfc_arith_power(): Bad base");
994 switch (op1->ts.type)
997 mpz_pow_ui (result->value.integer, op1->value.integer, apower);
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);
1010 mpfr_pow_ui (result->value.real, op1->value.real, apower,
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,
1020 mpfr_clear (unity_f);
1025 complex_pow_ui (op1, apower, result);
1027 complex_reciprocal (result);
1036 rc = gfc_range_check (result);
1038 return check_result (rc, op1, result, resultp);
1042 /* Concatenate two string constants. */
1045 gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1050 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
1053 len = op1->value.character.length + op2->value.character.length;
1055 result->value.character.string = gfc_getmem (len + 1);
1056 result->value.character.length = len;
1058 memcpy (result->value.character.string, op1->value.character.string,
1059 op1->value.character.length);
1061 memcpy (result->value.character.string + op1->value.character.length,
1062 op2->value.character.string, op2->value.character.length);
1064 result->value.character.string[len] = '\0';
1072 /* Comparison operators. Assumes that the two expression nodes
1073 contain two constants of the same type. */
1076 gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
1080 switch (op1->ts.type)
1083 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1087 rc = mpfr_cmp (op1->value.real, op2->value.real);
1091 rc = gfc_compare_string (op1, op2, NULL);
1095 rc = ((!op1->value.logical && op2->value.logical)
1096 || (op1->value.logical && !op2->value.logical));
1100 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1107 /* Compare a pair of complex numbers. Naturally, this is only for
1108 equality/nonequality. */
1111 compare_complex (gfc_expr * op1, gfc_expr * op2)
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);
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. */
1124 gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table)
1126 int len, alen, blen, i, ac, bc;
1128 alen = a->value.character.length;
1129 blen = b->value.character.length;
1131 len = (alen > blen) ? alen : blen;
1133 for (i = 0; i < len; i++)
1135 ac = (i < alen) ? a->value.character.string[i] : ' ';
1136 bc = (i < blen) ? b->value.character.string[i] : ' ';
1138 if (xcoll_table != NULL)
1140 ac = xcoll_table[ac];
1141 bc = xcoll_table[bc];
1150 /* Strings are equal */
1156 /* Specific comparison subroutines. */
1159 gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1163 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1165 result->value.logical = (op1->ts.type == BT_COMPLEX) ?
1166 compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) == 0);
1174 gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1178 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1180 result->value.logical = (op1->ts.type == BT_COMPLEX) ?
1181 !compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) != 0);
1189 gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1193 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1195 result->value.logical = (gfc_compare_expr (op1, op2) > 0);
1203 gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1207 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1209 result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
1217 gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1221 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1223 result->value.logical = (gfc_compare_expr (op1, op2) < 0);
1231 gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
1235 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1237 result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
1245 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op,
1248 gfc_constructor *c, *head;
1252 if (op->expr_type == EXPR_CONSTANT)
1253 return eval (op, result);
1256 head = gfc_copy_constructor (op->value.constructor);
1258 for (c = head; c; c = c->next)
1260 rc = eval (c->expr, &r);
1264 gfc_replace_expr (c->expr, r);
1268 gfc_free_constructor (head);
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);
1276 r->ts = head->expr->ts;
1277 r->where = op->where;
1288 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1289 gfc_expr * op1, gfc_expr * op2,
1292 gfc_constructor *c, *head;
1296 head = gfc_copy_constructor (op1->value.constructor);
1299 for (c = head; c; c = c->next)
1301 rc = eval (c->expr, op2, &r);
1305 gfc_replace_expr (c->expr, r);
1309 gfc_free_constructor (head);
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);
1317 r->ts = head->expr->ts;
1318 r->where = op1->where;
1319 r->rank = op1->rank;
1329 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1330 gfc_expr * op1, gfc_expr * op2,
1333 gfc_constructor *c, *head;
1337 head = gfc_copy_constructor (op2->value.constructor);
1340 for (c = head; c; c = c->next)
1342 rc = eval (op1, c->expr, &r);
1346 gfc_replace_expr (c->expr, r);
1350 gfc_free_constructor (head);
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);
1358 r->ts = head->expr->ts;
1359 r->where = op2->where;
1360 r->rank = op2->rank;
1370 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1371 gfc_expr * op1, gfc_expr * op2,
1374 gfc_constructor *c, *d, *head;
1378 head = gfc_copy_constructor (op1->value.constructor);
1381 d = op2->value.constructor;
1383 if (gfc_check_conformance ("Elemental binary operation", op1, op2)
1385 rc = ARITH_INCOMMENSURATE;
1389 for (c = head; c; c = c->next, d = d->next)
1393 rc = ARITH_INCOMMENSURATE;
1397 rc = eval (c->expr, d->expr, &r);
1401 gfc_replace_expr (c->expr, r);
1405 rc = ARITH_INCOMMENSURATE;
1409 gfc_free_constructor (head);
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);
1417 r->ts = head->expr->ts;
1418 r->where = op1->where;
1419 r->rank = op1->rank;
1429 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1430 gfc_expr * op1, gfc_expr * op2,
1433 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1434 return eval (op1, op2, result);
1436 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1437 return reduce_binary_ca (eval, op1, op2, result);
1439 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1440 return reduce_binary_ac (eval, op1, op2, result);
1442 return reduce_binary_aa (eval, op1, op2, result);
1448 arith (*f2)(gfc_expr *, gfc_expr **);
1449 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
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.
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. */
1464 eval_intrinsic (gfc_intrinsic_op operator,
1465 eval_f eval, gfc_expr * op1, gfc_expr * op2)
1467 gfc_expr temp, *result;
1471 gfc_clear_ts (&temp.ts);
1475 case INTRINSIC_NOT: /* Logical unary */
1476 if (op1->ts.type != BT_LOGICAL)
1479 temp.ts.type = BT_LOGICAL;
1480 temp.ts.kind = gfc_default_logical_kind;
1485 /* Logical binary operators */
1488 case INTRINSIC_NEQV:
1490 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1493 temp.ts.type = BT_LOGICAL;
1494 temp.ts.kind = gfc_default_logical_kind;
1499 case INTRINSIC_UPLUS:
1500 case INTRINSIC_UMINUS: /* Numeric unary */
1501 if (!gfc_numeric_ts (&op1->ts))
1510 case INTRINSIC_LT: /* Additional restrictions */
1511 case INTRINSIC_LE: /* for ordering relations. */
1513 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1515 temp.ts.type = BT_LOGICAL;
1516 temp.ts.kind = gfc_default_logical_kind;
1520 /* else fall through */
1524 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1527 temp.ts.type = BT_LOGICAL;
1528 temp.ts.kind = gfc_default_logical_kind;
1532 /* else fall through */
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))
1542 /* Insert any necessary type conversions to make the operands compatible. */
1544 temp.expr_type = EXPR_OP;
1545 gfc_clear_ts (&temp.ts);
1546 temp.value.op.operator = operator;
1548 temp.value.op.op1 = op1;
1549 temp.value.op.op2 = op2;
1551 gfc_type_convert_binary (&temp);
1553 if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
1554 || operator == INTRINSIC_GE || operator == INTRINSIC_GT
1555 || operator == INTRINSIC_LE || operator == INTRINSIC_LT)
1557 temp.ts.type = BT_LOGICAL;
1558 temp.ts.kind = gfc_default_logical_kind;
1564 case INTRINSIC_CONCAT: /* Character binary */
1565 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
1568 temp.ts.type = BT_CHARACTER;
1569 temp.ts.kind = gfc_default_character_kind;
1574 case INTRINSIC_USER:
1578 gfc_internal_error ("eval_intrinsic(): Bad operator");
1581 /* Try to combine the operators. */
1582 if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
1585 if (op1->expr_type != EXPR_CONSTANT
1586 && (op1->expr_type != EXPR_ARRAY
1587 || !gfc_is_constant_expr (op1)
1588 || !gfc_expanded_ac (op1)))
1592 && op2->expr_type != EXPR_CONSTANT
1593 && (op2->expr_type != EXPR_ARRAY
1594 || !gfc_is_constant_expr (op2)
1595 || !gfc_expanded_ac (op2)))
1599 rc = reduce_unary (eval.f2, op1, &result);
1601 rc = reduce_binary (eval.f3, op1, op2, &result);
1604 { /* Something went wrong */
1605 gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
1609 gfc_free_expr (op1);
1610 gfc_free_expr (op2);
1614 /* Create a run-time expression */
1615 result = gfc_get_expr ();
1616 result->ts = temp.ts;
1618 result->expr_type = EXPR_OP;
1619 result->value.op.operator = operator;
1621 result->value.op.op1 = op1;
1622 result->value.op.op2 = op2;
1624 result->where = op1->where;
1630 /* Modify type of expression for zero size array. */
1632 eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
1635 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1645 op->ts.type = BT_LOGICAL;
1646 op->ts.kind = gfc_default_logical_kind;
1657 /* Return nonzero if the expression is a zero size array. */
1660 gfc_zero_size_array (gfc_expr * e)
1662 if (e->expr_type != EXPR_ARRAY)
1665 return e->value.constructor == NULL;
1669 /* Reduce a binary expression where at least one of the operands
1670 involves a zero-length array. Returns NULL if neither of the
1671 operands is a zero-length array. */
1674 reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
1676 if (gfc_zero_size_array (op1))
1678 gfc_free_expr (op2);
1682 if (gfc_zero_size_array (op2))
1684 gfc_free_expr (op1);
1693 eval_intrinsic_f2 (gfc_intrinsic_op operator,
1694 arith (*eval) (gfc_expr *, gfc_expr **),
1695 gfc_expr * op1, gfc_expr * op2)
1702 if (gfc_zero_size_array (op1))
1703 return eval_type_intrinsic0 (operator, op1);
1707 result = reduce_binary0 (op1, op2);
1709 return eval_type_intrinsic0 (operator, result);
1713 return eval_intrinsic (operator, f, op1, op2);
1718 eval_intrinsic_f3 (gfc_intrinsic_op operator,
1719 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1720 gfc_expr * op1, gfc_expr * op2)
1725 result = reduce_binary0 (op1, op2);
1727 return eval_type_intrinsic0(operator, result);
1730 return eval_intrinsic (operator, f, op1, op2);
1736 gfc_uplus (gfc_expr * op)
1738 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_uplus, op, NULL);
1742 gfc_uminus (gfc_expr * op)
1744 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1748 gfc_add (gfc_expr * op1, gfc_expr * op2)
1750 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1754 gfc_subtract (gfc_expr * op1, gfc_expr * op2)
1756 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1760 gfc_multiply (gfc_expr * op1, gfc_expr * op2)
1762 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1766 gfc_divide (gfc_expr * op1, gfc_expr * op2)
1768 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1772 gfc_power (gfc_expr * op1, gfc_expr * op2)
1774 return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
1778 gfc_concat (gfc_expr * op1, gfc_expr * op2)
1780 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1784 gfc_and (gfc_expr * op1, gfc_expr * op2)
1786 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1790 gfc_or (gfc_expr * op1, gfc_expr * op2)
1792 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1796 gfc_not (gfc_expr * op1)
1798 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1802 gfc_eqv (gfc_expr * op1, gfc_expr * op2)
1804 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1808 gfc_neqv (gfc_expr * op1, gfc_expr * op2)
1810 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1814 gfc_eq (gfc_expr * op1, gfc_expr * op2)
1816 return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
1820 gfc_ne (gfc_expr * op1, gfc_expr * op2)
1822 return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
1826 gfc_gt (gfc_expr * op1, gfc_expr * op2)
1828 return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
1832 gfc_ge (gfc_expr * op1, gfc_expr * op2)
1834 return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
1838 gfc_lt (gfc_expr * op1, gfc_expr * op2)
1840 return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
1844 gfc_le (gfc_expr * op1, gfc_expr * op2)
1846 return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
1850 /* Convert an integer string to an expression node. */
1853 gfc_convert_integer (const char *buffer, int kind, int radix, locus * where)
1858 e = gfc_constant_result (BT_INTEGER, kind, where);
1859 /* a leading plus is allowed, but not by mpz_set_str */
1860 if (buffer[0] == '+')
1864 mpz_set_str (e->value.integer, t, radix);
1870 /* Convert a real string to an expression node. */
1873 gfc_convert_real (const char *buffer, int kind, locus * where)
1877 e = gfc_constant_result (BT_REAL, kind, where);
1878 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1884 /* Convert a pair of real, constant expression nodes to a single
1885 complex expression node. */
1888 gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
1892 e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1893 mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
1894 mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
1900 /******* Simplification of intrinsic functions with constant arguments *****/
1903 /* Deal with an arithmetic error. */
1906 arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
1908 gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
1909 gfc_typename (from), gfc_typename (to), where);
1911 /* TODO: Do something about the error, ie, throw exception, return
1915 /* Convert integers to integers. */
1918 gfc_int2int (gfc_expr * src, int kind)
1923 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
1925 mpz_set (result->value.integer, src->value.integer);
1927 if ((rc = gfc_check_integer_range (result->value.integer, kind))
1930 if (rc == ARITH_ASYMMETRIC)
1932 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
1936 arith_error (rc, &src->ts, &result->ts, &src->where);
1937 gfc_free_expr (result);
1946 /* Convert integers to reals. */
1949 gfc_int2real (gfc_expr * src, int kind)
1954 result = gfc_constant_result (BT_REAL, kind, &src->where);
1956 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1958 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1960 arith_error (rc, &src->ts, &result->ts, &src->where);
1961 gfc_free_expr (result);
1969 /* Convert default integer to default complex. */
1972 gfc_int2complex (gfc_expr * src, int kind)
1977 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
1979 mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
1980 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
1982 if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
1984 arith_error (rc, &src->ts, &result->ts, &src->where);
1985 gfc_free_expr (result);
1993 /* Convert default real to default integer. */
1996 gfc_real2int (gfc_expr * src, int kind)
2001 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2003 gfc_mpfr_to_mpz (result->value.integer, src->value.real);
2005 if ((rc = gfc_check_integer_range (result->value.integer, kind))
2008 arith_error (rc, &src->ts, &result->ts, &src->where);
2009 gfc_free_expr (result);
2017 /* Convert real to real. */
2020 gfc_real2real (gfc_expr * src, int kind)
2025 result = gfc_constant_result (BT_REAL, kind, &src->where);
2027 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2029 rc = gfc_check_real_range (result->value.real, kind);
2031 if (rc == ARITH_UNDERFLOW)
2033 if (gfc_option.warn_underflow)
2034 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
2035 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2037 else if (rc != ARITH_OK)
2039 arith_error (rc, &src->ts, &result->ts, &src->where);
2040 gfc_free_expr (result);
2048 /* Convert real to complex. */
2051 gfc_real2complex (gfc_expr * src, int kind)
2056 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2058 mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
2059 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2061 rc = gfc_check_real_range (result->value.complex.r, kind);
2063 if (rc == ARITH_UNDERFLOW)
2065 if (gfc_option.warn_underflow)
2066 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
2067 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2069 else if (rc != ARITH_OK)
2071 arith_error (rc, &src->ts, &result->ts, &src->where);
2072 gfc_free_expr (result);
2080 /* Convert complex to integer. */
2083 gfc_complex2int (gfc_expr * src, int kind)
2088 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2090 gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
2092 if ((rc = gfc_check_integer_range (result->value.integer, kind))
2095 arith_error (rc, &src->ts, &result->ts, &src->where);
2096 gfc_free_expr (result);
2104 /* Convert complex to real. */
2107 gfc_complex2real (gfc_expr * src, int kind)
2112 result = gfc_constant_result (BT_REAL, kind, &src->where);
2114 mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
2116 rc = gfc_check_real_range (result->value.real, kind);
2118 if (rc == ARITH_UNDERFLOW)
2120 if (gfc_option.warn_underflow)
2121 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
2122 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2126 arith_error (rc, &src->ts, &result->ts, &src->where);
2127 gfc_free_expr (result);
2135 /* Convert complex to complex. */
2138 gfc_complex2complex (gfc_expr * src, int kind)
2143 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2145 mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
2146 mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
2148 rc = gfc_check_real_range (result->value.complex.r, kind);
2150 if (rc == ARITH_UNDERFLOW)
2152 if (gfc_option.warn_underflow)
2153 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
2154 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2156 else if (rc != ARITH_OK)
2158 arith_error (rc, &src->ts, &result->ts, &src->where);
2159 gfc_free_expr (result);
2163 rc = gfc_check_real_range (result->value.complex.i, kind);
2165 if (rc == ARITH_UNDERFLOW)
2167 if (gfc_option.warn_underflow)
2168 gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
2169 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2171 else if (rc != ARITH_OK)
2173 arith_error (rc, &src->ts, &result->ts, &src->where);
2174 gfc_free_expr (result);
2182 /* Logical kind conversion. */
2185 gfc_log2log (gfc_expr * src, int kind)
2189 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2190 result->value.logical = src->value.logical;