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
)
787 extern bool init_flag
;
790 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
792 switch (op2
->ts
.type
)
795 power_sign
= mpz_sgn (op2
->value
.integer
);
799 /* Handle something to the zeroth power. Since we're dealing
800 with integral exponents, there is no ambiguity in the
801 limiting procedure used to determine the value of 0**0. */
802 switch (op1
->ts
.type
)
805 mpz_set_ui (result
->value
.integer
, 1);
809 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
813 mpc_set_ui (result
->value
.complex, 1, GFC_MPC_RND_MODE
);
817 gfc_internal_error ("arith_power(): Bad base");
822 switch (op1
->ts
.type
)
828 /* First, we simplify the cases of op1 == 1, 0 or -1. */
829 if (mpz_cmp_si (op1
->value
.integer
, 1) == 0)
832 mpz_set_si (result
->value
.integer
, 1);
834 else if (mpz_cmp_si (op1
->value
.integer
, 0) == 0)
836 /* 0**op2 == 0, if op2 > 0
837 0**op2 overflow, if op2 < 0 ; in that case, we
838 set the result to 0 and return ARITH_DIV0. */
839 mpz_set_si (result
->value
.integer
, 0);
840 if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
843 else if (mpz_cmp_si (op1
->value
.integer
, -1) == 0)
845 /* (-1)**op2 == (-1)**(mod(op2,2)) */
846 unsigned int odd
= mpz_fdiv_ui (op2
->value
.integer
, 2);
848 mpz_set_si (result
->value
.integer
, -1);
850 mpz_set_si (result
->value
.integer
, 1);
852 /* Then, we take care of op2 < 0. */
853 else if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
855 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
856 mpz_set_si (result
->value
.integer
, 0);
858 else if (gfc_extract_int (op2
, &power
) != NULL
)
860 /* If op2 doesn't fit in an int, the exponentiation will
861 overflow, because op2 > 0 and abs(op1) > 1. */
864 i
= gfc_validate_kind (BT_INTEGER
, result
->ts
.kind
, false);
866 if (gfc_option
.flag_range_check
)
869 /* Still, we want to give the same value as the
872 mpz_add_ui (max
, gfc_integer_kinds
[i
].huge
, 1);
873 mpz_mul_ui (max
, max
, 2);
874 mpz_powm (result
->value
.integer
, op1
->value
.integer
,
875 op2
->value
.integer
, max
);
879 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
,
885 mpfr_pow_z (result
->value
.real
, op1
->value
.real
,
886 op2
->value
.integer
, GFC_RND_MODE
);
890 mpc_pow_z (result
->value
.complex, op1
->value
.complex,
891 op2
->value
.integer
, GFC_MPC_RND_MODE
);
904 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
905 "exponent in an initialization "
906 "expression at %L", &op2
->where
) == FAILURE
)
907 return ARITH_PROHIBIT
;
910 if (mpfr_cmp_si (op1
->value
.real
, 0) < 0)
912 gfc_error ("Raising a negative REAL at %L to "
913 "a REAL power is prohibited", &op1
->where
);
915 return ARITH_PROHIBIT
;
918 mpfr_pow (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
926 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
927 "exponent in an initialization "
928 "expression at %L", &op2
->where
) == FAILURE
)
929 return ARITH_PROHIBIT
;
932 mpc_pow (result
->value
.complex, op1
->value
.complex,
933 op2
->value
.complex, GFC_MPC_RND_MODE
);
937 gfc_internal_error ("arith_power(): unknown type");
941 rc
= gfc_range_check (result
);
943 return check_result (rc
, op1
, result
, resultp
);
947 /* Concatenate two string constants. */
950 gfc_arith_concat (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
955 gcc_assert (op1
->ts
.kind
== op2
->ts
.kind
);
956 result
= gfc_get_constant_expr (BT_CHARACTER
, op1
->ts
.kind
,
959 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
961 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
962 result
->value
.character
.length
= len
;
964 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
965 op1
->value
.character
.length
* sizeof (gfc_char_t
));
967 memcpy (&result
->value
.character
.string
[op1
->value
.character
.length
],
968 op2
->value
.character
.string
,
969 op2
->value
.character
.length
* sizeof (gfc_char_t
));
971 result
->value
.character
.string
[len
] = '\0';
978 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
979 This function mimics mpfr_cmp but takes NaN into account. */
982 compare_real (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
988 rc
= mpfr_equal_p (op1
->value
.real
, op2
->value
.real
) ? 0 : 1;
991 rc
= mpfr_greater_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
994 rc
= mpfr_greaterequal_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
997 rc
= mpfr_less_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1000 rc
= mpfr_lessequal_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1003 gfc_internal_error ("compare_real(): Bad operator");
1009 /* Comparison operators. Assumes that the two expression nodes
1010 contain two constants of the same type. The op argument is
1011 needed to handle NaN correctly. */
1014 gfc_compare_expr (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1018 switch (op1
->ts
.type
)
1021 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1025 rc
= compare_real (op1
, op2
, op
);
1029 rc
= gfc_compare_string (op1
, op2
);
1033 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1034 || (op1
->value
.logical
&& !op2
->value
.logical
));
1038 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1045 /* Compare a pair of complex numbers. Naturally, this is only for
1046 equality and inequality. */
1049 compare_complex (gfc_expr
*op1
, gfc_expr
*op2
)
1051 return mpc_cmp (op1
->value
.complex, op2
->value
.complex) == 0;
1055 /* Given two constant strings and the inverse collating sequence, compare the
1056 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1057 We use the processor's default collating sequence. */
1060 gfc_compare_string (gfc_expr
*a
, gfc_expr
*b
)
1062 int len
, alen
, blen
, i
;
1065 alen
= a
->value
.character
.length
;
1066 blen
= b
->value
.character
.length
;
1068 len
= MAX(alen
, blen
);
1070 for (i
= 0; i
< len
; i
++)
1072 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1073 bc
= ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1081 /* Strings are equal */
1087 gfc_compare_with_Cstring (gfc_expr
*a
, const char *b
, bool case_sensitive
)
1089 int len
, alen
, blen
, i
;
1092 alen
= a
->value
.character
.length
;
1095 len
= MAX(alen
, blen
);
1097 for (i
= 0; i
< len
; i
++)
1099 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1100 bc
= ((i
< blen
) ? b
[i
] : ' ');
1102 if (!case_sensitive
)
1114 /* Strings are equal */
1119 /* Specific comparison subroutines. */
1122 gfc_arith_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1126 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1128 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1129 ? compare_complex (op1
, op2
)
1130 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) == 0);
1138 gfc_arith_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1142 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1144 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1145 ? !compare_complex (op1
, op2
)
1146 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) != 0);
1154 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1158 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1160 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GT
) > 0);
1168 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1172 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1174 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GE
) >= 0);
1182 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1186 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1188 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LT
) < 0);
1196 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1200 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1202 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LE
) <= 0);
1210 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1213 gfc_constructor_base head
;
1218 if (op
->expr_type
== EXPR_CONSTANT
)
1219 return eval (op
, result
);
1222 head
= gfc_constructor_copy (op
->value
.constructor
);
1223 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1225 rc
= reduce_unary (eval
, c
->expr
, &r
);
1230 gfc_replace_expr (c
->expr
, r
);
1234 gfc_constructor_free (head
);
1237 gfc_constructor
*c
= gfc_constructor_first (head
);
1238 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1240 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1242 r
->value
.constructor
= head
;
1251 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1252 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1254 gfc_constructor_base head
;
1257 arith rc
= ARITH_OK
;
1259 head
= gfc_constructor_copy (op1
->value
.constructor
);
1260 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1262 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1263 rc
= eval (c
->expr
, op2
, &r
);
1265 rc
= reduce_binary_ac (eval
, c
->expr
, op2
, &r
);
1270 gfc_replace_expr (c
->expr
, r
);
1274 gfc_constructor_free (head
);
1277 gfc_constructor
*c
= gfc_constructor_first (head
);
1278 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1280 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1281 r
->rank
= op1
->rank
;
1282 r
->value
.constructor
= head
;
1291 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1292 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1294 gfc_constructor_base head
;
1297 arith rc
= ARITH_OK
;
1299 head
= gfc_constructor_copy (op2
->value
.constructor
);
1300 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1302 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1303 rc
= eval (op1
, c
->expr
, &r
);
1305 rc
= reduce_binary_ca (eval
, op1
, c
->expr
, &r
);
1310 gfc_replace_expr (c
->expr
, r
);
1314 gfc_constructor_free (head
);
1317 gfc_constructor
*c
= gfc_constructor_first (head
);
1318 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1320 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1321 r
->rank
= op2
->rank
;
1322 r
->value
.constructor
= head
;
1330 /* We need a forward declaration of reduce_binary. */
1331 static arith
reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1332 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
);
1336 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1337 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1339 gfc_constructor_base head
;
1340 gfc_constructor
*c
, *d
;
1342 arith rc
= ARITH_OK
;
1344 if (gfc_check_conformance (op1
, op2
,
1345 "elemental binary operation") != SUCCESS
)
1346 return ARITH_INCOMMENSURATE
;
1348 head
= gfc_constructor_copy (op1
->value
.constructor
);
1349 for (c
= gfc_constructor_first (head
),
1350 d
= gfc_constructor_first (op2
->value
.constructor
);
1352 c
= gfc_constructor_next (c
), d
= gfc_constructor_next (d
))
1354 rc
= reduce_binary (eval
, c
->expr
, d
->expr
, &r
);
1358 gfc_replace_expr (c
->expr
, r
);
1362 rc
= ARITH_INCOMMENSURATE
;
1365 gfc_constructor_free (head
);
1368 gfc_constructor
*c
= gfc_constructor_first (head
);
1369 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1371 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1372 r
->rank
= op1
->rank
;
1373 r
->value
.constructor
= head
;
1382 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1383 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1385 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1386 return eval (op1
, op2
, result
);
1388 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1389 return reduce_binary_ca (eval
, op1
, op2
, result
);
1391 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1392 return reduce_binary_ac (eval
, op1
, op2
, result
);
1394 return reduce_binary_aa (eval
, op1
, op2
, result
);
1400 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1401 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1405 /* High level arithmetic subroutines. These subroutines go into
1406 eval_intrinsic(), which can do one of several things to its
1407 operands. If the operands are incompatible with the intrinsic
1408 operation, we return a node pointing to the operands and hope that
1409 an operator interface is found during resolution.
1411 If the operands are compatible and are constants, then we try doing
1412 the arithmetic. We also handle the cases where either or both
1413 operands are array constructors. */
1416 eval_intrinsic (gfc_intrinsic_op op
,
1417 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1419 gfc_expr temp
, *result
;
1423 gfc_clear_ts (&temp
.ts
);
1429 if (op1
->ts
.type
!= BT_LOGICAL
)
1432 temp
.ts
.type
= BT_LOGICAL
;
1433 temp
.ts
.kind
= gfc_default_logical_kind
;
1437 /* Logical binary operators */
1440 case INTRINSIC_NEQV
:
1442 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1445 temp
.ts
.type
= BT_LOGICAL
;
1446 temp
.ts
.kind
= gfc_default_logical_kind
;
1451 case INTRINSIC_UPLUS
:
1452 case INTRINSIC_UMINUS
:
1453 if (!gfc_numeric_ts (&op1
->ts
))
1460 case INTRINSIC_PARENTHESES
:
1465 /* Additional restrictions for ordering relations. */
1467 case INTRINSIC_GE_OS
:
1469 case INTRINSIC_LT_OS
:
1471 case INTRINSIC_LE_OS
:
1473 case INTRINSIC_GT_OS
:
1474 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1476 temp
.ts
.type
= BT_LOGICAL
;
1477 temp
.ts
.kind
= gfc_default_logical_kind
;
1483 case INTRINSIC_EQ_OS
:
1485 case INTRINSIC_NE_OS
:
1486 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1489 temp
.ts
.type
= BT_LOGICAL
;
1490 temp
.ts
.kind
= gfc_default_logical_kind
;
1492 /* If kind mismatch, exit and we'll error out later. */
1493 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1500 /* Numeric binary */
1501 case INTRINSIC_PLUS
:
1502 case INTRINSIC_MINUS
:
1503 case INTRINSIC_TIMES
:
1504 case INTRINSIC_DIVIDE
:
1505 case INTRINSIC_POWER
:
1506 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1509 /* Insert any necessary type conversions to make the operands
1512 temp
.expr_type
= EXPR_OP
;
1513 gfc_clear_ts (&temp
.ts
);
1514 temp
.value
.op
.op
= op
;
1516 temp
.value
.op
.op1
= op1
;
1517 temp
.value
.op
.op2
= op2
;
1519 gfc_type_convert_binary (&temp
, 0);
1521 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
1522 || op
== INTRINSIC_GE
|| op
== INTRINSIC_GT
1523 || op
== INTRINSIC_LE
|| op
== INTRINSIC_LT
1524 || op
== INTRINSIC_EQ_OS
|| op
== INTRINSIC_NE_OS
1525 || op
== INTRINSIC_GE_OS
|| op
== INTRINSIC_GT_OS
1526 || op
== INTRINSIC_LE_OS
|| op
== INTRINSIC_LT_OS
)
1528 temp
.ts
.type
= BT_LOGICAL
;
1529 temp
.ts
.kind
= gfc_default_logical_kind
;
1535 /* Character binary */
1536 case INTRINSIC_CONCAT
:
1537 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1538 || op1
->ts
.kind
!= op2
->ts
.kind
)
1541 temp
.ts
.type
= BT_CHARACTER
;
1542 temp
.ts
.kind
= op1
->ts
.kind
;
1546 case INTRINSIC_USER
:
1550 gfc_internal_error ("eval_intrinsic(): Bad operator");
1553 if (op1
->expr_type
!= EXPR_CONSTANT
1554 && (op1
->expr_type
!= EXPR_ARRAY
1555 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
)))
1559 && op2
->expr_type
!= EXPR_CONSTANT
1560 && (op2
->expr_type
!= EXPR_ARRAY
1561 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))
1565 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1567 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1570 /* Something went wrong. */
1571 if (op
== INTRINSIC_POWER
&& rc
== ARITH_PROHIBIT
)
1576 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1580 gfc_free_expr (op1
);
1581 gfc_free_expr (op2
);
1585 /* Create a run-time expression. */
1586 result
= gfc_get_operator_expr (&op1
->where
, op
, op1
, op2
);
1587 result
->ts
= temp
.ts
;
1593 /* Modify type of expression for zero size array. */
1596 eval_type_intrinsic0 (gfc_intrinsic_op iop
, gfc_expr
*op
)
1599 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1604 case INTRINSIC_GE_OS
:
1606 case INTRINSIC_LT_OS
:
1608 case INTRINSIC_LE_OS
:
1610 case INTRINSIC_GT_OS
:
1612 case INTRINSIC_EQ_OS
:
1614 case INTRINSIC_NE_OS
:
1615 op
->ts
.type
= BT_LOGICAL
;
1616 op
->ts
.kind
= gfc_default_logical_kind
;
1627 /* Return nonzero if the expression is a zero size array. */
1630 gfc_zero_size_array (gfc_expr
*e
)
1632 if (e
->expr_type
!= EXPR_ARRAY
)
1635 return e
->value
.constructor
== NULL
;
1639 /* Reduce a binary expression where at least one of the operands
1640 involves a zero-length array. Returns NULL if neither of the
1641 operands is a zero-length array. */
1644 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1646 if (gfc_zero_size_array (op1
))
1648 gfc_free_expr (op2
);
1652 if (gfc_zero_size_array (op2
))
1654 gfc_free_expr (op1
);
1663 eval_intrinsic_f2 (gfc_intrinsic_op op
,
1664 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1665 gfc_expr
*op1
, gfc_expr
*op2
)
1672 if (gfc_zero_size_array (op1
))
1673 return eval_type_intrinsic0 (op
, op1
);
1677 result
= reduce_binary0 (op1
, op2
);
1679 return eval_type_intrinsic0 (op
, result
);
1683 return eval_intrinsic (op
, f
, op1
, op2
);
1688 eval_intrinsic_f3 (gfc_intrinsic_op op
,
1689 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1690 gfc_expr
*op1
, gfc_expr
*op2
)
1695 result
= reduce_binary0 (op1
, op2
);
1697 return eval_type_intrinsic0(op
, result
);
1700 return eval_intrinsic (op
, f
, op1
, op2
);
1705 gfc_parentheses (gfc_expr
*op
)
1707 if (gfc_is_constant_expr (op
))
1710 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES
, gfc_arith_identity
,
1715 gfc_uplus (gfc_expr
*op
)
1717 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_identity
, op
, NULL
);
1722 gfc_uminus (gfc_expr
*op
)
1724 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1729 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1731 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1736 gfc_subtract (gfc_expr
*op1
, gfc_expr
*op2
)
1738 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1743 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1745 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1750 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1752 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1757 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1759 return eval_intrinsic_f3 (INTRINSIC_POWER
, arith_power
, op1
, op2
);
1764 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1766 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1771 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1773 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1778 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1780 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1785 gfc_not (gfc_expr
*op1
)
1787 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1792 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1794 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1799 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1801 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1806 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1808 return eval_intrinsic_f3 (op
, gfc_arith_eq
, op1
, op2
);
1813 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1815 return eval_intrinsic_f3 (op
, gfc_arith_ne
, op1
, op2
);
1820 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1822 return eval_intrinsic_f3 (op
, gfc_arith_gt
, op1
, op2
);
1827 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1829 return eval_intrinsic_f3 (op
, gfc_arith_ge
, op1
, op2
);
1834 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1836 return eval_intrinsic_f3 (op
, gfc_arith_lt
, op1
, op2
);
1841 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1843 return eval_intrinsic_f3 (op
, gfc_arith_le
, op1
, op2
);
1847 /* Convert an integer string to an expression node. */
1850 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
1855 e
= gfc_get_constant_expr (BT_INTEGER
, kind
, where
);
1856 /* A leading plus is allowed, but not by mpz_set_str. */
1857 if (buffer
[0] == '+')
1861 mpz_set_str (e
->value
.integer
, t
, radix
);
1867 /* Convert a real string to an expression node. */
1870 gfc_convert_real (const char *buffer
, int kind
, locus
*where
)
1874 e
= gfc_get_constant_expr (BT_REAL
, kind
, where
);
1875 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1881 /* Convert a pair of real, constant expression nodes to a single
1882 complex expression node. */
1885 gfc_convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
1889 e
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &real
->where
);
1890 mpc_set_fr_fr (e
->value
.complex, real
->value
.real
, imag
->value
.real
,
1897 /******* Simplification of intrinsic functions with constant arguments *****/
1900 /* Deal with an arithmetic error. */
1903 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
1908 gfc_error ("Arithmetic OK converting %s to %s at %L",
1909 gfc_typename (from
), gfc_typename (to
), where
);
1911 case ARITH_OVERFLOW
:
1912 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1913 "can be disabled with the option -fno-range-check",
1914 gfc_typename (from
), gfc_typename (to
), where
);
1916 case ARITH_UNDERFLOW
:
1917 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1918 "can be disabled with the option -fno-range-check",
1919 gfc_typename (from
), gfc_typename (to
), where
);
1922 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1923 "can be disabled with the option -fno-range-check",
1924 gfc_typename (from
), gfc_typename (to
), where
);
1927 gfc_error ("Division by zero converting %s to %s at %L",
1928 gfc_typename (from
), gfc_typename (to
), where
);
1930 case ARITH_INCOMMENSURATE
:
1931 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1932 gfc_typename (from
), gfc_typename (to
), where
);
1934 case ARITH_ASYMMETRIC
:
1935 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1936 " converting %s to %s at %L",
1937 gfc_typename (from
), gfc_typename (to
), where
);
1940 gfc_internal_error ("gfc_arith_error(): Bad error code");
1943 /* TODO: Do something about the error, i.e., throw exception, return
1948 /* Convert integers to integers. */
1951 gfc_int2int (gfc_expr
*src
, int kind
)
1956 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
1958 mpz_set (result
->value
.integer
, src
->value
.integer
);
1960 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
1962 if (rc
== ARITH_ASYMMETRIC
)
1964 gfc_warning (gfc_arith_error (rc
), &src
->where
);
1968 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1969 gfc_free_expr (result
);
1978 /* Convert integers to reals. */
1981 gfc_int2real (gfc_expr
*src
, int kind
)
1986 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
1988 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
1990 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
1992 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1993 gfc_free_expr (result
);
2001 /* Convert default integer to default complex. */
2004 gfc_int2complex (gfc_expr
*src
, int kind
)
2009 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2011 mpc_set_z (result
->value
.complex, src
->value
.integer
, GFC_MPC_RND_MODE
);
2013 if ((rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
))
2016 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2017 gfc_free_expr (result
);
2025 /* Convert default real to default integer. */
2028 gfc_real2int (gfc_expr
*src
, int kind
)
2033 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2035 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
, &src
->where
);
2037 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2039 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2040 gfc_free_expr (result
);
2048 /* Convert real to real. */
2051 gfc_real2real (gfc_expr
*src
, int kind
)
2056 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2058 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2060 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2062 if (rc
== ARITH_UNDERFLOW
)
2064 if (gfc_option
.warn_underflow
)
2065 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2066 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2068 else if (rc
!= ARITH_OK
)
2070 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2071 gfc_free_expr (result
);
2079 /* Convert real to complex. */
2082 gfc_real2complex (gfc_expr
*src
, int kind
)
2087 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2089 mpc_set_fr (result
->value
.complex, src
->value
.real
, GFC_MPC_RND_MODE
);
2091 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2093 if (rc
== ARITH_UNDERFLOW
)
2095 if (gfc_option
.warn_underflow
)
2096 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2097 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2099 else if (rc
!= ARITH_OK
)
2101 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2102 gfc_free_expr (result
);
2110 /* Convert complex to integer. */
2113 gfc_complex2int (gfc_expr
*src
, int kind
)
2118 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2120 gfc_mpfr_to_mpz (result
->value
.integer
, mpc_realref (src
->value
.complex),
2123 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2125 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2126 gfc_free_expr (result
);
2134 /* Convert complex to real. */
2137 gfc_complex2real (gfc_expr
*src
, int kind
)
2142 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2144 mpc_real (result
->value
.real
, src
->value
.complex, GFC_RND_MODE
);
2146 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2148 if (rc
== ARITH_UNDERFLOW
)
2150 if (gfc_option
.warn_underflow
)
2151 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2152 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2156 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2157 gfc_free_expr (result
);
2165 /* Convert complex to complex. */
2168 gfc_complex2complex (gfc_expr
*src
, int kind
)
2173 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2175 mpc_set (result
->value
.complex, src
->value
.complex, GFC_MPC_RND_MODE
);
2177 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2179 if (rc
== ARITH_UNDERFLOW
)
2181 if (gfc_option
.warn_underflow
)
2182 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2183 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2185 else if (rc
!= ARITH_OK
)
2187 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2188 gfc_free_expr (result
);
2192 rc
= gfc_check_real_range (mpc_imagref (result
->value
.complex), kind
);
2194 if (rc
== ARITH_UNDERFLOW
)
2196 if (gfc_option
.warn_underflow
)
2197 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2198 mpfr_set_ui (mpc_imagref (result
->value
.complex), 0, GFC_RND_MODE
);
2200 else if (rc
!= ARITH_OK
)
2202 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2203 gfc_free_expr (result
);
2211 /* Logical kind conversion. */
2214 gfc_log2log (gfc_expr
*src
, int kind
)
2218 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2219 result
->value
.logical
= src
->value
.logical
;
2225 /* Convert logical to integer. */
2228 gfc_log2int (gfc_expr
*src
, int kind
)
2232 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2233 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2239 /* Convert integer to logical. */
2242 gfc_int2log (gfc_expr
*src
, int kind
)
2246 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2247 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2253 /* Helper function to set the representation in a Hollerith conversion.
2254 This assumes that the ts.type and ts.kind of the result have already
2258 hollerith2representation (gfc_expr
*result
, gfc_expr
*src
)
2260 int src_len
, result_len
;
2262 src_len
= src
->representation
.length
;
2263 result_len
= gfc_target_expr_size (result
);
2265 if (src_len
> result_len
)
2267 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2268 &src
->where
, gfc_typename(&result
->ts
));
2271 result
->representation
.string
= XCNEWVEC (char, result_len
+ 1);
2272 memcpy (result
->representation
.string
, src
->representation
.string
,
2273 MIN (result_len
, src_len
));
2275 if (src_len
< result_len
)
2276 memset (&result
->representation
.string
[src_len
], ' ', result_len
- src_len
);
2278 result
->representation
.string
[result_len
] = '\0'; /* For debugger */
2279 result
->representation
.length
= result_len
;
2283 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2286 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2289 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2291 hollerith2representation (result
, src
);
2292 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2293 result
->representation
.length
, result
->value
.integer
);
2299 /* Convert Hollerith to real. The constant will be padded or truncated. */
2302 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2305 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2307 hollerith2representation (result
, src
);
2308 gfc_interpret_float (kind
, (unsigned char *) result
->representation
.string
,
2309 result
->representation
.length
, result
->value
.real
);
2315 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2318 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2321 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2323 hollerith2representation (result
, src
);
2324 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2325 result
->representation
.length
, result
->value
.complex);
2331 /* Convert Hollerith to character. */
2334 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2338 result
= gfc_copy_expr (src
);
2339 result
->ts
.type
= BT_CHARACTER
;
2340 result
->ts
.kind
= kind
;
2342 result
->value
.character
.length
= result
->representation
.length
;
2343 result
->value
.character
.string
2344 = gfc_char_to_widechar (result
->representation
.string
);
2350 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2353 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2356 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2358 hollerith2representation (result
, src
);
2359 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2360 result
->representation
.length
, &result
->value
.logical
);