2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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, locus *where)
42 if (mpfr_inf_p (x) || mpfr_nan_p (x))
44 gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
50 e = mpfr_get_z_exp (z, x);
53 mpz_mul_2exp (z, z, e);
55 mpz_tdiv_q_2exp (z, z, -e);
59 /* Set the model number precision by the requested KIND. */
62 gfc_set_model_kind (int kind)
64 int index = gfc_validate_kind (BT_REAL, kind, false);
67 base2prec = gfc_real_kinds[index].digits;
68 if (gfc_real_kinds[index].radix != 2)
69 base2prec *= gfc_real_kinds[index].radix / 2;
70 mpfr_set_default_prec (base2prec);
74 /* Set the model number precision from mpfr_t x. */
77 gfc_set_model (mpfr_t x)
79 mpfr_set_default_prec (mpfr_get_prec (x));
83 /* Given an arithmetic error code, return a pointer to a string that
84 explains the error. */
87 gfc_arith_error (arith code)
94 p = _("Arithmetic OK at %L");
97 p = _("Arithmetic overflow at %L");
100 p = _("Arithmetic underflow at %L");
103 p = _("Arithmetic NaN at %L");
106 p = _("Division by zero at %L");
108 case ARITH_INCOMMENSURATE:
109 p = _("Array operands are incommensurate at %L");
111 case ARITH_ASYMMETRIC:
113 _("Integer outside symmetric range implied by Standard Fortran at %L");
116 gfc_internal_error ("gfc_arith_error(): Bad error code");
123 /* Get things ready to do math. */
126 gfc_arith_init_1 (void)
128 gfc_integer_info *int_info;
129 gfc_real_info *real_info;
133 mpfr_set_default_prec (128);
136 /* Convert the minimum and maximum values for each kind into their
137 GNU MP representation. */
138 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
141 mpz_init (int_info->huge);
142 mpz_set_ui (int_info->huge, int_info->radix);
143 mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
144 mpz_sub_ui (int_info->huge, int_info->huge, 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 int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
173 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
175 gfc_set_model_kind (real_info->kind);
180 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
182 mpfr_init (real_info->huge);
183 mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
184 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
185 mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
186 mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
189 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
190 mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
192 /* (1 - b**(-p)) * b**(emax-1) */
193 mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
195 /* (1 - b**(-p)) * b**(emax-1) * b */
196 mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
199 /* tiny(x) = b**(emin-1) */
200 mpfr_init (real_info->tiny);
201 mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
202 mpfr_pow_si (real_info->tiny, real_info->tiny,
203 real_info->min_exponent - 1, GFC_RND_MODE);
205 /* subnormal (x) = b**(emin - digit) */
206 mpfr_init (real_info->subnormal);
207 mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
208 mpfr_pow_si (real_info->subnormal, real_info->subnormal,
209 real_info->min_exponent - real_info->digits, GFC_RND_MODE);
211 /* epsilon(x) = b**(1-p) */
212 mpfr_init (real_info->epsilon);
213 mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
214 mpfr_pow_si (real_info->epsilon, real_info->epsilon,
215 1 - real_info->digits, GFC_RND_MODE);
217 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
218 mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
219 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
220 mpfr_neg (b, b, GFC_RND_MODE);
223 mpfr_min (a, a, b, GFC_RND_MODE);
225 real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
227 /* precision(x) = int((p - 1) * log10(b)) + k */
228 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
229 mpfr_log10 (a, a, GFC_RND_MODE);
230 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
232 real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
234 /* If the radix is an integral power of 10, add one to the precision. */
235 for (i = 10; i <= real_info->radix; i *= 10)
236 if (i == real_info->radix)
237 real_info->precision++;
239 mpfr_clears (a, b, NULL);
244 /* Clean up, get rid of numeric constants. */
247 gfc_arith_done_1 (void)
249 gfc_integer_info *ip;
252 for (ip = gfc_integer_kinds; ip->kind; ip++)
254 mpz_clear (ip->min_int);
255 mpz_clear (ip->pedantic_min_int);
256 mpz_clear (ip->huge);
259 for (rp = gfc_real_kinds; rp->kind; rp++)
260 mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
264 /* Given a wide character value and a character kind, determine whether
265 the character is representable for that kind. */
267 gfc_check_character_range (gfc_char_t c, int kind)
269 /* As wide characters are stored as 32-bit values, they're all
270 representable in UCS=4. */
275 return c <= 255 ? true : false;
281 /* Given an integer and a kind, make sure that the integer lies within
282 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
286 gfc_check_integer_range (mpz_t p, int kind)
291 i = gfc_validate_kind (BT_INTEGER, kind, false);
296 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
297 result = ARITH_ASYMMETRIC;
301 if (gfc_option.flag_range_check == 0)
304 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
305 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
306 result = ARITH_OVERFLOW;
312 /* Given a real and a kind, make sure that the real lies within the
313 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
317 gfc_check_real_range (mpfr_t p, int kind)
323 i = gfc_validate_kind (BT_REAL, kind, false);
327 mpfr_abs (q, p, GFC_RND_MODE);
333 if (gfc_option.flag_range_check != 0)
334 retval = ARITH_OVERFLOW;
336 else if (mpfr_nan_p (p))
338 if (gfc_option.flag_range_check != 0)
341 else if (mpfr_sgn (q) == 0)
346 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
348 if (gfc_option.flag_range_check == 0)
349 mpfr_set_inf (p, mpfr_sgn (p));
351 retval = ARITH_OVERFLOW;
353 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
355 if (gfc_option.flag_range_check == 0)
357 if (mpfr_sgn (p) < 0)
359 mpfr_set_ui (p, 0, GFC_RND_MODE);
360 mpfr_set_si (q, -1, GFC_RND_MODE);
361 mpfr_copysign (p, p, q, GFC_RND_MODE);
364 mpfr_set_ui (p, 0, GFC_RND_MODE);
367 retval = ARITH_UNDERFLOW;
369 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
374 /* Save current values of emin and emax. */
375 emin = mpfr_get_emin ();
376 emax = mpfr_get_emax ();
378 /* Set emin and emax for the current model number. */
379 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
380 mpfr_set_emin ((mp_exp_t) en);
381 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
382 mpfr_check_range (q, 0, GFC_RND_MODE);
383 mpfr_subnormalize (q, 0, GFC_RND_MODE);
385 /* Reset emin and emax. */
386 mpfr_set_emin (emin);
387 mpfr_set_emax (emax);
389 /* Copy sign if needed. */
390 if (mpfr_sgn (p) < 0)
391 mpfr_neg (p, q, GMP_RNDN);
393 mpfr_set (p, q, GMP_RNDN);
402 /* Function to return a constant expression node of a given type and kind. */
405 gfc_constant_result (bt type, int kind, locus *where)
410 gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
412 result = gfc_get_expr ();
414 result->expr_type = EXPR_CONSTANT;
415 result->ts.type = type;
416 result->ts.kind = kind;
417 result->where = *where;
422 mpz_init (result->value.integer);
426 gfc_set_model_kind (kind);
427 mpfr_init (result->value.real);
431 gfc_set_model_kind (kind);
432 mpc_init2 (result->value.complex, mpfr_get_default_prec());
443 /* Low-level arithmetic functions. All of these subroutines assume
444 that all operands are of the same type and return an operand of the
445 same type. The other thing about these subroutines is that they
446 can fail in various ways -- overflow, underflow, division by zero,
447 zero raised to the zero, etc. */
450 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
454 result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
455 result->value.logical = !op1->value.logical;
463 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
467 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
469 result->value.logical = op1->value.logical && op2->value.logical;
477 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
481 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
483 result->value.logical = op1->value.logical || op2->value.logical;
491 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
495 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
497 result->value.logical = op1->value.logical == op2->value.logical;
505 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
509 result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
511 result->value.logical = op1->value.logical != op2->value.logical;
518 /* Make sure a constant numeric expression is within the range for
519 its type and kind. Note that there's also a gfc_check_range(),
520 but that one deals with the intrinsic RANGE function. */
523 gfc_range_check (gfc_expr *e)
531 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
535 rc = gfc_check_real_range (e->value.real, e->ts.kind);
536 if (rc == ARITH_UNDERFLOW)
537 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
538 if (rc == ARITH_OVERFLOW)
539 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
541 mpfr_set_nan (e->value.real);
545 rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
546 if (rc == ARITH_UNDERFLOW)
547 mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
548 if (rc == ARITH_OVERFLOW)
549 mpfr_set_inf (mpc_realref (e->value.complex),
550 mpfr_sgn (mpc_realref (e->value.complex)));
552 mpfr_set_nan (mpc_realref (e->value.complex));
554 rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
555 if (rc == ARITH_UNDERFLOW)
556 mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
557 if (rc == ARITH_OVERFLOW)
558 mpfr_set_inf (mpc_imagref (e->value.complex),
559 mpfr_sgn (mpc_imagref (e->value.complex)));
561 mpfr_set_nan (mpc_imagref (e->value.complex));
568 gfc_internal_error ("gfc_range_check(): Bad type");
575 /* Several of the following routines use the same set of statements to
576 check the validity of the result. Encapsulate the checking here. */
579 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
583 if (val == ARITH_UNDERFLOW)
585 if (gfc_option.warn_underflow)
586 gfc_warning (gfc_arith_error (val), &x->where);
590 if (val == ARITH_ASYMMETRIC)
592 gfc_warning (gfc_arith_error (val), &x->where);
605 /* It may seem silly to have a subroutine that actually computes the
606 unary plus of a constant, but it prevents us from making exceptions
607 in the code elsewhere. Used for unary plus and parenthesized
611 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
613 *resultp = gfc_copy_expr (op1);
619 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
624 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
626 switch (op1->ts.type)
629 mpz_neg (result->value.integer, op1->value.integer);
633 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
637 mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
641 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
644 rc = gfc_range_check (result);
646 return check_result (rc, op1, result, resultp);
651 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
656 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
658 switch (op1->ts.type)
661 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
665 mpfr_add (result->value.real, op1->value.real, op2->value.real,
670 mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
675 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
678 rc = gfc_range_check (result);
680 return check_result (rc, op1, result, resultp);
685 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
690 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
692 switch (op1->ts.type)
695 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
699 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
704 mpc_sub (result->value.complex, op1->value.complex,
705 op2->value.complex, GFC_MPC_RND_MODE);
709 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
712 rc = gfc_range_check (result);
714 return check_result (rc, op1, result, resultp);
719 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 (mpc_realref (op1->value.complex));
739 mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
744 gfc_internal_error ("gfc_arith_times(): Bad basic type");
747 rc = gfc_range_check (result);
749 return check_result (rc, op1, result, resultp);
754 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
761 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
763 switch (op1->ts.type)
766 if (mpz_sgn (op2->value.integer) == 0)
772 mpz_tdiv_q (result->value.integer, op1->value.integer,
777 if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
783 mpfr_div (result->value.real, op1->value.real, op2->value.real,
788 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
789 && gfc_option.flag_range_check == 1)
795 gfc_set_model (mpc_realref (op1->value.complex));
796 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
798 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
800 mpfr_set_nan (mpc_realref (result->value.complex));
801 mpfr_set_nan (mpc_imagref (result->value.complex));
804 mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
809 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
813 rc = gfc_range_check (result);
815 return check_result (rc, op1, result, resultp);
818 /* Raise a number to a power. */
821 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
826 extern bool init_flag;
829 result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
831 switch (op2->ts.type)
834 power_sign = mpz_sgn (op2->value.integer);
838 /* Handle something to the zeroth power. Since we're dealing
839 with integral exponents, there is no ambiguity in the
840 limiting procedure used to determine the value of 0**0. */
841 switch (op1->ts.type)
844 mpz_set_ui (result->value.integer, 1);
848 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
852 mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
856 gfc_internal_error ("arith_power(): Bad base");
861 switch (op1->ts.type)
867 /* First, we simplify the cases of op1 == 1, 0 or -1. */
868 if (mpz_cmp_si (op1->value.integer, 1) == 0)
871 mpz_set_si (result->value.integer, 1);
873 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
875 /* 0**op2 == 0, if op2 > 0
876 0**op2 overflow, if op2 < 0 ; in that case, we
877 set the result to 0 and return ARITH_DIV0. */
878 mpz_set_si (result->value.integer, 0);
879 if (mpz_cmp_si (op2->value.integer, 0) < 0)
882 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
884 /* (-1)**op2 == (-1)**(mod(op2,2)) */
885 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
887 mpz_set_si (result->value.integer, -1);
889 mpz_set_si (result->value.integer, 1);
891 /* Then, we take care of op2 < 0. */
892 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
894 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
895 mpz_set_si (result->value.integer, 0);
897 else if (gfc_extract_int (op2, &power) != NULL)
899 /* If op2 doesn't fit in an int, the exponentiation will
900 overflow, because op2 > 0 and abs(op1) > 1. */
903 i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
905 if (gfc_option.flag_range_check)
908 /* Still, we want to give the same value as the
911 mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
912 mpz_mul_ui (max, max, 2);
913 mpz_powm (result->value.integer, op1->value.integer,
914 op2->value.integer, max);
918 mpz_pow_ui (result->value.integer, op1->value.integer,
924 mpfr_pow_z (result->value.real, op1->value.real,
925 op2->value.integer, GFC_RND_MODE);
929 mpc_pow_z (result->value.complex, op1->value.complex,
930 op2->value.integer, GFC_MPC_RND_MODE);
943 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
944 "exponent in an initialization "
945 "expression at %L", &op2->where) == FAILURE)
946 return ARITH_PROHIBIT;
949 if (mpfr_cmp_si (op1->value.real, 0) < 0)
951 gfc_error ("Raising a negative REAL at %L to "
952 "a REAL power is prohibited", &op1->where);
954 return ARITH_PROHIBIT;
957 mpfr_pow (result->value.real, op1->value.real, op2->value.real,
965 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
966 "exponent in an initialization "
967 "expression at %L", &op2->where) == FAILURE)
968 return ARITH_PROHIBIT;
971 mpc_pow (result->value.complex, op1->value.complex,
972 op2->value.complex, GFC_MPC_RND_MODE);
976 gfc_internal_error ("arith_power(): unknown type");
980 rc = gfc_range_check (result);
982 return check_result (rc, op1, result, resultp);
986 /* Concatenate two string constants. */
989 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
994 gcc_assert (op1->ts.kind == op2->ts.kind);
995 result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
998 len = op1->value.character.length + op2->value.character.length;
1000 result->value.character.string = gfc_get_wide_string (len + 1);
1001 result->value.character.length = len;
1003 memcpy (result->value.character.string, op1->value.character.string,
1004 op1->value.character.length * sizeof (gfc_char_t));
1006 memcpy (&result->value.character.string[op1->value.character.length],
1007 op2->value.character.string,
1008 op2->value.character.length * sizeof (gfc_char_t));
1010 result->value.character.string[len] = '\0';
1017 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1018 This function mimics mpfr_cmp but takes NaN into account. */
1021 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1027 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1030 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1033 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1036 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1039 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1042 gfc_internal_error ("compare_real(): Bad operator");
1048 /* Comparison operators. Assumes that the two expression nodes
1049 contain two constants of the same type. The op argument is
1050 needed to handle NaN correctly. */
1053 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1057 switch (op1->ts.type)
1060 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1064 rc = compare_real (op1, op2, op);
1068 rc = gfc_compare_string (op1, op2);
1072 rc = ((!op1->value.logical && op2->value.logical)
1073 || (op1->value.logical && !op2->value.logical));
1077 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1084 /* Compare a pair of complex numbers. Naturally, this is only for
1085 equality and inequality. */
1088 compare_complex (gfc_expr *op1, gfc_expr *op2)
1090 return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1094 /* Given two constant strings and the inverse collating sequence, compare the
1095 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1096 We use the processor's default collating sequence. */
1099 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1101 int len, alen, blen, i;
1104 alen = a->value.character.length;
1105 blen = b->value.character.length;
1107 len = MAX(alen, blen);
1109 for (i = 0; i < len; i++)
1111 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1112 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1120 /* Strings are equal */
1126 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1128 int len, alen, blen, i;
1131 alen = a->value.character.length;
1134 len = MAX(alen, blen);
1136 for (i = 0; i < len; i++)
1138 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1139 bc = ((i < blen) ? b[i] : ' ');
1141 if (!case_sensitive)
1153 /* Strings are equal */
1158 /* Specific comparison subroutines. */
1161 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1165 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1167 result->value.logical = (op1->ts.type == BT_COMPLEX)
1168 ? compare_complex (op1, op2)
1169 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1177 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1181 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1183 result->value.logical = (op1->ts.type == BT_COMPLEX)
1184 ? !compare_complex (op1, op2)
1185 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1193 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1197 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1199 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1207 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1211 result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1213 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1221 gfc_arith_lt (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, INTRINSIC_LT) < 0);
1235 gfc_arith_le (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, INTRINSIC_LE) <= 0);
1249 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1252 gfc_constructor *c, *head;
1256 if (op->expr_type == EXPR_CONSTANT)
1257 return eval (op, result);
1260 head = gfc_copy_constructor (op->value.constructor);
1262 for (c = head; c; c = c->next)
1264 rc = reduce_unary (eval, c->expr, &r);
1269 gfc_replace_expr (c->expr, r);
1273 gfc_free_constructor (head);
1276 r = gfc_get_expr ();
1277 r->expr_type = EXPR_ARRAY;
1278 r->value.constructor = head;
1279 r->shape = gfc_copy_shape (op->shape, op->rank);
1281 r->ts = head->expr->ts;
1282 r->where = op->where;
1293 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1294 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1296 gfc_constructor *c, *head;
1300 head = gfc_copy_constructor (op1->value.constructor);
1303 for (c = head; c; c = c->next)
1305 if (c->expr->expr_type == EXPR_CONSTANT)
1306 rc = eval (c->expr, op2, &r);
1308 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1313 gfc_replace_expr (c->expr, r);
1317 gfc_free_constructor (head);
1320 r = gfc_get_expr ();
1321 r->expr_type = EXPR_ARRAY;
1322 r->value.constructor = head;
1323 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1325 r->ts = head->expr->ts;
1326 r->where = op1->where;
1327 r->rank = op1->rank;
1337 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1338 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1340 gfc_constructor *c, *head;
1344 head = gfc_copy_constructor (op2->value.constructor);
1347 for (c = head; c; c = c->next)
1349 if (c->expr->expr_type == EXPR_CONSTANT)
1350 rc = eval (op1, c->expr, &r);
1352 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1357 gfc_replace_expr (c->expr, r);
1361 gfc_free_constructor (head);
1364 r = gfc_get_expr ();
1365 r->expr_type = EXPR_ARRAY;
1366 r->value.constructor = head;
1367 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1369 r->ts = head->expr->ts;
1370 r->where = op2->where;
1371 r->rank = op2->rank;
1380 /* We need a forward declaration of reduce_binary. */
1381 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1382 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1386 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1387 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1389 gfc_constructor *c, *d, *head;
1393 head = gfc_copy_constructor (op1->value.constructor);
1396 d = op2->value.constructor;
1398 if (gfc_check_conformance (op1, op2, "elemental binary operation")
1400 rc = ARITH_INCOMMENSURATE;
1403 for (c = head; c; c = c->next, d = d->next)
1407 rc = ARITH_INCOMMENSURATE;
1411 rc = reduce_binary (eval, c->expr, d->expr, &r);
1415 gfc_replace_expr (c->expr, r);
1419 rc = ARITH_INCOMMENSURATE;
1423 gfc_free_constructor (head);
1426 r = gfc_get_expr ();
1427 r->expr_type = EXPR_ARRAY;
1428 r->value.constructor = head;
1429 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1431 r->ts = head->expr->ts;
1432 r->where = op1->where;
1433 r->rank = op1->rank;
1443 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1444 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1446 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1447 return eval (op1, op2, result);
1449 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1450 return reduce_binary_ca (eval, op1, op2, result);
1452 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1453 return reduce_binary_ac (eval, op1, op2, result);
1455 return reduce_binary_aa (eval, op1, op2, result);
1461 arith (*f2)(gfc_expr *, gfc_expr **);
1462 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1466 /* High level arithmetic subroutines. These subroutines go into
1467 eval_intrinsic(), which can do one of several things to its
1468 operands. If the operands are incompatible with the intrinsic
1469 operation, we return a node pointing to the operands and hope that
1470 an operator interface is found during resolution.
1472 If the operands are compatible and are constants, then we try doing
1473 the arithmetic. We also handle the cases where either or both
1474 operands are array constructors. */
1477 eval_intrinsic (gfc_intrinsic_op op,
1478 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1480 gfc_expr temp, *result;
1484 gfc_clear_ts (&temp.ts);
1490 if (op1->ts.type != BT_LOGICAL)
1493 temp.ts.type = BT_LOGICAL;
1494 temp.ts.kind = gfc_default_logical_kind;
1498 /* Logical binary operators */
1501 case INTRINSIC_NEQV:
1503 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1506 temp.ts.type = BT_LOGICAL;
1507 temp.ts.kind = gfc_default_logical_kind;
1512 case INTRINSIC_UPLUS:
1513 case INTRINSIC_UMINUS:
1514 if (!gfc_numeric_ts (&op1->ts))
1521 case INTRINSIC_PARENTHESES:
1526 /* Additional restrictions for ordering relations. */
1528 case INTRINSIC_GE_OS:
1530 case INTRINSIC_LT_OS:
1532 case INTRINSIC_LE_OS:
1534 case INTRINSIC_GT_OS:
1535 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1537 temp.ts.type = BT_LOGICAL;
1538 temp.ts.kind = gfc_default_logical_kind;
1544 case INTRINSIC_EQ_OS:
1546 case INTRINSIC_NE_OS:
1547 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1550 temp.ts.type = BT_LOGICAL;
1551 temp.ts.kind = gfc_default_logical_kind;
1553 /* If kind mismatch, exit and we'll error out later. */
1554 if (op1->ts.kind != op2->ts.kind)
1561 /* Numeric binary */
1562 case INTRINSIC_PLUS:
1563 case INTRINSIC_MINUS:
1564 case INTRINSIC_TIMES:
1565 case INTRINSIC_DIVIDE:
1566 case INTRINSIC_POWER:
1567 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1570 /* Insert any necessary type conversions to make the operands
1573 temp.expr_type = EXPR_OP;
1574 gfc_clear_ts (&temp.ts);
1575 temp.value.op.op = op;
1577 temp.value.op.op1 = op1;
1578 temp.value.op.op2 = op2;
1580 gfc_type_convert_binary (&temp);
1582 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1583 || op == INTRINSIC_GE || op == INTRINSIC_GT
1584 || op == INTRINSIC_LE || op == INTRINSIC_LT
1585 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1586 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1587 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
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
1599 || op1->ts.kind != op2->ts.kind)
1602 temp.ts.type = BT_CHARACTER;
1603 temp.ts.kind = op1->ts.kind;
1607 case INTRINSIC_USER:
1611 gfc_internal_error ("eval_intrinsic(): Bad operator");
1614 if (op1->expr_type != EXPR_CONSTANT
1615 && (op1->expr_type != EXPR_ARRAY
1616 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1620 && op2->expr_type != EXPR_CONSTANT
1621 && (op2->expr_type != EXPR_ARRAY
1622 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1626 rc = reduce_unary (eval.f2, op1, &result);
1628 rc = reduce_binary (eval.f3, op1, op2, &result);
1631 /* Something went wrong. */
1632 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1637 gfc_error (gfc_arith_error (rc), &op1->where);
1641 gfc_free_expr (op1);
1642 gfc_free_expr (op2);
1646 /* Create a run-time expression. */
1647 result = gfc_get_expr ();
1648 result->ts = temp.ts;
1650 result->expr_type = EXPR_OP;
1651 result->value.op.op = op;
1653 result->value.op.op1 = op1;
1654 result->value.op.op2 = op2;
1656 result->where = op1->where;
1662 /* Modify type of expression for zero size array. */
1665 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1668 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1673 case INTRINSIC_GE_OS:
1675 case INTRINSIC_LT_OS:
1677 case INTRINSIC_LE_OS:
1679 case INTRINSIC_GT_OS:
1681 case INTRINSIC_EQ_OS:
1683 case INTRINSIC_NE_OS:
1684 op->ts.type = BT_LOGICAL;
1685 op->ts.kind = gfc_default_logical_kind;
1696 /* Return nonzero if the expression is a zero size array. */
1699 gfc_zero_size_array (gfc_expr *e)
1701 if (e->expr_type != EXPR_ARRAY)
1704 return e->value.constructor == NULL;
1708 /* Reduce a binary expression where at least one of the operands
1709 involves a zero-length array. Returns NULL if neither of the
1710 operands is a zero-length array. */
1713 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1715 if (gfc_zero_size_array (op1))
1717 gfc_free_expr (op2);
1721 if (gfc_zero_size_array (op2))
1723 gfc_free_expr (op1);
1732 eval_intrinsic_f2 (gfc_intrinsic_op op,
1733 arith (*eval) (gfc_expr *, gfc_expr **),
1734 gfc_expr *op1, gfc_expr *op2)
1741 if (gfc_zero_size_array (op1))
1742 return eval_type_intrinsic0 (op, op1);
1746 result = reduce_binary0 (op1, op2);
1748 return eval_type_intrinsic0 (op, result);
1752 return eval_intrinsic (op, f, op1, op2);
1757 eval_intrinsic_f3 (gfc_intrinsic_op op,
1758 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1759 gfc_expr *op1, gfc_expr *op2)
1764 result = reduce_binary0 (op1, op2);
1766 return eval_type_intrinsic0(op, result);
1769 return eval_intrinsic (op, f, op1, op2);
1774 gfc_parentheses (gfc_expr *op)
1776 if (gfc_is_constant_expr (op))
1779 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1784 gfc_uplus (gfc_expr *op)
1786 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1791 gfc_uminus (gfc_expr *op)
1793 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1798 gfc_add (gfc_expr *op1, gfc_expr *op2)
1800 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1805 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1807 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1812 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1814 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1819 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1821 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1826 gfc_power (gfc_expr *op1, gfc_expr *op2)
1828 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1833 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1835 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1840 gfc_and (gfc_expr *op1, gfc_expr *op2)
1842 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1847 gfc_or (gfc_expr *op1, gfc_expr *op2)
1849 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1854 gfc_not (gfc_expr *op1)
1856 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1861 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1863 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1868 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1870 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1875 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1877 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1882 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1884 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1889 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1891 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1896 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1898 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1903 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1905 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1910 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1912 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1916 /* Convert an integer string to an expression node. */
1919 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1924 e = gfc_constant_result (BT_INTEGER, kind, where);
1925 /* A leading plus is allowed, but not by mpz_set_str. */
1926 if (buffer[0] == '+')
1930 mpz_set_str (e->value.integer, t, radix);
1936 /* Convert a real string to an expression node. */
1939 gfc_convert_real (const char *buffer, int kind, locus *where)
1943 e = gfc_constant_result (BT_REAL, kind, where);
1944 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1950 /* Convert a pair of real, constant expression nodes to a single
1951 complex expression node. */
1954 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1958 e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1959 mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1966 /******* Simplification of intrinsic functions with constant arguments *****/
1969 /* Deal with an arithmetic error. */
1972 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1977 gfc_error ("Arithmetic OK converting %s to %s at %L",
1978 gfc_typename (from), gfc_typename (to), where);
1980 case ARITH_OVERFLOW:
1981 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1982 "can be disabled with the option -fno-range-check",
1983 gfc_typename (from), gfc_typename (to), where);
1985 case ARITH_UNDERFLOW:
1986 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1987 "can be disabled with the option -fno-range-check",
1988 gfc_typename (from), gfc_typename (to), where);
1991 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1992 "can be disabled with the option -fno-range-check",
1993 gfc_typename (from), gfc_typename (to), where);
1996 gfc_error ("Division by zero converting %s to %s at %L",
1997 gfc_typename (from), gfc_typename (to), where);
1999 case ARITH_INCOMMENSURATE:
2000 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2001 gfc_typename (from), gfc_typename (to), where);
2003 case ARITH_ASYMMETRIC:
2004 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2005 " converting %s to %s at %L",
2006 gfc_typename (from), gfc_typename (to), where);
2009 gfc_internal_error ("gfc_arith_error(): Bad error code");
2012 /* TODO: Do something about the error, i.e., throw exception, return
2017 /* Convert integers to integers. */
2020 gfc_int2int (gfc_expr *src, int kind)
2025 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2027 mpz_set (result->value.integer, src->value.integer);
2029 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2031 if (rc == ARITH_ASYMMETRIC)
2033 gfc_warning (gfc_arith_error (rc), &src->where);
2037 arith_error (rc, &src->ts, &result->ts, &src->where);
2038 gfc_free_expr (result);
2047 /* Convert integers to reals. */
2050 gfc_int2real (gfc_expr *src, int kind)
2055 result = gfc_constant_result (BT_REAL, kind, &src->where);
2057 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2059 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2061 arith_error (rc, &src->ts, &result->ts, &src->where);
2062 gfc_free_expr (result);
2070 /* Convert default integer to default complex. */
2073 gfc_int2complex (gfc_expr *src, int kind)
2078 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2080 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2082 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2085 arith_error (rc, &src->ts, &result->ts, &src->where);
2086 gfc_free_expr (result);
2094 /* Convert default real to default integer. */
2097 gfc_real2int (gfc_expr *src, int kind)
2102 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2104 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2106 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2108 arith_error (rc, &src->ts, &result->ts, &src->where);
2109 gfc_free_expr (result);
2117 /* Convert real to real. */
2120 gfc_real2real (gfc_expr *src, int kind)
2125 result = gfc_constant_result (BT_REAL, kind, &src->where);
2127 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2129 rc = gfc_check_real_range (result->value.real, kind);
2131 if (rc == ARITH_UNDERFLOW)
2133 if (gfc_option.warn_underflow)
2134 gfc_warning (gfc_arith_error (rc), &src->where);
2135 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2137 else if (rc != ARITH_OK)
2139 arith_error (rc, &src->ts, &result->ts, &src->where);
2140 gfc_free_expr (result);
2148 /* Convert real to complex. */
2151 gfc_real2complex (gfc_expr *src, int kind)
2156 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2158 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2160 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2162 if (rc == ARITH_UNDERFLOW)
2164 if (gfc_option.warn_underflow)
2165 gfc_warning (gfc_arith_error (rc), &src->where);
2166 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2168 else if (rc != ARITH_OK)
2170 arith_error (rc, &src->ts, &result->ts, &src->where);
2171 gfc_free_expr (result);
2179 /* Convert complex to integer. */
2182 gfc_complex2int (gfc_expr *src, int kind)
2187 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2189 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2192 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2194 arith_error (rc, &src->ts, &result->ts, &src->where);
2195 gfc_free_expr (result);
2203 /* Convert complex to real. */
2206 gfc_complex2real (gfc_expr *src, int kind)
2211 result = gfc_constant_result (BT_REAL, kind, &src->where);
2213 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2215 rc = gfc_check_real_range (result->value.real, kind);
2217 if (rc == ARITH_UNDERFLOW)
2219 if (gfc_option.warn_underflow)
2220 gfc_warning (gfc_arith_error (rc), &src->where);
2221 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2225 arith_error (rc, &src->ts, &result->ts, &src->where);
2226 gfc_free_expr (result);
2234 /* Convert complex to complex. */
2237 gfc_complex2complex (gfc_expr *src, int kind)
2242 result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2244 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2246 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2248 if (rc == ARITH_UNDERFLOW)
2250 if (gfc_option.warn_underflow)
2251 gfc_warning (gfc_arith_error (rc), &src->where);
2252 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2254 else if (rc != ARITH_OK)
2256 arith_error (rc, &src->ts, &result->ts, &src->where);
2257 gfc_free_expr (result);
2261 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2263 if (rc == ARITH_UNDERFLOW)
2265 if (gfc_option.warn_underflow)
2266 gfc_warning (gfc_arith_error (rc), &src->where);
2267 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2269 else if (rc != ARITH_OK)
2271 arith_error (rc, &src->ts, &result->ts, &src->where);
2272 gfc_free_expr (result);
2280 /* Logical kind conversion. */
2283 gfc_log2log (gfc_expr *src, int kind)
2287 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2288 result->value.logical = src->value.logical;
2294 /* Convert logical to integer. */
2297 gfc_log2int (gfc_expr *src, int kind)
2301 result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2302 mpz_set_si (result->value.integer, src->value.logical);
2308 /* Convert integer to logical. */
2311 gfc_int2log (gfc_expr *src, int kind)
2315 result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2316 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2322 /* Helper function to set the representation in a Hollerith conversion.
2323 This assumes that the ts.type and ts.kind of the result have already
2327 hollerith2representation (gfc_expr *result, gfc_expr *src)
2329 int src_len, result_len;
2331 src_len = src->representation.length;
2332 result_len = gfc_target_expr_size (result);
2334 if (src_len > result_len)
2336 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2337 &src->where, gfc_typename(&result->ts));
2340 result->representation.string = XCNEWVEC (char, result_len + 1);
2341 memcpy (result->representation.string, src->representation.string,
2342 MIN (result_len, src_len));
2344 if (src_len < result_len)
2345 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2347 result->representation.string[result_len] = '\0'; /* For debugger */
2348 result->representation.length = result_len;
2352 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2355 gfc_hollerith2int (gfc_expr *src, int kind)
2359 result = gfc_get_expr ();
2360 result->expr_type = EXPR_CONSTANT;
2361 result->ts.type = BT_INTEGER;
2362 result->ts.kind = kind;
2363 result->where = src->where;
2365 hollerith2representation (result, src);
2366 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2367 result->representation.length, result->value.integer);
2373 /* Convert Hollerith to real. The constant will be padded or truncated. */
2376 gfc_hollerith2real (gfc_expr *src, int kind)
2380 result = gfc_get_expr ();
2381 result->expr_type = EXPR_CONSTANT;
2382 result->ts.type = BT_REAL;
2383 result->ts.kind = kind;
2384 result->where = src->where;
2386 hollerith2representation (result, src);
2387 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2388 result->representation.length, result->value.real);
2394 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2397 gfc_hollerith2complex (gfc_expr *src, int kind)
2401 result = gfc_get_expr ();
2402 result->expr_type = EXPR_CONSTANT;
2403 result->ts.type = BT_COMPLEX;
2404 result->ts.kind = kind;
2405 result->where = src->where;
2407 hollerith2representation (result, src);
2408 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2409 result->representation.length, result->value.complex);
2415 /* Convert Hollerith to character. */
2418 gfc_hollerith2character (gfc_expr *src, int kind)
2422 result = gfc_copy_expr (src);
2423 result->ts.type = BT_CHARACTER;
2424 result->ts.kind = kind;
2426 result->value.character.length = result->representation.length;
2427 result->value.character.string
2428 = gfc_char_to_widechar (result->representation.string);
2434 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2437 gfc_hollerith2logical (gfc_expr *src, int kind)
2441 result = gfc_get_expr ();
2442 result->expr_type = EXPR_CONSTANT;
2443 result->ts.type = BT_LOGICAL;
2444 result->ts.kind = kind;
2445 result->where = src->where;
2447 hollerith2representation (result, src);
2448 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2449 result->representation.length, &result->value.logical);