2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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, 51 Franklin Street, Fifth Floor, 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 and the MPFR
26 library to do arithmetic, 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
));
79 /* Given an arithmetic error code, return a pointer to a string that
80 explains the error. */
83 gfc_arith_error (arith code
)
90 p
= _("Arithmetic OK at %L");
93 p
= _("Arithmetic overflow at %L");
96 p
= _("Arithmetic underflow at %L");
99 p
= _("Arithmetic NaN at %L");
102 p
= _("Division by zero at %L");
104 case ARITH_INCOMMENSURATE
:
105 p
= _("Array operands are incommensurate at %L");
107 case ARITH_ASYMMETRIC
:
109 _("Integer outside symmetric range implied by Standard Fortran at %L");
112 gfc_internal_error ("gfc_arith_error(): Bad error code");
119 /* Get things ready to do math. */
122 gfc_arith_init_1 (void)
124 gfc_integer_info
*int_info
;
125 gfc_real_info
*real_info
;
130 mpfr_set_default_prec (128);
134 /* Convert the minimum and maximum values for each kind into their
135 GNU MP representation. */
136 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
139 mpz_set_ui (r
, int_info
->radix
);
140 mpz_pow_ui (r
, r
, int_info
->digits
);
142 mpz_init (int_info
->huge
);
143 mpz_sub_ui (int_info
->huge
, r
, 1);
145 /* These are the numbers that are actually representable by the
146 target. For bases other than two, this needs to be changed. */
147 if (int_info
->radix
!= 2)
148 gfc_internal_error ("Fix min_int calculation");
150 /* See PRs 13490 and 17912, related to integer ranges.
151 The pedantic_min_int exists for range checking when a program
152 is compiled with -pedantic, and reflects the belief that
153 Standard Fortran requires integers to be symmetrical, i.e.
154 every negative integer must have a representable positive
155 absolute value, and vice versa. */
157 mpz_init (int_info
->pedantic_min_int
);
158 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
160 mpz_init (int_info
->min_int
);
161 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
164 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
165 mpfr_log10 (a
, a
, GFC_RND_MODE
);
167 gfc_mpfr_to_mpz (r
, a
);
168 int_info
->range
= mpz_get_si (r
);
173 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
175 gfc_set_model_kind (real_info
->kind
);
181 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
182 /* a = 1 - b**(-p) */
183 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
184 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
185 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
186 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
188 /* c = b**(emax-1) */
189 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
190 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
192 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
193 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
195 /* a = (1 - b**(-p)) * b**(emax-1) * b */
196 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
198 mpfr_init (real_info
->huge
);
199 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
201 /* tiny(x) = b**(emin-1) */
202 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
203 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
205 mpfr_init (real_info
->tiny
);
206 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
208 /* subnormal (x) = b**(emin - digit) */
209 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
210 mpfr_pow_si (b
, b
, real_info
->min_exponent
- real_info
->digits
,
213 mpfr_init (real_info
->subnormal
);
214 mpfr_set (real_info
->subnormal
, b
, GFC_RND_MODE
);
216 /* epsilon(x) = b**(1-p) */
217 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
218 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
220 mpfr_init (real_info
->epsilon
);
221 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
223 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
224 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
225 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
226 mpfr_neg (b
, b
, GFC_RND_MODE
);
229 if (mpfr_cmp (a
, b
) > 0)
230 mpfr_set (a
, b
, GFC_RND_MODE
);
233 gfc_mpfr_to_mpz (r
, a
);
234 real_info
->range
= mpz_get_si (r
);
236 /* precision(x) = int((p - 1) * log10(b)) + k */
237 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
238 mpfr_log10 (a
, a
, GFC_RND_MODE
);
240 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
242 gfc_mpfr_to_mpz (r
, a
);
243 real_info
->precision
= mpz_get_si (r
);
245 /* If the radix is an integral power of 10, add one to the precision. */
246 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
247 if (i
== real_info
->radix
)
248 real_info
->precision
++;
259 /* Clean up, get rid of numeric constants. */
262 gfc_arith_done_1 (void)
264 gfc_integer_info
*ip
;
267 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
269 mpz_clear (ip
->min_int
);
270 mpz_clear (ip
->pedantic_min_int
);
271 mpz_clear (ip
->huge
);
274 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
276 mpfr_clear (rp
->epsilon
);
277 mpfr_clear (rp
->huge
);
278 mpfr_clear (rp
->tiny
);
279 mpfr_clear (rp
->subnormal
);
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 (gfc_option
.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
);
334 if (gfc_option
.flag_range_check
== 0)
337 retval
= ARITH_OVERFLOW
;
339 else if (mpfr_nan_p (p
))
341 if (gfc_option
.flag_range_check
== 0)
346 else if (mpfr_sgn (q
) == 0)
348 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
350 if (gfc_option
.flag_range_check
== 0)
353 retval
= ARITH_OVERFLOW
;
355 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
357 if (gfc_option
.flag_range_check
== 0)
360 retval
= ARITH_UNDERFLOW
;
362 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
367 /* Save current values of emin and emax. */
368 emin
= mpfr_get_emin ();
369 emax
= mpfr_get_emax ();
371 /* Set emin and emax for the current model number. */
372 en
= gfc_real_kinds
[i
].min_exponent
- gfc_real_kinds
[i
].digits
+ 1;
373 mpfr_set_emin ((mp_exp_t
) en
);
374 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[i
].max_exponent
);
375 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
377 /* Reset emin and emax. */
378 mpfr_set_emin (emin
);
379 mpfr_set_emax (emax
);
381 /* Copy sign if needed. */
382 if (mpfr_sgn (p
) < 0)
383 mpfr_neg (p
, q
, GMP_RNDN
);
385 mpfr_set (p
, q
, GMP_RNDN
);
398 /* Function to return a constant expression node of a given type and kind. */
401 gfc_constant_result (bt type
, int kind
, locus
*where
)
406 gfc_internal_error ("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
);
534 if (rc
== ARITH_OVERFLOW
)
535 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
537 mpfr_set_nan (e
->value
.real
);
541 rc
= gfc_check_real_range (e
->value
.complex.r
, e
->ts
.kind
);
542 if (rc
== ARITH_UNDERFLOW
)
543 mpfr_set_ui (e
->value
.complex.r
, 0, GFC_RND_MODE
);
544 if (rc
== ARITH_OVERFLOW
)
545 mpfr_set_inf (e
->value
.complex.r
, mpfr_sgn (e
->value
.complex.r
));
547 mpfr_set_nan (e
->value
.complex.r
);
549 rc
= gfc_check_real_range (e
->value
.complex.i
, e
->ts
.kind
);
550 if (rc
== ARITH_UNDERFLOW
)
551 mpfr_set_ui (e
->value
.complex.i
, 0, GFC_RND_MODE
);
552 if (rc
== ARITH_OVERFLOW
)
553 mpfr_set_inf (e
->value
.complex.i
, mpfr_sgn (e
->value
.complex.i
));
555 mpfr_set_nan (e
->value
.complex.i
);
559 gfc_internal_error ("gfc_range_check(): Bad type");
566 /* Several of the following routines use the same set of statements to
567 check the validity of the result. Encapsulate the checking here. */
570 check_result (arith rc
, gfc_expr
*x
, gfc_expr
*r
, gfc_expr
**rp
)
574 if (val
== ARITH_UNDERFLOW
)
576 if (gfc_option
.warn_underflow
)
577 gfc_warning (gfc_arith_error (val
), &x
->where
);
581 if (val
== ARITH_ASYMMETRIC
)
583 gfc_warning (gfc_arith_error (val
), &x
->where
);
596 /* It may seem silly to have a subroutine that actually computes the
597 unary plus of a constant, but it prevents us from making exceptions
598 in the code elsewhere. */
601 gfc_arith_uplus (gfc_expr
*op1
, gfc_expr
**resultp
)
603 *resultp
= gfc_copy_expr (op1
);
609 gfc_arith_uminus (gfc_expr
*op1
, gfc_expr
**resultp
)
614 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
616 switch (op1
->ts
.type
)
619 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
623 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
627 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
628 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
632 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
635 rc
= gfc_range_check (result
);
637 return check_result (rc
, op1
, result
, resultp
);
642 gfc_arith_plus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
647 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
649 switch (op1
->ts
.type
)
652 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
656 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
661 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
662 op2
->value
.complex.r
, GFC_RND_MODE
);
664 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
665 op2
->value
.complex.i
, GFC_RND_MODE
);
669 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
672 rc
= gfc_range_check (result
);
674 return check_result (rc
, op1
, result
, resultp
);
679 gfc_arith_minus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
684 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
686 switch (op1
->ts
.type
)
689 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
693 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
698 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
699 op2
->value
.complex.r
, GFC_RND_MODE
);
701 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
702 op2
->value
.complex.i
, GFC_RND_MODE
);
706 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
709 rc
= gfc_range_check (result
);
711 return check_result (rc
, op1
, result
, resultp
);
716 gfc_arith_times (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
722 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
724 switch (op1
->ts
.type
)
727 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
731 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
736 gfc_set_model (op1
->value
.complex.r
);
740 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
741 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
742 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
744 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
745 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
746 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
753 gfc_internal_error ("gfc_arith_times(): Bad basic type");
756 rc
= gfc_range_check (result
);
758 return check_result (rc
, op1
, result
, resultp
);
763 gfc_arith_divide (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
771 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
773 switch (op1
->ts
.type
)
776 if (mpz_sgn (op2
->value
.integer
) == 0)
782 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
787 if (mpfr_sgn (op2
->value
.real
) == 0 && gfc_option
.flag_range_check
== 1)
793 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
798 if (mpfr_sgn (op2
->value
.complex.r
) == 0
799 && mpfr_sgn (op2
->value
.complex.i
) == 0
800 && gfc_option
.flag_range_check
== 1)
806 gfc_set_model (op1
->value
.complex.r
);
811 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
812 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
813 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
815 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
816 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
817 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
818 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
821 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
822 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
823 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
824 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
833 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
837 rc
= gfc_range_check (result
);
839 return check_result (rc
, op1
, result
, resultp
);
843 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
846 complex_reciprocal (gfc_expr
*op
)
848 mpfr_t mod
, a
, re
, im
;
850 gfc_set_model (op
->value
.complex.r
);
856 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
857 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
858 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
860 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
862 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
863 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
865 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
866 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
875 /* Raise a complex number to positive power. */
878 complex_pow_ui (gfc_expr
*base
, int power
, gfc_expr
*result
)
882 gfc_set_model (base
->value
.complex.r
);
887 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
888 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
890 for (; power
> 0; power
--)
892 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
894 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
896 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
898 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
900 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
902 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
904 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
905 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
914 /* Raise a number to an integer power. */
917 gfc_arith_power (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
927 if (gfc_extract_int (op2
, &power
) != NULL
)
928 gfc_internal_error ("gfc_arith_power(): Bad exponent");
930 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
934 /* Handle something to the zeroth power. Since we're dealing
935 with integral exponents, there is no ambiguity in the
936 limiting procedure used to determine the value of 0**0. */
937 switch (op1
->ts
.type
)
940 mpz_set_ui (result
->value
.integer
, 1);
944 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
948 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
949 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
953 gfc_internal_error ("gfc_arith_power(): Bad base");
962 switch (op1
->ts
.type
)
965 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
969 mpz_init_set_ui (unity_z
, 1);
970 mpz_tdiv_q (result
->value
.integer
, unity_z
,
971 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
);
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 and 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, 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 int len
, alen
, blen
, i
, ac
, bc
;
1094 alen
= a
->value
.character
.length
;
1095 blen
= b
->value
.character
.length
;
1097 len
= (alen
> blen
) ? alen
: blen
;
1099 for (i
= 0; i
< len
; i
++)
1101 /* We cast to unsigned char because default char, if it is signed,
1102 would lead to ac < 0 for string[i] > 127. */
1103 ac
= (unsigned char) ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1104 bc
= (unsigned char) ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1112 /* Strings are equal */
1118 /* Specific comparison subroutines. */
1121 gfc_arith_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1125 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1127 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1128 ? compare_complex (op1
, op2
)
1129 : (gfc_compare_expr (op1
, op2
) == 0);
1137 gfc_arith_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1141 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1143 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1144 ? !compare_complex (op1
, op2
)
1145 : (gfc_compare_expr (op1
, op2
) != 0);
1153 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1157 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1159 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1167 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1171 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1173 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1181 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1185 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1187 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1195 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1199 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1201 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1209 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1212 gfc_constructor
*c
, *head
;
1216 if (op
->expr_type
== EXPR_CONSTANT
)
1217 return eval (op
, result
);
1220 head
= gfc_copy_constructor (op
->value
.constructor
);
1222 for (c
= head
; c
; c
= c
->next
)
1224 rc
= eval (c
->expr
, &r
);
1228 gfc_replace_expr (c
->expr
, r
);
1232 gfc_free_constructor (head
);
1235 r
= gfc_get_expr ();
1236 r
->expr_type
= EXPR_ARRAY
;
1237 r
->value
.constructor
= head
;
1238 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1240 r
->ts
= head
->expr
->ts
;
1241 r
->where
= op
->where
;
1252 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1253 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1255 gfc_constructor
*c
, *head
;
1259 head
= gfc_copy_constructor (op1
->value
.constructor
);
1262 for (c
= head
; c
; c
= c
->next
)
1264 rc
= eval (c
->expr
, op2
, &r
);
1268 gfc_replace_expr (c
->expr
, r
);
1272 gfc_free_constructor (head
);
1275 r
= gfc_get_expr ();
1276 r
->expr_type
= EXPR_ARRAY
;
1277 r
->value
.constructor
= head
;
1278 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1280 r
->ts
= head
->expr
->ts
;
1281 r
->where
= op1
->where
;
1282 r
->rank
= op1
->rank
;
1292 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1293 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1295 gfc_constructor
*c
, *head
;
1299 head
= gfc_copy_constructor (op2
->value
.constructor
);
1302 for (c
= head
; c
; c
= c
->next
)
1304 rc
= eval (op1
, c
->expr
, &r
);
1308 gfc_replace_expr (c
->expr
, r
);
1312 gfc_free_constructor (head
);
1315 r
= gfc_get_expr ();
1316 r
->expr_type
= EXPR_ARRAY
;
1317 r
->value
.constructor
= head
;
1318 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1320 r
->ts
= head
->expr
->ts
;
1321 r
->where
= op2
->where
;
1322 r
->rank
= op2
->rank
;
1332 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1333 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1335 gfc_constructor
*c
, *d
, *head
;
1339 head
= gfc_copy_constructor (op1
->value
.constructor
);
1342 d
= op2
->value
.constructor
;
1344 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1346 rc
= ARITH_INCOMMENSURATE
;
1349 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1353 rc
= ARITH_INCOMMENSURATE
;
1357 rc
= eval (c
->expr
, d
->expr
, &r
);
1361 gfc_replace_expr (c
->expr
, r
);
1365 rc
= ARITH_INCOMMENSURATE
;
1369 gfc_free_constructor (head
);
1372 r
= gfc_get_expr ();
1373 r
->expr_type
= EXPR_ARRAY
;
1374 r
->value
.constructor
= head
;
1375 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1377 r
->ts
= head
->expr
->ts
;
1378 r
->where
= op1
->where
;
1379 r
->rank
= op1
->rank
;
1389 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1390 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1392 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1393 return eval (op1
, op2
, result
);
1395 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1396 return reduce_binary_ca (eval
, op1
, op2
, result
);
1398 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1399 return reduce_binary_ac (eval
, op1
, op2
, result
);
1401 return reduce_binary_aa (eval
, op1
, op2
, result
);
1407 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1408 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1412 /* High level arithmetic subroutines. These subroutines go into
1413 eval_intrinsic(), which can do one of several things to its
1414 operands. If the operands are incompatible with the intrinsic
1415 operation, we return a node pointing to the operands and hope that
1416 an operator interface is found during resolution.
1418 If the operands are compatible and are constants, then we try doing
1419 the arithmetic. We also handle the cases where either or both
1420 operands are array constructors. */
1423 eval_intrinsic (gfc_intrinsic_op
operator,
1424 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1426 gfc_expr temp
, *result
;
1430 gfc_clear_ts (&temp
.ts
);
1436 if (op1
->ts
.type
!= BT_LOGICAL
)
1439 temp
.ts
.type
= BT_LOGICAL
;
1440 temp
.ts
.kind
= gfc_default_logical_kind
;
1444 /* Logical binary operators */
1447 case INTRINSIC_NEQV
:
1449 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1452 temp
.ts
.type
= BT_LOGICAL
;
1453 temp
.ts
.kind
= gfc_default_logical_kind
;
1458 case INTRINSIC_UPLUS
:
1459 case INTRINSIC_UMINUS
:
1460 if (!gfc_numeric_ts (&op1
->ts
))
1467 case INTRINSIC_PARENTHESES
:
1472 /* Additional restrictions for ordering relations. */
1477 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1479 temp
.ts
.type
= BT_LOGICAL
;
1480 temp
.ts
.kind
= gfc_default_logical_kind
;
1487 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1490 temp
.ts
.type
= BT_LOGICAL
;
1491 temp
.ts
.kind
= gfc_default_logical_kind
;
1496 /* Numeric binary */
1497 case INTRINSIC_PLUS
:
1498 case INTRINSIC_MINUS
:
1499 case INTRINSIC_TIMES
:
1500 case INTRINSIC_DIVIDE
:
1501 case INTRINSIC_POWER
:
1502 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1505 /* Insert any necessary type conversions to make the operands
1508 temp
.expr_type
= EXPR_OP
;
1509 gfc_clear_ts (&temp
.ts
);
1510 temp
.value
.op
.operator = operator;
1512 temp
.value
.op
.op1
= op1
;
1513 temp
.value
.op
.op2
= op2
;
1515 gfc_type_convert_binary (&temp
);
1517 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1518 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1519 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1521 temp
.ts
.type
= BT_LOGICAL
;
1522 temp
.ts
.kind
= gfc_default_logical_kind
;
1528 /* Character binary */
1529 case INTRINSIC_CONCAT
:
1530 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1533 temp
.ts
.type
= BT_CHARACTER
;
1534 temp
.ts
.kind
= gfc_default_character_kind
;
1538 case INTRINSIC_USER
:
1542 gfc_internal_error ("eval_intrinsic(): Bad operator");
1545 /* Try to combine the operators. */
1546 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1550 || (op1
->expr_type
!= EXPR_CONSTANT
1551 && (op1
->expr_type
!= EXPR_ARRAY
1552 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
))))
1557 || (op2
->expr_type
!= EXPR_CONSTANT
1558 && (op2
->expr_type
!= EXPR_ARRAY
1559 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))))
1563 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1565 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1568 { /* Something went wrong. */
1569 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1573 gfc_free_expr (op1
);
1574 gfc_free_expr (op2
);
1578 /* Create a run-time expression. */
1579 result
= gfc_get_expr ();
1580 result
->ts
= temp
.ts
;
1582 result
->expr_type
= EXPR_OP
;
1583 result
->value
.op
.operator = operator;
1585 result
->value
.op
.op1
= op1
;
1586 result
->value
.op
.op2
= op2
;
1588 result
->where
= op1
->where
;
1594 /* Modify type of expression for zero size array. */
1597 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1600 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1610 op
->ts
.type
= BT_LOGICAL
;
1611 op
->ts
.kind
= gfc_default_logical_kind
;
1622 /* Return nonzero if the expression is a zero size array. */
1625 gfc_zero_size_array (gfc_expr
*e
)
1627 if (e
->expr_type
!= EXPR_ARRAY
)
1630 return e
->value
.constructor
== NULL
;
1634 /* Reduce a binary expression where at least one of the operands
1635 involves a zero-length array. Returns NULL if neither of the
1636 operands is a zero-length array. */
1639 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1641 if (gfc_zero_size_array (op1
))
1643 gfc_free_expr (op2
);
1647 if (gfc_zero_size_array (op2
))
1649 gfc_free_expr (op1
);
1658 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1659 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1660 gfc_expr
*op1
, gfc_expr
*op2
)
1667 if (gfc_zero_size_array (op1
))
1668 return eval_type_intrinsic0 (operator, op1
);
1672 result
= reduce_binary0 (op1
, op2
);
1674 return eval_type_intrinsic0 (operator, result
);
1678 return eval_intrinsic (operator, f
, op1
, op2
);
1683 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1684 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1685 gfc_expr
*op1
, gfc_expr
*op2
)
1690 result
= reduce_binary0 (op1
, op2
);
1692 return eval_type_intrinsic0(operator, result
);
1695 return eval_intrinsic (operator, f
, op1
, op2
);
1700 gfc_uplus (gfc_expr
*op
)
1702 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1707 gfc_uminus (gfc_expr
*op
)
1709 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1714 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1716 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
);
1728 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1730 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1735 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1737 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1742 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1744 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1749 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1751 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1756 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1758 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1763 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1765 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1770 gfc_not (gfc_expr
*op1
)
1772 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1777 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1779 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1784 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1786 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1791 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
)
1793 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1798 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
)
1800 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1805 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
)
1807 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1812 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
)
1814 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1819 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
)
1821 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1826 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
)
1828 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1832 /* Convert an integer string to an expression node. */
1835 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
1840 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1841 /* A leading plus is allowed, but not by mpz_set_str. */
1842 if (buffer
[0] == '+')
1846 mpz_set_str (e
->value
.integer
, t
, radix
);
1852 /* Convert a real string to an expression node. */
1855 gfc_convert_real (const char *buffer
, int kind
, locus
*where
)
1859 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1860 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1866 /* Convert a pair of real, constant expression nodes to a single
1867 complex expression node. */
1870 gfc_convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
1874 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1875 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1876 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1882 /******* Simplification of intrinsic functions with constant arguments *****/
1885 /* Deal with an arithmetic error. */
1888 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
1893 gfc_error ("Arithmetic OK converting %s to %s at %L",
1894 gfc_typename (from
), gfc_typename (to
), where
);
1896 case ARITH_OVERFLOW
:
1897 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1898 gfc_typename (from
), gfc_typename (to
), where
);
1900 case ARITH_UNDERFLOW
:
1901 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1902 gfc_typename (from
), gfc_typename (to
), where
);
1905 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1906 gfc_typename (from
), gfc_typename (to
), where
);
1909 gfc_error ("Division by zero converting %s to %s at %L",
1910 gfc_typename (from
), gfc_typename (to
), where
);
1912 case ARITH_INCOMMENSURATE
:
1913 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1914 gfc_typename (from
), gfc_typename (to
), where
);
1916 case ARITH_ASYMMETRIC
:
1917 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1918 " converting %s to %s at %L",
1919 gfc_typename (from
), gfc_typename (to
), where
);
1922 gfc_internal_error ("gfc_arith_error(): Bad error code");
1925 /* TODO: Do something about the error, ie, throw exception, return
1930 /* Convert integers to integers. */
1933 gfc_int2int (gfc_expr
*src
, int kind
)
1938 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1940 mpz_set (result
->value
.integer
, src
->value
.integer
);
1942 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
1944 if (rc
== ARITH_ASYMMETRIC
)
1946 gfc_warning (gfc_arith_error (rc
), &src
->where
);
1950 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1951 gfc_free_expr (result
);
1960 /* Convert integers to reals. */
1963 gfc_int2real (gfc_expr
*src
, int kind
)
1968 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
1970 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
1972 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
1974 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1975 gfc_free_expr (result
);
1983 /* Convert default integer to default complex. */
1986 gfc_int2complex (gfc_expr
*src
, int kind
)
1991 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
1993 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
1994 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
1996 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
1998 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1999 gfc_free_expr (result
);
2007 /* Convert default real to default integer. */
2010 gfc_real2int (gfc_expr
*src
, int kind
)
2015 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2017 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2019 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2021 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2022 gfc_free_expr (result
);
2030 /* Convert real to real. */
2033 gfc_real2real (gfc_expr
*src
, int kind
)
2038 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2040 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2042 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2044 if (rc
== ARITH_UNDERFLOW
)
2046 if (gfc_option
.warn_underflow
)
2047 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2048 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2050 else if (rc
!= ARITH_OK
)
2052 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2053 gfc_free_expr (result
);
2061 /* Convert real to complex. */
2064 gfc_real2complex (gfc_expr
*src
, int kind
)
2069 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2071 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2072 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2074 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2076 if (rc
== ARITH_UNDERFLOW
)
2078 if (gfc_option
.warn_underflow
)
2079 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2080 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2082 else if (rc
!= ARITH_OK
)
2084 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2085 gfc_free_expr (result
);
2093 /* Convert complex to integer. */
2096 gfc_complex2int (gfc_expr
*src
, int kind
)
2101 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2103 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2105 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2107 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2108 gfc_free_expr (result
);
2116 /* Convert complex to real. */
2119 gfc_complex2real (gfc_expr
*src
, int kind
)
2124 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2126 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2128 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2130 if (rc
== ARITH_UNDERFLOW
)
2132 if (gfc_option
.warn_underflow
)
2133 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2134 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2138 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2139 gfc_free_expr (result
);
2147 /* Convert complex to complex. */
2150 gfc_complex2complex (gfc_expr
*src
, int kind
)
2155 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2157 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2158 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2160 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2162 if (rc
== ARITH_UNDERFLOW
)
2164 if (gfc_option
.warn_underflow
)
2165 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2166 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2168 else if (rc
!= ARITH_OK
)
2170 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2171 gfc_free_expr (result
);
2175 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2177 if (rc
== ARITH_UNDERFLOW
)
2179 if (gfc_option
.warn_underflow
)
2180 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2181 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2183 else if (rc
!= ARITH_OK
)
2185 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2186 gfc_free_expr (result
);
2194 /* Logical kind conversion. */
2197 gfc_log2log (gfc_expr
*src
, int kind
)
2201 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2202 result
->value
.logical
= src
->value
.logical
;
2208 /* Convert logical to integer. */
2211 gfc_log2int (gfc_expr
*src
, int kind
)
2215 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2216 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2222 /* Convert integer to logical. */
2225 gfc_int2log (gfc_expr
*src
, int kind
)
2229 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2230 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2236 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2239 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2244 len
= src
->value
.character
.length
;
2246 result
= gfc_get_expr ();
2247 result
->expr_type
= EXPR_CONSTANT
;
2248 result
->ts
.type
= BT_INTEGER
;
2249 result
->ts
.kind
= kind
;
2250 result
->where
= src
->where
;
2255 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2256 &src
->where
, gfc_typename(&result
->ts
));
2258 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2259 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2263 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2265 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2266 result
->value
.character
.length
= kind
;
2272 /* Convert Hollerith to real. The constant will be padded or truncated. */
2275 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2280 len
= src
->value
.character
.length
;
2282 result
= gfc_get_expr ();
2283 result
->expr_type
= EXPR_CONSTANT
;
2284 result
->ts
.type
= BT_REAL
;
2285 result
->ts
.kind
= kind
;
2286 result
->where
= src
->where
;
2291 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2292 &src
->where
, gfc_typename(&result
->ts
));
2294 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2295 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2299 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2301 result
->value
.character
.string
[kind
] = '\0'; /* For debugger. */
2302 result
->value
.character
.length
= kind
;
2308 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2311 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2316 len
= src
->value
.character
.length
;
2318 result
= gfc_get_expr ();
2319 result
->expr_type
= EXPR_CONSTANT
;
2320 result
->ts
.type
= BT_COMPLEX
;
2321 result
->ts
.kind
= kind
;
2322 result
->where
= src
->where
;
2329 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2330 &src
->where
, gfc_typename(&result
->ts
));
2332 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2333 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2337 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2339 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2340 result
->value
.character
.length
= kind
;
2346 /* Convert Hollerith to character. */
2349 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2353 result
= gfc_copy_expr (src
);
2354 result
->ts
.type
= BT_CHARACTER
;
2355 result
->ts
.kind
= kind
;
2362 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2365 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2370 len
= src
->value
.character
.length
;
2372 result
= gfc_get_expr ();
2373 result
->expr_type
= EXPR_CONSTANT
;
2374 result
->ts
.type
= BT_LOGICAL
;
2375 result
->ts
.kind
= kind
;
2376 result
->where
= src
->where
;
2381 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2382 &src
->where
, gfc_typename(&result
->ts
));
2384 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2385 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2389 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2391 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2392 result
->value
.character
.length
= kind
;
2398 /* Returns an initializer whose value is one higher than the value of the
2399 LAST_INITIALIZER argument. If the argument is NULL, the
2400 initializers value will be set to zero. The initializer's kind
2401 will be set to gfc_c_int_kind.
2403 If -fshort-enums is given, the appropriate kind will be selected
2404 later after all enumerators have been parsed. A warning is issued
2405 here if an initializer exceeds gfc_c_int_kind. */
2408 gfc_enum_initializer (gfc_expr
*last_initializer
, locus where
)
2412 result
= gfc_get_expr ();
2413 result
->expr_type
= EXPR_CONSTANT
;
2414 result
->ts
.type
= BT_INTEGER
;
2415 result
->ts
.kind
= gfc_c_int_kind
;
2416 result
->where
= where
;
2418 mpz_init (result
->value
.integer
);
2420 if (last_initializer
!= NULL
)
2422 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2423 result
->where
= last_initializer
->where
;
2425 if (gfc_check_integer_range (result
->value
.integer
,
2426 gfc_c_int_kind
) != ARITH_OK
)
2428 gfc_error ("Enumerator exceeds the C integer type at %C");
2434 /* Control comes here, if it's the very first enumerator and no
2435 initializer has been given. It will be initialized to zero. */
2436 mpz_set_si (result
->value
.integer
, 0);