2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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, 51 Franklin Street, Fifth Floor, 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 and the MPFR
26 library to do arithmetic, and this file provides the interface. */
33 #include "target-memory.h"
35 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
36 It's easily implemented with a few calls though. */
39 gfc_mpfr_to_mpz (mpz_t z, mpfr_t x)
43 e = mpfr_get_z_exp (z, x);
44 /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
45 may set the sign of z incorrectly. Work around that here. */
46 if (mpfr_sgn (x) != mpz_sgn (z))
50 mpz_mul_2exp (z, z, e);
52 mpz_tdiv_q_2exp (z, z, -e);
56 /* Set the model number precision by the requested KIND. */
59 gfc_set_model_kind (int kind)
61 int index = gfc_validate_kind (BT_REAL, kind, false);
64 base2prec = gfc_real_kinds[index].digits;
65 if (gfc_real_kinds[index].radix != 2)
66 base2prec *= gfc_real_kinds[index].radix / 2;
67 mpfr_set_default_prec (base2prec);
71 /* Set the model number precision from mpfr_t x. */
74 gfc_set_model (mpfr_t x)
76 mpfr_set_default_prec (mpfr_get_prec (x));
80 /* Given an arithmetic error code, return a pointer to a string that
81 explains the error. */
84 gfc_arith_error (arith code)
91 p = _("Arithmetic OK at %L");
94 p = _("Arithmetic overflow at %L");
97 p = _("Arithmetic underflow at %L");
100 p = _("Arithmetic NaN at %L");
103 p = _("Division by zero at %L");
105 case ARITH_INCOMMENSURATE:
106 p = _("Array operands are incommensurate at %L");
108 case ARITH_ASYMMETRIC:
110 _("Integer outside symmetric range implied by Standard Fortran at %L");
113 gfc_internal_error ("gfc_arith_error(): Bad error code");
120 /* Get things ready to do math. */
123 gfc_arith_init_1 (void)
125 gfc_integer_info *int_info;
126 gfc_real_info *real_info;
131 mpfr_set_default_prec (128);
135 /* Convert the minimum and maximum values for each kind into their
136 GNU MP representation. */
137 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
140 mpz_set_ui (r, int_info->radix);
141 mpz_pow_ui (r, r, int_info->digits);
143 mpz_init (int_info->huge);
144 mpz_sub_ui (int_info->huge, r, 1);
146 /* These are the numbers that are actually representable by the
147 target. For bases other than two, this needs to be changed. */
148 if (int_info->radix != 2)
149 gfc_internal_error ("Fix min_int calculation");
151 /* See PRs 13490 and 17912, related to integer ranges.
152 The pedantic_min_int exists for range checking when a program
153 is compiled with -pedantic, and reflects the belief that
154 Standard Fortran requires integers to be symmetrical, i.e.
155 every negative integer must have a representable positive
156 absolute value, and vice versa. */
158 mpz_init (int_info->pedantic_min_int);
159 mpz_neg (int_info->pedantic_min_int, int_info->huge);
161 mpz_init (int_info->min_int);
162 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
165 mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
166 mpfr_log10 (a, a, GFC_RND_MODE);
168 gfc_mpfr_to_mpz (r, a);
169 int_info->range = mpz_get_si (r);
174 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
176 gfc_set_model_kind (real_info->kind);
182 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
183 /* a = 1 - b**(-p) */
184 mpfr_set_ui (a, 1, GFC_RND_MODE);
185 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
186 mpfr_pow_si (b, b, -real_info->digits, GFC_RND_MODE);
187 mpfr_sub (a, a, b, GFC_RND_MODE);
189 /* c = b**(emax-1) */
190 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
191 mpfr_pow_ui (c, b, real_info->max_exponent - 1, GFC_RND_MODE);
193 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
194 mpfr_mul (a, a, c, GFC_RND_MODE);
196 /* a = (1 - b**(-p)) * b**(emax-1) * b */
197 mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
199 mpfr_init (real_info->huge);
200 mpfr_set (real_info->huge, a, GFC_RND_MODE);
202 /* tiny(x) = b**(emin-1) */
203 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
204 mpfr_pow_si (b, b, real_info->min_exponent - 1, GFC_RND_MODE);
206 mpfr_init (real_info->tiny);
207 mpfr_set (real_info->tiny, b, GFC_RND_MODE);
209 /* subnormal (x) = b**(emin - digit) */
210 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
211 mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits,
214 mpfr_init (real_info->subnormal);
215 mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
217 /* epsilon(x) = b**(1-p) */
218 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
219 mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE);
221 mpfr_init (real_info->epsilon);
222 mpfr_set (real_info->epsilon, b, GFC_RND_MODE);
224 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
225 mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
226 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
227 mpfr_neg (b, b, GFC_RND_MODE);
230 if (mpfr_cmp (a, b) > 0)
231 mpfr_set (a, b, GFC_RND_MODE);
234 gfc_mpfr_to_mpz (r, a);
235 real_info->range = mpz_get_si (r);
237 /* precision(x) = int((p - 1) * log10(b)) + k */
238 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
239 mpfr_log10 (a, a, GFC_RND_MODE);
241 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
243 gfc_mpfr_to_mpz (r, a);
244 real_info->precision = mpz_get_si (r);
246 /* If the radix is an integral power of 10, add one to the precision. */
247 for (i = 10; i <= real_info->radix; i *= 10)
248 if (i == real_info->radix)
249 real_info->precision++;
260 /* Clean up, get rid of numeric constants. */
263 gfc_arith_done_1 (void)
265 gfc_integer_info *ip;
268 for (ip = gfc_integer_kinds; ip->kind; ip++)
270 mpz_clear (ip->min_int);
271 mpz_clear (ip->pedantic_min_int);
272 mpz_clear (ip->huge);
275 for (rp = gfc_real_kinds; rp->kind; rp++)
277 mpfr_clear (rp->epsilon);
278 mpfr_clear (rp->huge);
279 mpfr_clear (rp->tiny);
280 mpfr_clear (rp->subnormal);
285 /* Given an integer and a kind, make sure that the integer lies within
286 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
290 gfc_check_integer_range (mpz_t p, int kind)
295 i = gfc_validate_kind (BT_INTEGER, kind, false);
300 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
301 result = ARITH_ASYMMETRIC;
305 if (gfc_option.flag_range_check == 0)
308 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
309 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
310 result = ARITH_OVERFLOW;
316 /* Given a real and a kind, make sure that the real lies within the
317 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
321 gfc_check_real_range (mpfr_t p, int kind)
327 i = gfc_validate_kind (BT_REAL, kind, false);
331 mpfr_abs (q, p, GFC_RND_MODE);
335 if (gfc_option.flag_range_check == 0)
338 retval = ARITH_OVERFLOW;
340 else if (mpfr_nan_p (p))
342 if (gfc_option.flag_range_check == 0)
347 else if (mpfr_sgn (q) == 0)
349 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
351 if (gfc_option.flag_range_check == 0)
354 retval = ARITH_OVERFLOW;
356 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
358 if (gfc_option.flag_range_check == 0)
361 retval = ARITH_UNDERFLOW;
363 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
368 /* Save current values of emin and emax. */
369 emin = mpfr_get_emin ();
370 emax = mpfr_get_emax ();
372 /* Set emin and emax for the current model number. */
373 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
374 mpfr_set_emin ((mp_exp_t) en);
375 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
376 mpfr_subnormalize (q, 0, GFC_RND_MODE);
378 /* Reset emin and emax. */
379 mpfr_set_emin (emin);
380 mpfr_set_emax (emax);
382 /* Copy sign if needed. */
383 if (mpfr_sgn (p) < 0)
384 mpfr_neg (p, q, GMP_RNDN);
386 mpfr_set (p, q, GMP_RNDN);
399 /* Function to return a constant expression node of a given type and kind. */
402 gfc_constant_result (bt type, int kind, locus *where)
407 gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
409 result = gfc_get_expr ();
411 result->expr_type = EXPR_CONSTANT;
412 result->ts.type = type;
413 result->ts.kind = kind;
414 result->where = *where;
419 mpz_init (result->value.integer);
423 gfc_set_model_kind (kind);
424 mpfr_init (result->value.real);
428 gfc_set_model_kind (kind);
429 mpfr_init (result->value.complex.r);
430 mpfr_init (result->value.complex.i);
441 /* Low-level arithmetic functions. All of these subroutines assume
442 that all operands are of the same type and return an operand of the
443 same type. The other thing about these subroutines is that they
444 can fail in various ways -- overflow, underflow, division by zero,
445 zero raised to the zero, etc. */
448 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
452 result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
453 result->value.logical = !op1->value.logical;
461 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
465 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
467 result->value.logical = op1->value.logical && op2->value.logical;
475 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
479 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
481 result->value.logical = op1->value.logical || op2->value.logical;
489 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
493 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
495 result->value.logical = op1->value.logical == op2->value.logical;
503 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
507 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
509 result->value.logical = op1->value.logical != op2->value.logical;
516 /* Make sure a constant numeric expression is within the range for
517 its type and kind. Note that there's also a gfc_check_range(),
518 but that one deals with the intrinsic RANGE function. */
521 gfc_range_check (gfc_expr *e)
528 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
532 rc = gfc_check_real_range (e->value.real, e->ts.kind);
533 if (rc == ARITH_UNDERFLOW)
534 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
535 if (rc == ARITH_OVERFLOW)
536 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
538 mpfr_set_nan (e->value.real);
542 rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
543 if (rc == ARITH_UNDERFLOW)
544 mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
545 if (rc == ARITH_OVERFLOW)
546 mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
548 mpfr_set_nan (e->value.complex.r);
550 rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
551 if (rc == ARITH_UNDERFLOW)
552 mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
553 if (rc == ARITH_OVERFLOW)
554 mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
556 mpfr_set_nan (e->value.complex.i);
560 gfc_internal_error ("gfc_range_check(): Bad type");
567 /* Several of the following routines use the same set of statements to
568 check the validity of the result. Encapsulate the checking here. */
571 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
575 if (val == ARITH_UNDERFLOW)
577 if (gfc_option.warn_underflow)
578 gfc_warning (gfc_arith_error (val), &x->where);
582 if (val == ARITH_ASYMMETRIC)
584 gfc_warning (gfc_arith_error (val), &x->where);
597 /* It may seem silly to have a subroutine that actually computes the
598 unary plus of a constant, but it prevents us from making exceptions
599 in the code elsewhere. Used for unary plus and parenthesized
603 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
605 *resultp = gfc_copy_expr (op1);
611 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
616 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
618 switch (op1->ts.type)
621 mpz_neg (result->value.integer, op1->value.integer);
625 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
629 mpfr_neg (result->value.complex.r, op1->value.complex.r, GFC_RND_MODE);
630 mpfr_neg (result->value.complex.i, op1->value.complex.i, GFC_RND_MODE);
634 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
637 rc = gfc_range_check (result);
639 return check_result (rc, op1, result, resultp);
644 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
649 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
651 switch (op1->ts.type)
654 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
658 mpfr_add (result->value.real, op1->value.real, op2->value.real,
663 mpfr_add (result->value.complex.r, op1->value.complex.r,
664 op2->value.complex.r, GFC_RND_MODE);
666 mpfr_add (result->value.complex.i, op1->value.complex.i,
667 op2->value.complex.i, GFC_RND_MODE);
671 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
674 rc = gfc_range_check (result);
676 return check_result (rc, op1, result, resultp);
681 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
686 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
688 switch (op1->ts.type)
691 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
695 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
700 mpfr_sub (result->value.complex.r, op1->value.complex.r,
701 op2->value.complex.r, GFC_RND_MODE);
703 mpfr_sub (result->value.complex.i, op1->value.complex.i,
704 op2->value.complex.i, GFC_RND_MODE);
708 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
711 rc = gfc_range_check (result);
713 return check_result (rc, op1, result, resultp);
718 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
724 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
726 switch (op1->ts.type)
729 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
733 mpfr_mul (result->value.real, op1->value.real, op2->value.real,
738 gfc_set_model (op1->value.complex.r);
742 mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
743 mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
744 mpfr_sub (result->value.complex.r, x, y, GFC_RND_MODE);
746 mpfr_mul (x, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
747 mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
748 mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE);
755 gfc_internal_error ("gfc_arith_times(): Bad basic type");
758 rc = gfc_range_check (result);
760 return check_result (rc, op1, result, resultp);
765 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
773 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
775 switch (op1->ts.type)
778 if (mpz_sgn (op2->value.integer) == 0)
784 mpz_tdiv_q (result->value.integer, op1->value.integer,
789 if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
795 mpfr_div (result->value.real, op1->value.real, op2->value.real,
800 if (mpfr_sgn (op2->value.complex.r) == 0
801 && mpfr_sgn (op2->value.complex.i) == 0
802 && gfc_option.flag_range_check == 1)
808 gfc_set_model (op1->value.complex.r);
813 mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
814 mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
815 mpfr_add (div, x, y, GFC_RND_MODE);
817 mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
818 mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
819 mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE);
820 mpfr_div (result->value.complex.r, result->value.complex.r, div,
823 mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
824 mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
825 mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE);
826 mpfr_div (result->value.complex.i, result->value.complex.i, div,
835 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
839 rc = gfc_range_check (result);
841 return check_result (rc, op1, result, resultp);
845 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
848 complex_reciprocal (gfc_expr *op)
850 mpfr_t mod, a, re, im;
852 gfc_set_model (op->value.complex.r);
858 mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
859 mpfr_mul (a, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
860 mpfr_add (mod, mod, a, GFC_RND_MODE);
862 mpfr_div (re, op->value.complex.r, mod, GFC_RND_MODE);
864 mpfr_neg (im, op->value.complex.i, GFC_RND_MODE);
865 mpfr_div (im, im, mod, GFC_RND_MODE);
867 mpfr_set (op->value.complex.r, re, GFC_RND_MODE);
868 mpfr_set (op->value.complex.i, im, GFC_RND_MODE);
877 /* Raise a complex number to positive power (power > 0).
878 This function will modify the content of power.
880 Use Binary Method, which is not an optimal but a simple and reasonable
881 arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth,
882 "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming",
883 3rd Edition, 1998. */
886 complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power)
888 mpfr_t x_r, x_i, tmp, re, im;
890 gfc_set_model (base->value.complex.r);
898 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
899 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
902 mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE);
903 mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE);
905 /* Macro for complex multiplication. We have to take care that
906 res_r/res_i and a_r/a_i can (and will) be the same variable. */
907 #define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \
908 mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \
909 mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \
910 mpfr_sub (re, re, tmp, GFC_RND_MODE), \
912 mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \
913 mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \
914 mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
915 mpfr_set (res_r, re, GFC_RND_MODE)
917 #define res_r result->value.complex.r
918 #define res_i result->value.complex.i
920 /* for (; power > 0; x *= x) */
921 for (; mpz_cmp_si (power, 0) > 0; CMULT(x_r,x_i,x_r,x_i,x_r,x_i))
923 /* if (power & 1) res = res * x; */
924 if (mpz_congruent_ui_p (power, 1, 2))
925 CMULT(res_r,res_i,res_r,res_i,x_r,x_i);
928 mpz_fdiv_q_ui (power, power, 2);
943 /* Raise a number to an integer power. */
946 gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
952 gcc_assert (op2->expr_type == EXPR_CONSTANT && op2->ts.type == BT_INTEGER);
955 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
956 power_sign = mpz_sgn (op2->value.integer);
960 /* Handle something to the zeroth power. Since we're dealing
961 with integral exponents, there is no ambiguity in the
962 limiting procedure used to determine the value of 0**0. */
963 switch (op1->ts.type)
966 mpz_set_ui (result->value.integer, 1);
970 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
974 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
975 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
979 gfc_internal_error ("gfc_arith_power(): Bad base");
984 switch (op1->ts.type)
990 /* First, we simplify the cases of op1 == 1, 0 or -1. */
991 if (mpz_cmp_si (op1->value.integer, 1) == 0)
994 mpz_set_si (result->value.integer, 1);
996 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
998 /* 0**op2 == 0, if op2 > 0
999 0**op2 overflow, if op2 < 0 ; in that case, we
1000 set the result to 0 and return ARITH_DIV0. */
1001 mpz_set_si (result->value.integer, 0);
1002 if (mpz_cmp_si (op2->value.integer, 0) < 0)
1005 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
1007 /* (-1)**op2 == (-1)**(mod(op2,2)) */
1008 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
1010 mpz_set_si (result->value.integer, -1);
1012 mpz_set_si (result->value.integer, 1);
1014 /* Then, we take care of op2 < 0. */
1015 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
1017 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1018 mpz_set_si (result->value.integer, 0);
1020 else if (gfc_extract_int (op2, &power) != NULL)
1022 /* If op2 doesn't fit in an int, the exponentiation will
1023 overflow, because op2 > 0 and abs(op1) > 1. */
1025 int i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
1027 if (gfc_option.flag_range_check)
1028 rc = ARITH_OVERFLOW;
1030 /* Still, we want to give the same value as the processor. */
1032 mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
1033 mpz_mul_ui (max, max, 2);
1034 mpz_powm (result->value.integer, op1->value.integer,
1035 op2->value.integer, max);
1039 mpz_pow_ui (result->value.integer, op1->value.integer, power);
1044 mpfr_pow_z (result->value.real, op1->value.real, op2->value.integer,
1052 /* Compute op1**abs(op2) */
1054 mpz_abs (apower, op2->value.integer);
1055 complex_pow (result, op1, apower);
1058 /* If (op2 < 0), compute the inverse. */
1060 complex_reciprocal (result);
1071 rc = gfc_range_check (result);
1073 return check_result (rc, op1, result, resultp);
1077 /* Concatenate two string constants. */
1080 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1085 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
1088 len = op1->value.character.length + op2->value.character.length;
1090 result->value.character.string = gfc_getmem (len + 1);
1091 result->value.character.length = len;
1093 memcpy (result->value.character.string, op1->value.character.string,
1094 op1->value.character.length);
1096 memcpy (result->value.character.string + op1->value.character.length,
1097 op2->value.character.string, op2->value.character.length);
1099 result->value.character.string[len] = '\0';
1107 /* Comparison operators. Assumes that the two expression nodes
1108 contain two constants of the same type. */
1111 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
1115 switch (op1->ts.type)
1118 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1122 rc = mpfr_cmp (op1->value.real, op2->value.real);
1126 rc = gfc_compare_string (op1, op2);
1130 rc = ((!op1->value.logical && op2->value.logical)
1131 || (op1->value.logical && !op2->value.logical));
1135 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1142 /* Compare a pair of complex numbers. Naturally, this is only for
1143 equality and nonequality. */
1146 compare_complex (gfc_expr *op1, gfc_expr *op2)
1148 return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0
1149 && mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0);
1153 /* Given two constant strings and the inverse collating sequence, compare the
1154 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1155 We use the processor's default collating sequence. */
1158 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1160 int len, alen, blen, i, ac, bc;
1162 alen = a->value.character.length;
1163 blen = b->value.character.length;
1165 len = (alen > blen) ? alen : blen;
1167 for (i = 0; i < len; i++)
1169 /* We cast to unsigned char because default char, if it is signed,
1170 would lead to ac < 0 for string[i] > 127. */
1171 ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
1172 bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
1180 /* Strings are equal */
1186 /* Specific comparison subroutines. */
1189 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1193 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1195 result->value.logical = (op1->ts.type == BT_COMPLEX)
1196 ? compare_complex (op1, op2)
1197 : (gfc_compare_expr (op1, op2) == 0);
1205 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1209 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1211 result->value.logical = (op1->ts.type == BT_COMPLEX)
1212 ? !compare_complex (op1, op2)
1213 : (gfc_compare_expr (op1, op2) != 0);
1221 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1225 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1227 result->value.logical = (gfc_compare_expr (op1, op2) > 0);
1235 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1239 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1241 result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
1249 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1253 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1255 result->value.logical = (gfc_compare_expr (op1, op2) < 0);
1263 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1267 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1269 result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
1277 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1280 gfc_constructor *c, *head;
1284 if (op->expr_type == EXPR_CONSTANT)
1285 return eval (op, result);
1288 head = gfc_copy_constructor (op->value.constructor);
1290 for (c = head; c; c = c->next)
1292 rc = eval (c->expr, &r);
1296 gfc_replace_expr (c->expr, r);
1300 gfc_free_constructor (head);
1303 r = gfc_get_expr ();
1304 r->expr_type = EXPR_ARRAY;
1305 r->value.constructor = head;
1306 r->shape = gfc_copy_shape (op->shape, op->rank);
1308 r->ts = head->expr->ts;
1309 r->where = op->where;
1320 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1321 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1323 gfc_constructor *c, *head;
1327 head = gfc_copy_constructor (op1->value.constructor);
1330 for (c = head; c; c = c->next)
1332 rc = eval (c->expr, op2, &r);
1336 gfc_replace_expr (c->expr, r);
1340 gfc_free_constructor (head);
1343 r = gfc_get_expr ();
1344 r->expr_type = EXPR_ARRAY;
1345 r->value.constructor = head;
1346 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1348 r->ts = head->expr->ts;
1349 r->where = op1->where;
1350 r->rank = op1->rank;
1360 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1361 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1363 gfc_constructor *c, *head;
1367 head = gfc_copy_constructor (op2->value.constructor);
1370 for (c = head; c; c = c->next)
1372 rc = eval (op1, c->expr, &r);
1376 gfc_replace_expr (c->expr, r);
1380 gfc_free_constructor (head);
1383 r = gfc_get_expr ();
1384 r->expr_type = EXPR_ARRAY;
1385 r->value.constructor = head;
1386 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1388 r->ts = head->expr->ts;
1389 r->where = op2->where;
1390 r->rank = op2->rank;
1400 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1401 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1403 gfc_constructor *c, *d, *head;
1407 head = gfc_copy_constructor (op1->value.constructor);
1410 d = op2->value.constructor;
1412 if (gfc_check_conformance ("Elemental binary operation", op1, op2)
1414 rc = ARITH_INCOMMENSURATE;
1417 for (c = head; c; c = c->next, d = d->next)
1421 rc = ARITH_INCOMMENSURATE;
1425 rc = eval (c->expr, d->expr, &r);
1429 gfc_replace_expr (c->expr, r);
1433 rc = ARITH_INCOMMENSURATE;
1437 gfc_free_constructor (head);
1440 r = gfc_get_expr ();
1441 r->expr_type = EXPR_ARRAY;
1442 r->value.constructor = head;
1443 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1445 r->ts = head->expr->ts;
1446 r->where = op1->where;
1447 r->rank = op1->rank;
1457 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1458 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1460 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1461 return eval (op1, op2, result);
1463 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1464 return reduce_binary_ca (eval, op1, op2, result);
1466 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1467 return reduce_binary_ac (eval, op1, op2, result);
1469 return reduce_binary_aa (eval, op1, op2, result);
1475 arith (*f2)(gfc_expr *, gfc_expr **);
1476 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1480 /* High level arithmetic subroutines. These subroutines go into
1481 eval_intrinsic(), which can do one of several things to its
1482 operands. If the operands are incompatible with the intrinsic
1483 operation, we return a node pointing to the operands and hope that
1484 an operator interface is found during resolution.
1486 If the operands are compatible and are constants, then we try doing
1487 the arithmetic. We also handle the cases where either or both
1488 operands are array constructors. */
1491 eval_intrinsic (gfc_intrinsic_op operator,
1492 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1494 gfc_expr temp, *result;
1498 gfc_clear_ts (&temp.ts);
1504 if (op1->ts.type != BT_LOGICAL)
1507 temp.ts.type = BT_LOGICAL;
1508 temp.ts.kind = gfc_default_logical_kind;
1512 /* Logical binary operators */
1515 case INTRINSIC_NEQV:
1517 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1520 temp.ts.type = BT_LOGICAL;
1521 temp.ts.kind = gfc_default_logical_kind;
1526 case INTRINSIC_UPLUS:
1527 case INTRINSIC_UMINUS:
1528 if (!gfc_numeric_ts (&op1->ts))
1535 case INTRINSIC_PARENTHESES:
1540 /* Additional restrictions for ordering relations. */
1545 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1547 temp.ts.type = BT_LOGICAL;
1548 temp.ts.kind = gfc_default_logical_kind;
1555 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1558 temp.ts.type = BT_LOGICAL;
1559 temp.ts.kind = gfc_default_logical_kind;
1564 /* Numeric binary */
1565 case INTRINSIC_PLUS:
1566 case INTRINSIC_MINUS:
1567 case INTRINSIC_TIMES:
1568 case INTRINSIC_DIVIDE:
1569 case INTRINSIC_POWER:
1570 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1573 /* Insert any necessary type conversions to make the operands
1576 temp.expr_type = EXPR_OP;
1577 gfc_clear_ts (&temp.ts);
1578 temp.value.op.operator = operator;
1580 temp.value.op.op1 = op1;
1581 temp.value.op.op2 = op2;
1583 gfc_type_convert_binary (&temp);
1585 if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
1586 || operator == INTRINSIC_GE || operator == INTRINSIC_GT
1587 || operator == INTRINSIC_LE || operator == INTRINSIC_LT)
1589 temp.ts.type = BT_LOGICAL;
1590 temp.ts.kind = gfc_default_logical_kind;
1596 /* Character binary */
1597 case INTRINSIC_CONCAT:
1598 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
1601 temp.ts.type = BT_CHARACTER;
1602 temp.ts.kind = gfc_default_character_kind;
1606 case INTRINSIC_USER:
1610 gfc_internal_error ("eval_intrinsic(): Bad operator");
1613 /* Try to combine the operators. */
1614 if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
1617 if (op1->expr_type != EXPR_CONSTANT
1618 && (op1->expr_type != EXPR_ARRAY
1619 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1623 && op2->expr_type != EXPR_CONSTANT
1624 && (op2->expr_type != EXPR_ARRAY
1625 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1629 rc = reduce_unary (eval.f2, op1, &result);
1631 rc = reduce_binary (eval.f3, op1, op2, &result);
1634 { /* Something went wrong. */
1635 gfc_error (gfc_arith_error (rc), &op1->where);
1639 gfc_free_expr (op1);
1640 gfc_free_expr (op2);
1644 /* Create a run-time expression. */
1645 result = gfc_get_expr ();
1646 result->ts = temp.ts;
1648 result->expr_type = EXPR_OP;
1649 result->value.op.operator = operator;
1651 result->value.op.op1 = op1;
1652 result->value.op.op2 = op2;
1654 result->where = op1->where;
1660 /* Modify type of expression for zero size array. */
1663 eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
1666 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1676 op->ts.type = BT_LOGICAL;
1677 op->ts.kind = gfc_default_logical_kind;
1688 /* Return nonzero if the expression is a zero size array. */
1691 gfc_zero_size_array (gfc_expr *e)
1693 if (e->expr_type != EXPR_ARRAY)
1696 return e->value.constructor == NULL;
1700 /* Reduce a binary expression where at least one of the operands
1701 involves a zero-length array. Returns NULL if neither of the
1702 operands is a zero-length array. */
1705 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1707 if (gfc_zero_size_array (op1))
1709 gfc_free_expr (op2);
1713 if (gfc_zero_size_array (op2))
1715 gfc_free_expr (op1);
1724 eval_intrinsic_f2 (gfc_intrinsic_op operator,
1725 arith (*eval) (gfc_expr *, gfc_expr **),
1726 gfc_expr *op1, gfc_expr *op2)
1733 if (gfc_zero_size_array (op1))
1734 return eval_type_intrinsic0 (operator, op1);
1738 result = reduce_binary0 (op1, op2);
1740 return eval_type_intrinsic0 (operator, result);
1744 return eval_intrinsic (operator, f, op1, op2);
1749 eval_intrinsic_f3 (gfc_intrinsic_op operator,
1750 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1751 gfc_expr *op1, gfc_expr *op2)
1756 result = reduce_binary0 (op1, op2);
1758 return eval_type_intrinsic0(operator, result);
1761 return eval_intrinsic (operator, f, op1, op2);
1766 gfc_parentheses (gfc_expr *op)
1768 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1773 gfc_uplus (gfc_expr *op)
1775 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1780 gfc_uminus (gfc_expr *op)
1782 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1787 gfc_add (gfc_expr *op1, gfc_expr *op2)
1789 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1794 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1796 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1801 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1803 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1808 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1810 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1815 gfc_power (gfc_expr *op1, gfc_expr *op2)
1817 return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
1822 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1824 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1829 gfc_and (gfc_expr *op1, gfc_expr *op2)
1831 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1836 gfc_or (gfc_expr *op1, gfc_expr *op2)
1838 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1843 gfc_not (gfc_expr *op1)
1845 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1850 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1852 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1857 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1859 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1864 gfc_eq (gfc_expr *op1, gfc_expr *op2)
1866 return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
1871 gfc_ne (gfc_expr *op1, gfc_expr *op2)
1873 return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
1878 gfc_gt (gfc_expr *op1, gfc_expr *op2)
1880 return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
1885 gfc_ge (gfc_expr *op1, gfc_expr *op2)
1887 return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
1892 gfc_lt (gfc_expr *op1, gfc_expr *op2)
1894 return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
1899 gfc_le (gfc_expr *op1, gfc_expr *op2)
1901 return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
1905 /* Convert an integer string to an expression node. */
1908 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1913 e = gfc_constant_result (BT_INTEGER, kind, where);
1914 /* A leading plus is allowed, but not by mpz_set_str. */
1915 if (buffer[0] == '+')
1919 mpz_set_str (e->value.integer, t, radix);
1925 /* Convert a real string to an expression node. */
1928 gfc_convert_real (const char *buffer, int kind, locus *where)
1932 e = gfc_constant_result (BT_REAL, kind, where);
1933 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1939 /* Convert a pair of real, constant expression nodes to a single
1940 complex expression node. */
1943 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1947 e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1948 mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
1949 mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
1955 /******* Simplification of intrinsic functions with constant arguments *****/
1958 /* Deal with an arithmetic error. */
1961 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1966 gfc_error ("Arithmetic OK converting %s to %s at %L",
1967 gfc_typename (from), gfc_typename (to), where);
1969 case ARITH_OVERFLOW:
1970 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1971 gfc_typename (from), gfc_typename (to), where);
1973 case ARITH_UNDERFLOW:
1974 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1975 gfc_typename (from), gfc_typename (to), where);
1978 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1979 gfc_typename (from), gfc_typename (to), where);
1982 gfc_error ("Division by zero converting %s to %s at %L",
1983 gfc_typename (from), gfc_typename (to), where);
1985 case ARITH_INCOMMENSURATE:
1986 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1987 gfc_typename (from), gfc_typename (to), where);
1989 case ARITH_ASYMMETRIC:
1990 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1991 " converting %s to %s at %L",
1992 gfc_typename (from), gfc_typename (to), where);
1995 gfc_internal_error ("gfc_arith_error(): Bad error code");
1998 /* TODO: Do something about the error, ie, throw exception, return
2003 /* Convert integers to integers. */
2006 gfc_int2int (gfc_expr *src, int kind)
2011 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2013 mpz_set (result->value.integer, src->value.integer);
2015 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2017 if (rc == ARITH_ASYMMETRIC)
2019 gfc_warning (gfc_arith_error (rc), &src->where);
2023 arith_error (rc, &src->ts, &result->ts, &src->where);
2024 gfc_free_expr (result);
2033 /* Convert integers to reals. */
2036 gfc_int2real (gfc_expr *src, int kind)
2041 result = gfc_constant_result (BT_REAL, kind, &src->where);
2043 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2045 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2047 arith_error (rc, &src->ts, &result->ts, &src->where);
2048 gfc_free_expr (result);
2056 /* Convert default integer to default complex. */
2059 gfc_int2complex (gfc_expr *src, int kind)
2064 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2066 mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
2067 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2069 if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
2071 arith_error (rc, &src->ts, &result->ts, &src->where);
2072 gfc_free_expr (result);
2080 /* Convert default real to default integer. */
2083 gfc_real2int (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.real);
2092 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2094 arith_error (rc, &src->ts, &result->ts, &src->where);
2095 gfc_free_expr (result);
2103 /* Convert real to real. */
2106 gfc_real2real (gfc_expr *src, int kind)
2111 result = gfc_constant_result (BT_REAL, kind, &src->where);
2113 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2115 rc = gfc_check_real_range (result->value.real, kind);
2117 if (rc == ARITH_UNDERFLOW)
2119 if (gfc_option.warn_underflow)
2120 gfc_warning (gfc_arith_error (rc), &src->where);
2121 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2123 else if (rc != ARITH_OK)
2125 arith_error (rc, &src->ts, &result->ts, &src->where);
2126 gfc_free_expr (result);
2134 /* Convert real to complex. */
2137 gfc_real2complex (gfc_expr *src, int kind)
2142 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2144 mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
2145 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2147 rc = gfc_check_real_range (result->value.complex.r, kind);
2149 if (rc == ARITH_UNDERFLOW)
2151 if (gfc_option.warn_underflow)
2152 gfc_warning (gfc_arith_error (rc), &src->where);
2153 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2155 else if (rc != ARITH_OK)
2157 arith_error (rc, &src->ts, &result->ts, &src->where);
2158 gfc_free_expr (result);
2166 /* Convert complex to integer. */
2169 gfc_complex2int (gfc_expr *src, int kind)
2174 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2176 gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
2178 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2180 arith_error (rc, &src->ts, &result->ts, &src->where);
2181 gfc_free_expr (result);
2189 /* Convert complex to real. */
2192 gfc_complex2real (gfc_expr *src, int kind)
2197 result = gfc_constant_result (BT_REAL, kind, &src->where);
2199 mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
2201 rc = gfc_check_real_range (result->value.real, kind);
2203 if (rc == ARITH_UNDERFLOW)
2205 if (gfc_option.warn_underflow)
2206 gfc_warning (gfc_arith_error (rc), &src->where);
2207 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2211 arith_error (rc, &src->ts, &result->ts, &src->where);
2212 gfc_free_expr (result);
2220 /* Convert complex to complex. */
2223 gfc_complex2complex (gfc_expr *src, int kind)
2228 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2230 mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
2231 mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
2233 rc = gfc_check_real_range (result->value.complex.r, kind);
2235 if (rc == ARITH_UNDERFLOW)
2237 if (gfc_option.warn_underflow)
2238 gfc_warning (gfc_arith_error (rc), &src->where);
2239 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2241 else if (rc != ARITH_OK)
2243 arith_error (rc, &src->ts, &result->ts, &src->where);
2244 gfc_free_expr (result);
2248 rc = gfc_check_real_range (result->value.complex.i, kind);
2250 if (rc == ARITH_UNDERFLOW)
2252 if (gfc_option.warn_underflow)
2253 gfc_warning (gfc_arith_error (rc), &src->where);
2254 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2256 else if (rc != ARITH_OK)
2258 arith_error (rc, &src->ts, &result->ts, &src->where);
2259 gfc_free_expr (result);
2267 /* Logical kind conversion. */
2270 gfc_log2log (gfc_expr *src, int kind)
2274 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2275 result->value.logical = src->value.logical;
2281 /* Convert logical to integer. */
2284 gfc_log2int (gfc_expr *src, int kind)
2288 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2289 mpz_set_si (result->value.integer, src->value.logical);
2295 /* Convert integer to logical. */
2298 gfc_int2log (gfc_expr *src, int kind)
2302 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2303 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2309 /* Helper function to set the representation in a Hollerith conversion.
2310 This assumes that the ts.type and ts.kind of the result have already
2314 hollerith2representation (gfc_expr *result, gfc_expr *src)
2316 int src_len, result_len;
2318 src_len = src->representation.length;
2319 result_len = gfc_target_expr_size (result);
2321 if (src_len > result_len)
2323 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2324 &src->where, gfc_typename(&result->ts));
2327 result->representation.string = gfc_getmem (result_len + 1);
2328 memcpy (result->representation.string, src->representation.string,
2329 MIN (result_len, src_len));
2331 if (src_len < result_len)
2332 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2334 result->representation.string[result_len] = '\0'; /* For debugger */
2335 result->representation.length = result_len;
2339 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2342 gfc_hollerith2int (gfc_expr *src, int kind)
2346 result = gfc_get_expr ();
2347 result->expr_type = EXPR_CONSTANT;
2348 result->ts.type = BT_INTEGER;
2349 result->ts.kind = kind;
2350 result->where = src->where;
2352 hollerith2representation (result, src);
2353 gfc_interpret_integer(kind, (unsigned char *) result->representation.string,
2354 result->representation.length, result->value.integer);
2360 /* Convert Hollerith to real. The constant will be padded or truncated. */
2363 gfc_hollerith2real (gfc_expr *src, int kind)
2368 len = src->value.character.length;
2370 result = gfc_get_expr ();
2371 result->expr_type = EXPR_CONSTANT;
2372 result->ts.type = BT_REAL;
2373 result->ts.kind = kind;
2374 result->where = src->where;
2376 hollerith2representation (result, src);
2377 gfc_interpret_float(kind, (unsigned char *) result->representation.string,
2378 result->representation.length, result->value.real);
2384 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2387 gfc_hollerith2complex (gfc_expr *src, int kind)
2392 len = src->value.character.length;
2394 result = gfc_get_expr ();
2395 result->expr_type = EXPR_CONSTANT;
2396 result->ts.type = BT_COMPLEX;
2397 result->ts.kind = kind;
2398 result->where = src->where;
2400 hollerith2representation (result, src);
2401 gfc_interpret_complex(kind, (unsigned char *) result->representation.string,
2402 result->representation.length, result->value.complex.r,
2403 result->value.complex.i);
2409 /* Convert Hollerith to character. */
2412 gfc_hollerith2character (gfc_expr *src, int kind)
2416 result = gfc_copy_expr (src);
2417 result->ts.type = BT_CHARACTER;
2418 result->ts.kind = kind;
2420 result->value.character.string = result->representation.string;
2421 result->value.character.length = result->representation.length;
2427 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2430 gfc_hollerith2logical (gfc_expr *src, int kind)
2435 len = src->value.character.length;
2437 result = gfc_get_expr ();
2438 result->expr_type = EXPR_CONSTANT;
2439 result->ts.type = BT_LOGICAL;
2440 result->ts.kind = kind;
2441 result->where = src->where;
2443 hollerith2representation (result, src);
2444 gfc_interpret_logical(kind, (unsigned char *) result->representation.string,
2445 result->representation.length, &result->value.logical);
2451 /* Returns an initializer whose value is one higher than the value of the
2452 LAST_INITIALIZER argument. If the argument is NULL, the
2453 initializers value will be set to zero. The initializer's kind
2454 will be set to gfc_c_int_kind.
2456 If -fshort-enums is given, the appropriate kind will be selected
2457 later after all enumerators have been parsed. A warning is issued
2458 here if an initializer exceeds gfc_c_int_kind. */
2461 gfc_enum_initializer (gfc_expr *last_initializer, locus where)
2465 result = gfc_get_expr ();
2466 result->expr_type = EXPR_CONSTANT;
2467 result->ts.type = BT_INTEGER;
2468 result->ts.kind = gfc_c_int_kind;
2469 result->where = where;
2471 mpz_init (result->value.integer);
2473 if (last_initializer != NULL)
2475 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
2476 result->where = last_initializer->where;
2478 if (gfc_check_integer_range (result->value.integer,
2479 gfc_c_int_kind) != ARITH_OK)
2481 gfc_error ("Enumerator exceeds the C integer type at %C");
2487 /* Control comes here, if it's the very first enumerator and no
2488 initializer has been given. It will be initialized to zero. */
2489 mpz_set_si (result->value.integer, 0);