2 Copyright (C) 2000, 2001, 2002, 2003, 2004 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";
156 p
= "Indeterminate form 0 ** 0";
158 case ARITH_INCOMMENSURATE
:
159 p
= "Array operands are incommensurate";
161 case ARITH_ASYMMETRIC
:
162 p
= "Integer outside symmetric range implied by Standard Fortran";
165 gfc_internal_error ("gfc_arith_error(): Bad error code");
172 /* Get things ready to do math. */
175 gfc_arith_init_1 (void)
177 gfc_integer_info
*int_info
;
178 gfc_real_info
*real_info
;
183 mpfr_set_default_prec (128);
187 /* Convert the minimum/maximum values for each kind into their
188 GNU MP representation. */
189 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
192 mpz_set_ui (r
, int_info
->radix
);
193 mpz_pow_ui (r
, r
, int_info
->digits
);
195 mpz_init (int_info
->huge
);
196 mpz_sub_ui (int_info
->huge
, r
, 1);
198 /* These are the numbers that are actually representable by the
199 target. For bases other than two, this needs to be changed. */
200 if (int_info
->radix
!= 2)
201 gfc_internal_error ("Fix min_int, max_int calculation");
203 /* See PRs 13490 and 17912, related to integer ranges.
204 The pedantic_min_int exists for range checking when a program
205 is compiled with -pedantic, and reflects the belief that
206 Standard Fortran requires integers to be symmetrical, i.e.
207 every negative integer must have a representable positive
208 absolute value, and vice versa. */
210 mpz_init (int_info
->pedantic_min_int
);
211 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
213 mpz_init (int_info
->min_int
);
214 mpz_sub_ui(int_info
->min_int
, int_info
->pedantic_min_int
, 1);
216 mpz_init (int_info
->max_int
);
217 mpz_add (int_info
->max_int
, int_info
->huge
, int_info
->huge
);
218 mpz_add_ui (int_info
->max_int
, int_info
->max_int
, 1);
221 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
222 mpfr_log10 (a
, a
, GFC_RND_MODE
);
224 gfc_mpfr_to_mpz (r
, a
);
225 int_info
->range
= mpz_get_si (r
);
230 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
232 gfc_set_model_kind (real_info
->kind
);
238 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
239 /* a = 1 - b**(-p) */
240 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
241 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
242 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
243 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
245 /* c = b**(emax-1) */
246 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
247 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
249 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
250 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
252 /* a = (1 - b**(-p)) * b**(emax-1) * b */
253 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
255 mpfr_init (real_info
->huge
);
256 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
258 /* tiny(x) = b**(emin-1) */
259 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
260 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
262 mpfr_init (real_info
->tiny
);
263 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
265 /* epsilon(x) = b**(1-p) */
266 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
267 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
269 mpfr_init (real_info
->epsilon
);
270 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
272 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
273 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
274 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
275 mpfr_neg (b
, b
, GFC_RND_MODE
);
277 if (mpfr_cmp (a
, b
) > 0)
278 mpfr_set (a
, b
, GFC_RND_MODE
); /* a = min(a, b) */
281 gfc_mpfr_to_mpz (r
, a
);
282 real_info
->range
= mpz_get_si (r
);
284 /* precision(x) = int((p - 1) * log10(b)) + k */
285 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
286 mpfr_log10 (a
, a
, GFC_RND_MODE
);
288 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
290 gfc_mpfr_to_mpz (r
, a
);
291 real_info
->precision
= mpz_get_si (r
);
293 /* If the radix is an integral power of 10, add one to the
295 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
296 if (i
== real_info
->radix
)
297 real_info
->precision
++;
308 /* Clean up, get rid of numeric constants. */
311 gfc_arith_done_1 (void)
313 gfc_integer_info
*ip
;
316 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
318 mpz_clear (ip
->min_int
);
319 mpz_clear (ip
->max_int
);
320 mpz_clear (ip
->huge
);
323 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
325 mpfr_clear (rp
->epsilon
);
326 mpfr_clear (rp
->huge
);
327 mpfr_clear (rp
->tiny
);
332 /* Given an integer and a kind, make sure that the integer lies within
333 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
337 gfc_check_integer_range (mpz_t p
, int kind
)
342 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
347 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
348 result
= ARITH_ASYMMETRIC
;
351 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
352 || mpz_cmp (p
, gfc_integer_kinds
[i
].max_int
) > 0)
353 result
= ARITH_OVERFLOW
;
359 /* Given a real and a kind, make sure that the real lies within the
360 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
364 gfc_check_real_range (mpfr_t p
, int kind
)
370 i
= gfc_validate_kind (BT_REAL
, kind
, false);
374 mpfr_abs (q
, p
, GFC_RND_MODE
);
377 if (mpfr_sgn (q
) == 0)
380 if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
382 retval
= ARITH_OVERFLOW
;
386 if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
387 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 /* It may seem silly to have a subroutine that actually computes the
558 unary plus of a constant, but it prevents us from making exceptions
559 in the code elsewhere. */
562 gfc_arith_uplus (gfc_expr
* op1
, gfc_expr
** resultp
)
564 *resultp
= gfc_copy_expr (op1
);
570 gfc_arith_uminus (gfc_expr
* op1
, gfc_expr
** resultp
)
575 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
577 switch (op1
->ts
.type
)
580 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
584 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
588 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
589 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
593 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
596 rc
= gfc_range_check (result
);
598 if (rc
== ARITH_UNDERFLOW
)
600 if (gfc_option
.warn_underflow
)
601 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
605 else if (rc
== ARITH_ASYMMETRIC
)
607 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
611 else if (rc
!= ARITH_OK
)
612 gfc_free_expr (result
);
621 gfc_arith_plus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
626 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
628 switch (op1
->ts
.type
)
631 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
635 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
640 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
641 op2
->value
.complex.r
, GFC_RND_MODE
);
643 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
644 op2
->value
.complex.i
, GFC_RND_MODE
);
648 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
651 rc
= gfc_range_check (result
);
653 if (rc
== ARITH_UNDERFLOW
)
655 if (gfc_option
.warn_underflow
)
656 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
660 else if (rc
== ARITH_ASYMMETRIC
)
662 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
666 else if (rc
!= ARITH_OK
)
667 gfc_free_expr (result
);
676 gfc_arith_minus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
681 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
683 switch (op1
->ts
.type
)
686 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
690 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
695 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
696 op2
->value
.complex.r
, GFC_RND_MODE
);
698 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
699 op2
->value
.complex.i
, GFC_RND_MODE
);
703 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
706 rc
= gfc_range_check (result
);
708 if (rc
== ARITH_UNDERFLOW
)
710 if (gfc_option
.warn_underflow
)
711 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
715 else if (rc
== ARITH_ASYMMETRIC
)
717 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
721 else if (rc
!= ARITH_OK
)
722 gfc_free_expr (result
);
731 gfc_arith_times (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
737 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
739 switch (op1
->ts
.type
)
742 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
746 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
752 /* FIXME: possible numericals problem. */
754 gfc_set_model (op1
->value
.complex.r
);
758 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
759 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
760 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
762 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
763 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
764 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
772 gfc_internal_error ("gfc_arith_times(): Bad basic type");
775 rc
= gfc_range_check (result
);
777 if (rc
== ARITH_UNDERFLOW
)
779 if (gfc_option
.warn_underflow
)
780 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
784 else if (rc
== ARITH_ASYMMETRIC
)
786 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
790 else if (rc
!= ARITH_OK
)
791 gfc_free_expr (result
);
800 gfc_arith_divide (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
808 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
810 switch (op1
->ts
.type
)
813 if (mpz_sgn (op2
->value
.integer
) == 0)
819 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
824 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
825 if (mpfr_sgn (op2
->value
.real
) == 0)
831 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
836 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
837 if (mpfr_sgn (op2
->value
.complex.r
) == 0
838 && mpfr_sgn (op2
->value
.complex.i
) == 0)
844 gfc_set_model (op1
->value
.complex.r
);
849 /* FIXME: possible numerical problems. */
850 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
851 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
852 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
854 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
855 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
856 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
857 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
860 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
861 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
862 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
863 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
873 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
877 rc
= gfc_range_check (result
);
879 if (rc
== ARITH_UNDERFLOW
)
881 if (gfc_option
.warn_underflow
)
882 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
886 else if (rc
== ARITH_ASYMMETRIC
)
888 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
892 else if (rc
!= ARITH_OK
)
893 gfc_free_expr (result
);
901 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
904 complex_reciprocal (gfc_expr
* op
)
906 mpfr_t mod
, a
, re
, im
;
908 gfc_set_model (op
->value
.complex.r
);
914 /* FIXME: another possible numerical problem. */
915 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
916 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
917 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
919 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
921 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
922 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
924 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
925 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
934 /* Raise a complex number to positive power. */
937 complex_pow_ui (gfc_expr
* base
, int power
, gfc_expr
* result
)
941 gfc_set_model (base
->value
.complex.r
);
946 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
947 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
949 for (; power
> 0; power
--)
951 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
953 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
955 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
957 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
959 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
961 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
963 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
964 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
973 /* Raise a number to an integer power. */
976 gfc_arith_power (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
986 if (gfc_extract_int (op2
, &power
) != NULL
)
987 gfc_internal_error ("gfc_arith_power(): Bad exponent");
989 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
992 { /* Handle something to the zeroth power */
993 switch (op1
->ts
.type
)
996 if (mpz_sgn (op1
->value
.integer
) == 0)
999 mpz_set_ui (result
->value
.integer
, 1);
1003 if (mpfr_sgn (op1
->value
.real
) == 0)
1006 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
1010 if (mpfr_sgn (op1
->value
.complex.r
) == 0
1011 && mpfr_sgn (op1
->value
.complex.i
) == 0)
1015 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
1016 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
1022 gfc_internal_error ("gfc_arith_power(): Bad base");
1031 switch (op1
->ts
.type
)
1034 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
1038 mpz_init_set_ui (unity_z
, 1);
1039 mpz_tdiv_q (result
->value
.integer
, unity_z
,
1040 result
->value
.integer
);
1041 mpz_clear (unity_z
);
1047 mpfr_pow_ui (result
->value
.real
, op1
->value
.real
, apower
,
1052 gfc_set_model (op1
->value
.real
);
1053 mpfr_init (unity_f
);
1054 mpfr_set_ui (unity_f
, 1, GFC_RND_MODE
);
1055 mpfr_div (result
->value
.real
, unity_f
, result
->value
.real
,
1057 mpfr_clear (unity_f
);
1062 complex_pow_ui (op1
, apower
, result
);
1064 complex_reciprocal (result
);
1073 rc
= gfc_range_check (result
);
1075 if (rc
== ARITH_UNDERFLOW
)
1077 if (gfc_option
.warn_underflow
)
1078 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
1082 else if (rc
== ARITH_ASYMMETRIC
)
1084 gfc_warning ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
1088 else if (rc
!= ARITH_OK
)
1089 gfc_free_expr (result
);
1097 /* Concatenate two string constants. */
1100 gfc_arith_concat (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1105 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1108 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1110 result
->value
.character
.string
= gfc_getmem (len
+ 1);
1111 result
->value
.character
.length
= len
;
1113 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1114 op1
->value
.character
.length
);
1116 memcpy (result
->value
.character
.string
+ op1
->value
.character
.length
,
1117 op2
->value
.character
.string
, op2
->value
.character
.length
);
1119 result
->value
.character
.string
[len
] = '\0';
1127 /* Comparison operators. Assumes that the two expression nodes
1128 contain two constants of the same type. */
1131 gfc_compare_expr (gfc_expr
* op1
, gfc_expr
* op2
)
1135 switch (op1
->ts
.type
)
1138 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1142 rc
= mpfr_cmp (op1
->value
.real
, op2
->value
.real
);
1146 rc
= gfc_compare_string (op1
, op2
, NULL
);
1150 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1151 || (op1
->value
.logical
&& !op2
->value
.logical
));
1155 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1162 /* Compare a pair of complex numbers. Naturally, this is only for
1163 equality/nonequality. */
1166 compare_complex (gfc_expr
* op1
, gfc_expr
* op2
)
1168 return (mpfr_cmp (op1
->value
.complex.r
, op2
->value
.complex.r
) == 0
1169 && mpfr_cmp (op1
->value
.complex.i
, op2
->value
.complex.i
) == 0);
1173 /* Given two constant strings and the inverse collating sequence,
1174 compare the strings. We return -1 for a<b, 0 for a==b and 1 for
1175 a>b. If the xcoll_table is NULL, we use the processor's default
1176 collating sequence. */
1179 gfc_compare_string (gfc_expr
* a
, gfc_expr
* b
, const int *xcoll_table
)
1181 int len
, alen
, blen
, i
, ac
, bc
;
1183 alen
= a
->value
.character
.length
;
1184 blen
= b
->value
.character
.length
;
1186 len
= (alen
> blen
) ? alen
: blen
;
1188 for (i
= 0; i
< len
; i
++)
1190 ac
= (i
< alen
) ? a
->value
.character
.string
[i
] : ' ';
1191 bc
= (i
< blen
) ? b
->value
.character
.string
[i
] : ' ';
1193 if (xcoll_table
!= NULL
)
1195 ac
= xcoll_table
[ac
];
1196 bc
= xcoll_table
[bc
];
1205 /* Strings are equal */
1211 /* Specific comparison subroutines. */
1214 gfc_arith_eq (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1218 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1220 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1221 compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) == 0);
1229 gfc_arith_ne (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1233 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1235 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1236 !compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) != 0);
1244 gfc_arith_gt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1248 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1250 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1258 gfc_arith_ge (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1262 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1264 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1272 gfc_arith_lt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1276 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1278 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1286 gfc_arith_le (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1290 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1292 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1300 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
* op
,
1303 gfc_constructor
*c
, *head
;
1307 if (op
->expr_type
== EXPR_CONSTANT
)
1308 return eval (op
, result
);
1311 head
= gfc_copy_constructor (op
->value
.constructor
);
1313 for (c
= head
; c
; c
= c
->next
)
1315 rc
= eval (c
->expr
, &r
);
1319 gfc_replace_expr (c
->expr
, r
);
1323 gfc_free_constructor (head
);
1326 r
= gfc_get_expr ();
1327 r
->expr_type
= EXPR_ARRAY
;
1328 r
->value
.constructor
= head
;
1329 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1331 r
->ts
= head
->expr
->ts
;
1332 r
->where
= op
->where
;
1343 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1344 gfc_expr
* op1
, gfc_expr
* op2
,
1347 gfc_constructor
*c
, *head
;
1351 head
= gfc_copy_constructor (op1
->value
.constructor
);
1354 for (c
= head
; c
; c
= c
->next
)
1356 rc
= eval (c
->expr
, op2
, &r
);
1360 gfc_replace_expr (c
->expr
, r
);
1364 gfc_free_constructor (head
);
1367 r
= gfc_get_expr ();
1368 r
->expr_type
= EXPR_ARRAY
;
1369 r
->value
.constructor
= head
;
1370 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1372 r
->ts
= head
->expr
->ts
;
1373 r
->where
= op1
->where
;
1374 r
->rank
= op1
->rank
;
1384 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1385 gfc_expr
* op1
, gfc_expr
* op2
,
1388 gfc_constructor
*c
, *head
;
1392 head
= gfc_copy_constructor (op2
->value
.constructor
);
1395 for (c
= head
; c
; c
= c
->next
)
1397 rc
= eval (op1
, c
->expr
, &r
);
1401 gfc_replace_expr (c
->expr
, r
);
1405 gfc_free_constructor (head
);
1408 r
= gfc_get_expr ();
1409 r
->expr_type
= EXPR_ARRAY
;
1410 r
->value
.constructor
= head
;
1411 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1413 r
->ts
= head
->expr
->ts
;
1414 r
->where
= op2
->where
;
1415 r
->rank
= op2
->rank
;
1425 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1426 gfc_expr
* op1
, gfc_expr
* op2
,
1429 gfc_constructor
*c
, *d
, *head
;
1433 head
= gfc_copy_constructor (op1
->value
.constructor
);
1436 d
= op2
->value
.constructor
;
1438 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1440 rc
= ARITH_INCOMMENSURATE
;
1444 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1448 rc
= ARITH_INCOMMENSURATE
;
1452 rc
= eval (c
->expr
, d
->expr
, &r
);
1456 gfc_replace_expr (c
->expr
, r
);
1460 rc
= ARITH_INCOMMENSURATE
;
1464 gfc_free_constructor (head
);
1467 r
= gfc_get_expr ();
1468 r
->expr_type
= EXPR_ARRAY
;
1469 r
->value
.constructor
= head
;
1470 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1472 r
->ts
= head
->expr
->ts
;
1473 r
->where
= op1
->where
;
1474 r
->rank
= op1
->rank
;
1484 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1485 gfc_expr
* op1
, gfc_expr
* op2
,
1488 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1489 return eval (op1
, op2
, result
);
1491 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1492 return reduce_binary_ca (eval
, op1
, op2
, result
);
1494 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1495 return reduce_binary_ac (eval
, op1
, op2
, result
);
1497 return reduce_binary_aa (eval
, op1
, op2
, result
);
1503 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1504 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1508 /* High level arithmetic subroutines. These subroutines go into
1509 eval_intrinsic(), which can do one of several things to its
1510 operands. If the operands are incompatible with the intrinsic
1511 operation, we return a node pointing to the operands and hope that
1512 an operator interface is found during resolution.
1514 If the operands are compatible and are constants, then we try doing
1515 the arithmetic. We also handle the cases where either or both
1516 operands are array constructors. */
1519 eval_intrinsic (gfc_intrinsic_op
operator,
1520 eval_f eval
, gfc_expr
* op1
, gfc_expr
* op2
)
1522 gfc_expr temp
, *result
;
1526 gfc_clear_ts (&temp
.ts
);
1530 case INTRINSIC_NOT
: /* Logical unary */
1531 if (op1
->ts
.type
!= BT_LOGICAL
)
1534 temp
.ts
.type
= BT_LOGICAL
;
1535 temp
.ts
.kind
= gfc_default_logical_kind
;
1540 /* Logical binary operators */
1543 case INTRINSIC_NEQV
:
1545 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1548 temp
.ts
.type
= BT_LOGICAL
;
1549 temp
.ts
.kind
= gfc_default_logical_kind
;
1554 case INTRINSIC_UPLUS
:
1555 case INTRINSIC_UMINUS
: /* Numeric unary */
1556 if (!gfc_numeric_ts (&op1
->ts
))
1565 case INTRINSIC_LT
: /* Additional restrictions */
1566 case INTRINSIC_LE
: /* for ordering relations. */
1568 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1570 temp
.ts
.type
= BT_LOGICAL
;
1571 temp
.ts
.kind
= gfc_default_logical_kind
;
1575 /* else fall through */
1579 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1582 temp
.ts
.type
= BT_LOGICAL
;
1583 temp
.ts
.kind
= gfc_default_logical_kind
;
1587 /* else fall through */
1589 case INTRINSIC_PLUS
:
1590 case INTRINSIC_MINUS
:
1591 case INTRINSIC_TIMES
:
1592 case INTRINSIC_DIVIDE
:
1593 case INTRINSIC_POWER
: /* Numeric binary */
1594 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1597 /* Insert any necessary type conversions to make the operands compatible. */
1599 temp
.expr_type
= EXPR_OP
;
1600 gfc_clear_ts (&temp
.ts
);
1601 temp
.operator = operator;
1606 gfc_type_convert_binary (&temp
);
1608 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1609 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1610 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1612 temp
.ts
.type
= BT_LOGICAL
;
1613 temp
.ts
.kind
= gfc_default_logical_kind
;
1619 case INTRINSIC_CONCAT
: /* Character binary */
1620 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1623 temp
.ts
.type
= BT_CHARACTER
;
1624 temp
.ts
.kind
= gfc_default_character_kind
;
1629 case INTRINSIC_USER
:
1633 gfc_internal_error ("eval_intrinsic(): Bad operator");
1636 /* Try to combine the operators. */
1637 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1640 if (op1
->expr_type
!= EXPR_CONSTANT
1641 && (op1
->expr_type
!= EXPR_ARRAY
1642 || !gfc_is_constant_expr (op1
)
1643 || !gfc_expanded_ac (op1
)))
1647 && op2
->expr_type
!= EXPR_CONSTANT
1648 && (op2
->expr_type
!= EXPR_ARRAY
1649 || !gfc_is_constant_expr (op2
)
1650 || !gfc_expanded_ac (op2
)))
1654 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1656 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1659 { /* Something went wrong */
1660 gfc_error ("%s at %L", gfc_arith_error (rc
), &op1
->where
);
1664 gfc_free_expr (op1
);
1665 gfc_free_expr (op2
);
1669 /* Create a run-time expression */
1670 result
= gfc_get_expr ();
1671 result
->ts
= temp
.ts
;
1673 result
->expr_type
= EXPR_OP
;
1674 result
->operator = operator;
1679 result
->where
= op1
->where
;
1685 /* Modify type of expression for zero size array. */
1687 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1690 gfc_internal_error("eval_type_intrinsic0(): op NULL");
1700 op
->ts
.type
= BT_LOGICAL
;
1701 op
->ts
.kind
= gfc_default_logical_kind
;
1712 /* Return nonzero if the expression is a zero size array. */
1715 gfc_zero_size_array (gfc_expr
* e
)
1717 if (e
->expr_type
!= EXPR_ARRAY
)
1720 return e
->value
.constructor
== NULL
;
1724 /* Reduce a binary expression where at least one of the operands
1725 involves a zero-length array. Returns NULL if neither of the
1726 operands is a zero-length array. */
1729 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1731 if (gfc_zero_size_array (op1
))
1733 gfc_free_expr (op2
);
1737 if (gfc_zero_size_array (op2
))
1739 gfc_free_expr (op1
);
1748 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1749 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1750 gfc_expr
* op1
, gfc_expr
* op2
)
1757 if (gfc_zero_size_array (op1
))
1758 return eval_type_intrinsic0(operator, op1
);
1762 result
= reduce_binary0 (op1
, op2
);
1764 return eval_type_intrinsic0(operator, result
);
1768 return eval_intrinsic (operator, f
, op1
, op2
);
1773 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1774 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1775 gfc_expr
* op1
, gfc_expr
* op2
)
1780 result
= reduce_binary0 (op1
, op2
);
1782 return eval_type_intrinsic0(operator, result
);
1785 return eval_intrinsic (operator, f
, op1
, op2
);
1791 gfc_uplus (gfc_expr
* op
)
1793 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1797 gfc_uminus (gfc_expr
* op
)
1799 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1803 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1805 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1809 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1811 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1815 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1817 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1821 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1823 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1827 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1829 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1833 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1835 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1839 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1841 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1845 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1847 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1851 gfc_not (gfc_expr
* op1
)
1853 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1857 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1859 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1863 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1865 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1869 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1871 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1875 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1877 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1881 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1883 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1887 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1889 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1893 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1895 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1899 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1901 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1905 /* Convert an integer string to an expression node. */
1908 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
* where
)
1913 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1914 /* a leading plus is allowed, but not by mpz_set_str */
1915 if (buffer
[0] == '+')
1919 mpz_set_str (e
->value
.integer
, t
, radix
);
1925 /* Convert a real string to an expression node. */
1928 gfc_convert_real (const char *buffer
, int kind
, locus
* where
)
1933 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1934 /* A leading plus is allowed in Fortran, but not by mpfr_set_str */
1935 if (buffer
[0] == '+')
1939 mpfr_set_str (e
->value
.real
, t
, 10, GFC_RND_MODE
);
1945 /* Convert a pair of real, constant expression nodes to a single
1946 complex expression node. */
1949 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1953 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1954 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1955 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1961 /******* Simplification of intrinsic functions with constant arguments *****/
1964 /* Deal with an arithmetic error. */
1967 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1969 gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc
),
1970 gfc_typename (from
), gfc_typename (to
), where
);
1972 /* TODO: Do something about the error, ie, throw exception, return
1976 /* Convert integers to integers. */
1979 gfc_int2int (gfc_expr
* src
, int kind
)
1984 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1986 mpz_set (result
->value
.integer
, src
->value
.integer
);
1988 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
1991 if (rc
== ARITH_ASYMMETRIC
)
1993 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
1997 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1998 gfc_free_expr (result
);
2007 /* Convert integers to reals. */
2010 gfc_int2real (gfc_expr
* src
, int kind
)
2015 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2017 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2019 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2021 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2022 gfc_free_expr (result
);
2030 /* Convert default integer to default complex. */
2033 gfc_int2complex (gfc_expr
* src
, int kind
)
2038 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2040 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2041 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2043 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2045 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2046 gfc_free_expr (result
);
2054 /* Convert default real to default integer. */
2057 gfc_real2int (gfc_expr
* src
, int kind
)
2062 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2064 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2066 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2069 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2070 gfc_free_expr (result
);
2078 /* Convert real to real. */
2081 gfc_real2real (gfc_expr
* src
, int kind
)
2086 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2088 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2090 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2092 if (rc
== ARITH_UNDERFLOW
)
2094 if (gfc_option
.warn_underflow
)
2095 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2096 mpfr_set_ui(result
->value
.real
, 0, GFC_RND_MODE
);
2098 else if (rc
!= ARITH_OK
)
2100 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2101 gfc_free_expr (result
);
2109 /* Convert real to complex. */
2112 gfc_real2complex (gfc_expr
* src
, int kind
)
2117 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2119 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2120 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2122 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2124 if (rc
== ARITH_UNDERFLOW
)
2126 if (gfc_option
.warn_underflow
)
2127 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2128 mpfr_set_ui(result
->value
.complex.r
, 0, GFC_RND_MODE
);
2130 else if (rc
!= ARITH_OK
)
2132 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2133 gfc_free_expr (result
);
2141 /* Convert complex to integer. */
2144 gfc_complex2int (gfc_expr
* src
, int kind
)
2149 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2151 gfc_mpfr_to_mpz(result
->value
.integer
, src
->value
.complex.r
);
2153 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2156 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2157 gfc_free_expr (result
);
2165 /* Convert complex to real. */
2168 gfc_complex2real (gfc_expr
* src
, int kind
)
2173 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2175 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2177 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2179 if (rc
== ARITH_UNDERFLOW
)
2181 if (gfc_option
.warn_underflow
)
2182 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2183 mpfr_set_ui(result
->value
.real
, 0, GFC_RND_MODE
);
2187 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2188 gfc_free_expr (result
);
2196 /* Convert complex to complex. */
2199 gfc_complex2complex (gfc_expr
* src
, int kind
)
2204 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2206 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2207 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2209 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2211 if (rc
== ARITH_UNDERFLOW
)
2213 if (gfc_option
.warn_underflow
)
2214 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2215 mpfr_set_ui(result
->value
.complex.r
, 0, GFC_RND_MODE
);
2217 else if (rc
!= ARITH_OK
)
2219 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2220 gfc_free_expr (result
);
2224 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2226 if (rc
== ARITH_UNDERFLOW
)
2228 if (gfc_option
.warn_underflow
)
2229 gfc_warning ("%s at %L", gfc_arith_error (rc
), &src
->where
);
2230 mpfr_set_ui(result
->value
.complex.i
, 0, GFC_RND_MODE
);
2232 else if (rc
!= ARITH_OK
)
2234 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2235 gfc_free_expr (result
);
2243 /* Logical kind conversion. */
2246 gfc_log2log (gfc_expr
* src
, int kind
)
2250 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2251 result
->value
.logical
= src
->value
.logical
;