2 Copyright (C) 2000-2018 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");
117 gfc_internal_error ("gfc_arith_error(): Bad error code");
124 /* Get things ready to do math. */
127 gfc_arith_init_1 (void)
129 gfc_integer_info
*int_info
;
130 gfc_real_info
*real_info
;
134 mpfr_set_default_prec (128);
137 /* Convert the minimum and maximum values for each kind into their
138 GNU MP representation. */
139 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
142 mpz_init (int_info
->huge
);
143 mpz_set_ui (int_info
->huge
, int_info
->radix
);
144 mpz_pow_ui (int_info
->huge
, int_info
->huge
, int_info
->digits
);
145 mpz_sub_ui (int_info
->huge
, int_info
->huge
, 1);
147 /* These are the numbers that are actually representable by the
148 target. For bases other than two, this needs to be changed. */
149 if (int_info
->radix
!= 2)
150 gfc_internal_error ("Fix min_int calculation");
152 /* See PRs 13490 and 17912, related to integer ranges.
153 The pedantic_min_int exists for range checking when a program
154 is compiled with -pedantic, and reflects the belief that
155 Standard Fortran requires integers to be symmetrical, i.e.
156 every negative integer must have a representable positive
157 absolute value, and vice versa. */
159 mpz_init (int_info
->pedantic_min_int
);
160 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
162 mpz_init (int_info
->min_int
);
163 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
166 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
167 mpfr_log10 (a
, a
, GFC_RND_MODE
);
169 int_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
174 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
176 gfc_set_model_kind (real_info
->kind
);
181 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
183 mpfr_init (real_info
->huge
);
184 mpfr_set_ui (real_info
->huge
, 1, GFC_RND_MODE
);
185 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
186 mpfr_pow_si (a
, a
, -real_info
->digits
, GFC_RND_MODE
);
187 mpfr_sub (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
190 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
191 mpfr_pow_ui (a
, a
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
193 /* (1 - b**(-p)) * b**(emax-1) */
194 mpfr_mul (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
196 /* (1 - b**(-p)) * b**(emax-1) * b */
197 mpfr_mul_ui (real_info
->huge
, real_info
->huge
, real_info
->radix
,
200 /* tiny(x) = b**(emin-1) */
201 mpfr_init (real_info
->tiny
);
202 mpfr_set_ui (real_info
->tiny
, real_info
->radix
, GFC_RND_MODE
);
203 mpfr_pow_si (real_info
->tiny
, real_info
->tiny
,
204 real_info
->min_exponent
- 1, GFC_RND_MODE
);
206 /* subnormal (x) = b**(emin - digit) */
207 mpfr_init (real_info
->subnormal
);
208 mpfr_set_ui (real_info
->subnormal
, real_info
->radix
, GFC_RND_MODE
);
209 mpfr_pow_si (real_info
->subnormal
, real_info
->subnormal
,
210 real_info
->min_exponent
- real_info
->digits
, GFC_RND_MODE
);
212 /* epsilon(x) = b**(1-p) */
213 mpfr_init (real_info
->epsilon
);
214 mpfr_set_ui (real_info
->epsilon
, real_info
->radix
, GFC_RND_MODE
);
215 mpfr_pow_si (real_info
->epsilon
, real_info
->epsilon
,
216 1 - real_info
->digits
, GFC_RND_MODE
);
218 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
219 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
220 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
221 mpfr_neg (b
, b
, GFC_RND_MODE
);
224 mpfr_min (a
, a
, b
, GFC_RND_MODE
);
226 real_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
228 /* precision(x) = int((p - 1) * log10(b)) + k */
229 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
230 mpfr_log10 (a
, a
, GFC_RND_MODE
);
231 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
233 real_info
->precision
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
235 /* If the radix is an integral power of 10, add one to the precision. */
236 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
237 if (i
== real_info
->radix
)
238 real_info
->precision
++;
240 mpfr_clears (a
, b
, NULL
);
245 /* Clean up, get rid of numeric constants. */
248 gfc_arith_done_1 (void)
250 gfc_integer_info
*ip
;
253 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
255 mpz_clear (ip
->min_int
);
256 mpz_clear (ip
->pedantic_min_int
);
257 mpz_clear (ip
->huge
);
260 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
261 mpfr_clears (rp
->epsilon
, rp
->huge
, rp
->tiny
, rp
->subnormal
, NULL
);
267 /* Given a wide character value and a character kind, determine whether
268 the character is representable for that kind. */
270 gfc_check_character_range (gfc_char_t c
, int kind
)
272 /* As wide characters are stored as 32-bit values, they're all
273 representable in UCS=4. */
278 return c
<= 255 ? true : false;
284 /* Given an integer and a kind, make sure that the integer lies within
285 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
289 gfc_check_integer_range (mpz_t p
, int kind
)
294 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
299 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
300 result
= ARITH_ASYMMETRIC
;
304 if (flag_range_check
== 0)
307 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
308 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
309 result
= ARITH_OVERFLOW
;
315 /* Given a real and a kind, make sure that the real lies within the
316 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
320 gfc_check_real_range (mpfr_t p
, int kind
)
326 i
= gfc_validate_kind (BT_REAL
, kind
, false);
330 mpfr_abs (q
, p
, GFC_RND_MODE
);
336 if (flag_range_check
!= 0)
337 retval
= ARITH_OVERFLOW
;
339 else if (mpfr_nan_p (p
))
341 if (flag_range_check
!= 0)
344 else if (mpfr_sgn (q
) == 0)
349 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
351 if (flag_range_check
== 0)
352 mpfr_set_inf (p
, mpfr_sgn (p
));
354 retval
= ARITH_OVERFLOW
;
356 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
358 if (flag_range_check
== 0)
360 if (mpfr_sgn (p
) < 0)
362 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
363 mpfr_set_si (q
, -1, GFC_RND_MODE
);
364 mpfr_copysign (p
, p
, q
, GFC_RND_MODE
);
367 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
370 retval
= ARITH_UNDERFLOW
;
372 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
377 /* Save current values of emin and emax. */
378 emin
= mpfr_get_emin ();
379 emax
= mpfr_get_emax ();
381 /* Set emin and emax for the current model number. */
382 en
= gfc_real_kinds
[i
].min_exponent
- gfc_real_kinds
[i
].digits
+ 1;
383 mpfr_set_emin ((mp_exp_t
) en
);
384 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[i
].max_exponent
);
385 mpfr_check_range (q
, 0, GFC_RND_MODE
);
386 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
388 /* Reset emin and emax. */
389 mpfr_set_emin (emin
);
390 mpfr_set_emax (emax
);
392 /* Copy sign if needed. */
393 if (mpfr_sgn (p
) < 0)
394 mpfr_neg (p
, q
, GMP_RNDN
);
396 mpfr_set (p
, q
, GMP_RNDN
);
405 /* Low-level arithmetic functions. All of these subroutines assume
406 that all operands are of the same type and return an operand of the
407 same type. The other thing about these subroutines is that they
408 can fail in various ways -- overflow, underflow, division by zero,
409 zero raised to the zero, etc. */
412 gfc_arith_not (gfc_expr
*op1
, gfc_expr
**resultp
)
416 result
= gfc_get_constant_expr (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
417 result
->value
.logical
= !op1
->value
.logical
;
425 gfc_arith_and (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
429 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
431 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
439 gfc_arith_or (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
443 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
445 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
453 gfc_arith_eqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
457 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
459 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
467 gfc_arith_neqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
471 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
473 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
480 /* Make sure a constant numeric expression is within the range for
481 its type and kind. Note that there's also a gfc_check_range(),
482 but that one deals with the intrinsic RANGE function. */
485 gfc_range_check (gfc_expr
*e
)
493 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
497 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
498 if (rc
== ARITH_UNDERFLOW
)
499 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
500 if (rc
== ARITH_OVERFLOW
)
501 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
503 mpfr_set_nan (e
->value
.real
);
507 rc
= gfc_check_real_range (mpc_realref (e
->value
.complex), e
->ts
.kind
);
508 if (rc
== ARITH_UNDERFLOW
)
509 mpfr_set_ui (mpc_realref (e
->value
.complex), 0, GFC_RND_MODE
);
510 if (rc
== ARITH_OVERFLOW
)
511 mpfr_set_inf (mpc_realref (e
->value
.complex),
512 mpfr_sgn (mpc_realref (e
->value
.complex)));
514 mpfr_set_nan (mpc_realref (e
->value
.complex));
516 rc2
= gfc_check_real_range (mpc_imagref (e
->value
.complex), e
->ts
.kind
);
517 if (rc
== ARITH_UNDERFLOW
)
518 mpfr_set_ui (mpc_imagref (e
->value
.complex), 0, GFC_RND_MODE
);
519 if (rc
== ARITH_OVERFLOW
)
520 mpfr_set_inf (mpc_imagref (e
->value
.complex),
521 mpfr_sgn (mpc_imagref (e
->value
.complex)));
523 mpfr_set_nan (mpc_imagref (e
->value
.complex));
530 gfc_internal_error ("gfc_range_check(): Bad type");
537 /* Several of the following routines use the same set of statements to
538 check the validity of the result. Encapsulate the checking here. */
541 check_result (arith rc
, gfc_expr
*x
, gfc_expr
*r
, gfc_expr
**rp
)
545 if (val
== ARITH_UNDERFLOW
)
548 gfc_warning (OPT_Wunderflow
, gfc_arith_error (val
), &x
->where
);
552 if (val
== ARITH_ASYMMETRIC
)
554 gfc_warning (0, gfc_arith_error (val
), &x
->where
);
567 /* It may seem silly to have a subroutine that actually computes the
568 unary plus of a constant, but it prevents us from making exceptions
569 in the code elsewhere. Used for unary plus and parenthesized
573 gfc_arith_identity (gfc_expr
*op1
, gfc_expr
**resultp
)
575 *resultp
= gfc_copy_expr (op1
);
581 gfc_arith_uminus (gfc_expr
*op1
, gfc_expr
**resultp
)
586 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
588 switch (op1
->ts
.type
)
591 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
595 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
599 mpc_neg (result
->value
.complex, op1
->value
.complex, GFC_MPC_RND_MODE
);
603 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
606 rc
= gfc_range_check (result
);
608 return check_result (rc
, op1
, result
, resultp
);
613 gfc_arith_plus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
618 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
620 switch (op1
->ts
.type
)
623 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
627 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
632 mpc_add (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
637 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
640 rc
= gfc_range_check (result
);
642 return check_result (rc
, op1
, result
, resultp
);
647 gfc_arith_minus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
652 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
654 switch (op1
->ts
.type
)
657 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
661 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
666 mpc_sub (result
->value
.complex, op1
->value
.complex,
667 op2
->value
.complex, GFC_MPC_RND_MODE
);
671 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
674 rc
= gfc_range_check (result
);
676 return check_result (rc
, op1
, result
, resultp
);
681 gfc_arith_times (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
686 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
688 switch (op1
->ts
.type
)
691 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
695 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
700 gfc_set_model (mpc_realref (op1
->value
.complex));
701 mpc_mul (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
706 gfc_internal_error ("gfc_arith_times(): Bad basic type");
709 rc
= gfc_range_check (result
);
711 return check_result (rc
, op1
, result
, resultp
);
716 gfc_arith_divide (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
723 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
725 switch (op1
->ts
.type
)
728 if (mpz_sgn (op2
->value
.integer
) == 0)
734 if (warn_integer_division
)
738 mpz_tdiv_qr (result
->value
.integer
, r
, op1
->value
.integer
,
741 if (mpz_cmp_si (r
, 0) != 0)
744 p
= mpz_get_str (NULL
, 10, result
->value
.integer
);
745 gfc_warning_now (OPT_Winteger_division
, "Integer division "
746 "truncated to constant %qs at %L", p
,
753 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
759 if (mpfr_sgn (op2
->value
.real
) == 0 && flag_range_check
== 1)
765 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
770 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0
771 && flag_range_check
== 1)
777 gfc_set_model (mpc_realref (op1
->value
.complex));
778 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0)
780 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
782 mpfr_set_nan (mpc_realref (result
->value
.complex));
783 mpfr_set_nan (mpc_imagref (result
->value
.complex));
786 mpc_div (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
791 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
795 rc
= gfc_range_check (result
);
797 return check_result (rc
, op1
, result
, resultp
);
800 /* Raise a number to a power. */
803 arith_power (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
810 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
812 switch (op2
->ts
.type
)
815 power_sign
= mpz_sgn (op2
->value
.integer
);
819 /* Handle something to the zeroth power. Since we're dealing
820 with integral exponents, there is no ambiguity in the
821 limiting procedure used to determine the value of 0**0. */
822 switch (op1
->ts
.type
)
825 mpz_set_ui (result
->value
.integer
, 1);
829 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
833 mpc_set_ui (result
->value
.complex, 1, GFC_MPC_RND_MODE
);
837 gfc_internal_error ("arith_power(): Bad base");
842 switch (op1
->ts
.type
)
848 /* First, we simplify the cases of op1 == 1, 0 or -1. */
849 if (mpz_cmp_si (op1
->value
.integer
, 1) == 0)
852 mpz_set_si (result
->value
.integer
, 1);
854 else if (mpz_cmp_si (op1
->value
.integer
, 0) == 0)
856 /* 0**op2 == 0, if op2 > 0
857 0**op2 overflow, if op2 < 0 ; in that case, we
858 set the result to 0 and return ARITH_DIV0. */
859 mpz_set_si (result
->value
.integer
, 0);
860 if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
863 else if (mpz_cmp_si (op1
->value
.integer
, -1) == 0)
865 /* (-1)**op2 == (-1)**(mod(op2,2)) */
866 unsigned int odd
= mpz_fdiv_ui (op2
->value
.integer
, 2);
868 mpz_set_si (result
->value
.integer
, -1);
870 mpz_set_si (result
->value
.integer
, 1);
872 /* Then, we take care of op2 < 0. */
873 else if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
875 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
876 mpz_set_si (result
->value
.integer
, 0);
877 if (warn_integer_division
)
878 gfc_warning_now (OPT_Winteger_division
, "Negative "
879 "exponent of integer has zero "
880 "result at %L", &result
->where
);
882 else if (gfc_extract_int (op2
, &power
))
884 /* If op2 doesn't fit in an int, the exponentiation will
885 overflow, because op2 > 0 and abs(op1) > 1. */
888 i
= gfc_validate_kind (BT_INTEGER
, result
->ts
.kind
, false);
890 if (flag_range_check
)
893 /* Still, we want to give the same value as the
896 mpz_add_ui (max
, gfc_integer_kinds
[i
].huge
, 1);
897 mpz_mul_ui (max
, max
, 2);
898 mpz_powm (result
->value
.integer
, op1
->value
.integer
,
899 op2
->value
.integer
, max
);
903 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
,
909 mpfr_pow_z (result
->value
.real
, op1
->value
.real
,
910 op2
->value
.integer
, GFC_RND_MODE
);
914 mpc_pow_z (result
->value
.complex, op1
->value
.complex,
915 op2
->value
.integer
, GFC_MPC_RND_MODE
);
926 if (gfc_init_expr_flag
)
928 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
929 "exponent in an initialization "
930 "expression at %L", &op2
->where
))
932 gfc_free_expr (result
);
933 return ARITH_PROHIBIT
;
937 if (mpfr_cmp_si (op1
->value
.real
, 0) < 0)
939 gfc_error ("Raising a negative REAL at %L to "
940 "a REAL power is prohibited", &op1
->where
);
941 gfc_free_expr (result
);
942 return ARITH_PROHIBIT
;
945 mpfr_pow (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
951 if (gfc_init_expr_flag
)
953 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
954 "exponent in an initialization "
955 "expression at %L", &op2
->where
))
957 gfc_free_expr (result
);
958 return ARITH_PROHIBIT
;
962 mpc_pow (result
->value
.complex, op1
->value
.complex,
963 op2
->value
.complex, GFC_MPC_RND_MODE
);
967 gfc_internal_error ("arith_power(): unknown type");
971 rc
= gfc_range_check (result
);
973 return check_result (rc
, op1
, result
, resultp
);
977 /* Concatenate two string constants. */
980 gfc_arith_concat (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
985 gcc_assert (op1
->ts
.kind
== op2
->ts
.kind
);
986 result
= gfc_get_constant_expr (BT_CHARACTER
, op1
->ts
.kind
,
989 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
991 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
992 result
->value
.character
.length
= len
;
994 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
995 op1
->value
.character
.length
* sizeof (gfc_char_t
));
997 memcpy (&result
->value
.character
.string
[op1
->value
.character
.length
],
998 op2
->value
.character
.string
,
999 op2
->value
.character
.length
* sizeof (gfc_char_t
));
1001 result
->value
.character
.string
[len
] = '\0';
1008 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1009 This function mimics mpfr_cmp but takes NaN into account. */
1012 compare_real (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1018 rc
= mpfr_equal_p (op1
->value
.real
, op2
->value
.real
) ? 0 : 1;
1021 rc
= mpfr_greater_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1024 rc
= mpfr_greaterequal_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1027 rc
= mpfr_less_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1030 rc
= mpfr_lessequal_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1033 gfc_internal_error ("compare_real(): Bad operator");
1039 /* Comparison operators. Assumes that the two expression nodes
1040 contain two constants of the same type. The op argument is
1041 needed to handle NaN correctly. */
1044 gfc_compare_expr (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1048 switch (op1
->ts
.type
)
1051 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1055 rc
= compare_real (op1
, op2
, op
);
1059 rc
= gfc_compare_string (op1
, op2
);
1063 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1064 || (op1
->value
.logical
&& !op2
->value
.logical
));
1068 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1075 /* Compare a pair of complex numbers. Naturally, this is only for
1076 equality and inequality. */
1079 compare_complex (gfc_expr
*op1
, gfc_expr
*op2
)
1081 return mpc_cmp (op1
->value
.complex, op2
->value
.complex) == 0;
1085 /* Given two constant strings and the inverse collating sequence, compare the
1086 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1087 We use the processor's default collating sequence. */
1090 gfc_compare_string (gfc_expr
*a
, gfc_expr
*b
)
1092 size_t len
, alen
, blen
, i
;
1095 alen
= a
->value
.character
.length
;
1096 blen
= b
->value
.character
.length
;
1098 len
= MAX(alen
, blen
);
1100 for (i
= 0; i
< len
; i
++)
1102 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1103 bc
= ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1111 /* Strings are equal */
1117 gfc_compare_with_Cstring (gfc_expr
*a
, const char *b
, bool case_sensitive
)
1119 size_t len
, alen
, blen
, i
;
1122 alen
= a
->value
.character
.length
;
1125 len
= MAX(alen
, blen
);
1127 for (i
= 0; i
< len
; i
++)
1129 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1130 bc
= ((i
< blen
) ? b
[i
] : ' ');
1132 if (!case_sensitive
)
1144 /* Strings are equal */
1149 /* Specific comparison subroutines. */
1152 gfc_arith_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1156 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1158 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1159 ? compare_complex (op1
, op2
)
1160 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) == 0);
1168 gfc_arith_ne (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
= (op1
->ts
.type
== BT_COMPLEX
)
1175 ? !compare_complex (op1
, op2
)
1176 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) != 0);
1184 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1188 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1190 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GT
) > 0);
1198 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1202 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1204 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GE
) >= 0);
1212 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1216 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1218 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LT
) < 0);
1226 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1230 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1232 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LE
) <= 0);
1240 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1243 gfc_constructor_base head
;
1248 if (op
->expr_type
== EXPR_CONSTANT
)
1249 return eval (op
, result
);
1252 head
= gfc_constructor_copy (op
->value
.constructor
);
1253 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1255 rc
= reduce_unary (eval
, c
->expr
, &r
);
1260 gfc_replace_expr (c
->expr
, r
);
1264 gfc_constructor_free (head
);
1267 gfc_constructor
*c
= gfc_constructor_first (head
);
1268 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1270 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1272 r
->value
.constructor
= head
;
1281 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1282 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1284 gfc_constructor_base head
;
1287 arith rc
= ARITH_OK
;
1289 head
= gfc_constructor_copy (op1
->value
.constructor
);
1290 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1292 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1293 rc
= eval (c
->expr
, op2
, &r
);
1295 rc
= reduce_binary_ac (eval
, c
->expr
, op2
, &r
);
1300 gfc_replace_expr (c
->expr
, r
);
1304 gfc_constructor_free (head
);
1307 gfc_constructor
*c
= gfc_constructor_first (head
);
1308 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1310 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1311 r
->rank
= op1
->rank
;
1312 r
->value
.constructor
= head
;
1321 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1322 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1324 gfc_constructor_base head
;
1327 arith rc
= ARITH_OK
;
1329 head
= gfc_constructor_copy (op2
->value
.constructor
);
1330 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1332 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1333 rc
= eval (op1
, c
->expr
, &r
);
1335 rc
= reduce_binary_ca (eval
, op1
, c
->expr
, &r
);
1340 gfc_replace_expr (c
->expr
, r
);
1344 gfc_constructor_free (head
);
1347 gfc_constructor
*c
= gfc_constructor_first (head
);
1348 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1350 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1351 r
->rank
= op2
->rank
;
1352 r
->value
.constructor
= head
;
1360 /* We need a forward declaration of reduce_binary. */
1361 static arith
reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1362 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
);
1366 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1367 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1369 gfc_constructor_base head
;
1370 gfc_constructor
*c
, *d
;
1372 arith rc
= ARITH_OK
;
1374 if (!gfc_check_conformance (op1
, op2
, "elemental binary operation"))
1375 return ARITH_INCOMMENSURATE
;
1377 head
= gfc_constructor_copy (op1
->value
.constructor
);
1378 for (c
= gfc_constructor_first (head
),
1379 d
= gfc_constructor_first (op2
->value
.constructor
);
1381 c
= gfc_constructor_next (c
), d
= gfc_constructor_next (d
))
1383 rc
= reduce_binary (eval
, c
->expr
, d
->expr
, &r
);
1387 gfc_replace_expr (c
->expr
, r
);
1391 rc
= ARITH_INCOMMENSURATE
;
1394 gfc_constructor_free (head
);
1397 gfc_constructor
*c
= gfc_constructor_first (head
);
1398 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1400 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1401 r
->rank
= op1
->rank
;
1402 r
->value
.constructor
= head
;
1411 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1412 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1414 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1415 return eval (op1
, op2
, result
);
1417 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1418 return reduce_binary_ca (eval
, op1
, op2
, result
);
1420 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1421 return reduce_binary_ac (eval
, op1
, op2
, result
);
1423 return reduce_binary_aa (eval
, op1
, op2
, result
);
1429 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1430 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1434 /* High level arithmetic subroutines. These subroutines go into
1435 eval_intrinsic(), which can do one of several things to its
1436 operands. If the operands are incompatible with the intrinsic
1437 operation, we return a node pointing to the operands and hope that
1438 an operator interface is found during resolution.
1440 If the operands are compatible and are constants, then we try doing
1441 the arithmetic. We also handle the cases where either or both
1442 operands are array constructors. */
1445 eval_intrinsic (gfc_intrinsic_op op
,
1446 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1448 gfc_expr temp
, *result
;
1452 gfc_clear_ts (&temp
.ts
);
1458 if (op1
->ts
.type
!= BT_LOGICAL
)
1461 temp
.ts
.type
= BT_LOGICAL
;
1462 temp
.ts
.kind
= gfc_default_logical_kind
;
1466 /* Logical binary operators */
1469 case INTRINSIC_NEQV
:
1471 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1474 temp
.ts
.type
= BT_LOGICAL
;
1475 temp
.ts
.kind
= gfc_default_logical_kind
;
1480 case INTRINSIC_UPLUS
:
1481 case INTRINSIC_UMINUS
:
1482 if (!gfc_numeric_ts (&op1
->ts
))
1489 case INTRINSIC_PARENTHESES
:
1494 /* Additional restrictions for ordering relations. */
1496 case INTRINSIC_GE_OS
:
1498 case INTRINSIC_LT_OS
:
1500 case INTRINSIC_LE_OS
:
1502 case INTRINSIC_GT_OS
:
1503 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1505 temp
.ts
.type
= BT_LOGICAL
;
1506 temp
.ts
.kind
= gfc_default_logical_kind
;
1512 case INTRINSIC_EQ_OS
:
1514 case INTRINSIC_NE_OS
:
1515 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1518 temp
.ts
.type
= BT_LOGICAL
;
1519 temp
.ts
.kind
= gfc_default_logical_kind
;
1521 /* If kind mismatch, exit and we'll error out later. */
1522 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1529 /* Numeric binary */
1530 case INTRINSIC_PLUS
:
1531 case INTRINSIC_MINUS
:
1532 case INTRINSIC_TIMES
:
1533 case INTRINSIC_DIVIDE
:
1534 case INTRINSIC_POWER
:
1535 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1538 /* Insert any necessary type conversions to make the operands
1541 temp
.expr_type
= EXPR_OP
;
1542 gfc_clear_ts (&temp
.ts
);
1543 temp
.value
.op
.op
= op
;
1545 temp
.value
.op
.op1
= op1
;
1546 temp
.value
.op
.op2
= op2
;
1548 gfc_type_convert_binary (&temp
, warn_conversion
|| warn_conversion_extra
);
1550 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
1551 || op
== INTRINSIC_GE
|| op
== INTRINSIC_GT
1552 || op
== INTRINSIC_LE
|| op
== INTRINSIC_LT
1553 || op
== INTRINSIC_EQ_OS
|| op
== INTRINSIC_NE_OS
1554 || op
== INTRINSIC_GE_OS
|| op
== INTRINSIC_GT_OS
1555 || op
== INTRINSIC_LE_OS
|| op
== INTRINSIC_LT_OS
)
1557 temp
.ts
.type
= BT_LOGICAL
;
1558 temp
.ts
.kind
= gfc_default_logical_kind
;
1564 /* Character binary */
1565 case INTRINSIC_CONCAT
:
1566 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1567 || op1
->ts
.kind
!= op2
->ts
.kind
)
1570 temp
.ts
.type
= BT_CHARACTER
;
1571 temp
.ts
.kind
= op1
->ts
.kind
;
1575 case INTRINSIC_USER
:
1579 gfc_internal_error ("eval_intrinsic(): Bad operator");
1582 if (op1
->expr_type
!= EXPR_CONSTANT
1583 && (op1
->expr_type
!= EXPR_ARRAY
1584 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
)))
1588 && op2
->expr_type
!= EXPR_CONSTANT
1589 && (op2
->expr_type
!= EXPR_ARRAY
1590 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))
1594 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1596 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1599 /* Something went wrong. */
1600 if (op
== INTRINSIC_POWER
&& rc
== ARITH_PROHIBIT
)
1605 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1609 gfc_free_expr (op1
);
1610 gfc_free_expr (op2
);
1614 /* Create a run-time expression. */
1615 result
= gfc_get_operator_expr (&op1
->where
, op
, op1
, op2
);
1616 result
->ts
= temp
.ts
;
1622 /* Modify type of expression for zero size array. */
1625 eval_type_intrinsic0 (gfc_intrinsic_op iop
, gfc_expr
*op
)
1628 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1633 case INTRINSIC_GE_OS
:
1635 case INTRINSIC_LT_OS
:
1637 case INTRINSIC_LE_OS
:
1639 case INTRINSIC_GT_OS
:
1641 case INTRINSIC_EQ_OS
:
1643 case INTRINSIC_NE_OS
:
1644 op
->ts
.type
= BT_LOGICAL
;
1645 op
->ts
.kind
= gfc_default_logical_kind
;
1656 /* Return nonzero if the expression is a zero size array. */
1659 gfc_zero_size_array (gfc_expr
*e
)
1661 if (e
->expr_type
!= EXPR_ARRAY
)
1664 return e
->value
.constructor
== NULL
;
1668 /* Reduce a binary expression where at least one of the operands
1669 involves a zero-length array. Returns NULL if neither of the
1670 operands is a zero-length array. */
1673 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1675 if (gfc_zero_size_array (op1
))
1677 gfc_free_expr (op2
);
1681 if (gfc_zero_size_array (op2
))
1683 gfc_free_expr (op1
);
1692 eval_intrinsic_f2 (gfc_intrinsic_op op
,
1693 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1694 gfc_expr
*op1
, gfc_expr
*op2
)
1701 if (gfc_zero_size_array (op1
))
1702 return eval_type_intrinsic0 (op
, op1
);
1706 result
= reduce_binary0 (op1
, op2
);
1708 return eval_type_intrinsic0 (op
, result
);
1712 return eval_intrinsic (op
, f
, op1
, op2
);
1717 eval_intrinsic_f3 (gfc_intrinsic_op op
,
1718 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1719 gfc_expr
*op1
, gfc_expr
*op2
)
1724 result
= reduce_binary0 (op1
, op2
);
1726 return eval_type_intrinsic0(op
, result
);
1729 return eval_intrinsic (op
, f
, op1
, op2
);
1734 gfc_parentheses (gfc_expr
*op
)
1736 if (gfc_is_constant_expr (op
))
1739 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES
, gfc_arith_identity
,
1744 gfc_uplus (gfc_expr
*op
)
1746 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_identity
, op
, NULL
);
1751 gfc_uminus (gfc_expr
*op
)
1753 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1758 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1760 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1765 gfc_subtract (gfc_expr
*op1
, gfc_expr
*op2
)
1767 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1772 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1774 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1779 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1781 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1786 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1788 return eval_intrinsic_f3 (INTRINSIC_POWER
, arith_power
, op1
, op2
);
1793 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1795 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1800 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1802 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1807 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1809 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1814 gfc_not (gfc_expr
*op1
)
1816 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1821 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1823 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1828 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1830 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1835 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1837 return eval_intrinsic_f3 (op
, gfc_arith_eq
, op1
, op2
);
1842 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1844 return eval_intrinsic_f3 (op
, gfc_arith_ne
, op1
, op2
);
1849 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1851 return eval_intrinsic_f3 (op
, gfc_arith_gt
, op1
, op2
);
1856 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1858 return eval_intrinsic_f3 (op
, gfc_arith_ge
, op1
, op2
);
1863 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1865 return eval_intrinsic_f3 (op
, gfc_arith_lt
, op1
, op2
);
1870 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1872 return eval_intrinsic_f3 (op
, gfc_arith_le
, op1
, op2
);
1876 /* Convert an integer string to an expression node. */
1879 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
1884 e
= gfc_get_constant_expr (BT_INTEGER
, kind
, where
);
1885 /* A leading plus is allowed, but not by mpz_set_str. */
1886 if (buffer
[0] == '+')
1890 mpz_set_str (e
->value
.integer
, t
, radix
);
1896 /* Convert a real string to an expression node. */
1899 gfc_convert_real (const char *buffer
, int kind
, locus
*where
)
1903 e
= gfc_get_constant_expr (BT_REAL
, kind
, where
);
1904 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1910 /* Convert a pair of real, constant expression nodes to a single
1911 complex expression node. */
1914 gfc_convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
1918 e
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &real
->where
);
1919 mpc_set_fr_fr (e
->value
.complex, real
->value
.real
, imag
->value
.real
,
1926 /******* Simplification of intrinsic functions with constant arguments *****/
1929 /* Deal with an arithmetic error. */
1932 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
1937 gfc_error ("Arithmetic OK converting %s to %s at %L",
1938 gfc_typename (from
), gfc_typename (to
), where
);
1940 case ARITH_OVERFLOW
:
1941 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1942 "can be disabled with the option %<-fno-range-check%>",
1943 gfc_typename (from
), gfc_typename (to
), where
);
1945 case ARITH_UNDERFLOW
:
1946 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1947 "can be disabled with the option %<-fno-range-check%>",
1948 gfc_typename (from
), gfc_typename (to
), where
);
1951 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1952 "can be disabled with the option %<-fno-range-check%>",
1953 gfc_typename (from
), gfc_typename (to
), where
);
1956 gfc_error ("Division by zero converting %s to %s at %L",
1957 gfc_typename (from
), gfc_typename (to
), where
);
1959 case ARITH_INCOMMENSURATE
:
1960 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1961 gfc_typename (from
), gfc_typename (to
), where
);
1963 case ARITH_ASYMMETRIC
:
1964 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1965 " converting %s to %s at %L",
1966 gfc_typename (from
), gfc_typename (to
), where
);
1969 gfc_internal_error ("gfc_arith_error(): Bad error code");
1972 /* TODO: Do something about the error, i.e., throw exception, return
1976 /* Returns true if significant bits were lost when converting real
1977 constant r from from_kind to to_kind. */
1980 wprecision_real_real (mpfr_t r
, int from_kind
, int to_kind
)
1985 gfc_set_model_kind (to_kind
);
1987 gfc_set_model_kind (from_kind
);
1990 mpfr_set (rv
, r
, GFC_RND_MODE
);
1991 mpfr_sub (diff
, rv
, r
, GFC_RND_MODE
);
1993 ret
= ! mpfr_zero_p (diff
);
1999 /* Return true if conversion from an integer to a real loses precision. */
2002 wprecision_int_real (mpz_t n
, mpfr_t r
)
2007 mpfr_get_z (i
, r
, GFC_RND_MODE
);
2009 ret
= mpz_cmp_si (i
, 0) != 0;
2014 /* Convert integers to integers. */
2017 gfc_int2int (gfc_expr
*src
, int kind
)
2022 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2024 mpz_set (result
->value
.integer
, src
->value
.integer
);
2026 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2028 if (rc
== ARITH_ASYMMETRIC
)
2030 gfc_warning (0, gfc_arith_error (rc
), &src
->where
);
2034 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2035 gfc_free_expr (result
);
2040 /* If we do not trap numeric overflow, we need to convert the number to
2041 signed, throwing away high-order bits if necessary. */
2042 if (flag_range_check
== 0)
2046 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
2047 gfc_convert_mpz_to_signed (result
->value
.integer
,
2048 gfc_integer_kinds
[k
].bit_size
);
2050 if (warn_conversion
&& kind
< src
->ts
.kind
)
2051 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2052 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2059 /* Convert integers to reals. */
2062 gfc_int2real (gfc_expr
*src
, int kind
)
2067 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2069 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2071 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2073 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2074 gfc_free_expr (result
);
2079 && wprecision_int_real (src
->value
.integer
, result
->value
.real
))
2080 gfc_warning (OPT_Wconversion
, "Change of value in conversion "
2081 "from %qs to %qs at %L",
2082 gfc_typename (&src
->ts
),
2083 gfc_typename (&result
->ts
),
2090 /* Convert default integer to default complex. */
2093 gfc_int2complex (gfc_expr
*src
, int kind
)
2098 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2100 mpc_set_z (result
->value
.complex, src
->value
.integer
, GFC_MPC_RND_MODE
);
2102 if ((rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
))
2105 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2106 gfc_free_expr (result
);
2111 && wprecision_int_real (src
->value
.integer
,
2112 mpc_realref (result
->value
.complex)))
2113 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2114 "from %qs to %qs at %L",
2115 gfc_typename (&src
->ts
),
2116 gfc_typename (&result
->ts
),
2123 /* Convert default real to default integer. */
2126 gfc_real2int (gfc_expr
*src
, int kind
)
2130 bool did_warn
= false;
2132 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2134 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
, &src
->where
);
2136 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2138 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2139 gfc_free_expr (result
);
2143 /* If there was a fractional part, warn about this. */
2145 if (warn_conversion
)
2149 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2150 if (mpfr_cmp_si (f
, 0) != 0)
2152 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2153 "from %qs to %qs at %L", gfc_typename (&src
->ts
),
2154 gfc_typename (&result
->ts
), &src
->where
);
2158 if (!did_warn
&& warn_conversion_extra
)
2160 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2161 "at %L", gfc_typename (&src
->ts
),
2162 gfc_typename (&result
->ts
), &src
->where
);
2169 /* Convert real to real. */
2172 gfc_real2real (gfc_expr
*src
, int kind
)
2176 bool did_warn
= false;
2178 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2180 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2182 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2184 if (rc
== ARITH_UNDERFLOW
)
2187 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2188 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2190 else if (rc
!= ARITH_OK
)
2192 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2193 gfc_free_expr (result
);
2197 /* As a special bonus, don't warn about REAL values which are not changed by
2198 the conversion if -Wconversion is specified and -Wconversion-extra is
2201 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2203 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2205 /* Calculate the difference between the constant and the rounded
2206 value and check it against zero. */
2208 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2210 gfc_warning_now (w
, "Change of value in conversion from "
2212 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2214 /* Make sure the conversion warning is not emitted again. */
2219 if (!did_warn
&& warn_conversion_extra
)
2220 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2221 "at %L", gfc_typename(&src
->ts
),
2222 gfc_typename(&result
->ts
), &src
->where
);
2228 /* Convert real to complex. */
2231 gfc_real2complex (gfc_expr
*src
, int kind
)
2235 bool did_warn
= false;
2237 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2239 mpc_set_fr (result
->value
.complex, src
->value
.real
, GFC_MPC_RND_MODE
);
2241 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2243 if (rc
== ARITH_UNDERFLOW
)
2246 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2247 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2249 else if (rc
!= ARITH_OK
)
2251 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2252 gfc_free_expr (result
);
2256 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2258 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2260 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2262 gfc_warning_now (w
, "Change of value in conversion from "
2264 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2266 /* Make sure the conversion warning is not emitted again. */
2271 if (!did_warn
&& warn_conversion_extra
)
2272 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2273 "at %L", gfc_typename(&src
->ts
),
2274 gfc_typename(&result
->ts
), &src
->where
);
2280 /* Convert complex to integer. */
2283 gfc_complex2int (gfc_expr
*src
, int kind
)
2287 bool did_warn
= false;
2289 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2291 gfc_mpfr_to_mpz (result
->value
.integer
, mpc_realref (src
->value
.complex),
2294 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2296 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2297 gfc_free_expr (result
);
2301 if (warn_conversion
|| warn_conversion_extra
)
2303 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2305 /* See if we discarded an imaginary part. */
2306 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2308 gfc_warning_now (w
, "Non-zero imaginary part discarded "
2309 "in conversion from %qs to %qs at %L",
2310 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2319 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2320 if (mpfr_cmp_si (f
, 0) != 0)
2322 gfc_warning_now (w
, "Change of value in conversion from "
2323 "%qs to %qs at %L", gfc_typename (&src
->ts
),
2324 gfc_typename (&result
->ts
), &src
->where
);
2330 if (!did_warn
&& warn_conversion_extra
)
2332 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2333 "at %L", gfc_typename (&src
->ts
),
2334 gfc_typename (&result
->ts
), &src
->where
);
2342 /* Convert complex to real. */
2345 gfc_complex2real (gfc_expr
*src
, int kind
)
2349 bool did_warn
= false;
2351 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2353 mpc_real (result
->value
.real
, src
->value
.complex, GFC_RND_MODE
);
2355 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2357 if (rc
== ARITH_UNDERFLOW
)
2360 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2361 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2365 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2366 gfc_free_expr (result
);
2370 if (warn_conversion
|| warn_conversion_extra
)
2372 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2374 /* See if we discarded an imaginary part. */
2375 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2377 gfc_warning (w
, "Non-zero imaginary part discarded "
2378 "in conversion from %qs to %qs at %L",
2379 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2384 /* Calculate the difference between the real constant and the rounded
2385 value and check it against zero. */
2387 if (kind
> src
->ts
.kind
2388 && wprecision_real_real (mpc_realref (src
->value
.complex),
2389 src
->ts
.kind
, kind
))
2391 gfc_warning_now (w
, "Change of value in conversion from "
2393 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2395 /* Make sure the conversion warning is not emitted again. */
2400 if (!did_warn
&& warn_conversion_extra
)
2401 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2402 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2409 /* Convert complex to complex. */
2412 gfc_complex2complex (gfc_expr
*src
, int kind
)
2416 bool did_warn
= false;
2418 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2420 mpc_set (result
->value
.complex, src
->value
.complex, GFC_MPC_RND_MODE
);
2422 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2424 if (rc
== ARITH_UNDERFLOW
)
2427 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2428 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2430 else if (rc
!= ARITH_OK
)
2432 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2433 gfc_free_expr (result
);
2437 rc
= gfc_check_real_range (mpc_imagref (result
->value
.complex), kind
);
2439 if (rc
== ARITH_UNDERFLOW
)
2442 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2443 mpfr_set_ui (mpc_imagref (result
->value
.complex), 0, GFC_RND_MODE
);
2445 else if (rc
!= ARITH_OK
)
2447 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2448 gfc_free_expr (result
);
2452 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
2453 && (wprecision_real_real (mpc_realref (src
->value
.complex),
2455 || wprecision_real_real (mpc_imagref (src
->value
.complex),
2456 src
->ts
.kind
, kind
)))
2458 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2460 gfc_warning_now (w
, "Change of value in conversion from "
2461 " %qs to %qs at %L",
2462 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2467 if (!did_warn
&& warn_conversion_extra
&& src
->ts
.kind
!= kind
)
2468 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2469 "at %L", gfc_typename(&src
->ts
),
2470 gfc_typename (&result
->ts
), &src
->where
);
2476 /* Logical kind conversion. */
2479 gfc_log2log (gfc_expr
*src
, int kind
)
2483 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2484 result
->value
.logical
= src
->value
.logical
;
2490 /* Convert logical to integer. */
2493 gfc_log2int (gfc_expr
*src
, int kind
)
2497 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2498 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2504 /* Convert integer to logical. */
2507 gfc_int2log (gfc_expr
*src
, int kind
)
2511 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2512 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2517 /* Convert character to character. We only use wide strings internally,
2518 so we only set the kind. */
2521 gfc_character2character (gfc_expr
*src
, int kind
)
2524 result
= gfc_copy_expr (src
);
2525 result
->ts
.kind
= kind
;
2530 /* Helper function to set the representation in a Hollerith conversion.
2531 This assumes that the ts.type and ts.kind of the result have already
2535 hollerith2representation (gfc_expr
*result
, gfc_expr
*src
)
2537 int src_len
, result_len
;
2539 src_len
= src
->representation
.length
- src
->ts
.u
.pad
;
2540 result_len
= gfc_target_expr_size (result
);
2542 if (src_len
> result_len
)
2545 "The Hollerith constant at %L is too long to convert to %qs",
2546 &src
->where
, gfc_typename(&result
->ts
));
2549 result
->representation
.string
= XCNEWVEC (char, result_len
+ 1);
2550 memcpy (result
->representation
.string
, src
->representation
.string
,
2551 MIN (result_len
, src_len
));
2553 if (src_len
< result_len
)
2554 memset (&result
->representation
.string
[src_len
], ' ', result_len
- src_len
);
2556 result
->representation
.string
[result_len
] = '\0'; /* For debugger */
2557 result
->representation
.length
= result_len
;
2561 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2564 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2567 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2569 hollerith2representation (result
, src
);
2570 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2571 result
->representation
.length
, result
->value
.integer
);
2577 /* Convert Hollerith to real. The constant will be padded or truncated. */
2580 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2583 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2585 hollerith2representation (result
, src
);
2586 gfc_interpret_float (kind
, (unsigned char *) result
->representation
.string
,
2587 result
->representation
.length
, result
->value
.real
);
2593 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2596 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2599 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2601 hollerith2representation (result
, src
);
2602 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2603 result
->representation
.length
, result
->value
.complex);
2609 /* Convert Hollerith to character. */
2612 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2616 result
= gfc_copy_expr (src
);
2617 result
->ts
.type
= BT_CHARACTER
;
2618 result
->ts
.kind
= kind
;
2619 result
->ts
.u
.pad
= 0;
2621 result
->value
.character
.length
= result
->representation
.length
;
2622 result
->value
.character
.string
2623 = gfc_char_to_widechar (result
->representation
.string
);
2629 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2632 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2635 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2637 hollerith2representation (result
, src
);
2638 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2639 result
->representation
.length
, &result
->value
.logical
);