2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* Since target arithmetic must be done on the host, there has to
24 be some way of evaluating arithmetic expressions as the host
25 would evaluate them. We use the GNU MP library and the MPFR
26 library to do arithmetic, and this file provides the interface. */
33 #include "target-memory.h"
34 #include "constructor.h"
36 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
37 It's easily implemented with a few calls though. */
40 gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
44 if (mpfr_inf_p (x) || mpfr_nan_p (x))
46 gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
52 e = mpfr_get_z_exp (z, x);
55 mpz_mul_2exp (z, z, e);
57 mpz_tdiv_q_2exp (z, z, -e);
61 /* Set the model number precision by the requested KIND. */
64 gfc_set_model_kind (int kind)
66 int index = gfc_validate_kind (BT_REAL, kind, false);
69 base2prec = gfc_real_kinds[index].digits;
70 if (gfc_real_kinds[index].radix != 2)
71 base2prec *= gfc_real_kinds[index].radix / 2;
72 mpfr_set_default_prec (base2prec);
76 /* Set the model number precision from mpfr_t x. */
79 gfc_set_model (mpfr_t x)
81 mpfr_set_default_prec (mpfr_get_prec (x));
85 /* Given an arithmetic error code, return a pointer to a string that
86 explains the error. */
89 gfc_arith_error (arith code)
96 p = _("Arithmetic OK at %L");
99 p = _("Arithmetic overflow at %L");
101 case ARITH_UNDERFLOW:
102 p = _("Arithmetic underflow at %L");
105 p = _("Arithmetic NaN at %L");
108 p = _("Division by zero at %L");
110 case ARITH_INCOMMENSURATE:
111 p = _("Array operands are incommensurate at %L");
113 case ARITH_ASYMMETRIC:
115 _("Integer outside symmetric range implied by Standard Fortran at %L");
118 gfc_internal_error ("gfc_arith_error(): Bad error code");
125 /* Get things ready to do math. */
128 gfc_arith_init_1 (void)
130 gfc_integer_info *int_info;
131 gfc_real_info *real_info;
135 mpfr_set_default_prec (128);
138 /* Convert the minimum and maximum values for each kind into their
139 GNU MP representation. */
140 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
143 mpz_init (int_info->huge);
144 mpz_set_ui (int_info->huge, int_info->radix);
145 mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
146 mpz_sub_ui (int_info->huge, int_info->huge, 1);
148 /* These are the numbers that are actually representable by the
149 target. For bases other than two, this needs to be changed. */
150 if (int_info->radix != 2)
151 gfc_internal_error ("Fix min_int calculation");
153 /* See PRs 13490 and 17912, related to integer ranges.
154 The pedantic_min_int exists for range checking when a program
155 is compiled with -pedantic, and reflects the belief that
156 Standard Fortran requires integers to be symmetrical, i.e.
157 every negative integer must have a representable positive
158 absolute value, and vice versa. */
160 mpz_init (int_info->pedantic_min_int);
161 mpz_neg (int_info->pedantic_min_int, int_info->huge);
163 mpz_init (int_info->min_int);
164 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
167 mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
168 mpfr_log10 (a, a, GFC_RND_MODE);
170 int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
175 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
177 gfc_set_model_kind (real_info->kind);
182 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
184 mpfr_init (real_info->huge);
185 mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
186 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
187 mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
188 mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
191 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
192 mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
194 /* (1 - b**(-p)) * b**(emax-1) */
195 mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
197 /* (1 - b**(-p)) * b**(emax-1) * b */
198 mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
201 /* tiny(x) = b**(emin-1) */
202 mpfr_init (real_info->tiny);
203 mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
204 mpfr_pow_si (real_info->tiny, real_info->tiny,
205 real_info->min_exponent - 1, GFC_RND_MODE);
207 /* subnormal (x) = b**(emin - digit) */
208 mpfr_init (real_info->subnormal);
209 mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
210 mpfr_pow_si (real_info->subnormal, real_info->subnormal,
211 real_info->min_exponent - real_info->digits, GFC_RND_MODE);
213 /* epsilon(x) = b**(1-p) */
214 mpfr_init (real_info->epsilon);
215 mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
216 mpfr_pow_si (real_info->epsilon, real_info->epsilon,
217 1 - real_info->digits, GFC_RND_MODE);
219 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
220 mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
221 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
222 mpfr_neg (b, b, GFC_RND_MODE);
225 mpfr_min (a, a, b, GFC_RND_MODE);
227 real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
229 /* precision(x) = int((p - 1) * log10(b)) + k */
230 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
231 mpfr_log10 (a, a, GFC_RND_MODE);
232 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
234 real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
236 /* If the radix is an integral power of 10, add one to the precision. */
237 for (i = 10; i <= real_info->radix; i *= 10)
238 if (i == real_info->radix)
239 real_info->precision++;
241 mpfr_clears (a, b, NULL);
246 /* Clean up, get rid of numeric constants. */
249 gfc_arith_done_1 (void)
251 gfc_integer_info *ip;
254 for (ip = gfc_integer_kinds; ip->kind; ip++)
256 mpz_clear (ip->min_int);
257 mpz_clear (ip->pedantic_min_int);
258 mpz_clear (ip->huge);
261 for (rp = gfc_real_kinds; rp->kind; rp++)
262 mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
266 /* Given a wide character value and a character kind, determine whether
267 the character is representable for that kind. */
269 gfc_check_character_range (gfc_char_t c, int kind)
271 /* As wide characters are stored as 32-bit values, they're all
272 representable in UCS=4. */
277 return c <= 255 ? true : false;
283 /* Given an integer and a kind, make sure that the integer lies within
284 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
288 gfc_check_integer_range (mpz_t p, int kind)
293 i = gfc_validate_kind (BT_INTEGER, kind, false);
298 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
299 result = ARITH_ASYMMETRIC;
303 if (gfc_option.flag_range_check == 0)
306 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
307 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
308 result = ARITH_OVERFLOW;
314 /* Given a real and a kind, make sure that the real lies within the
315 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
319 gfc_check_real_range (mpfr_t p, int kind)
325 i = gfc_validate_kind (BT_REAL, kind, false);
329 mpfr_abs (q, p, GFC_RND_MODE);
335 if (gfc_option.flag_range_check != 0)
336 retval = ARITH_OVERFLOW;
338 else if (mpfr_nan_p (p))
340 if (gfc_option.flag_range_check != 0)
343 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)
351 mpfr_set_inf (p, mpfr_sgn (p));
353 retval = ARITH_OVERFLOW;
355 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
357 if (gfc_option.flag_range_check == 0)
359 if (mpfr_sgn (p) < 0)
361 mpfr_set_ui (p, 0, GFC_RND_MODE);
362 mpfr_set_si (q, -1, GFC_RND_MODE);
363 mpfr_copysign (p, p, q, GFC_RND_MODE);
366 mpfr_set_ui (p, 0, GFC_RND_MODE);
369 retval = ARITH_UNDERFLOW;
371 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
376 /* Save current values of emin and emax. */
377 emin = mpfr_get_emin ();
378 emax = mpfr_get_emax ();
380 /* Set emin and emax for the current model number. */
381 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
382 mpfr_set_emin ((mp_exp_t) en);
383 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
384 mpfr_check_range (q, 0, GFC_RND_MODE);
385 mpfr_subnormalize (q, 0, GFC_RND_MODE);
387 /* Reset emin and emax. */
388 mpfr_set_emin (emin);
389 mpfr_set_emax (emax);
391 /* Copy sign if needed. */
392 if (mpfr_sgn (p) < 0)
393 mpfr_neg (p, q, GMP_RNDN);
395 mpfr_set (p, q, GMP_RNDN);
404 /* Low-level arithmetic functions. All of these subroutines assume
405 that all operands are of the same type and return an operand of the
406 same type. The other thing about these subroutines is that they
407 can fail in various ways -- overflow, underflow, division by zero,
408 zero raised to the zero, etc. */
411 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
415 result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
416 result->value.logical = !op1->value.logical;
424 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
428 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
430 result->value.logical = op1->value.logical && op2->value.logical;
438 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
442 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
444 result->value.logical = op1->value.logical || op2->value.logical;
452 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
456 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
458 result->value.logical = op1->value.logical == op2->value.logical;
466 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
470 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
472 result->value.logical = op1->value.logical != op2->value.logical;
479 /* Make sure a constant numeric expression is within the range for
480 its type and kind. Note that there's also a gfc_check_range(),
481 but that one deals with the intrinsic RANGE function. */
484 gfc_range_check (gfc_expr *e)
492 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
496 rc = gfc_check_real_range (e->value.real, e->ts.kind);
497 if (rc == ARITH_UNDERFLOW)
498 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
499 if (rc == ARITH_OVERFLOW)
500 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
502 mpfr_set_nan (e->value.real);
506 rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
507 if (rc == ARITH_UNDERFLOW)
508 mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
509 if (rc == ARITH_OVERFLOW)
510 mpfr_set_inf (mpc_realref (e->value.complex),
511 mpfr_sgn (mpc_realref (e->value.complex)));
513 mpfr_set_nan (mpc_realref (e->value.complex));
515 rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
516 if (rc == ARITH_UNDERFLOW)
517 mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
518 if (rc == ARITH_OVERFLOW)
519 mpfr_set_inf (mpc_imagref (e->value.complex),
520 mpfr_sgn (mpc_imagref (e->value.complex)));
522 mpfr_set_nan (mpc_imagref (e->value.complex));
529 gfc_internal_error ("gfc_range_check(): Bad type");
536 /* Several of the following routines use the same set of statements to
537 check the validity of the result. Encapsulate the checking here. */
540 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
544 if (val == ARITH_UNDERFLOW)
546 if (gfc_option.warn_underflow)
547 gfc_warning (gfc_arith_error (val), &x->where);
551 if (val == ARITH_ASYMMETRIC)
553 gfc_warning (gfc_arith_error (val), &x->where);
566 /* It may seem silly to have a subroutine that actually computes the
567 unary plus of a constant, but it prevents us from making exceptions
568 in the code elsewhere. Used for unary plus and parenthesized
572 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
574 *resultp = gfc_copy_expr (op1);
580 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
585 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
587 switch (op1->ts.type)
590 mpz_neg (result->value.integer, op1->value.integer);
594 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
598 mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
602 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
605 rc = gfc_range_check (result);
607 return check_result (rc, op1, result, resultp);
612 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
617 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
619 switch (op1->ts.type)
622 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
626 mpfr_add (result->value.real, op1->value.real, op2->value.real,
631 mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
636 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
639 rc = gfc_range_check (result);
641 return check_result (rc, op1, result, resultp);
646 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
651 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
653 switch (op1->ts.type)
656 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
660 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
665 mpc_sub (result->value.complex, op1->value.complex,
666 op2->value.complex, GFC_MPC_RND_MODE);
670 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
673 rc = gfc_range_check (result);
675 return check_result (rc, op1, result, resultp);
680 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
685 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
687 switch (op1->ts.type)
690 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
694 mpfr_mul (result->value.real, op1->value.real, op2->value.real,
699 gfc_set_model (mpc_realref (op1->value.complex));
700 mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
705 gfc_internal_error ("gfc_arith_times(): Bad basic type");
708 rc = gfc_range_check (result);
710 return check_result (rc, op1, result, resultp);
715 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
722 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
724 switch (op1->ts.type)
727 if (mpz_sgn (op2->value.integer) == 0)
733 mpz_tdiv_q (result->value.integer, op1->value.integer,
738 if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
744 mpfr_div (result->value.real, op1->value.real, op2->value.real,
749 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
750 && gfc_option.flag_range_check == 1)
756 gfc_set_model (mpc_realref (op1->value.complex));
757 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
759 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
761 mpfr_set_nan (mpc_realref (result->value.complex));
762 mpfr_set_nan (mpc_imagref (result->value.complex));
765 mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
770 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
774 rc = gfc_range_check (result);
776 return check_result (rc, op1, result, resultp);
779 /* Raise a number to a power. */
782 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
789 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
791 switch (op2->ts.type)
794 power_sign = mpz_sgn (op2->value.integer);
798 /* Handle something to the zeroth power. Since we're dealing
799 with integral exponents, there is no ambiguity in the
800 limiting procedure used to determine the value of 0**0. */
801 switch (op1->ts.type)
804 mpz_set_ui (result->value.integer, 1);
808 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
812 mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
816 gfc_internal_error ("arith_power(): Bad base");
821 switch (op1->ts.type)
827 /* First, we simplify the cases of op1 == 1, 0 or -1. */
828 if (mpz_cmp_si (op1->value.integer, 1) == 0)
831 mpz_set_si (result->value.integer, 1);
833 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
835 /* 0**op2 == 0, if op2 > 0
836 0**op2 overflow, if op2 < 0 ; in that case, we
837 set the result to 0 and return ARITH_DIV0. */
838 mpz_set_si (result->value.integer, 0);
839 if (mpz_cmp_si (op2->value.integer, 0) < 0)
842 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
844 /* (-1)**op2 == (-1)**(mod(op2,2)) */
845 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
847 mpz_set_si (result->value.integer, -1);
849 mpz_set_si (result->value.integer, 1);
851 /* Then, we take care of op2 < 0. */
852 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
854 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
855 mpz_set_si (result->value.integer, 0);
857 else if (gfc_extract_int (op2, &power) != NULL)
859 /* If op2 doesn't fit in an int, the exponentiation will
860 overflow, because op2 > 0 and abs(op1) > 1. */
863 i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
865 if (gfc_option.flag_range_check)
868 /* Still, we want to give the same value as the
871 mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
872 mpz_mul_ui (max, max, 2);
873 mpz_powm (result->value.integer, op1->value.integer,
874 op2->value.integer, max);
878 mpz_pow_ui (result->value.integer, op1->value.integer,
884 mpfr_pow_z (result->value.real, op1->value.real,
885 op2->value.integer, GFC_RND_MODE);
889 mpc_pow_z (result->value.complex, op1->value.complex,
890 op2->value.integer, GFC_MPC_RND_MODE);
901 if (gfc_init_expr_flag)
903 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
904 "exponent in an initialization "
905 "expression at %L", &op2->where) == FAILURE)
906 return ARITH_PROHIBIT;
909 if (mpfr_cmp_si (op1->value.real, 0) < 0)
911 gfc_error ("Raising a negative REAL at %L to "
912 "a REAL power is prohibited", &op1->where);
914 return ARITH_PROHIBIT;
917 mpfr_pow (result->value.real, op1->value.real, op2->value.real,
923 if (gfc_init_expr_flag)
925 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
926 "exponent in an initialization "
927 "expression at %L", &op2->where) == FAILURE)
928 return ARITH_PROHIBIT;
931 mpc_pow (result->value.complex, op1->value.complex,
932 op2->value.complex, GFC_MPC_RND_MODE);
936 gfc_internal_error ("arith_power(): unknown type");
940 rc = gfc_range_check (result);
942 return check_result (rc, op1, result, resultp);
946 /* Concatenate two string constants. */
949 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
954 gcc_assert (op1->ts.kind == op2->ts.kind);
955 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
958 len = op1->value.character.length + op2->value.character.length;
960 result->value.character.string = gfc_get_wide_string (len + 1);
961 result->value.character.length = len;
963 memcpy (result->value.character.string, op1->value.character.string,
964 op1->value.character.length * sizeof (gfc_char_t));
966 memcpy (&result->value.character.string[op1->value.character.length],
967 op2->value.character.string,
968 op2->value.character.length * sizeof (gfc_char_t));
970 result->value.character.string[len] = '\0';
977 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
978 This function mimics mpfr_cmp but takes NaN into account. */
981 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
987 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
990 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
993 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
996 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
999 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1002 gfc_internal_error ("compare_real(): Bad operator");
1008 /* Comparison operators. Assumes that the two expression nodes
1009 contain two constants of the same type. The op argument is
1010 needed to handle NaN correctly. */
1013 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1017 switch (op1->ts.type)
1020 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1024 rc = compare_real (op1, op2, op);
1028 rc = gfc_compare_string (op1, op2);
1032 rc = ((!op1->value.logical && op2->value.logical)
1033 || (op1->value.logical && !op2->value.logical));
1037 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1044 /* Compare a pair of complex numbers. Naturally, this is only for
1045 equality and inequality. */
1048 compare_complex (gfc_expr *op1, gfc_expr *op2)
1050 return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1054 /* Given two constant strings and the inverse collating sequence, compare the
1055 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1056 We use the processor's default collating sequence. */
1059 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1061 int len, alen, blen, i;
1064 alen = a->value.character.length;
1065 blen = b->value.character.length;
1067 len = MAX(alen, blen);
1069 for (i = 0; i < len; i++)
1071 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1072 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1080 /* Strings are equal */
1086 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1088 int len, alen, blen, i;
1091 alen = a->value.character.length;
1094 len = MAX(alen, blen);
1096 for (i = 0; i < len; i++)
1098 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1099 bc = ((i < blen) ? b[i] : ' ');
1101 if (!case_sensitive)
1113 /* Strings are equal */
1118 /* Specific comparison subroutines. */
1121 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1125 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1127 result->value.logical = (op1->ts.type == BT_COMPLEX)
1128 ? compare_complex (op1, op2)
1129 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1137 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1141 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1143 result->value.logical = (op1->ts.type == BT_COMPLEX)
1144 ? !compare_complex (op1, op2)
1145 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1153 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1157 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1159 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1167 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1171 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1173 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1181 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1185 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1187 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1195 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1199 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1201 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1209 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1212 gfc_constructor_base head;
1217 if (op->expr_type == EXPR_CONSTANT)
1218 return eval (op, result);
1221 head = gfc_constructor_copy (op->value.constructor);
1222 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1224 rc = reduce_unary (eval, c->expr, &r);
1229 gfc_replace_expr (c->expr, r);
1233 gfc_constructor_free (head);
1236 gfc_constructor *c = gfc_constructor_first (head);
1237 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1239 r->shape = gfc_copy_shape (op->shape, op->rank);
1241 r->value.constructor = head;
1250 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1251 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1253 gfc_constructor_base head;
1256 arith rc = ARITH_OK;
1258 head = gfc_constructor_copy (op1->value.constructor);
1259 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1261 if (c->expr->expr_type == EXPR_CONSTANT)
1262 rc = eval (c->expr, op2, &r);
1264 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1269 gfc_replace_expr (c->expr, r);
1273 gfc_constructor_free (head);
1276 gfc_constructor *c = gfc_constructor_first (head);
1277 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1279 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1280 r->rank = op1->rank;
1281 r->value.constructor = head;
1290 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1291 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1293 gfc_constructor_base head;
1296 arith rc = ARITH_OK;
1298 head = gfc_constructor_copy (op2->value.constructor);
1299 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1301 if (c->expr->expr_type == EXPR_CONSTANT)
1302 rc = eval (op1, c->expr, &r);
1304 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1309 gfc_replace_expr (c->expr, r);
1313 gfc_constructor_free (head);
1316 gfc_constructor *c = gfc_constructor_first (head);
1317 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1319 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1320 r->rank = op2->rank;
1321 r->value.constructor = head;
1329 /* We need a forward declaration of reduce_binary. */
1330 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1331 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1335 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1336 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1338 gfc_constructor_base head;
1339 gfc_constructor *c, *d;
1341 arith rc = ARITH_OK;
1343 if (gfc_check_conformance (op1, op2,
1344 "elemental binary operation") != SUCCESS)
1345 return ARITH_INCOMMENSURATE;
1347 head = gfc_constructor_copy (op1->value.constructor);
1348 for (c = gfc_constructor_first (head),
1349 d = gfc_constructor_first (op2->value.constructor);
1351 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1353 rc = reduce_binary (eval, c->expr, d->expr, &r);
1357 gfc_replace_expr (c->expr, r);
1361 rc = ARITH_INCOMMENSURATE;
1364 gfc_constructor_free (head);
1367 gfc_constructor *c = gfc_constructor_first (head);
1368 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1370 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1371 r->rank = op1->rank;
1372 r->value.constructor = head;
1381 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1382 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1384 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1385 return eval (op1, op2, result);
1387 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1388 return reduce_binary_ca (eval, op1, op2, result);
1390 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1391 return reduce_binary_ac (eval, op1, op2, result);
1393 return reduce_binary_aa (eval, op1, op2, result);
1399 arith (*f2)(gfc_expr *, gfc_expr **);
1400 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1404 /* High level arithmetic subroutines. These subroutines go into
1405 eval_intrinsic(), which can do one of several things to its
1406 operands. If the operands are incompatible with the intrinsic
1407 operation, we return a node pointing to the operands and hope that
1408 an operator interface is found during resolution.
1410 If the operands are compatible and are constants, then we try doing
1411 the arithmetic. We also handle the cases where either or both
1412 operands are array constructors. */
1415 eval_intrinsic (gfc_intrinsic_op op,
1416 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1418 gfc_expr temp, *result;
1422 gfc_clear_ts (&temp.ts);
1428 if (op1->ts.type != BT_LOGICAL)
1431 temp.ts.type = BT_LOGICAL;
1432 temp.ts.kind = gfc_default_logical_kind;
1436 /* Logical binary operators */
1439 case INTRINSIC_NEQV:
1441 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1444 temp.ts.type = BT_LOGICAL;
1445 temp.ts.kind = gfc_default_logical_kind;
1450 case INTRINSIC_UPLUS:
1451 case INTRINSIC_UMINUS:
1452 if (!gfc_numeric_ts (&op1->ts))
1459 case INTRINSIC_PARENTHESES:
1464 /* Additional restrictions for ordering relations. */
1466 case INTRINSIC_GE_OS:
1468 case INTRINSIC_LT_OS:
1470 case INTRINSIC_LE_OS:
1472 case INTRINSIC_GT_OS:
1473 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1475 temp.ts.type = BT_LOGICAL;
1476 temp.ts.kind = gfc_default_logical_kind;
1482 case INTRINSIC_EQ_OS:
1484 case INTRINSIC_NE_OS:
1485 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1488 temp.ts.type = BT_LOGICAL;
1489 temp.ts.kind = gfc_default_logical_kind;
1491 /* If kind mismatch, exit and we'll error out later. */
1492 if (op1->ts.kind != op2->ts.kind)
1499 /* Numeric binary */
1500 case INTRINSIC_PLUS:
1501 case INTRINSIC_MINUS:
1502 case INTRINSIC_TIMES:
1503 case INTRINSIC_DIVIDE:
1504 case INTRINSIC_POWER:
1505 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1508 /* Insert any necessary type conversions to make the operands
1511 temp.expr_type = EXPR_OP;
1512 gfc_clear_ts (&temp.ts);
1513 temp.value.op.op = op;
1515 temp.value.op.op1 = op1;
1516 temp.value.op.op2 = op2;
1518 gfc_type_convert_binary (&temp, 0);
1520 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1521 || op == INTRINSIC_GE || op == INTRINSIC_GT
1522 || op == INTRINSIC_LE || op == INTRINSIC_LT
1523 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1524 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1525 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1527 temp.ts.type = BT_LOGICAL;
1528 temp.ts.kind = gfc_default_logical_kind;
1534 /* Character binary */
1535 case INTRINSIC_CONCAT:
1536 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1537 || op1->ts.kind != op2->ts.kind)
1540 temp.ts.type = BT_CHARACTER;
1541 temp.ts.kind = op1->ts.kind;
1545 case INTRINSIC_USER:
1549 gfc_internal_error ("eval_intrinsic(): Bad operator");
1552 if (op1->expr_type != EXPR_CONSTANT
1553 && (op1->expr_type != EXPR_ARRAY
1554 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1558 && op2->expr_type != EXPR_CONSTANT
1559 && (op2->expr_type != EXPR_ARRAY
1560 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1564 rc = reduce_unary (eval.f2, op1, &result);
1566 rc = reduce_binary (eval.f3, op1, op2, &result);
1569 /* Something went wrong. */
1570 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1575 gfc_error (gfc_arith_error (rc), &op1->where);
1579 gfc_free_expr (op1);
1580 gfc_free_expr (op2);
1584 /* Create a run-time expression. */
1585 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1586 result->ts = temp.ts;
1592 /* Modify type of expression for zero size array. */
1595 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1598 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1603 case INTRINSIC_GE_OS:
1605 case INTRINSIC_LT_OS:
1607 case INTRINSIC_LE_OS:
1609 case INTRINSIC_GT_OS:
1611 case INTRINSIC_EQ_OS:
1613 case INTRINSIC_NE_OS:
1614 op->ts.type = BT_LOGICAL;
1615 op->ts.kind = gfc_default_logical_kind;
1626 /* Return nonzero if the expression is a zero size array. */
1629 gfc_zero_size_array (gfc_expr *e)
1631 if (e->expr_type != EXPR_ARRAY)
1634 return e->value.constructor == NULL;
1638 /* Reduce a binary expression where at least one of the operands
1639 involves a zero-length array. Returns NULL if neither of the
1640 operands is a zero-length array. */
1643 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1645 if (gfc_zero_size_array (op1))
1647 gfc_free_expr (op2);
1651 if (gfc_zero_size_array (op2))
1653 gfc_free_expr (op1);
1662 eval_intrinsic_f2 (gfc_intrinsic_op op,
1663 arith (*eval) (gfc_expr *, gfc_expr **),
1664 gfc_expr *op1, gfc_expr *op2)
1671 if (gfc_zero_size_array (op1))
1672 return eval_type_intrinsic0 (op, op1);
1676 result = reduce_binary0 (op1, op2);
1678 return eval_type_intrinsic0 (op, result);
1682 return eval_intrinsic (op, f, op1, op2);
1687 eval_intrinsic_f3 (gfc_intrinsic_op op,
1688 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1689 gfc_expr *op1, gfc_expr *op2)
1694 result = reduce_binary0 (op1, op2);
1696 return eval_type_intrinsic0(op, result);
1699 return eval_intrinsic (op, f, op1, op2);
1704 gfc_parentheses (gfc_expr *op)
1706 if (gfc_is_constant_expr (op))
1709 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1714 gfc_uplus (gfc_expr *op)
1716 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1721 gfc_uminus (gfc_expr *op)
1723 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1728 gfc_add (gfc_expr *op1, gfc_expr *op2)
1730 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1735 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1737 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1742 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1744 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1749 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1751 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1756 gfc_power (gfc_expr *op1, gfc_expr *op2)
1758 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1763 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1765 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1770 gfc_and (gfc_expr *op1, gfc_expr *op2)
1772 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1777 gfc_or (gfc_expr *op1, gfc_expr *op2)
1779 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1784 gfc_not (gfc_expr *op1)
1786 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1791 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1793 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1798 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1800 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1805 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1807 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1812 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1814 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1819 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1821 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1826 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1828 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1833 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1835 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1840 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1842 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1846 /* Convert an integer string to an expression node. */
1849 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1854 e = gfc_get_constant_expr (BT_INTEGER, kind, where);
1855 /* A leading plus is allowed, but not by mpz_set_str. */
1856 if (buffer[0] == '+')
1860 mpz_set_str (e->value.integer, t, radix);
1866 /* Convert a real string to an expression node. */
1869 gfc_convert_real (const char *buffer, int kind, locus *where)
1873 e = gfc_get_constant_expr (BT_REAL, kind, where);
1874 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1880 /* Convert a pair of real, constant expression nodes to a single
1881 complex expression node. */
1884 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1888 e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
1889 mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1896 /******* Simplification of intrinsic functions with constant arguments *****/
1899 /* Deal with an arithmetic error. */
1902 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1907 gfc_error ("Arithmetic OK converting %s to %s at %L",
1908 gfc_typename (from), gfc_typename (to), where);
1910 case ARITH_OVERFLOW:
1911 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1912 "can be disabled with the option -fno-range-check",
1913 gfc_typename (from), gfc_typename (to), where);
1915 case ARITH_UNDERFLOW:
1916 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1917 "can be disabled with the option -fno-range-check",
1918 gfc_typename (from), gfc_typename (to), where);
1921 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1922 "can be disabled with the option -fno-range-check",
1923 gfc_typename (from), gfc_typename (to), where);
1926 gfc_error ("Division by zero converting %s to %s at %L",
1927 gfc_typename (from), gfc_typename (to), where);
1929 case ARITH_INCOMMENSURATE:
1930 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1931 gfc_typename (from), gfc_typename (to), where);
1933 case ARITH_ASYMMETRIC:
1934 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1935 " converting %s to %s at %L",
1936 gfc_typename (from), gfc_typename (to), where);
1939 gfc_internal_error ("gfc_arith_error(): Bad error code");
1942 /* TODO: Do something about the error, i.e., throw exception, return
1947 /* Convert integers to integers. */
1950 gfc_int2int (gfc_expr *src, int kind)
1955 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
1957 mpz_set (result->value.integer, src->value.integer);
1959 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1961 if (rc == ARITH_ASYMMETRIC)
1963 gfc_warning (gfc_arith_error (rc), &src->where);
1967 arith_error (rc, &src->ts, &result->ts, &src->where);
1968 gfc_free_expr (result);
1977 /* Convert integers to reals. */
1980 gfc_int2real (gfc_expr *src, int kind)
1985 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
1987 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1989 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1991 arith_error (rc, &src->ts, &result->ts, &src->where);
1992 gfc_free_expr (result);
2000 /* Convert default integer to default complex. */
2003 gfc_int2complex (gfc_expr *src, int kind)
2008 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2010 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2012 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2015 arith_error (rc, &src->ts, &result->ts, &src->where);
2016 gfc_free_expr (result);
2024 /* Convert default real to default integer. */
2027 gfc_real2int (gfc_expr *src, int kind)
2032 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2034 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2036 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2038 arith_error (rc, &src->ts, &result->ts, &src->where);
2039 gfc_free_expr (result);
2047 /* Convert real to real. */
2050 gfc_real2real (gfc_expr *src, int kind)
2055 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2057 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2059 rc = gfc_check_real_range (result->value.real, kind);
2061 if (rc == ARITH_UNDERFLOW)
2063 if (gfc_option.warn_underflow)
2064 gfc_warning (gfc_arith_error (rc), &src->where);
2065 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2067 else if (rc != ARITH_OK)
2069 arith_error (rc, &src->ts, &result->ts, &src->where);
2070 gfc_free_expr (result);
2078 /* Convert real to complex. */
2081 gfc_real2complex (gfc_expr *src, int kind)
2086 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2088 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2090 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2092 if (rc == ARITH_UNDERFLOW)
2094 if (gfc_option.warn_underflow)
2095 gfc_warning (gfc_arith_error (rc), &src->where);
2096 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2098 else if (rc != ARITH_OK)
2100 arith_error (rc, &src->ts, &result->ts, &src->where);
2101 gfc_free_expr (result);
2109 /* Convert complex to integer. */
2112 gfc_complex2int (gfc_expr *src, int kind)
2117 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2119 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2122 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2124 arith_error (rc, &src->ts, &result->ts, &src->where);
2125 gfc_free_expr (result);
2133 /* Convert complex to real. */
2136 gfc_complex2real (gfc_expr *src, int kind)
2141 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2143 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2145 rc = gfc_check_real_range (result->value.real, kind);
2147 if (rc == ARITH_UNDERFLOW)
2149 if (gfc_option.warn_underflow)
2150 gfc_warning (gfc_arith_error (rc), &src->where);
2151 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2155 arith_error (rc, &src->ts, &result->ts, &src->where);
2156 gfc_free_expr (result);
2164 /* Convert complex to complex. */
2167 gfc_complex2complex (gfc_expr *src, int kind)
2172 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2174 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2176 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2178 if (rc == ARITH_UNDERFLOW)
2180 if (gfc_option.warn_underflow)
2181 gfc_warning (gfc_arith_error (rc), &src->where);
2182 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2184 else if (rc != ARITH_OK)
2186 arith_error (rc, &src->ts, &result->ts, &src->where);
2187 gfc_free_expr (result);
2191 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2193 if (rc == ARITH_UNDERFLOW)
2195 if (gfc_option.warn_underflow)
2196 gfc_warning (gfc_arith_error (rc), &src->where);
2197 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2199 else if (rc != ARITH_OK)
2201 arith_error (rc, &src->ts, &result->ts, &src->where);
2202 gfc_free_expr (result);
2210 /* Logical kind conversion. */
2213 gfc_log2log (gfc_expr *src, int kind)
2217 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2218 result->value.logical = src->value.logical;
2224 /* Convert logical to integer. */
2227 gfc_log2int (gfc_expr *src, int kind)
2231 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2232 mpz_set_si (result->value.integer, src->value.logical);
2238 /* Convert integer to logical. */
2241 gfc_int2log (gfc_expr *src, int kind)
2245 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2246 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2252 /* Helper function to set the representation in a Hollerith conversion.
2253 This assumes that the ts.type and ts.kind of the result have already
2257 hollerith2representation (gfc_expr *result, gfc_expr *src)
2259 int src_len, result_len;
2261 src_len = src->representation.length;
2262 result_len = gfc_target_expr_size (result);
2264 if (src_len > result_len)
2266 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2267 &src->where, gfc_typename(&result->ts));
2270 result->representation.string = XCNEWVEC (char, result_len + 1);
2271 memcpy (result->representation.string, src->representation.string,
2272 MIN (result_len, src_len));
2274 if (src_len < result_len)
2275 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2277 result->representation.string[result_len] = '\0'; /* For debugger */
2278 result->representation.length = result_len;
2282 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2285 gfc_hollerith2int (gfc_expr *src, int kind)
2288 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2290 hollerith2representation (result, src);
2291 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2292 result->representation.length, result->value.integer);
2298 /* Convert Hollerith to real. The constant will be padded or truncated. */
2301 gfc_hollerith2real (gfc_expr *src, int kind)
2304 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2306 hollerith2representation (result, src);
2307 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2308 result->representation.length, result->value.real);
2314 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2317 gfc_hollerith2complex (gfc_expr *src, int kind)
2320 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2322 hollerith2representation (result, src);
2323 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2324 result->representation.length, result->value.complex);
2330 /* Convert Hollerith to character. */
2333 gfc_hollerith2character (gfc_expr *src, int kind)
2337 result = gfc_copy_expr (src);
2338 result->ts.type = BT_CHARACTER;
2339 result->ts.kind = kind;
2341 result->value.character.length = result->representation.length;
2342 result->value.character.string
2343 = gfc_char_to_widechar (result->representation.string);
2349 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2352 gfc_hollerith2logical (gfc_expr *src, int kind)
2355 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2357 hollerith2representation (result, src);
2358 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2359 result->representation.length, &result->value.logical);