2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* Since target arithmetic must be done on the host, there has to
24 be some way of evaluating arithmetic expressions as the host
25 would evaluate them. We use the GNU MP library to do arithmetic,
26 and this file provides the interface. */
34 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
35 It's easily implemented with a few calls though. */
38 gfc_mpfr_to_mpz (mpz_t z
, mpfr_t x
)
42 e
= mpfr_get_z_exp (z
, x
);
43 /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
44 may set the sign of z incorrectly. Work around that here. */
45 if (mpfr_sgn (x
) != mpz_sgn (z
))
49 mpz_mul_2exp (z
, z
, e
);
51 mpz_tdiv_q_2exp (z
, z
, -e
);
55 /* Set the model number precision by the requested KIND. */
58 gfc_set_model_kind (int kind
)
60 int index
= gfc_validate_kind (BT_REAL
, kind
, false);
63 base2prec
= gfc_real_kinds
[index
].digits
;
64 if (gfc_real_kinds
[index
].radix
!= 2)
65 base2prec
*= gfc_real_kinds
[index
].radix
/ 2;
66 mpfr_set_default_prec (base2prec
);
70 /* Set the model number precision from mpfr_t x. */
73 gfc_set_model (mpfr_t x
)
75 mpfr_set_default_prec (mpfr_get_prec (x
));
78 /* Calculate atan2 (y, x)
80 atan2(y, x) = atan(y/x) if x > 0,
81 sign(y)*(pi - atan(|y/x|)) if x < 0,
83 sign(y)*pi/2 if x = 0 && y != 0.
87 arctangent2 (mpfr_t y
, mpfr_t x
, mpfr_t result
)
99 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
100 mpfr_atan (result
, t
, GFC_RND_MODE
);
104 mpfr_const_pi (result
, GFC_RND_MODE
);
105 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
106 mpfr_abs (t
, t
, GFC_RND_MODE
);
107 mpfr_atan (t
, t
, GFC_RND_MODE
);
108 mpfr_sub (result
, result
, t
, GFC_RND_MODE
);
109 if (mpfr_sgn (y
) < 0)
110 mpfr_neg (result
, result
, GFC_RND_MODE
);
114 if (mpfr_sgn (y
) == 0)
115 mpfr_set_ui (result
, 0, GFC_RND_MODE
);
118 mpfr_const_pi (result
, GFC_RND_MODE
);
119 mpfr_div_ui (result
, result
, 2, GFC_RND_MODE
);
120 if (mpfr_sgn (y
) < 0)
121 mpfr_neg (result
, result
, GFC_RND_MODE
);
130 /* Given an arithmetic error code, return a pointer to a string that
131 explains the error. */
134 gfc_arith_error (arith code
)
144 p
= "Arithmetic overflow";
146 case ARITH_UNDERFLOW
:
147 p
= "Arithmetic underflow";
150 p
= "Arithmetic NaN";
153 p
= "Division by zero";
155 case ARITH_INCOMMENSURATE
:
156 p
= "Array operands are incommensurate";
158 case ARITH_ASYMMETRIC
:
159 p
= "Integer outside symmetric range implied by Standard Fortran";
162 gfc_internal_error ("gfc_arith_error(): Bad error code");
169 /* Get things ready to do math. */
172 gfc_arith_init_1 (void)
174 gfc_integer_info
*int_info
;
175 gfc_real_info
*real_info
;
180 mpfr_set_default_prec (128);
184 /* Convert the minimum/maximum values for each kind into their
185 GNU MP representation. */
186 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
189 mpz_set_ui (r
, int_info
->radix
);
190 mpz_pow_ui (r
, r
, int_info
->digits
);
192 mpz_init (int_info
->huge
);
193 mpz_sub_ui (int_info
->huge
, r
, 1);
195 /* These are the numbers that are actually representable by the
196 target. For bases other than two, this needs to be changed. */
197 if (int_info
->radix
!= 2)
198 gfc_internal_error ("Fix min_int, max_int calculation");
200 /* See PRs 13490 and 17912, related to integer ranges.
201 The pedantic_min_int exists for range checking when a program
202 is compiled with -pedantic, and reflects the belief that
203 Standard Fortran requires integers to be symmetrical, i.e.
204 every negative integer must have a representable positive
205 absolute value, and vice versa. */
207 mpz_init (int_info
->pedantic_min_int
);
208 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
210 mpz_init (int_info
->min_int
);
211 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
213 mpz_init (int_info
->max_int
);
214 mpz_add (int_info
->max_int
, int_info
->huge
, int_info
->huge
);
215 mpz_add_ui (int_info
->max_int
, int_info
->max_int
, 1);
218 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
219 mpfr_log10 (a
, a
, GFC_RND_MODE
);
221 gfc_mpfr_to_mpz (r
, a
);
222 int_info
->range
= mpz_get_si (r
);
227 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
229 gfc_set_model_kind (real_info
->kind
);
235 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
236 /* a = 1 - b**(-p) */
237 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
238 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
239 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
240 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
242 /* c = b**(emax-1) */
243 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
244 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
246 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
247 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
249 /* a = (1 - b**(-p)) * b**(emax-1) * b */
250 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
252 mpfr_init (real_info
->huge
);
253 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
255 /* tiny(x) = b**(emin-1) */
256 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
257 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
259 mpfr_init (real_info
->tiny
);
260 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
262 /* subnormal (x) = b**(emin - digit + 1) */
263 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
264 mpfr_pow_si (b
, b
, real_info
->min_exponent
- real_info
->digits
+ 1,
267 mpfr_init (real_info
->subnormal
);
268 mpfr_set (real_info
->subnormal
, b
, GFC_RND_MODE
);
270 /* epsilon(x) = b**(1-p) */
271 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
272 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
274 mpfr_init (real_info
->epsilon
);
275 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
277 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
278 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
279 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
280 mpfr_neg (b
, b
, GFC_RND_MODE
);
282 if (mpfr_cmp (a
, b
) > 0)
283 mpfr_set (a
, b
, GFC_RND_MODE
); /* a = min(a, b) */
286 gfc_mpfr_to_mpz (r
, a
);
287 real_info
->range
= mpz_get_si (r
);
289 /* precision(x) = int((p - 1) * log10(b)) + k */
290 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
291 mpfr_log10 (a
, a
, GFC_RND_MODE
);
293 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
295 gfc_mpfr_to_mpz (r
, a
);
296 real_info
->precision
= mpz_get_si (r
);
298 /* If the radix is an integral power of 10, add one to the
300 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
301 if (i
== real_info
->radix
)
302 real_info
->precision
++;
313 /* Clean up, get rid of numeric constants. */
316 gfc_arith_done_1 (void)
318 gfc_integer_info
*ip
;
321 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
323 mpz_clear (ip
->min_int
);
324 mpz_clear (ip
->max_int
);
325 mpz_clear (ip
->huge
);
328 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
330 mpfr_clear (rp
->epsilon
);
331 mpfr_clear (rp
->huge
);
332 mpfr_clear (rp
->tiny
);
337 /* Given an integer and a kind, make sure that the integer lies within
338 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
342 gfc_check_integer_range (mpz_t p
, int kind
)
347 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
352 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
353 result
= ARITH_ASYMMETRIC
;
356 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
357 || mpz_cmp (p
, gfc_integer_kinds
[i
].max_int
) > 0)
358 result
= ARITH_OVERFLOW
;
364 /* Given a real and a kind, make sure that the real lies within the
365 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
369 gfc_check_real_range (mpfr_t p
, int kind
)
375 i
= gfc_validate_kind (BT_REAL
, kind
, false);
379 mpfr_abs (q
, p
, GFC_RND_MODE
);
381 if (mpfr_sgn (q
) == 0)
383 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
384 retval
= ARITH_OVERFLOW
;
385 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
386 retval
= ARITH_UNDERFLOW
;
396 /* Function to return a constant expression node of a given type and
400 gfc_constant_result (bt type
, int kind
, locus
* where
)
406 ("gfc_constant_result(): locus 'where' cannot be NULL");
408 result
= gfc_get_expr ();
410 result
->expr_type
= EXPR_CONSTANT
;
411 result
->ts
.type
= type
;
412 result
->ts
.kind
= kind
;
413 result
->where
= *where
;
418 mpz_init (result
->value
.integer
);
422 gfc_set_model_kind (kind
);
423 mpfr_init (result
->value
.real
);
427 gfc_set_model_kind (kind
);
428 mpfr_init (result
->value
.complex.r
);
429 mpfr_init (result
->value
.complex.i
);
440 /* Low-level arithmetic functions. All of these subroutines assume
441 that all operands are of the same type and return an operand of the
442 same type. The other thing about these subroutines is that they
443 can fail in various ways -- overflow, underflow, division by zero,
444 zero raised to the zero, etc. */
447 gfc_arith_not (gfc_expr
* op1
, gfc_expr
** resultp
)
451 result
= gfc_constant_result (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
452 result
->value
.logical
= !op1
->value
.logical
;
460 gfc_arith_and (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
464 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
466 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
474 gfc_arith_or (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
478 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
480 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
488 gfc_arith_eqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
492 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
494 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
502 gfc_arith_neqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
506 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
508 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
515 /* Make sure a constant numeric expression is within the range for
516 its type and kind. Note that there's also a gfc_check_range(),
517 but that one deals with the intrinsic RANGE function. */
520 gfc_range_check (gfc_expr
* e
)
527 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
531 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
532 if (rc
== ARITH_UNDERFLOW
)
533 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
537 rc
= gfc_check_real_range (e
->value
.complex.r
, e
->ts
.kind
);
538 if (rc
== ARITH_UNDERFLOW
)
539 mpfr_set_ui (e
->value
.complex.r
, 0, GFC_RND_MODE
);
540 if (rc
== ARITH_OK
|| rc
== ARITH_UNDERFLOW
)
542 rc
= gfc_check_real_range (e
->value
.complex.i
, e
->ts
.kind
);
543 if (rc
== ARITH_UNDERFLOW
)
544 mpfr_set_ui (e
->value
.complex.i
, 0, GFC_RND_MODE
);
550 gfc_internal_error ("gfc_range_check(): Bad type");
557 /* Several of the following routines use the same set of statements to
558 check the validity of the result. Encapsulate the checking here. */
561 check_result (arith rc
, gfc_expr
* x
, gfc_expr
* r
, gfc_expr
** rp
)
565 if (val
== ARITH_UNDERFLOW
)
567 if (gfc_option
.warn_underflow
)
568 gfc_warning ("%s at %L", gfc_arith_error (val
), &x
->where
);
572 if (val
== ARITH_ASYMMETRIC
)
574 gfc_warning ("%s at %L", gfc_arith_error (val
), &x
->where
);
587 /* It may seem silly to have a subroutine that actually computes the
588 unary plus of a constant, but it prevents us from making exceptions
589 in the code elsewhere. */
592 gfc_arith_uplus (gfc_expr
* op1
, gfc_expr
** resultp
)
594 *resultp
= gfc_copy_expr (op1
);
600 gfc_arith_uminus (gfc_expr
* op1
, gfc_expr
** resultp
)
605 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
607 switch (op1
->ts
.type
)
610 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
614 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
618 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
619 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
623 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
626 rc
= gfc_range_check (result
);
628 return check_result (rc
, op1
, result
, resultp
);
633 gfc_arith_plus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
638 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
640 switch (op1
->ts
.type
)
643 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
647 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
652 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
653 op2
->value
.complex.r
, GFC_RND_MODE
);
655 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
656 op2
->value
.complex.i
, GFC_RND_MODE
);
660 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
663 rc
= gfc_range_check (result
);
665 return check_result (rc
, op1
, result
, resultp
);
670 gfc_arith_minus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
675 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
677 switch (op1
->ts
.type
)
680 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
684 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
689 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
690 op2
->value
.complex.r
, GFC_RND_MODE
);
692 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
693 op2
->value
.complex.i
, GFC_RND_MODE
);
697 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
700 rc
= gfc_range_check (result
);
702 return check_result (rc
, op1
, result
, resultp
);
707 gfc_arith_times (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
713 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
715 switch (op1
->ts
.type
)
718 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
722 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
728 /* FIXME: possible numericals problem. */
730 gfc_set_model (op1
->value
.complex.r
);
734 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
735 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
736 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
738 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
739 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
740 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
748 gfc_internal_error ("gfc_arith_times(): Bad basic type");
751 rc
= gfc_range_check (result
);
753 return check_result (rc
, op1
, result
, resultp
);
758 gfc_arith_divide (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
766 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
768 switch (op1
->ts
.type
)
771 if (mpz_sgn (op2
->value
.integer
) == 0)
777 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
782 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
783 if (mpfr_sgn (op2
->value
.real
) == 0)
789 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
794 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
795 if (mpfr_sgn (op2
->value
.complex.r
) == 0
796 && mpfr_sgn (op2
->value
.complex.i
) == 0)
802 gfc_set_model (op1
->value
.complex.r
);
807 /* FIXME: possible numerical problems. */
808 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
809 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
810 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
812 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
813 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
814 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
815 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
818 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
819 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
820 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
821 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
831 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
835 rc
= gfc_range_check (result
);
837 return check_result (rc
, op1
, result
, resultp
);
841 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
844 complex_reciprocal (gfc_expr
* op
)
846 mpfr_t mod
, a
, re
, im
;
848 gfc_set_model (op
->value
.complex.r
);
854 /* FIXME: another possible numerical problem. */
855 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
856 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
857 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
859 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
861 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
862 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
864 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
865 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
874 /* Raise a complex number to positive power. */
877 complex_pow_ui (gfc_expr
* base
, int power
, gfc_expr
* result
)
881 gfc_set_model (base
->value
.complex.r
);
886 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
887 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
889 for (; power
> 0; power
--)
891 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
893 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
895 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
897 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
899 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
901 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
903 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
904 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
913 /* Raise a number to an integer power. */
916 gfc_arith_power (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
926 if (gfc_extract_int (op2
, &power
) != NULL
)
927 gfc_internal_error ("gfc_arith_power(): Bad exponent");
929 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
933 /* Handle something to the zeroth power. Since we're dealing
934 with integral exponents, there is no ambiguity in the
935 limiting procedure used to determine the value of 0**0. */
936 switch (op1
->ts
.type
)
939 mpz_set_ui (result
->value
.integer
, 1);
943 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
947 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
948 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
952 gfc_internal_error ("gfc_arith_power(): Bad base");
961 switch (op1
->ts
.type
)
964 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
968 mpz_init_set_ui (unity_z
, 1);
969 mpz_tdiv_q (result
->value
.integer
, unity_z
,
970 result
->value
.integer
);
977 mpfr_pow_ui (result
->value
.real
, op1
->value
.real
, apower
,
982 gfc_set_model (op1
->value
.real
);
984 mpfr_set_ui (unity_f
, 1, GFC_RND_MODE
);
985 mpfr_div (result
->value
.real
, unity_f
, result
->value
.real
,
987 mpfr_clear (unity_f
);
992 complex_pow_ui (op1
, apower
, result
);
994 complex_reciprocal (result
);
1003 rc
= gfc_range_check (result
);
1005 return check_result (rc
, op1
, result
, resultp
);
1009 /* Concatenate two string constants. */
1012 gfc_arith_concat (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1017 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1020 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1022 result
->value
.character
.string
= gfc_getmem (len
+ 1);
1023 result
->value
.character
.length
= len
;
1025 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1026 op1
->value
.character
.length
);
1028 memcpy (result
->value
.character
.string
+ op1
->value
.character
.length
,
1029 op2
->value
.character
.string
, op2
->value
.character
.length
);
1031 result
->value
.character
.string
[len
] = '\0';
1039 /* Comparison operators. Assumes that the two expression nodes
1040 contain two constants of the same type. */
1043 gfc_compare_expr (gfc_expr
* op1
, gfc_expr
* op2
)
1047 switch (op1
->ts
.type
)
1050 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1054 rc
= mpfr_cmp (op1
->value
.real
, op2
->value
.real
);
1058 rc
= gfc_compare_string (op1
, op2
, NULL
);
1062 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1063 || (op1
->value
.logical
&& !op2
->value
.logical
));
1067 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1074 /* Compare a pair of complex numbers. Naturally, this is only for
1075 equality/nonequality. */
1078 compare_complex (gfc_expr
* op1
, gfc_expr
* op2
)
1080 return (mpfr_cmp (op1
->value
.complex.r
, op2
->value
.complex.r
) == 0
1081 && mpfr_cmp (op1
->value
.complex.i
, op2
->value
.complex.i
) == 0);
1085 /* Given two constant strings and the inverse collating sequence,
1086 compare the strings. We return -1 for a<b, 0 for a==b and 1 for
1087 a>b. If the xcoll_table is NULL, we use the processor's default
1088 collating sequence. */
1091 gfc_compare_string (gfc_expr
* a
, gfc_expr
* b
, const int *xcoll_table
)
1093 int len
, alen
, blen
, i
, ac
, bc
;
1095 alen
= a
->value
.character
.length
;
1096 blen
= b
->value
.character
.length
;
1098 len
= (alen
> blen
) ? 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
] : ' ';
1105 if (xcoll_table
!= NULL
)
1107 ac
= xcoll_table
[ac
];
1108 bc
= xcoll_table
[bc
];
1117 /* Strings are equal */
1123 /* Specific comparison subroutines. */
1126 gfc_arith_eq (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1130 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1132 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1133 compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) == 0);
1141 gfc_arith_ne (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1145 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1147 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1148 !compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) != 0);
1156 gfc_arith_gt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1160 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1162 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1170 gfc_arith_ge (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1174 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1176 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1184 gfc_arith_lt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1188 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1190 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1198 gfc_arith_le (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1202 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1204 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1212 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
* op
,
1215 gfc_constructor
*c
, *head
;
1219 if (op
->expr_type
== EXPR_CONSTANT
)
1220 return eval (op
, result
);
1223 head
= gfc_copy_constructor (op
->value
.constructor
);
1225 for (c
= head
; c
; c
= c
->next
)
1227 rc
= eval (c
->expr
, &r
);
1231 gfc_replace_expr (c
->expr
, r
);
1235 gfc_free_constructor (head
);
1238 r
= gfc_get_expr ();
1239 r
->expr_type
= EXPR_ARRAY
;
1240 r
->value
.constructor
= head
;
1241 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1243 r
->ts
= head
->expr
->ts
;
1244 r
->where
= op
->where
;
1255 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1256 gfc_expr
* op1
, gfc_expr
* op2
,
1259 gfc_constructor
*c
, *head
;
1263 head
= gfc_copy_constructor (op1
->value
.constructor
);
1266 for (c
= head
; c
; c
= c
->next
)
1268 rc
= eval (c
->expr
, op2
, &r
);
1272 gfc_replace_expr (c
->expr
, r
);
1276 gfc_free_constructor (head
);
1279 r
= gfc_get_expr ();
1280 r
->expr_type
= EXPR_ARRAY
;
1281 r
->value
.constructor
= head
;
1282 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1284 r
->ts
= head
->expr
->ts
;
1285 r
->where
= op1
->where
;
1286 r
->rank
= op1
->rank
;
1296 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1297 gfc_expr
* op1
, gfc_expr
* op2
,
1300 gfc_constructor
*c
, *head
;
1304 head
= gfc_copy_constructor (op2
->value
.constructor
);
1307 for (c
= head
; c
; c
= c
->next
)
1309 rc
= eval (op1
, c
->expr
, &r
);
1313 gfc_replace_expr (c
->expr
, r
);
1317 gfc_free_constructor (head
);
1320 r
= gfc_get_expr ();
1321 r
->expr_type
= EXPR_ARRAY
;
1322 r
->value
.constructor
= head
;
1323 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1325 r
->ts
= head
->expr
->ts
;
1326 r
->where
= op2
->where
;
1327 r
->rank
= op2
->rank
;
1337 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1338 gfc_expr
* op1
, gfc_expr
* op2
,
1341 gfc_constructor
*c
, *d
, *head
;
1345 head
= gfc_copy_constructor (op1
->value
.constructor
);
1348 d
= op2
->value
.constructor
;
1350 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1352 rc
= ARITH_INCOMMENSURATE
;
1356 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1360 rc
= ARITH_INCOMMENSURATE
;
1364 rc
= eval (c
->expr
, d
->expr
, &r
);
1368 gfc_replace_expr (c
->expr
, r
);
1372 rc
= ARITH_INCOMMENSURATE
;
1376 gfc_free_constructor (head
);
1379 r
= gfc_get_expr ();
1380 r
->expr_type
= EXPR_ARRAY
;
1381 r
->value
.constructor
= head
;
1382 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1384 r
->ts
= head
->expr
->ts
;
1385 r
->where
= op1
->where
;
1386 r
->rank
= op1
->rank
;
1396 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1397 gfc_expr
* op1
, gfc_expr
* op2
,
1400 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1401 return eval (op1
, op2
, result
);
1403 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1404 return reduce_binary_ca (eval
, op1
, op2
, result
);
1406 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1407 return reduce_binary_ac (eval
, op1
, op2
, result
);
1409 return reduce_binary_aa (eval
, op1
, op2
, result
);
1415 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1416 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1420 /* High level arithmetic subroutines. These subroutines go into
1421 eval_intrinsic(), which can do one of several things to its
1422 operands. If the operands are incompatible with the intrinsic
1423 operation, we return a node pointing to the operands and hope that
1424 an operator interface is found during resolution.
1426 If the operands are compatible and are constants, then we try doing
1427 the arithmetic. We also handle the cases where either or both
1428 operands are array constructors. */
1431 eval_intrinsic (gfc_intrinsic_op
operator,
1432 eval_f eval
, gfc_expr
* op1
, gfc_expr
* op2
)
1434 gfc_expr temp
, *result
;
1438 gfc_clear_ts (&temp
.ts
);
1442 case INTRINSIC_NOT
: /* Logical unary */
1443 if (op1
->ts
.type
!= BT_LOGICAL
)
1446 temp
.ts
.type
= BT_LOGICAL
;
1447 temp
.ts
.kind
= gfc_default_logical_kind
;
1452 /* Logical binary operators */
1455 case INTRINSIC_NEQV
:
1457 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1460 temp
.ts
.type
= BT_LOGICAL
;
1461 temp
.ts
.kind
= gfc_default_logical_kind
;
1466 case INTRINSIC_UPLUS
:
1467 case INTRINSIC_UMINUS
: /* Numeric unary */
1468 if (!gfc_numeric_ts (&op1
->ts
))
1477 case INTRINSIC_LT
: /* Additional restrictions */
1478 case INTRINSIC_LE
: /* for ordering relations. */
1480 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1482 temp
.ts
.type
= BT_LOGICAL
;
1483 temp
.ts
.kind
= gfc_default_logical_kind
;
1487 /* else fall through */
1491 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1494 temp
.ts
.type
= BT_LOGICAL
;
1495 temp
.ts
.kind
= gfc_default_logical_kind
;
1499 /* else fall through */
1501 case INTRINSIC_PLUS
:
1502 case INTRINSIC_MINUS
:
1503 case INTRINSIC_TIMES
:
1504 case INTRINSIC_DIVIDE
:
1505 case INTRINSIC_POWER
: /* Numeric binary */
1506 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1509 /* Insert any necessary type conversions to make the operands compatible. */
1511 temp
.expr_type
= EXPR_OP
;
1512 gfc_clear_ts (&temp
.ts
);
1513 temp
.value
.op
.operator = operator;
1515 temp
.value
.op
.op1
= op1
;
1516 temp
.value
.op
.op2
= op2
;
1518 gfc_type_convert_binary (&temp
);
1520 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1521 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1522 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1524 temp
.ts
.type
= BT_LOGICAL
;
1525 temp
.ts
.kind
= gfc_default_logical_kind
;
1531 case INTRINSIC_CONCAT
: /* Character binary */
1532 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1535 temp
.ts
.type
= BT_CHARACTER
;
1536 temp
.ts
.kind
= gfc_default_character_kind
;
1541 case INTRINSIC_USER
:
1545 gfc_internal_error ("eval_intrinsic(): Bad operator");
1548 /* Try to combine the operators. */
1549 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1552 if (op1
->expr_type
!= EXPR_CONSTANT
1553 && (op1
->expr_type
!= EXPR_ARRAY
1554 || !gfc_is_constant_expr (op1
)
1555 || !gfc_expanded_ac (op1
)))
1559 && op2
->expr_type
!= EXPR_CONSTANT
1560 && (op2
->expr_type
!= EXPR_ARRAY
1561 || !gfc_is_constant_expr (op2
)
1562 || !gfc_expanded_ac (op2
)))
1566 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1568 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1571 { /* Something went wrong */
1572 gfc_error ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
1576 gfc_free_expr (op1
);
1577 gfc_free_expr (op2
);
1581 /* Create a run-time expression */
1582 result
= gfc_get_expr ();
1583 result
->ts
= temp
.ts
;
1585 result
->expr_type
= EXPR_OP
;
1586 result
->value
.op
.operator = operator;
1588 result
->value
.op
.op1
= op1
;
1589 result
->value
.op
.op2
= op2
;
1591 result
->where
= op1
->where
;
1597 /* Modify type of expression for zero size array. */
1599 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1602 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1612 op
->ts
.type
= BT_LOGICAL
;
1613 op
->ts
.kind
= gfc_default_logical_kind
;
1624 /* Return nonzero if the expression is a zero size array. */
1627 gfc_zero_size_array (gfc_expr
* e
)
1629 if (e
->expr_type
!= EXPR_ARRAY
)
1632 return e
->value
.constructor
== NULL
;
1636 /* Reduce a binary expression where at least one of the operands
1637 involves a zero-length array. Returns NULL if neither of the
1638 operands is a zero-length array. */
1641 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1643 if (gfc_zero_size_array (op1
))
1645 gfc_free_expr (op2
);
1649 if (gfc_zero_size_array (op2
))
1651 gfc_free_expr (op1
);
1660 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1661 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1662 gfc_expr
* op1
, gfc_expr
* op2
)
1669 if (gfc_zero_size_array (op1
))
1670 return eval_type_intrinsic0 (operator, op1
);
1674 result
= reduce_binary0 (op1
, op2
);
1676 return eval_type_intrinsic0 (operator, result
);
1680 return eval_intrinsic (operator, f
, op1
, op2
);
1685 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1686 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1687 gfc_expr
* op1
, gfc_expr
* op2
)
1692 result
= reduce_binary0 (op1
, op2
);
1694 return eval_type_intrinsic0(operator, result
);
1697 return eval_intrinsic (operator, f
, op1
, op2
);
1703 gfc_uplus (gfc_expr
* op
)
1705 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1709 gfc_uminus (gfc_expr
* op
)
1711 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1715 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1717 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1721 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1723 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1727 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1729 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1733 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1735 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1739 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1741 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1745 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1747 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1751 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1753 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1757 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1759 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1763 gfc_not (gfc_expr
* op1
)
1765 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1769 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1771 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1775 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1777 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1781 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1783 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1787 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1789 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1793 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1795 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1799 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1801 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1805 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1807 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1811 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1813 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1817 /* Convert an integer string to an expression node. */
1820 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
* where
)
1825 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1826 /* a leading plus is allowed, but not by mpz_set_str */
1827 if (buffer
[0] == '+')
1831 mpz_set_str (e
->value
.integer
, t
, radix
);
1837 /* Convert a real string to an expression node. */
1840 gfc_convert_real (const char *buffer
, int kind
, locus
* where
)
1844 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1845 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1851 /* Convert a pair of real, constant expression nodes to a single
1852 complex expression node. */
1855 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1859 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1860 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1861 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1867 /******* Simplification of intrinsic functions with constant arguments *****/
1870 /* Deal with an arithmetic error. */
1873 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1875 gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc
),
1876 gfc_typename (from
), gfc_typename (to
), where
);
1878 /* TODO: Do something about the error, ie, throw exception, return
1882 /* Convert integers to integers. */
1885 gfc_int2int (gfc_expr
* src
, int kind
)
1890 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1892 mpz_set (result
->value
.integer
, src
->value
.integer
);
1894 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
1897 if (rc
== ARITH_ASYMMETRIC
)
1899 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
1903 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1904 gfc_free_expr (result
);
1913 /* Convert integers to reals. */
1916 gfc_int2real (gfc_expr
* src
, int kind
)
1921 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
1923 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
1925 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
1927 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1928 gfc_free_expr (result
);
1936 /* Convert default integer to default complex. */
1939 gfc_int2complex (gfc_expr
* src
, int kind
)
1944 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
1946 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
1947 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
1949 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
1951 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1952 gfc_free_expr (result
);
1960 /* Convert default real to default integer. */
1963 gfc_real2int (gfc_expr
* src
, int kind
)
1968 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1970 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
1972 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
1975 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1976 gfc_free_expr (result
);
1984 /* Convert real to real. */
1987 gfc_real2real (gfc_expr
* src
, int kind
)
1992 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
1994 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
1996 rc
= gfc_check_real_range (result
->value
.real
, kind
);
1998 if (rc
== ARITH_UNDERFLOW
)
2000 if (gfc_option
.warn_underflow
)
2001 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2002 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2004 else if (rc
!= ARITH_OK
)
2006 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2007 gfc_free_expr (result
);
2015 /* Convert real to complex. */
2018 gfc_real2complex (gfc_expr
* src
, int kind
)
2023 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2025 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2026 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2028 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2030 if (rc
== ARITH_UNDERFLOW
)
2032 if (gfc_option
.warn_underflow
)
2033 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2034 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2036 else if (rc
!= ARITH_OK
)
2038 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2039 gfc_free_expr (result
);
2047 /* Convert complex to integer. */
2050 gfc_complex2int (gfc_expr
* src
, int kind
)
2055 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2057 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2059 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2062 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2063 gfc_free_expr (result
);
2071 /* Convert complex to real. */
2074 gfc_complex2real (gfc_expr
* src
, int kind
)
2079 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2081 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2083 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2085 if (rc
== ARITH_UNDERFLOW
)
2087 if (gfc_option
.warn_underflow
)
2088 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2089 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2093 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2094 gfc_free_expr (result
);
2102 /* Convert complex to complex. */
2105 gfc_complex2complex (gfc_expr
* src
, int kind
)
2110 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2112 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2113 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2115 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2117 if (rc
== ARITH_UNDERFLOW
)
2119 if (gfc_option
.warn_underflow
)
2120 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2121 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2123 else if (rc
!= ARITH_OK
)
2125 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2126 gfc_free_expr (result
);
2130 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2132 if (rc
== ARITH_UNDERFLOW
)
2134 if (gfc_option
.warn_underflow
)
2135 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2136 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2138 else if (rc
!= ARITH_OK
)
2140 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2141 gfc_free_expr (result
);
2149 /* Logical kind conversion. */
2152 gfc_log2log (gfc_expr
* src
, int kind
)
2156 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2157 result
->value
.logical
= src
->value
.logical
;