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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* Since target arithmetic must be done on the host, there has to
23 be some way of evaluating arithmetic expressions as the host
24 would evaluate them. We use the GNU MP library and the MPFR
25 library to do arithmetic, and this file provides the interface. */
32 #include "target-memory.h"
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));
79 /* Given an arithmetic error code, return a pointer to a string that
80 explains the error. */
83 gfc_arith_error (arith code)
90 p = _("Arithmetic OK at %L");
93 p = _("Arithmetic overflow at %L");
96 p = _("Arithmetic underflow at %L");
99 p = _("Arithmetic NaN at %L");
102 p = _("Division by zero at %L");
104 case ARITH_INCOMMENSURATE:
105 p = _("Array operands are incommensurate at %L");
107 case ARITH_ASYMMETRIC:
109 _("Integer outside symmetric range implied by Standard Fortran at %L");
112 gfc_internal_error ("gfc_arith_error(): Bad error code");
119 /* Get things ready to do math. */
122 gfc_arith_init_1 (void)
124 gfc_integer_info *int_info;
125 gfc_real_info *real_info;
130 mpfr_set_default_prec (128);
134 /* Convert the minimum and maximum values for each kind into their
135 GNU MP representation. */
136 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
139 mpz_set_ui (r, int_info->radix);
140 mpz_pow_ui (r, r, int_info->digits);
142 mpz_init (int_info->huge);
143 mpz_sub_ui (int_info->huge, r, 1);
145 /* These are the numbers that are actually representable by the
146 target. For bases other than two, this needs to be changed. */
147 if (int_info->radix != 2)
148 gfc_internal_error ("Fix min_int calculation");
150 /* See PRs 13490 and 17912, related to integer ranges.
151 The pedantic_min_int exists for range checking when a program
152 is compiled with -pedantic, and reflects the belief that
153 Standard Fortran requires integers to be symmetrical, i.e.
154 every negative integer must have a representable positive
155 absolute value, and vice versa. */
157 mpz_init (int_info->pedantic_min_int);
158 mpz_neg (int_info->pedantic_min_int, int_info->huge);
160 mpz_init (int_info->min_int);
161 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
164 mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
165 mpfr_log10 (a, a, GFC_RND_MODE);
167 gfc_mpfr_to_mpz (r, a);
168 int_info->range = mpz_get_si (r);
173 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
175 gfc_set_model_kind (real_info->kind);
181 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
182 /* a = 1 - b**(-p) */
183 mpfr_set_ui (a, 1, GFC_RND_MODE);
184 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
185 mpfr_pow_si (b, b, -real_info->digits, GFC_RND_MODE);
186 mpfr_sub (a, a, b, GFC_RND_MODE);
188 /* c = b**(emax-1) */
189 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
190 mpfr_pow_ui (c, b, real_info->max_exponent - 1, GFC_RND_MODE);
192 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
193 mpfr_mul (a, a, c, GFC_RND_MODE);
195 /* a = (1 - b**(-p)) * b**(emax-1) * b */
196 mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
198 mpfr_init (real_info->huge);
199 mpfr_set (real_info->huge, a, GFC_RND_MODE);
201 /* tiny(x) = b**(emin-1) */
202 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
203 mpfr_pow_si (b, b, real_info->min_exponent - 1, GFC_RND_MODE);
205 mpfr_init (real_info->tiny);
206 mpfr_set (real_info->tiny, b, GFC_RND_MODE);
208 /* subnormal (x) = b**(emin - digit) */
209 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
210 mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits,
213 mpfr_init (real_info->subnormal);
214 mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
216 /* epsilon(x) = b**(1-p) */
217 mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
218 mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE);
220 mpfr_init (real_info->epsilon);
221 mpfr_set (real_info->epsilon, b, GFC_RND_MODE);
223 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
224 mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
225 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
226 mpfr_neg (b, b, GFC_RND_MODE);
229 if (mpfr_cmp (a, b) > 0)
230 mpfr_set (a, b, GFC_RND_MODE);
233 gfc_mpfr_to_mpz (r, a);
234 real_info->range = mpz_get_si (r);
236 /* precision(x) = int((p - 1) * log10(b)) + k */
237 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
238 mpfr_log10 (a, a, GFC_RND_MODE);
240 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
242 gfc_mpfr_to_mpz (r, a);
243 real_info->precision = mpz_get_si (r);
245 /* If the radix is an integral power of 10, add one to the precision. */
246 for (i = 10; i <= real_info->radix; i *= 10)
247 if (i == real_info->radix)
248 real_info->precision++;
259 /* Clean up, get rid of numeric constants. */
262 gfc_arith_done_1 (void)
264 gfc_integer_info *ip;
267 for (ip = gfc_integer_kinds; ip->kind; ip++)
269 mpz_clear (ip->min_int);
270 mpz_clear (ip->pedantic_min_int);
271 mpz_clear (ip->huge);
274 for (rp = gfc_real_kinds; rp->kind; rp++)
276 mpfr_clear (rp->epsilon);
277 mpfr_clear (rp->huge);
278 mpfr_clear (rp->tiny);
279 mpfr_clear (rp->subnormal);
284 /* Given an integer and a kind, make sure that the integer lies within
285 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
289 gfc_check_integer_range (mpz_t p, int kind)
294 i = gfc_validate_kind (BT_INTEGER, kind, false);
299 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
300 result = ARITH_ASYMMETRIC;
304 if (gfc_option.flag_range_check == 0)
307 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
308 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
309 result = ARITH_OVERFLOW;
315 /* Given a real and a kind, make sure that the real lies within the
316 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
320 gfc_check_real_range (mpfr_t p, int kind)
326 i = gfc_validate_kind (BT_REAL, kind, false);
330 mpfr_abs (q, p, GFC_RND_MODE);
334 if (gfc_option.flag_range_check == 0)
337 retval = ARITH_OVERFLOW;
339 else if (mpfr_nan_p (p))
341 if (gfc_option.flag_range_check == 0)
346 else if (mpfr_sgn (q) == 0)
348 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
350 if (gfc_option.flag_range_check == 0)
353 retval = ARITH_OVERFLOW;
355 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
357 if (gfc_option.flag_range_check == 0)
360 retval = ARITH_UNDERFLOW;
362 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
367 /* Save current values of emin and emax. */
368 emin = mpfr_get_emin ();
369 emax = mpfr_get_emax ();
371 /* Set emin and emax for the current model number. */
372 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
373 mpfr_set_emin ((mp_exp_t) en);
374 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
375 mpfr_subnormalize (q, 0, GFC_RND_MODE);
377 /* Reset emin and emax. */
378 mpfr_set_emin (emin);
379 mpfr_set_emax (emax);
381 /* Copy sign if needed. */
382 if (mpfr_sgn (p) < 0)
383 mpfr_neg (p, q, GMP_RNDN);
385 mpfr_set (p, q, GMP_RNDN);
398 /* Function to return a constant expression node of a given type and kind. */
401 gfc_constant_result (bt type, int kind, locus *where)
406 gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
408 result = gfc_get_expr ();
410 result->expr_type = EXPR_CONSTANT;
411 result->ts.type = type;
412 result->ts.kind = kind;
413 result->where = *where;
418 mpz_init (result->value.integer);
422 gfc_set_model_kind (kind);
423 mpfr_init (result->value.real);
427 gfc_set_model_kind (kind);
428 mpfr_init (result->value.complex.r);
429 mpfr_init (result->value.complex.i);
440 /* Low-level arithmetic functions. All of these subroutines assume
441 that all operands are of the same type and return an operand of the
442 same type. The other thing about these subroutines is that they
443 can fail in various ways -- overflow, underflow, division by zero,
444 zero raised to the zero, etc. */
447 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
451 result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
452 result->value.logical = !op1->value.logical;
460 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
464 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
466 result->value.logical = op1->value.logical && op2->value.logical;
474 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
478 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
480 result->value.logical = op1->value.logical || op2->value.logical;
488 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
492 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
494 result->value.logical = op1->value.logical == op2->value.logical;
502 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
506 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
508 result->value.logical = op1->value.logical != op2->value.logical;
515 /* Make sure a constant numeric expression is within the range for
516 its type and kind. Note that there's also a gfc_check_range(),
517 but that one deals with the intrinsic RANGE function. */
520 gfc_range_check (gfc_expr *e)
527 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
531 rc = gfc_check_real_range (e->value.real, e->ts.kind);
532 if (rc == ARITH_UNDERFLOW)
533 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
534 if (rc == ARITH_OVERFLOW)
535 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
537 mpfr_set_nan (e->value.real);
541 rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
542 if (rc == ARITH_UNDERFLOW)
543 mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
544 if (rc == ARITH_OVERFLOW)
545 mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
547 mpfr_set_nan (e->value.complex.r);
549 rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
550 if (rc == ARITH_UNDERFLOW)
551 mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
552 if (rc == ARITH_OVERFLOW)
553 mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
555 mpfr_set_nan (e->value.complex.i);
559 gfc_internal_error ("gfc_range_check(): Bad type");
566 /* Several of the following routines use the same set of statements to
567 check the validity of the result. Encapsulate the checking here. */
570 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
574 if (val == ARITH_UNDERFLOW)
576 if (gfc_option.warn_underflow)
577 gfc_warning (gfc_arith_error (val), &x->where);
581 if (val == ARITH_ASYMMETRIC)
583 gfc_warning (gfc_arith_error (val), &x->where);
596 /* It may seem silly to have a subroutine that actually computes the
597 unary plus of a constant, but it prevents us from making exceptions
598 in the code elsewhere. Used for unary plus and parenthesized
602 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
604 *resultp = gfc_copy_expr (op1);
610 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
615 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
617 switch (op1->ts.type)
620 mpz_neg (result->value.integer, op1->value.integer);
624 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
628 mpfr_neg (result->value.complex.r, op1->value.complex.r, GFC_RND_MODE);
629 mpfr_neg (result->value.complex.i, op1->value.complex.i, GFC_RND_MODE);
633 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
636 rc = gfc_range_check (result);
638 return check_result (rc, op1, result, resultp);
643 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
648 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
650 switch (op1->ts.type)
653 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
657 mpfr_add (result->value.real, op1->value.real, op2->value.real,
662 mpfr_add (result->value.complex.r, op1->value.complex.r,
663 op2->value.complex.r, GFC_RND_MODE);
665 mpfr_add (result->value.complex.i, op1->value.complex.i,
666 op2->value.complex.i, GFC_RND_MODE);
670 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
673 rc = gfc_range_check (result);
675 return check_result (rc, op1, result, resultp);
680 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
685 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
687 switch (op1->ts.type)
690 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
694 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
699 mpfr_sub (result->value.complex.r, op1->value.complex.r,
700 op2->value.complex.r, GFC_RND_MODE);
702 mpfr_sub (result->value.complex.i, op1->value.complex.i,
703 op2->value.complex.i, GFC_RND_MODE);
707 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
710 rc = gfc_range_check (result);
712 return check_result (rc, op1, result, resultp);
717 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
723 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
725 switch (op1->ts.type)
728 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
732 mpfr_mul (result->value.real, op1->value.real, op2->value.real,
737 gfc_set_model (op1->value.complex.r);
741 mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
742 mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
743 mpfr_sub (result->value.complex.r, x, y, GFC_RND_MODE);
745 mpfr_mul (x, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
746 mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
747 mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE);
754 gfc_internal_error ("gfc_arith_times(): Bad basic type");
757 rc = gfc_range_check (result);
759 return check_result (rc, op1, result, resultp);
764 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
772 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
774 switch (op1->ts.type)
777 if (mpz_sgn (op2->value.integer) == 0)
783 mpz_tdiv_q (result->value.integer, op1->value.integer,
788 if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
794 mpfr_div (result->value.real, op1->value.real, op2->value.real,
799 if (mpfr_sgn (op2->value.complex.r) == 0
800 && mpfr_sgn (op2->value.complex.i) == 0
801 && gfc_option.flag_range_check == 1)
807 gfc_set_model (op1->value.complex.r);
812 mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
813 mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
814 mpfr_add (div, x, y, GFC_RND_MODE);
816 mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
817 mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
818 mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE);
819 mpfr_div (result->value.complex.r, result->value.complex.r, div,
822 mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
823 mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
824 mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE);
825 mpfr_div (result->value.complex.i, result->value.complex.i, div,
834 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
838 rc = gfc_range_check (result);
840 return check_result (rc, op1, result, resultp);
844 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
847 complex_reciprocal (gfc_expr *op)
849 mpfr_t mod, a, re, im;
851 gfc_set_model (op->value.complex.r);
857 mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
858 mpfr_mul (a, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
859 mpfr_add (mod, mod, a, GFC_RND_MODE);
861 mpfr_div (re, op->value.complex.r, mod, GFC_RND_MODE);
863 mpfr_neg (im, op->value.complex.i, GFC_RND_MODE);
864 mpfr_div (im, im, mod, GFC_RND_MODE);
866 mpfr_set (op->value.complex.r, re, GFC_RND_MODE);
867 mpfr_set (op->value.complex.i, im, GFC_RND_MODE);
876 /* Raise a complex number to positive power (power > 0).
877 This function will modify the content of power.
879 Use Binary Method, which is not an optimal but a simple and reasonable
880 arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth,
881 "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming",
882 3rd Edition, 1998. */
885 complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power)
887 mpfr_t x_r, x_i, tmp, re, im;
889 gfc_set_model (base->value.complex.r);
897 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
898 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
901 mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE);
902 mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE);
904 /* Macro for complex multiplication. We have to take care that
905 res_r/res_i and a_r/a_i can (and will) be the same variable. */
906 #define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \
907 mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \
908 mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \
909 mpfr_sub (re, re, tmp, GFC_RND_MODE), \
911 mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \
912 mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \
913 mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
914 mpfr_set (res_r, re, GFC_RND_MODE)
916 #define res_r result->value.complex.r
917 #define res_i result->value.complex.i
919 /* for (; power > 0; x *= x) */
920 for (; mpz_cmp_si (power, 0) > 0; CMULT(x_r,x_i,x_r,x_i,x_r,x_i))
922 /* if (power & 1) res = res * x; */
923 if (mpz_congruent_ui_p (power, 1, 2))
924 CMULT(res_r,res_i,res_r,res_i,x_r,x_i);
927 mpz_fdiv_q_ui (power, power, 2);
942 /* Raise a number to an integer power. */
945 gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
951 gcc_assert (op2->expr_type == EXPR_CONSTANT && op2->ts.type == BT_INTEGER);
954 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
955 power_sign = mpz_sgn (op2->value.integer);
959 /* Handle something to the zeroth power. Since we're dealing
960 with integral exponents, there is no ambiguity in the
961 limiting procedure used to determine the value of 0**0. */
962 switch (op1->ts.type)
965 mpz_set_ui (result->value.integer, 1);
969 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
973 mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
974 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
978 gfc_internal_error ("gfc_arith_power(): Bad base");
983 switch (op1->ts.type)
989 /* First, we simplify the cases of op1 == 1, 0 or -1. */
990 if (mpz_cmp_si (op1->value.integer, 1) == 0)
993 mpz_set_si (result->value.integer, 1);
995 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
997 /* 0**op2 == 0, if op2 > 0
998 0**op2 overflow, if op2 < 0 ; in that case, we
999 set the result to 0 and return ARITH_DIV0. */
1000 mpz_set_si (result->value.integer, 0);
1001 if (mpz_cmp_si (op2->value.integer, 0) < 0)
1004 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
1006 /* (-1)**op2 == (-1)**(mod(op2,2)) */
1007 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
1009 mpz_set_si (result->value.integer, -1);
1011 mpz_set_si (result->value.integer, 1);
1013 /* Then, we take care of op2 < 0. */
1014 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
1016 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1017 mpz_set_si (result->value.integer, 0);
1019 else if (gfc_extract_int (op2, &power) != NULL)
1021 /* If op2 doesn't fit in an int, the exponentiation will
1022 overflow, because op2 > 0 and abs(op1) > 1. */
1024 int i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
1026 if (gfc_option.flag_range_check)
1027 rc = ARITH_OVERFLOW;
1029 /* Still, we want to give the same value as the processor. */
1031 mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
1032 mpz_mul_ui (max, max, 2);
1033 mpz_powm (result->value.integer, op1->value.integer,
1034 op2->value.integer, max);
1038 mpz_pow_ui (result->value.integer, op1->value.integer, power);
1043 mpfr_pow_z (result->value.real, op1->value.real, op2->value.integer,
1051 /* Compute op1**abs(op2) */
1053 mpz_abs (apower, op2->value.integer);
1054 complex_pow (result, op1, apower);
1057 /* If (op2 < 0), compute the inverse. */
1059 complex_reciprocal (result);
1070 rc = gfc_range_check (result);
1072 return check_result (rc, op1, result, resultp);
1076 /* Concatenate two string constants. */
1079 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1084 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
1087 len = op1->value.character.length + op2->value.character.length;
1089 result->value.character.string = gfc_getmem (len + 1);
1090 result->value.character.length = len;
1092 memcpy (result->value.character.string, op1->value.character.string,
1093 op1->value.character.length);
1095 memcpy (result->value.character.string + op1->value.character.length,
1096 op2->value.character.string, op2->value.character.length);
1098 result->value.character.string[len] = '\0';
1106 /* Comparison operators. Assumes that the two expression nodes
1107 contain two constants of the same type. */
1110 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
1114 switch (op1->ts.type)
1117 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1121 rc = mpfr_cmp (op1->value.real, op2->value.real);
1125 rc = gfc_compare_string (op1, op2);
1129 rc = ((!op1->value.logical && op2->value.logical)
1130 || (op1->value.logical && !op2->value.logical));
1134 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1141 /* Compare a pair of complex numbers. Naturally, this is only for
1142 equality and nonequality. */
1145 compare_complex (gfc_expr *op1, gfc_expr *op2)
1147 return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0
1148 && mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0);
1152 /* Given two constant strings and the inverse collating sequence, compare the
1153 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1154 We use the processor's default collating sequence. */
1157 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1159 int len, alen, blen, i, ac, bc;
1161 alen = a->value.character.length;
1162 blen = b->value.character.length;
1164 len = (alen > blen) ? alen : blen;
1166 for (i = 0; i < len; i++)
1168 /* We cast to unsigned char because default char, if it is signed,
1169 would lead to ac < 0 for string[i] > 127. */
1170 ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
1171 bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
1179 /* Strings are equal */
1185 /* Specific comparison subroutines. */
1188 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1192 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1194 result->value.logical = (op1->ts.type == BT_COMPLEX)
1195 ? compare_complex (op1, op2)
1196 : (gfc_compare_expr (op1, op2) == 0);
1204 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1208 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1210 result->value.logical = (op1->ts.type == BT_COMPLEX)
1211 ? !compare_complex (op1, op2)
1212 : (gfc_compare_expr (op1, op2) != 0);
1220 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1224 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1226 result->value.logical = (gfc_compare_expr (op1, op2) > 0);
1234 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1238 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1240 result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
1248 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1252 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1254 result->value.logical = (gfc_compare_expr (op1, op2) < 0);
1262 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1266 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1268 result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
1276 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1279 gfc_constructor *c, *head;
1283 if (op->expr_type == EXPR_CONSTANT)
1284 return eval (op, result);
1287 head = gfc_copy_constructor (op->value.constructor);
1289 for (c = head; c; c = c->next)
1291 rc = reduce_unary (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 if (c->expr->expr_type == EXPR_CONSTANT)
1333 rc = eval (c->expr, op2, &r);
1335 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1340 gfc_replace_expr (c->expr, r);
1344 gfc_free_constructor (head);
1347 r = gfc_get_expr ();
1348 r->expr_type = EXPR_ARRAY;
1349 r->value.constructor = head;
1350 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1352 r->ts = head->expr->ts;
1353 r->where = op1->where;
1354 r->rank = op1->rank;
1364 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1365 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1367 gfc_constructor *c, *head;
1371 head = gfc_copy_constructor (op2->value.constructor);
1374 for (c = head; c; c = c->next)
1376 if (c->expr->expr_type == EXPR_CONSTANT)
1377 rc = eval (op1, c->expr, &r);
1379 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1384 gfc_replace_expr (c->expr, r);
1388 gfc_free_constructor (head);
1391 r = gfc_get_expr ();
1392 r->expr_type = EXPR_ARRAY;
1393 r->value.constructor = head;
1394 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1396 r->ts = head->expr->ts;
1397 r->where = op2->where;
1398 r->rank = op2->rank;
1407 /* We need a forward declaration of reduce_binary. */
1408 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1409 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1413 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1414 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1416 gfc_constructor *c, *d, *head;
1420 head = gfc_copy_constructor (op1->value.constructor);
1423 d = op2->value.constructor;
1425 if (gfc_check_conformance ("elemental binary operation", op1, op2)
1427 rc = ARITH_INCOMMENSURATE;
1430 for (c = head; c; c = c->next, d = d->next)
1434 rc = ARITH_INCOMMENSURATE;
1438 rc = reduce_binary (eval, c->expr, d->expr, &r);
1442 gfc_replace_expr (c->expr, r);
1446 rc = ARITH_INCOMMENSURATE;
1450 gfc_free_constructor (head);
1453 r = gfc_get_expr ();
1454 r->expr_type = EXPR_ARRAY;
1455 r->value.constructor = head;
1456 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1458 r->ts = head->expr->ts;
1459 r->where = op1->where;
1460 r->rank = op1->rank;
1470 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1471 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1473 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1474 return eval (op1, op2, result);
1476 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1477 return reduce_binary_ca (eval, op1, op2, result);
1479 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1480 return reduce_binary_ac (eval, op1, op2, result);
1482 return reduce_binary_aa (eval, op1, op2, result);
1488 arith (*f2)(gfc_expr *, gfc_expr **);
1489 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1493 /* High level arithmetic subroutines. These subroutines go into
1494 eval_intrinsic(), which can do one of several things to its
1495 operands. If the operands are incompatible with the intrinsic
1496 operation, we return a node pointing to the operands and hope that
1497 an operator interface is found during resolution.
1499 If the operands are compatible and are constants, then we try doing
1500 the arithmetic. We also handle the cases where either or both
1501 operands are array constructors. */
1504 eval_intrinsic (gfc_intrinsic_op operator,
1505 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1507 gfc_expr temp, *result;
1511 gfc_clear_ts (&temp.ts);
1517 if (op1->ts.type != BT_LOGICAL)
1520 temp.ts.type = BT_LOGICAL;
1521 temp.ts.kind = gfc_default_logical_kind;
1525 /* Logical binary operators */
1528 case INTRINSIC_NEQV:
1530 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1533 temp.ts.type = BT_LOGICAL;
1534 temp.ts.kind = gfc_default_logical_kind;
1539 case INTRINSIC_UPLUS:
1540 case INTRINSIC_UMINUS:
1541 if (!gfc_numeric_ts (&op1->ts))
1548 case INTRINSIC_PARENTHESES:
1553 /* Additional restrictions for ordering relations. */
1555 case INTRINSIC_GE_OS:
1557 case INTRINSIC_LT_OS:
1559 case INTRINSIC_LE_OS:
1561 case INTRINSIC_GT_OS:
1562 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1564 temp.ts.type = BT_LOGICAL;
1565 temp.ts.kind = gfc_default_logical_kind;
1571 case INTRINSIC_EQ_OS:
1573 case INTRINSIC_NE_OS:
1574 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1577 temp.ts.type = BT_LOGICAL;
1578 temp.ts.kind = gfc_default_logical_kind;
1583 /* Numeric binary */
1584 case INTRINSIC_PLUS:
1585 case INTRINSIC_MINUS:
1586 case INTRINSIC_TIMES:
1587 case INTRINSIC_DIVIDE:
1588 case INTRINSIC_POWER:
1589 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1592 /* Insert any necessary type conversions to make the operands
1595 temp.expr_type = EXPR_OP;
1596 gfc_clear_ts (&temp.ts);
1597 temp.value.op.operator = operator;
1599 temp.value.op.op1 = op1;
1600 temp.value.op.op2 = op2;
1602 gfc_type_convert_binary (&temp);
1604 if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
1605 || operator == INTRINSIC_GE || operator == INTRINSIC_GT
1606 || operator == INTRINSIC_LE || operator == INTRINSIC_LT
1607 || operator == INTRINSIC_EQ_OS || operator == INTRINSIC_NE_OS
1608 || operator == INTRINSIC_GE_OS || operator == INTRINSIC_GT_OS
1609 || operator == INTRINSIC_LE_OS || operator == INTRINSIC_LT_OS)
1611 temp.ts.type = BT_LOGICAL;
1612 temp.ts.kind = gfc_default_logical_kind;
1618 /* Character binary */
1619 case INTRINSIC_CONCAT:
1620 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
1623 temp.ts.type = BT_CHARACTER;
1624 temp.ts.kind = gfc_default_character_kind;
1628 case INTRINSIC_USER:
1632 gfc_internal_error ("eval_intrinsic(): Bad operator");
1635 /* Try to combine the operators. */
1636 if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
1639 if (op1->expr_type != EXPR_CONSTANT
1640 && (op1->expr_type != EXPR_ARRAY
1641 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1645 && op2->expr_type != EXPR_CONSTANT
1646 && (op2->expr_type != EXPR_ARRAY
1647 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1651 rc = reduce_unary (eval.f2, op1, &result);
1653 rc = reduce_binary (eval.f3, op1, op2, &result);
1656 { /* Something went wrong. */
1657 gfc_error (gfc_arith_error (rc), &op1->where);
1661 gfc_free_expr (op1);
1662 gfc_free_expr (op2);
1666 /* Create a run-time expression. */
1667 result = gfc_get_expr ();
1668 result->ts = temp.ts;
1670 result->expr_type = EXPR_OP;
1671 result->value.op.operator = operator;
1673 result->value.op.op1 = op1;
1674 result->value.op.op2 = op2;
1676 result->where = op1->where;
1682 /* Modify type of expression for zero size array. */
1685 eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
1688 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1693 case INTRINSIC_GE_OS:
1695 case INTRINSIC_LT_OS:
1697 case INTRINSIC_LE_OS:
1699 case INTRINSIC_GT_OS:
1701 case INTRINSIC_EQ_OS:
1703 case INTRINSIC_NE_OS:
1704 op->ts.type = BT_LOGICAL;
1705 op->ts.kind = gfc_default_logical_kind;
1716 /* Return nonzero if the expression is a zero size array. */
1719 gfc_zero_size_array (gfc_expr *e)
1721 if (e->expr_type != EXPR_ARRAY)
1724 return e->value.constructor == NULL;
1728 /* Reduce a binary expression where at least one of the operands
1729 involves a zero-length array. Returns NULL if neither of the
1730 operands is a zero-length array. */
1733 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1735 if (gfc_zero_size_array (op1))
1737 gfc_free_expr (op2);
1741 if (gfc_zero_size_array (op2))
1743 gfc_free_expr (op1);
1752 eval_intrinsic_f2 (gfc_intrinsic_op operator,
1753 arith (*eval) (gfc_expr *, gfc_expr **),
1754 gfc_expr *op1, gfc_expr *op2)
1761 if (gfc_zero_size_array (op1))
1762 return eval_type_intrinsic0 (operator, op1);
1766 result = reduce_binary0 (op1, op2);
1768 return eval_type_intrinsic0 (operator, result);
1772 return eval_intrinsic (operator, f, op1, op2);
1777 eval_intrinsic_f3 (gfc_intrinsic_op operator,
1778 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1779 gfc_expr *op1, gfc_expr *op2)
1784 result = reduce_binary0 (op1, op2);
1786 return eval_type_intrinsic0(operator, result);
1789 return eval_intrinsic (operator, f, op1, op2);
1794 gfc_parentheses (gfc_expr *op)
1796 if (gfc_is_constant_expr (op))
1799 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1804 gfc_uplus (gfc_expr *op)
1806 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1811 gfc_uminus (gfc_expr *op)
1813 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1818 gfc_add (gfc_expr *op1, gfc_expr *op2)
1820 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1825 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1827 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1832 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1834 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1839 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1841 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1846 gfc_power (gfc_expr *op1, gfc_expr *op2)
1848 return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
1853 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1855 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1860 gfc_and (gfc_expr *op1, gfc_expr *op2)
1862 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1867 gfc_or (gfc_expr *op1, gfc_expr *op2)
1869 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1874 gfc_not (gfc_expr *op1)
1876 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1881 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1883 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1888 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1890 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1895 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1897 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1902 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1904 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1909 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1911 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1916 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1918 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1923 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1925 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1930 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1932 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1936 /* Convert an integer string to an expression node. */
1939 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1944 e = gfc_constant_result (BT_INTEGER, kind, where);
1945 /* A leading plus is allowed, but not by mpz_set_str. */
1946 if (buffer[0] == '+')
1950 mpz_set_str (e->value.integer, t, radix);
1956 /* Convert a real string to an expression node. */
1959 gfc_convert_real (const char *buffer, int kind, locus *where)
1963 e = gfc_constant_result (BT_REAL, kind, where);
1964 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1970 /* Convert a pair of real, constant expression nodes to a single
1971 complex expression node. */
1974 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1978 e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1979 mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
1980 mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
1986 /******* Simplification of intrinsic functions with constant arguments *****/
1989 /* Deal with an arithmetic error. */
1992 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1997 gfc_error ("Arithmetic OK converting %s to %s at %L",
1998 gfc_typename (from), gfc_typename (to), where);
2000 case ARITH_OVERFLOW:
2001 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2002 "can be disabled with the option -fno-range-check",
2003 gfc_typename (from), gfc_typename (to), where);
2005 case ARITH_UNDERFLOW:
2006 gfc_error ("Arithmetic underflow converting %s to %s at %L",
2007 gfc_typename (from), gfc_typename (to), where);
2010 gfc_error ("Arithmetic NaN converting %s to %s at %L",
2011 gfc_typename (from), gfc_typename (to), where);
2014 gfc_error ("Division by zero converting %s to %s at %L",
2015 gfc_typename (from), gfc_typename (to), where);
2017 case ARITH_INCOMMENSURATE:
2018 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2019 gfc_typename (from), gfc_typename (to), where);
2021 case ARITH_ASYMMETRIC:
2022 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2023 " converting %s to %s at %L",
2024 gfc_typename (from), gfc_typename (to), where);
2027 gfc_internal_error ("gfc_arith_error(): Bad error code");
2030 /* TODO: Do something about the error, ie, throw exception, return
2035 /* Convert integers to integers. */
2038 gfc_int2int (gfc_expr *src, int kind)
2043 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2045 mpz_set (result->value.integer, src->value.integer);
2047 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2049 if (rc == ARITH_ASYMMETRIC)
2051 gfc_warning (gfc_arith_error (rc), &src->where);
2055 arith_error (rc, &src->ts, &result->ts, &src->where);
2056 gfc_free_expr (result);
2065 /* Convert integers to reals. */
2068 gfc_int2real (gfc_expr *src, int kind)
2073 result = gfc_constant_result (BT_REAL, kind, &src->where);
2075 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2077 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2079 arith_error (rc, &src->ts, &result->ts, &src->where);
2080 gfc_free_expr (result);
2088 /* Convert default integer to default complex. */
2091 gfc_int2complex (gfc_expr *src, int kind)
2096 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2098 mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
2099 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2101 if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
2103 arith_error (rc, &src->ts, &result->ts, &src->where);
2104 gfc_free_expr (result);
2112 /* Convert default real to default integer. */
2115 gfc_real2int (gfc_expr *src, int kind)
2120 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2122 gfc_mpfr_to_mpz (result->value.integer, src->value.real);
2124 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2126 arith_error (rc, &src->ts, &result->ts, &src->where);
2127 gfc_free_expr (result);
2135 /* Convert real to real. */
2138 gfc_real2real (gfc_expr *src, int kind)
2143 result = gfc_constant_result (BT_REAL, kind, &src->where);
2145 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2147 rc = gfc_check_real_range (result->value.real, 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.real, 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 real to complex. */
2169 gfc_real2complex (gfc_expr *src, int kind)
2174 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2176 mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
2177 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2179 rc = gfc_check_real_range (result->value.complex.r, kind);
2181 if (rc == ARITH_UNDERFLOW)
2183 if (gfc_option.warn_underflow)
2184 gfc_warning (gfc_arith_error (rc), &src->where);
2185 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2187 else if (rc != ARITH_OK)
2189 arith_error (rc, &src->ts, &result->ts, &src->where);
2190 gfc_free_expr (result);
2198 /* Convert complex to integer. */
2201 gfc_complex2int (gfc_expr *src, int kind)
2206 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2208 gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
2210 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2212 arith_error (rc, &src->ts, &result->ts, &src->where);
2213 gfc_free_expr (result);
2221 /* Convert complex to real. */
2224 gfc_complex2real (gfc_expr *src, int kind)
2229 result = gfc_constant_result (BT_REAL, kind, &src->where);
2231 mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
2233 rc = gfc_check_real_range (result->value.real, 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.real, 0, GFC_RND_MODE);
2243 arith_error (rc, &src->ts, &result->ts, &src->where);
2244 gfc_free_expr (result);
2252 /* Convert complex to complex. */
2255 gfc_complex2complex (gfc_expr *src, int kind)
2260 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2262 mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
2263 mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
2265 rc = gfc_check_real_range (result->value.complex.r, kind);
2267 if (rc == ARITH_UNDERFLOW)
2269 if (gfc_option.warn_underflow)
2270 gfc_warning (gfc_arith_error (rc), &src->where);
2271 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
2273 else if (rc != ARITH_OK)
2275 arith_error (rc, &src->ts, &result->ts, &src->where);
2276 gfc_free_expr (result);
2280 rc = gfc_check_real_range (result->value.complex.i, kind);
2282 if (rc == ARITH_UNDERFLOW)
2284 if (gfc_option.warn_underflow)
2285 gfc_warning (gfc_arith_error (rc), &src->where);
2286 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
2288 else if (rc != ARITH_OK)
2290 arith_error (rc, &src->ts, &result->ts, &src->where);
2291 gfc_free_expr (result);
2299 /* Logical kind conversion. */
2302 gfc_log2log (gfc_expr *src, int kind)
2306 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2307 result->value.logical = src->value.logical;
2313 /* Convert logical to integer. */
2316 gfc_log2int (gfc_expr *src, int kind)
2320 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2321 mpz_set_si (result->value.integer, src->value.logical);
2327 /* Convert integer to logical. */
2330 gfc_int2log (gfc_expr *src, int kind)
2334 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2335 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2341 /* Helper function to set the representation in a Hollerith conversion.
2342 This assumes that the ts.type and ts.kind of the result have already
2346 hollerith2representation (gfc_expr *result, gfc_expr *src)
2348 int src_len, result_len;
2350 src_len = src->representation.length;
2351 result_len = gfc_target_expr_size (result);
2353 if (src_len > result_len)
2355 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2356 &src->where, gfc_typename(&result->ts));
2359 result->representation.string = gfc_getmem (result_len + 1);
2360 memcpy (result->representation.string, src->representation.string,
2361 MIN (result_len, src_len));
2363 if (src_len < result_len)
2364 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2366 result->representation.string[result_len] = '\0'; /* For debugger */
2367 result->representation.length = result_len;
2371 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2374 gfc_hollerith2int (gfc_expr *src, int kind)
2378 result = gfc_get_expr ();
2379 result->expr_type = EXPR_CONSTANT;
2380 result->ts.type = BT_INTEGER;
2381 result->ts.kind = kind;
2382 result->where = src->where;
2384 hollerith2representation (result, src);
2385 gfc_interpret_integer(kind, (unsigned char *) result->representation.string,
2386 result->representation.length, result->value.integer);
2392 /* Convert Hollerith to real. The constant will be padded or truncated. */
2395 gfc_hollerith2real (gfc_expr *src, int kind)
2400 len = src->value.character.length;
2402 result = gfc_get_expr ();
2403 result->expr_type = EXPR_CONSTANT;
2404 result->ts.type = BT_REAL;
2405 result->ts.kind = kind;
2406 result->where = src->where;
2408 hollerith2representation (result, src);
2409 gfc_interpret_float(kind, (unsigned char *) result->representation.string,
2410 result->representation.length, result->value.real);
2416 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2419 gfc_hollerith2complex (gfc_expr *src, int kind)
2424 len = src->value.character.length;
2426 result = gfc_get_expr ();
2427 result->expr_type = EXPR_CONSTANT;
2428 result->ts.type = BT_COMPLEX;
2429 result->ts.kind = kind;
2430 result->where = src->where;
2432 hollerith2representation (result, src);
2433 gfc_interpret_complex(kind, (unsigned char *) result->representation.string,
2434 result->representation.length, result->value.complex.r,
2435 result->value.complex.i);
2441 /* Convert Hollerith to character. */
2444 gfc_hollerith2character (gfc_expr *src, int kind)
2448 result = gfc_copy_expr (src);
2449 result->ts.type = BT_CHARACTER;
2450 result->ts.kind = kind;
2452 result->value.character.string = result->representation.string;
2453 result->value.character.length = result->representation.length;
2459 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2462 gfc_hollerith2logical (gfc_expr *src, int kind)
2467 len = src->value.character.length;
2469 result = gfc_get_expr ();
2470 result->expr_type = EXPR_CONSTANT;
2471 result->ts.type = BT_LOGICAL;
2472 result->ts.kind = kind;
2473 result->where = src->where;
2475 hollerith2representation (result, src);
2476 gfc_interpret_logical(kind, (unsigned char *) result->representation.string,
2477 result->representation.length, &result->value.logical);
2483 /* Returns an initializer whose value is one higher than the value of the
2484 LAST_INITIALIZER argument. If the argument is NULL, the
2485 initializers value will be set to zero. The initializer's kind
2486 will be set to gfc_c_int_kind.
2488 If -fshort-enums is given, the appropriate kind will be selected
2489 later after all enumerators have been parsed. A warning is issued
2490 here if an initializer exceeds gfc_c_int_kind. */
2493 gfc_enum_initializer (gfc_expr *last_initializer, locus where)
2497 result = gfc_get_expr ();
2498 result->expr_type = EXPR_CONSTANT;
2499 result->ts.type = BT_INTEGER;
2500 result->ts.kind = gfc_c_int_kind;
2501 result->where = where;
2503 mpz_init (result->value.integer);
2505 if (last_initializer != NULL)
2507 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
2508 result->where = last_initializer->where;
2510 if (gfc_check_integer_range (result->value.integer,
2511 gfc_c_int_kind) != ARITH_OK)
2513 gfc_error ("Enumerator exceeds the C integer type at %C");
2519 /* Control comes here, if it's the very first enumerator and no
2520 initializer has been given. It will be initialized to zero. */
2521 mpz_set_si (result->value.integer, 0);