2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* Since target arithmetic must be done on the host, there has to
22 be some way of evaluating arithmetic expressions as the host
23 would evaluate them. We use the GNU MP library and the MPFR
24 library to do arithmetic, and this file provides the interface. */
28 #include "coretypes.h"
32 #include "target-memory.h"
33 #include "constructor.h"
35 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
36 It's easily implemented with a few calls though. */
39 gfc_mpfr_to_mpz (mpz_t z
, mpfr_t x
, locus
*where
)
43 if (mpfr_inf_p (x
) || mpfr_nan_p (x
))
45 gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
51 e
= mpfr_get_z_exp (z
, x
);
54 mpz_mul_2exp (z
, z
, e
);
56 mpz_tdiv_q_2exp (z
, z
, -e
);
60 /* Set the model number precision by the requested KIND. */
63 gfc_set_model_kind (int kind
)
65 int index
= gfc_validate_kind (BT_REAL
, kind
, false);
68 base2prec
= gfc_real_kinds
[index
].digits
;
69 if (gfc_real_kinds
[index
].radix
!= 2)
70 base2prec
*= gfc_real_kinds
[index
].radix
/ 2;
71 mpfr_set_default_prec (base2prec
);
75 /* Set the model number precision from mpfr_t x. */
78 gfc_set_model (mpfr_t x
)
80 mpfr_set_default_prec (mpfr_get_prec (x
));
84 /* Given an arithmetic error code, return a pointer to a string that
85 explains the error. */
88 gfc_arith_error (arith code
)
95 p
= _("Arithmetic OK at %L");
98 p
= _("Arithmetic overflow at %L");
100 case ARITH_UNDERFLOW
:
101 p
= _("Arithmetic underflow at %L");
104 p
= _("Arithmetic NaN at %L");
107 p
= _("Division by zero at %L");
109 case ARITH_INCOMMENSURATE
:
110 p
= _("Array operands are incommensurate at %L");
112 case ARITH_ASYMMETRIC
:
114 _("Integer outside symmetric range implied by Standard Fortran at %L");
116 case ARITH_WRONGCONCAT
:
118 _("Illegal type in character concatenation at %L");
122 gfc_internal_error ("gfc_arith_error(): Bad error code");
129 /* Get things ready to do math. */
132 gfc_arith_init_1 (void)
134 gfc_integer_info
*int_info
;
135 gfc_real_info
*real_info
;
139 mpfr_set_default_prec (128);
142 /* Convert the minimum and maximum values for each kind into their
143 GNU MP representation. */
144 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
147 mpz_init (int_info
->huge
);
148 mpz_set_ui (int_info
->huge
, int_info
->radix
);
149 mpz_pow_ui (int_info
->huge
, int_info
->huge
, int_info
->digits
);
150 mpz_sub_ui (int_info
->huge
, int_info
->huge
, 1);
152 /* These are the numbers that are actually representable by the
153 target. For bases other than two, this needs to be changed. */
154 if (int_info
->radix
!= 2)
155 gfc_internal_error ("Fix min_int calculation");
157 /* See PRs 13490 and 17912, related to integer ranges.
158 The pedantic_min_int exists for range checking when a program
159 is compiled with -pedantic, and reflects the belief that
160 Standard Fortran requires integers to be symmetrical, i.e.
161 every negative integer must have a representable positive
162 absolute value, and vice versa. */
164 mpz_init (int_info
->pedantic_min_int
);
165 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
167 mpz_init (int_info
->min_int
);
168 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
171 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
172 mpfr_log10 (a
, a
, GFC_RND_MODE
);
174 int_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
179 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
181 gfc_set_model_kind (real_info
->kind
);
186 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
188 mpfr_init (real_info
->huge
);
189 mpfr_set_ui (real_info
->huge
, 1, GFC_RND_MODE
);
190 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
191 mpfr_pow_si (a
, a
, -real_info
->digits
, GFC_RND_MODE
);
192 mpfr_sub (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
195 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
196 mpfr_pow_ui (a
, a
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
198 /* (1 - b**(-p)) * b**(emax-1) */
199 mpfr_mul (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
201 /* (1 - b**(-p)) * b**(emax-1) * b */
202 mpfr_mul_ui (real_info
->huge
, real_info
->huge
, real_info
->radix
,
205 /* tiny(x) = b**(emin-1) */
206 mpfr_init (real_info
->tiny
);
207 mpfr_set_ui (real_info
->tiny
, real_info
->radix
, GFC_RND_MODE
);
208 mpfr_pow_si (real_info
->tiny
, real_info
->tiny
,
209 real_info
->min_exponent
- 1, GFC_RND_MODE
);
211 /* subnormal (x) = b**(emin - digit) */
212 mpfr_init (real_info
->subnormal
);
213 mpfr_set_ui (real_info
->subnormal
, real_info
->radix
, GFC_RND_MODE
);
214 mpfr_pow_si (real_info
->subnormal
, real_info
->subnormal
,
215 real_info
->min_exponent
- real_info
->digits
, GFC_RND_MODE
);
217 /* epsilon(x) = b**(1-p) */
218 mpfr_init (real_info
->epsilon
);
219 mpfr_set_ui (real_info
->epsilon
, real_info
->radix
, GFC_RND_MODE
);
220 mpfr_pow_si (real_info
->epsilon
, real_info
->epsilon
,
221 1 - real_info
->digits
, GFC_RND_MODE
);
223 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
224 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
225 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
226 mpfr_neg (b
, b
, GFC_RND_MODE
);
229 mpfr_min (a
, a
, b
, GFC_RND_MODE
);
231 real_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
233 /* precision(x) = int((p - 1) * log10(b)) + k */
234 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
235 mpfr_log10 (a
, a
, GFC_RND_MODE
);
236 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
238 real_info
->precision
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
240 /* If the radix is an integral power of 10, add one to the precision. */
241 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
242 if (i
== real_info
->radix
)
243 real_info
->precision
++;
245 mpfr_clears (a
, b
, NULL
);
250 /* Clean up, get rid of numeric constants. */
253 gfc_arith_done_1 (void)
255 gfc_integer_info
*ip
;
258 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
260 mpz_clear (ip
->min_int
);
261 mpz_clear (ip
->pedantic_min_int
);
262 mpz_clear (ip
->huge
);
265 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
266 mpfr_clears (rp
->epsilon
, rp
->huge
, rp
->tiny
, rp
->subnormal
, NULL
);
272 /* Given a wide character value and a character kind, determine whether
273 the character is representable for that kind. */
275 gfc_check_character_range (gfc_char_t c
, int kind
)
277 /* As wide characters are stored as 32-bit values, they're all
278 representable in UCS=4. */
283 return c
<= 255 ? true : false;
289 /* Given an integer and a kind, make sure that the integer lies within
290 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
294 gfc_check_integer_range (mpz_t p
, int kind
)
299 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
304 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
305 result
= ARITH_ASYMMETRIC
;
309 if (flag_range_check
== 0)
312 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
313 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
314 result
= ARITH_OVERFLOW
;
320 /* Given a real and a kind, make sure that the real lies within the
321 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
325 gfc_check_real_range (mpfr_t p
, int kind
)
331 i
= gfc_validate_kind (BT_REAL
, kind
, false);
335 mpfr_abs (q
, p
, GFC_RND_MODE
);
341 if (flag_range_check
!= 0)
342 retval
= ARITH_OVERFLOW
;
344 else if (mpfr_nan_p (p
))
346 if (flag_range_check
!= 0)
349 else if (mpfr_sgn (q
) == 0)
354 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
356 if (flag_range_check
== 0)
357 mpfr_set_inf (p
, mpfr_sgn (p
));
359 retval
= ARITH_OVERFLOW
;
361 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
363 if (flag_range_check
== 0)
365 if (mpfr_sgn (p
) < 0)
367 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
368 mpfr_set_si (q
, -1, GFC_RND_MODE
);
369 mpfr_copysign (p
, p
, q
, GFC_RND_MODE
);
372 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
375 retval
= ARITH_UNDERFLOW
;
377 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
382 /* Save current values of emin and emax. */
383 emin
= mpfr_get_emin ();
384 emax
= mpfr_get_emax ();
386 /* Set emin and emax for the current model number. */
387 en
= gfc_real_kinds
[i
].min_exponent
- gfc_real_kinds
[i
].digits
+ 1;
388 mpfr_set_emin ((mp_exp_t
) en
);
389 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[i
].max_exponent
);
390 mpfr_check_range (q
, 0, GFC_RND_MODE
);
391 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
393 /* Reset emin and emax. */
394 mpfr_set_emin (emin
);
395 mpfr_set_emax (emax
);
397 /* Copy sign if needed. */
398 if (mpfr_sgn (p
) < 0)
399 mpfr_neg (p
, q
, GMP_RNDN
);
401 mpfr_set (p
, q
, GMP_RNDN
);
410 /* Low-level arithmetic functions. All of these subroutines assume
411 that all operands are of the same type and return an operand of the
412 same type. The other thing about these subroutines is that they
413 can fail in various ways -- overflow, underflow, division by zero,
414 zero raised to the zero, etc. */
417 gfc_arith_not (gfc_expr
*op1
, gfc_expr
**resultp
)
421 result
= gfc_get_constant_expr (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
422 result
->value
.logical
= !op1
->value
.logical
;
430 gfc_arith_and (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
434 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
436 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
444 gfc_arith_or (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
448 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
450 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
458 gfc_arith_eqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
462 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
464 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
472 gfc_arith_neqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
476 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
478 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
485 /* Make sure a constant numeric expression is within the range for
486 its type and kind. Note that there's also a gfc_check_range(),
487 but that one deals with the intrinsic RANGE function. */
490 gfc_range_check (gfc_expr
*e
)
498 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
502 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
503 if (rc
== ARITH_UNDERFLOW
)
504 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
505 if (rc
== ARITH_OVERFLOW
)
506 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
508 mpfr_set_nan (e
->value
.real
);
512 rc
= gfc_check_real_range (mpc_realref (e
->value
.complex), e
->ts
.kind
);
513 if (rc
== ARITH_UNDERFLOW
)
514 mpfr_set_ui (mpc_realref (e
->value
.complex), 0, GFC_RND_MODE
);
515 if (rc
== ARITH_OVERFLOW
)
516 mpfr_set_inf (mpc_realref (e
->value
.complex),
517 mpfr_sgn (mpc_realref (e
->value
.complex)));
519 mpfr_set_nan (mpc_realref (e
->value
.complex));
521 rc2
= gfc_check_real_range (mpc_imagref (e
->value
.complex), e
->ts
.kind
);
522 if (rc
== ARITH_UNDERFLOW
)
523 mpfr_set_ui (mpc_imagref (e
->value
.complex), 0, GFC_RND_MODE
);
524 if (rc
== ARITH_OVERFLOW
)
525 mpfr_set_inf (mpc_imagref (e
->value
.complex),
526 mpfr_sgn (mpc_imagref (e
->value
.complex)));
528 mpfr_set_nan (mpc_imagref (e
->value
.complex));
535 gfc_internal_error ("gfc_range_check(): Bad type");
542 /* Several of the following routines use the same set of statements to
543 check the validity of the result. Encapsulate the checking here. */
546 check_result (arith rc
, gfc_expr
*x
, gfc_expr
*r
, gfc_expr
**rp
)
550 if (val
== ARITH_UNDERFLOW
)
553 gfc_warning (OPT_Wunderflow
, gfc_arith_error (val
), &x
->where
);
557 if (val
== ARITH_ASYMMETRIC
)
559 gfc_warning (0, gfc_arith_error (val
), &x
->where
);
563 if (val
== ARITH_OK
|| val
== ARITH_OVERFLOW
)
572 /* It may seem silly to have a subroutine that actually computes the
573 unary plus of a constant, but it prevents us from making exceptions
574 in the code elsewhere. Used for unary plus and parenthesized
578 gfc_arith_identity (gfc_expr
*op1
, gfc_expr
**resultp
)
580 *resultp
= gfc_copy_expr (op1
);
586 gfc_arith_uminus (gfc_expr
*op1
, gfc_expr
**resultp
)
591 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
593 switch (op1
->ts
.type
)
596 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
600 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
604 mpc_neg (result
->value
.complex, op1
->value
.complex, GFC_MPC_RND_MODE
);
608 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
611 rc
= gfc_range_check (result
);
613 return check_result (rc
, op1
, result
, resultp
);
618 gfc_arith_plus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
623 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
625 switch (op1
->ts
.type
)
628 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
632 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
637 mpc_add (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
642 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
645 rc
= gfc_range_check (result
);
647 return check_result (rc
, op1
, result
, resultp
);
652 gfc_arith_minus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
657 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
659 switch (op1
->ts
.type
)
662 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
666 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
671 mpc_sub (result
->value
.complex, op1
->value
.complex,
672 op2
->value
.complex, GFC_MPC_RND_MODE
);
676 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
679 rc
= gfc_range_check (result
);
681 return check_result (rc
, op1
, result
, resultp
);
686 gfc_arith_times (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
691 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
693 switch (op1
->ts
.type
)
696 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
700 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
705 gfc_set_model (mpc_realref (op1
->value
.complex));
706 mpc_mul (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
711 gfc_internal_error ("gfc_arith_times(): Bad basic type");
714 rc
= gfc_range_check (result
);
716 return check_result (rc
, op1
, result
, resultp
);
721 gfc_arith_divide (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
728 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
730 switch (op1
->ts
.type
)
733 if (mpz_sgn (op2
->value
.integer
) == 0)
739 if (warn_integer_division
)
743 mpz_tdiv_qr (result
->value
.integer
, r
, op1
->value
.integer
,
746 if (mpz_cmp_si (r
, 0) != 0)
749 p
= mpz_get_str (NULL
, 10, result
->value
.integer
);
750 gfc_warning_now (OPT_Winteger_division
, "Integer division "
751 "truncated to constant %qs at %L", p
,
758 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
764 if (mpfr_sgn (op2
->value
.real
) == 0 && flag_range_check
== 1)
770 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
775 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0
776 && flag_range_check
== 1)
782 gfc_set_model (mpc_realref (op1
->value
.complex));
783 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0)
785 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
787 mpfr_set_nan (mpc_realref (result
->value
.complex));
788 mpfr_set_nan (mpc_imagref (result
->value
.complex));
791 mpc_div (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
796 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
800 rc
= gfc_range_check (result
);
802 return check_result (rc
, op1
, result
, resultp
);
805 /* Raise a number to a power. */
808 arith_power (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
815 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
817 switch (op2
->ts
.type
)
820 power_sign
= mpz_sgn (op2
->value
.integer
);
824 /* Handle something to the zeroth power. Since we're dealing
825 with integral exponents, there is no ambiguity in the
826 limiting procedure used to determine the value of 0**0. */
827 switch (op1
->ts
.type
)
830 mpz_set_ui (result
->value
.integer
, 1);
834 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
838 mpc_set_ui (result
->value
.complex, 1, GFC_MPC_RND_MODE
);
842 gfc_internal_error ("arith_power(): Bad base");
847 switch (op1
->ts
.type
)
851 /* First, we simplify the cases of op1 == 1, 0 or -1. */
852 if (mpz_cmp_si (op1
->value
.integer
, 1) == 0)
855 mpz_set_si (result
->value
.integer
, 1);
857 else if (mpz_cmp_si (op1
->value
.integer
, 0) == 0)
859 /* 0**op2 == 0, if op2 > 0
860 0**op2 overflow, if op2 < 0 ; in that case, we
861 set the result to 0 and return ARITH_DIV0. */
862 mpz_set_si (result
->value
.integer
, 0);
863 if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
866 else if (mpz_cmp_si (op1
->value
.integer
, -1) == 0)
868 /* (-1)**op2 == (-1)**(mod(op2,2)) */
869 unsigned int odd
= mpz_fdiv_ui (op2
->value
.integer
, 2);
871 mpz_set_si (result
->value
.integer
, -1);
873 mpz_set_si (result
->value
.integer
, 1);
875 /* Then, we take care of op2 < 0. */
876 else if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
878 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
879 mpz_set_si (result
->value
.integer
, 0);
880 if (warn_integer_division
)
881 gfc_warning_now (OPT_Winteger_division
, "Negative "
882 "exponent of integer has zero "
883 "result at %L", &result
->where
);
887 /* We have abs(op1) > 1 and op2 > 1.
888 If op2 > bit_size(op1), we'll have an out-of-range
892 k
= gfc_validate_kind (BT_INTEGER
, op1
->ts
.kind
, false);
893 power
= gfc_integer_kinds
[k
].bit_size
;
894 if (mpz_cmp_si (op2
->value
.integer
, power
) < 0)
896 gfc_extract_int (op2
, &power
);
897 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
,
899 rc
= gfc_range_check (result
);
900 if (rc
== ARITH_OVERFLOW
)
901 gfc_error_now ("Result of exponentiation at %L "
902 "exceeds the range of %s", &op1
->where
,
903 gfc_typename (&(op1
->ts
)));
907 /* Provide a nonsense value to propagate up. */
908 mpz_set (result
->value
.integer
,
909 gfc_integer_kinds
[k
].huge
);
910 mpz_add_ui (result
->value
.integer
,
911 result
->value
.integer
, 1);
919 mpfr_pow_z (result
->value
.real
, op1
->value
.real
,
920 op2
->value
.integer
, GFC_RND_MODE
);
924 mpc_pow_z (result
->value
.complex, op1
->value
.complex,
925 op2
->value
.integer
, GFC_MPC_RND_MODE
);
936 if (gfc_init_expr_flag
)
938 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
939 "exponent in an initialization "
940 "expression at %L", &op2
->where
))
942 gfc_free_expr (result
);
943 return ARITH_PROHIBIT
;
947 if (mpfr_cmp_si (op1
->value
.real
, 0) < 0)
949 gfc_error ("Raising a negative REAL at %L to "
950 "a REAL power is prohibited", &op1
->where
);
951 gfc_free_expr (result
);
952 return ARITH_PROHIBIT
;
955 mpfr_pow (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
961 if (gfc_init_expr_flag
)
963 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
964 "exponent in an initialization "
965 "expression at %L", &op2
->where
))
967 gfc_free_expr (result
);
968 return ARITH_PROHIBIT
;
972 mpc_pow (result
->value
.complex, op1
->value
.complex,
973 op2
->value
.complex, GFC_MPC_RND_MODE
);
977 gfc_internal_error ("arith_power(): unknown type");
981 rc
= gfc_range_check (result
);
983 return check_result (rc
, op1
, result
, resultp
);
987 /* Concatenate two string constants. */
990 gfc_arith_concat (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
995 /* By cleverly playing around with constructors, is is possible
996 to get mismaching types here. */
997 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
998 || op1
->ts
.kind
!= op2
->ts
.kind
)
999 return ARITH_WRONGCONCAT
;
1001 result
= gfc_get_constant_expr (BT_CHARACTER
, op1
->ts
.kind
,
1004 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1006 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
1007 result
->value
.character
.length
= len
;
1009 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1010 op1
->value
.character
.length
* sizeof (gfc_char_t
));
1012 memcpy (&result
->value
.character
.string
[op1
->value
.character
.length
],
1013 op2
->value
.character
.string
,
1014 op2
->value
.character
.length
* sizeof (gfc_char_t
));
1016 result
->value
.character
.string
[len
] = '\0';
1023 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1024 This function mimics mpfr_cmp but takes NaN into account. */
1027 compare_real (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1033 rc
= mpfr_equal_p (op1
->value
.real
, op2
->value
.real
) ? 0 : 1;
1036 rc
= mpfr_greater_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1039 rc
= mpfr_greaterequal_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1042 rc
= mpfr_less_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1045 rc
= mpfr_lessequal_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1048 gfc_internal_error ("compare_real(): Bad operator");
1054 /* Comparison operators. Assumes that the two expression nodes
1055 contain two constants of the same type. The op argument is
1056 needed to handle NaN correctly. */
1059 gfc_compare_expr (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1063 switch (op1
->ts
.type
)
1066 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1070 rc
= compare_real (op1
, op2
, op
);
1074 rc
= gfc_compare_string (op1
, op2
);
1078 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1079 || (op1
->value
.logical
&& !op2
->value
.logical
));
1083 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1090 /* Compare a pair of complex numbers. Naturally, this is only for
1091 equality and inequality. */
1094 compare_complex (gfc_expr
*op1
, gfc_expr
*op2
)
1096 return mpc_cmp (op1
->value
.complex, op2
->value
.complex) == 0;
1100 /* Given two constant strings and the inverse collating sequence, compare the
1101 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1102 We use the processor's default collating sequence. */
1105 gfc_compare_string (gfc_expr
*a
, gfc_expr
*b
)
1107 size_t len
, alen
, blen
, i
;
1110 alen
= a
->value
.character
.length
;
1111 blen
= b
->value
.character
.length
;
1113 len
= MAX(alen
, blen
);
1115 for (i
= 0; i
< len
; i
++)
1117 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1118 bc
= ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1126 /* Strings are equal */
1132 gfc_compare_with_Cstring (gfc_expr
*a
, const char *b
, bool case_sensitive
)
1134 size_t len
, alen
, blen
, i
;
1137 alen
= a
->value
.character
.length
;
1140 len
= MAX(alen
, blen
);
1142 for (i
= 0; i
< len
; i
++)
1144 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1145 bc
= ((i
< blen
) ? b
[i
] : ' ');
1147 if (!case_sensitive
)
1159 /* Strings are equal */
1164 /* Specific comparison subroutines. */
1167 gfc_arith_eq (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
= (op1
->ts
.type
== BT_COMPLEX
)
1174 ? compare_complex (op1
, op2
)
1175 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) == 0);
1183 gfc_arith_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1187 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1189 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1190 ? !compare_complex (op1
, op2
)
1191 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) != 0);
1199 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1203 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1205 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GT
) > 0);
1213 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1217 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1219 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GE
) >= 0);
1227 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1231 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1233 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LT
) < 0);
1241 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1245 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1247 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LE
) <= 0);
1255 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1258 gfc_constructor_base head
;
1263 if (op
->expr_type
== EXPR_CONSTANT
)
1264 return eval (op
, result
);
1267 head
= gfc_constructor_copy (op
->value
.constructor
);
1268 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1270 rc
= reduce_unary (eval
, c
->expr
, &r
);
1275 gfc_replace_expr (c
->expr
, r
);
1279 gfc_constructor_free (head
);
1282 gfc_constructor
*c
= gfc_constructor_first (head
);
1283 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1285 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1287 r
->value
.constructor
= head
;
1296 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1297 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1299 gfc_constructor_base head
;
1302 arith rc
= ARITH_OK
;
1304 head
= gfc_constructor_copy (op1
->value
.constructor
);
1305 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1307 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1308 rc
= eval (c
->expr
, op2
, &r
);
1310 rc
= reduce_binary_ac (eval
, c
->expr
, op2
, &r
);
1315 gfc_replace_expr (c
->expr
, r
);
1319 gfc_constructor_free (head
);
1322 gfc_constructor
*c
= gfc_constructor_first (head
);
1323 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1325 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1326 r
->rank
= op1
->rank
;
1327 r
->value
.constructor
= head
;
1336 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1337 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1339 gfc_constructor_base head
;
1342 arith rc
= ARITH_OK
;
1344 head
= gfc_constructor_copy (op2
->value
.constructor
);
1345 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1347 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1348 rc
= eval (op1
, c
->expr
, &r
);
1350 rc
= reduce_binary_ca (eval
, op1
, c
->expr
, &r
);
1355 gfc_replace_expr (c
->expr
, r
);
1359 gfc_constructor_free (head
);
1362 gfc_constructor
*c
= gfc_constructor_first (head
);
1363 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1365 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1366 r
->rank
= op2
->rank
;
1367 r
->value
.constructor
= head
;
1375 /* We need a forward declaration of reduce_binary. */
1376 static arith
reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1377 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
);
1381 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1382 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1384 gfc_constructor_base head
;
1385 gfc_constructor
*c
, *d
;
1387 arith rc
= ARITH_OK
;
1389 if (!gfc_check_conformance (op1
, op2
, "elemental binary operation"))
1390 return ARITH_INCOMMENSURATE
;
1392 head
= gfc_constructor_copy (op1
->value
.constructor
);
1393 for (c
= gfc_constructor_first (head
),
1394 d
= gfc_constructor_first (op2
->value
.constructor
);
1396 c
= gfc_constructor_next (c
), d
= gfc_constructor_next (d
))
1398 rc
= reduce_binary (eval
, c
->expr
, d
->expr
, &r
);
1402 gfc_replace_expr (c
->expr
, r
);
1406 rc
= ARITH_INCOMMENSURATE
;
1409 gfc_constructor_free (head
);
1412 gfc_constructor
*c
= gfc_constructor_first (head
);
1413 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1415 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1416 r
->rank
= op1
->rank
;
1417 r
->value
.constructor
= head
;
1426 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1427 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1429 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1430 return eval (op1
, op2
, result
);
1432 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1433 return reduce_binary_ca (eval
, op1
, op2
, result
);
1435 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1436 return reduce_binary_ac (eval
, op1
, op2
, result
);
1438 return reduce_binary_aa (eval
, op1
, op2
, result
);
1444 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1445 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1449 /* High level arithmetic subroutines. These subroutines go into
1450 eval_intrinsic(), which can do one of several things to its
1451 operands. If the operands are incompatible with the intrinsic
1452 operation, we return a node pointing to the operands and hope that
1453 an operator interface is found during resolution.
1455 If the operands are compatible and are constants, then we try doing
1456 the arithmetic. We also handle the cases where either or both
1457 operands are array constructors. */
1460 eval_intrinsic (gfc_intrinsic_op op
,
1461 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1463 gfc_expr temp
, *result
;
1467 gfc_clear_ts (&temp
.ts
);
1473 if (op1
->ts
.type
!= BT_LOGICAL
)
1476 temp
.ts
.type
= BT_LOGICAL
;
1477 temp
.ts
.kind
= gfc_default_logical_kind
;
1481 /* Logical binary operators */
1484 case INTRINSIC_NEQV
:
1486 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1489 temp
.ts
.type
= BT_LOGICAL
;
1490 temp
.ts
.kind
= gfc_default_logical_kind
;
1495 case INTRINSIC_UPLUS
:
1496 case INTRINSIC_UMINUS
:
1497 if (!gfc_numeric_ts (&op1
->ts
))
1504 case INTRINSIC_PARENTHESES
:
1509 /* Additional restrictions for ordering relations. */
1511 case INTRINSIC_GE_OS
:
1513 case INTRINSIC_LT_OS
:
1515 case INTRINSIC_LE_OS
:
1517 case INTRINSIC_GT_OS
:
1518 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1520 temp
.ts
.type
= BT_LOGICAL
;
1521 temp
.ts
.kind
= gfc_default_logical_kind
;
1527 case INTRINSIC_EQ_OS
:
1529 case INTRINSIC_NE_OS
:
1530 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1533 temp
.ts
.type
= BT_LOGICAL
;
1534 temp
.ts
.kind
= gfc_default_logical_kind
;
1536 /* If kind mismatch, exit and we'll error out later. */
1537 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1544 /* Numeric binary */
1545 case INTRINSIC_PLUS
:
1546 case INTRINSIC_MINUS
:
1547 case INTRINSIC_TIMES
:
1548 case INTRINSIC_DIVIDE
:
1549 case INTRINSIC_POWER
:
1550 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1553 /* Insert any necessary type conversions to make the operands
1556 temp
.expr_type
= EXPR_OP
;
1557 gfc_clear_ts (&temp
.ts
);
1558 temp
.value
.op
.op
= op
;
1560 temp
.value
.op
.op1
= op1
;
1561 temp
.value
.op
.op2
= op2
;
1563 gfc_type_convert_binary (&temp
, warn_conversion
|| warn_conversion_extra
);
1565 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
1566 || op
== INTRINSIC_GE
|| op
== INTRINSIC_GT
1567 || op
== INTRINSIC_LE
|| op
== INTRINSIC_LT
1568 || op
== INTRINSIC_EQ_OS
|| op
== INTRINSIC_NE_OS
1569 || op
== INTRINSIC_GE_OS
|| op
== INTRINSIC_GT_OS
1570 || op
== INTRINSIC_LE_OS
|| op
== INTRINSIC_LT_OS
)
1572 temp
.ts
.type
= BT_LOGICAL
;
1573 temp
.ts
.kind
= gfc_default_logical_kind
;
1579 /* Character binary */
1580 case INTRINSIC_CONCAT
:
1581 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1582 || op1
->ts
.kind
!= op2
->ts
.kind
)
1585 temp
.ts
.type
= BT_CHARACTER
;
1586 temp
.ts
.kind
= op1
->ts
.kind
;
1590 case INTRINSIC_USER
:
1594 gfc_internal_error ("eval_intrinsic(): Bad operator");
1597 if (op1
->expr_type
!= EXPR_CONSTANT
1598 && (op1
->expr_type
!= EXPR_ARRAY
1599 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
)))
1603 && op2
->expr_type
!= EXPR_CONSTANT
1604 && (op2
->expr_type
!= EXPR_ARRAY
1605 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))
1609 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1611 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1614 /* Something went wrong. */
1615 if (op
== INTRINSIC_POWER
&& rc
== ARITH_PROHIBIT
)
1620 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1621 if (rc
== ARITH_OVERFLOW
)
1628 gfc_free_expr (op1
);
1629 gfc_free_expr (op2
);
1633 /* Create a run-time expression. */
1634 result
= gfc_get_operator_expr (&op1
->where
, op
, op1
, op2
);
1635 result
->ts
= temp
.ts
;
1641 /* Modify type of expression for zero size array. */
1644 eval_type_intrinsic0 (gfc_intrinsic_op iop
, gfc_expr
*op
)
1647 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1652 case INTRINSIC_GE_OS
:
1654 case INTRINSIC_LT_OS
:
1656 case INTRINSIC_LE_OS
:
1658 case INTRINSIC_GT_OS
:
1660 case INTRINSIC_EQ_OS
:
1662 case INTRINSIC_NE_OS
:
1663 op
->ts
.type
= BT_LOGICAL
;
1664 op
->ts
.kind
= gfc_default_logical_kind
;
1675 /* Return nonzero if the expression is a zero size array. */
1678 gfc_zero_size_array (gfc_expr
*e
)
1680 if (e
->expr_type
!= EXPR_ARRAY
)
1683 return e
->value
.constructor
== NULL
;
1687 /* Reduce a binary expression where at least one of the operands
1688 involves a zero-length array. Returns NULL if neither of the
1689 operands is a zero-length array. */
1692 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1694 if (gfc_zero_size_array (op1
))
1696 gfc_free_expr (op2
);
1700 if (gfc_zero_size_array (op2
))
1702 gfc_free_expr (op1
);
1711 eval_intrinsic_f2 (gfc_intrinsic_op op
,
1712 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1713 gfc_expr
*op1
, gfc_expr
*op2
)
1720 if (gfc_zero_size_array (op1
))
1721 return eval_type_intrinsic0 (op
, op1
);
1725 result
= reduce_binary0 (op1
, op2
);
1727 return eval_type_intrinsic0 (op
, result
);
1731 return eval_intrinsic (op
, f
, op1
, op2
);
1736 eval_intrinsic_f3 (gfc_intrinsic_op op
,
1737 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1738 gfc_expr
*op1
, gfc_expr
*op2
)
1743 result
= reduce_binary0 (op1
, op2
);
1745 return eval_type_intrinsic0(op
, result
);
1748 return eval_intrinsic (op
, f
, op1
, op2
);
1753 gfc_parentheses (gfc_expr
*op
)
1755 if (gfc_is_constant_expr (op
))
1758 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES
, gfc_arith_identity
,
1763 gfc_uplus (gfc_expr
*op
)
1765 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_identity
, op
, NULL
);
1770 gfc_uminus (gfc_expr
*op
)
1772 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1777 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1779 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1784 gfc_subtract (gfc_expr
*op1
, gfc_expr
*op2
)
1786 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1791 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1793 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1798 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1800 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1805 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1807 return eval_intrinsic_f3 (INTRINSIC_POWER
, arith_power
, op1
, op2
);
1812 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1814 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1819 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1821 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1826 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1828 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1833 gfc_not (gfc_expr
*op1
)
1835 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1840 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1842 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1847 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1849 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1854 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1856 return eval_intrinsic_f3 (op
, gfc_arith_eq
, op1
, op2
);
1861 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1863 return eval_intrinsic_f3 (op
, gfc_arith_ne
, op1
, op2
);
1868 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1870 return eval_intrinsic_f3 (op
, gfc_arith_gt
, op1
, op2
);
1875 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1877 return eval_intrinsic_f3 (op
, gfc_arith_ge
, op1
, op2
);
1882 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1884 return eval_intrinsic_f3 (op
, gfc_arith_lt
, op1
, op2
);
1889 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1891 return eval_intrinsic_f3 (op
, gfc_arith_le
, op1
, op2
);
1895 /******* Simplification of intrinsic functions with constant arguments *****/
1898 /* Deal with an arithmetic error. */
1901 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
1906 gfc_error ("Arithmetic OK converting %s to %s at %L",
1907 gfc_typename (from
), gfc_typename (to
), where
);
1909 case ARITH_OVERFLOW
:
1910 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1911 "can be disabled with the option %<-fno-range-check%>",
1912 gfc_typename (from
), gfc_typename (to
), where
);
1914 case ARITH_UNDERFLOW
:
1915 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1916 "can be disabled with the option %<-fno-range-check%>",
1917 gfc_typename (from
), gfc_typename (to
), where
);
1920 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1921 "can be disabled with the option %<-fno-range-check%>",
1922 gfc_typename (from
), gfc_typename (to
), where
);
1925 gfc_error ("Division by zero converting %s to %s at %L",
1926 gfc_typename (from
), gfc_typename (to
), where
);
1928 case ARITH_INCOMMENSURATE
:
1929 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1930 gfc_typename (from
), gfc_typename (to
), where
);
1932 case ARITH_ASYMMETRIC
:
1933 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1934 " converting %s to %s at %L",
1935 gfc_typename (from
), gfc_typename (to
), where
);
1938 gfc_internal_error ("gfc_arith_error(): Bad error code");
1941 /* TODO: Do something about the error, i.e., throw exception, return
1945 /* Returns true if significant bits were lost when converting real
1946 constant r from from_kind to to_kind. */
1949 wprecision_real_real (mpfr_t r
, int from_kind
, int to_kind
)
1954 gfc_set_model_kind (to_kind
);
1956 gfc_set_model_kind (from_kind
);
1959 mpfr_set (rv
, r
, GFC_RND_MODE
);
1960 mpfr_sub (diff
, rv
, r
, GFC_RND_MODE
);
1962 ret
= ! mpfr_zero_p (diff
);
1968 /* Return true if conversion from an integer to a real loses precision. */
1971 wprecision_int_real (mpz_t n
, mpfr_t r
)
1976 mpfr_get_z (i
, r
, GFC_RND_MODE
);
1978 ret
= mpz_cmp_si (i
, 0) != 0;
1983 /* Convert integers to integers. */
1986 gfc_int2int (gfc_expr
*src
, int kind
)
1991 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
1993 mpz_set (result
->value
.integer
, src
->value
.integer
);
1995 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
1997 if (rc
== ARITH_ASYMMETRIC
)
1999 gfc_warning (0, gfc_arith_error (rc
), &src
->where
);
2003 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2004 gfc_free_expr (result
);
2009 /* If we do not trap numeric overflow, we need to convert the number to
2010 signed, throwing away high-order bits if necessary. */
2011 if (flag_range_check
== 0)
2015 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
2016 gfc_convert_mpz_to_signed (result
->value
.integer
,
2017 gfc_integer_kinds
[k
].bit_size
);
2019 if (warn_conversion
&& !src
->do_not_warn
&& kind
< src
->ts
.kind
)
2020 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2021 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2028 /* Convert integers to reals. */
2031 gfc_int2real (gfc_expr
*src
, int kind
)
2036 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2038 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2040 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2042 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2043 gfc_free_expr (result
);
2048 && wprecision_int_real (src
->value
.integer
, result
->value
.real
))
2049 gfc_warning (OPT_Wconversion
, "Change of value in conversion "
2050 "from %qs to %qs at %L",
2051 gfc_typename (&src
->ts
),
2052 gfc_typename (&result
->ts
),
2059 /* Convert default integer to default complex. */
2062 gfc_int2complex (gfc_expr
*src
, int kind
)
2067 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2069 mpc_set_z (result
->value
.complex, src
->value
.integer
, GFC_MPC_RND_MODE
);
2071 if ((rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
))
2074 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2075 gfc_free_expr (result
);
2080 && wprecision_int_real (src
->value
.integer
,
2081 mpc_realref (result
->value
.complex)))
2082 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2083 "from %qs to %qs at %L",
2084 gfc_typename (&src
->ts
),
2085 gfc_typename (&result
->ts
),
2092 /* Convert default real to default integer. */
2095 gfc_real2int (gfc_expr
*src
, int kind
)
2099 bool did_warn
= false;
2101 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2103 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
, &src
->where
);
2105 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2107 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2108 gfc_free_expr (result
);
2112 /* If there was a fractional part, warn about this. */
2114 if (warn_conversion
)
2118 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2119 if (mpfr_cmp_si (f
, 0) != 0)
2121 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2122 "from %qs to %qs at %L", gfc_typename (&src
->ts
),
2123 gfc_typename (&result
->ts
), &src
->where
);
2127 if (!did_warn
&& warn_conversion_extra
)
2129 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2130 "at %L", gfc_typename (&src
->ts
),
2131 gfc_typename (&result
->ts
), &src
->where
);
2138 /* Convert real to real. */
2141 gfc_real2real (gfc_expr
*src
, int kind
)
2145 bool did_warn
= false;
2147 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2149 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2151 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2153 if (rc
== ARITH_UNDERFLOW
)
2156 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2157 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2159 else if (rc
!= ARITH_OK
)
2161 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2162 gfc_free_expr (result
);
2166 /* As a special bonus, don't warn about REAL values which are not changed by
2167 the conversion if -Wconversion is specified and -Wconversion-extra is
2170 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2172 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2174 /* Calculate the difference between the constant and the rounded
2175 value and check it against zero. */
2177 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2179 gfc_warning_now (w
, "Change of value in conversion from "
2181 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2183 /* Make sure the conversion warning is not emitted again. */
2188 if (!did_warn
&& warn_conversion_extra
)
2189 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2190 "at %L", gfc_typename(&src
->ts
),
2191 gfc_typename(&result
->ts
), &src
->where
);
2197 /* Convert real to complex. */
2200 gfc_real2complex (gfc_expr
*src
, int kind
)
2204 bool did_warn
= false;
2206 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2208 mpc_set_fr (result
->value
.complex, src
->value
.real
, GFC_MPC_RND_MODE
);
2210 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2212 if (rc
== ARITH_UNDERFLOW
)
2215 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2216 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2218 else if (rc
!= ARITH_OK
)
2220 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2221 gfc_free_expr (result
);
2225 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2227 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2229 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2231 gfc_warning_now (w
, "Change of value in conversion from "
2233 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2235 /* Make sure the conversion warning is not emitted again. */
2240 if (!did_warn
&& warn_conversion_extra
)
2241 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2242 "at %L", gfc_typename(&src
->ts
),
2243 gfc_typename(&result
->ts
), &src
->where
);
2249 /* Convert complex to integer. */
2252 gfc_complex2int (gfc_expr
*src
, int kind
)
2256 bool did_warn
= false;
2258 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2260 gfc_mpfr_to_mpz (result
->value
.integer
, mpc_realref (src
->value
.complex),
2263 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2265 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2266 gfc_free_expr (result
);
2270 if (warn_conversion
|| warn_conversion_extra
)
2272 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2274 /* See if we discarded an imaginary part. */
2275 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2277 gfc_warning_now (w
, "Non-zero imaginary part discarded "
2278 "in conversion from %qs to %qs at %L",
2279 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2288 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2289 if (mpfr_cmp_si (f
, 0) != 0)
2291 gfc_warning_now (w
, "Change of value in conversion from "
2292 "%qs to %qs at %L", gfc_typename (&src
->ts
),
2293 gfc_typename (&result
->ts
), &src
->where
);
2299 if (!did_warn
&& warn_conversion_extra
)
2301 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2302 "at %L", gfc_typename (&src
->ts
),
2303 gfc_typename (&result
->ts
), &src
->where
);
2311 /* Convert complex to real. */
2314 gfc_complex2real (gfc_expr
*src
, int kind
)
2318 bool did_warn
= false;
2320 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2322 mpc_real (result
->value
.real
, src
->value
.complex, GFC_RND_MODE
);
2324 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2326 if (rc
== ARITH_UNDERFLOW
)
2329 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2330 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2334 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2335 gfc_free_expr (result
);
2339 if (warn_conversion
|| warn_conversion_extra
)
2341 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2343 /* See if we discarded an imaginary part. */
2344 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2346 gfc_warning (w
, "Non-zero imaginary part discarded "
2347 "in conversion from %qs to %qs at %L",
2348 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2353 /* Calculate the difference between the real constant and the rounded
2354 value and check it against zero. */
2356 if (kind
> src
->ts
.kind
2357 && wprecision_real_real (mpc_realref (src
->value
.complex),
2358 src
->ts
.kind
, kind
))
2360 gfc_warning_now (w
, "Change of value in conversion from "
2362 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2364 /* Make sure the conversion warning is not emitted again. */
2369 if (!did_warn
&& warn_conversion_extra
)
2370 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2371 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2378 /* Convert complex to complex. */
2381 gfc_complex2complex (gfc_expr
*src
, int kind
)
2385 bool did_warn
= false;
2387 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2389 mpc_set (result
->value
.complex, src
->value
.complex, GFC_MPC_RND_MODE
);
2391 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2393 if (rc
== ARITH_UNDERFLOW
)
2396 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2397 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2399 else if (rc
!= ARITH_OK
)
2401 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2402 gfc_free_expr (result
);
2406 rc
= gfc_check_real_range (mpc_imagref (result
->value
.complex), kind
);
2408 if (rc
== ARITH_UNDERFLOW
)
2411 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2412 mpfr_set_ui (mpc_imagref (result
->value
.complex), 0, GFC_RND_MODE
);
2414 else if (rc
!= ARITH_OK
)
2416 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2417 gfc_free_expr (result
);
2421 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
2422 && (wprecision_real_real (mpc_realref (src
->value
.complex),
2424 || wprecision_real_real (mpc_imagref (src
->value
.complex),
2425 src
->ts
.kind
, kind
)))
2427 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2429 gfc_warning_now (w
, "Change of value in conversion from "
2431 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2436 if (!did_warn
&& warn_conversion_extra
&& src
->ts
.kind
!= kind
)
2437 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2438 "at %L", gfc_typename(&src
->ts
),
2439 gfc_typename (&result
->ts
), &src
->where
);
2445 /* Logical kind conversion. */
2448 gfc_log2log (gfc_expr
*src
, int kind
)
2452 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2453 result
->value
.logical
= src
->value
.logical
;
2459 /* Convert logical to integer. */
2462 gfc_log2int (gfc_expr
*src
, int kind
)
2466 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2467 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2473 /* Convert integer to logical. */
2476 gfc_int2log (gfc_expr
*src
, int kind
)
2480 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2481 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2486 /* Convert character to character. We only use wide strings internally,
2487 so we only set the kind. */
2490 gfc_character2character (gfc_expr
*src
, int kind
)
2493 result
= gfc_copy_expr (src
);
2494 result
->ts
.kind
= kind
;
2499 /* Helper function to set the representation in a Hollerith conversion.
2500 This assumes that the ts.type and ts.kind of the result have already
2504 hollerith2representation (gfc_expr
*result
, gfc_expr
*src
)
2506 size_t src_len
, result_len
;
2508 src_len
= src
->representation
.length
- src
->ts
.u
.pad
;
2509 gfc_target_expr_size (result
, &result_len
);
2511 if (src_len
> result_len
)
2514 "The Hollerith constant at %L is too long to convert to %qs",
2515 &src
->where
, gfc_typename(&result
->ts
));
2518 result
->representation
.string
= XCNEWVEC (char, result_len
+ 1);
2519 memcpy (result
->representation
.string
, src
->representation
.string
,
2520 MIN (result_len
, src_len
));
2522 if (src_len
< result_len
)
2523 memset (&result
->representation
.string
[src_len
], ' ', result_len
- src_len
);
2525 result
->representation
.string
[result_len
] = '\0'; /* For debugger */
2526 result
->representation
.length
= result_len
;
2530 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2533 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2536 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2538 hollerith2representation (result
, src
);
2539 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2540 result
->representation
.length
, result
->value
.integer
);
2546 /* Convert Hollerith to real. The constant will be padded or truncated. */
2549 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2552 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2554 hollerith2representation (result
, src
);
2555 gfc_interpret_float (kind
, (unsigned char *) result
->representation
.string
,
2556 result
->representation
.length
, result
->value
.real
);
2562 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2565 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2568 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2570 hollerith2representation (result
, src
);
2571 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2572 result
->representation
.length
, result
->value
.complex);
2578 /* Convert Hollerith to character. */
2581 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2585 result
= gfc_copy_expr (src
);
2586 result
->ts
.type
= BT_CHARACTER
;
2587 result
->ts
.kind
= kind
;
2588 result
->ts
.u
.pad
= 0;
2590 result
->value
.character
.length
= result
->representation
.length
;
2591 result
->value
.character
.string
2592 = gfc_char_to_widechar (result
->representation
.string
);
2598 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2601 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2604 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2606 hollerith2representation (result
, src
);
2607 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2608 result
->representation
.length
, &result
->value
.logical
);