2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* Since target arithmetic must be done on the host, there has to
23 be some way of evaluating arithmetic expressions as the host
24 would evaluate them. We use the GNU MP library and the MPFR
25 library to do arithmetic, and this file provides the interface. */
32 #include "target-memory.h"
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
;
129 mpfr_set_default_prec (128);
132 /* Convert the minimum and maximum values for each kind into their
133 GNU MP representation. */
134 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
137 mpz_init (int_info
->huge
);
138 mpz_set_ui (int_info
->huge
, int_info
->radix
);
139 mpz_pow_ui (int_info
->huge
, int_info
->huge
, int_info
->digits
);
140 mpz_sub_ui (int_info
->huge
, int_info
->huge
, 1);
142 /* These are the numbers that are actually representable by the
143 target. For bases other than two, this needs to be changed. */
144 if (int_info
->radix
!= 2)
145 gfc_internal_error ("Fix min_int calculation");
147 /* See PRs 13490 and 17912, related to integer ranges.
148 The pedantic_min_int exists for range checking when a program
149 is compiled with -pedantic, and reflects the belief that
150 Standard Fortran requires integers to be symmetrical, i.e.
151 every negative integer must have a representable positive
152 absolute value, and vice versa. */
154 mpz_init (int_info
->pedantic_min_int
);
155 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
157 mpz_init (int_info
->min_int
);
158 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
161 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
162 mpfr_log10 (a
, a
, GFC_RND_MODE
);
164 int_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
169 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
171 gfc_set_model_kind (real_info
->kind
);
176 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
178 mpfr_init (real_info
->huge
);
179 mpfr_set_ui (real_info
->huge
, 1, GFC_RND_MODE
);
180 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
181 mpfr_pow_si (a
, a
, -real_info
->digits
, GFC_RND_MODE
);
182 mpfr_sub (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
185 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
186 mpfr_pow_ui (a
, a
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
188 /* (1 - b**(-p)) * b**(emax-1) */
189 mpfr_mul (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
191 /* (1 - b**(-p)) * b**(emax-1) * b */
192 mpfr_mul_ui (real_info
->huge
, real_info
->huge
, real_info
->radix
,
195 /* tiny(x) = b**(emin-1) */
196 mpfr_init (real_info
->tiny
);
197 mpfr_set_ui (real_info
->tiny
, real_info
->radix
, GFC_RND_MODE
);
198 mpfr_pow_si (real_info
->tiny
, real_info
->tiny
,
199 real_info
->min_exponent
- 1, GFC_RND_MODE
);
201 /* subnormal (x) = b**(emin - digit) */
202 mpfr_init (real_info
->subnormal
);
203 mpfr_set_ui (real_info
->subnormal
, real_info
->radix
, GFC_RND_MODE
);
204 mpfr_pow_si (real_info
->subnormal
, real_info
->subnormal
,
205 real_info
->min_exponent
- real_info
->digits
, GFC_RND_MODE
);
207 /* epsilon(x) = b**(1-p) */
208 mpfr_init (real_info
->epsilon
);
209 mpfr_set_ui (real_info
->epsilon
, real_info
->radix
, GFC_RND_MODE
);
210 mpfr_pow_si (real_info
->epsilon
, real_info
->epsilon
,
211 1 - real_info
->digits
, GFC_RND_MODE
);
213 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
214 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
215 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
216 mpfr_neg (b
, b
, GFC_RND_MODE
);
219 mpfr_min (a
, a
, b
, GFC_RND_MODE
);
221 real_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
223 /* precision(x) = int((p - 1) * log10(b)) + k */
224 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
225 mpfr_log10 (a
, a
, GFC_RND_MODE
);
226 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
228 real_info
->precision
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
230 /* If the radix is an integral power of 10, add one to the precision. */
231 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
232 if (i
== real_info
->radix
)
233 real_info
->precision
++;
235 mpfr_clears (a
, b
, NULL
);
240 /* Clean up, get rid of numeric constants. */
243 gfc_arith_done_1 (void)
245 gfc_integer_info
*ip
;
248 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
250 mpz_clear (ip
->min_int
);
251 mpz_clear (ip
->pedantic_min_int
);
252 mpz_clear (ip
->huge
);
255 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
256 mpfr_clears (rp
->epsilon
, rp
->huge
, rp
->tiny
, rp
->subnormal
, NULL
);
260 /* Given a wide character value and a character kind, determine whether
261 the character is representable for that kind. */
263 gfc_check_character_range (gfc_char_t c
, int kind
)
265 /* As wide characters are stored as 32-bit values, they're all
266 representable in UCS=4. */
271 return c
<= 255 ? true : false;
277 /* Given an integer and a kind, make sure that the integer lies within
278 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
282 gfc_check_integer_range (mpz_t p
, int kind
)
287 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
292 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
293 result
= ARITH_ASYMMETRIC
;
297 if (gfc_option
.flag_range_check
== 0)
300 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
301 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
302 result
= ARITH_OVERFLOW
;
308 /* Given a real and a kind, make sure that the real lies within the
309 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
313 gfc_check_real_range (mpfr_t p
, int kind
)
319 i
= gfc_validate_kind (BT_REAL
, kind
, false);
323 mpfr_abs (q
, p
, GFC_RND_MODE
);
329 if (gfc_option
.flag_range_check
!= 0)
330 retval
= ARITH_OVERFLOW
;
332 else if (mpfr_nan_p (p
))
334 if (gfc_option
.flag_range_check
!= 0)
337 else if (mpfr_sgn (q
) == 0)
342 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
344 if (gfc_option
.flag_range_check
== 0)
345 mpfr_set_inf (p
, mpfr_sgn (p
));
347 retval
= ARITH_OVERFLOW
;
349 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
351 if (gfc_option
.flag_range_check
== 0)
353 if (mpfr_sgn (p
) < 0)
355 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
356 mpfr_set_si (q
, -1, GFC_RND_MODE
);
357 mpfr_copysign (p
, p
, q
, GFC_RND_MODE
);
360 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
363 retval
= ARITH_UNDERFLOW
;
365 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
370 /* Save current values of emin and emax. */
371 emin
= mpfr_get_emin ();
372 emax
= mpfr_get_emax ();
374 /* Set emin and emax for the current model number. */
375 en
= gfc_real_kinds
[i
].min_exponent
- gfc_real_kinds
[i
].digits
+ 1;
376 mpfr_set_emin ((mp_exp_t
) en
);
377 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[i
].max_exponent
);
378 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
380 /* Reset emin and emax. */
381 mpfr_set_emin (emin
);
382 mpfr_set_emax (emax
);
384 /* Copy sign if needed. */
385 if (mpfr_sgn (p
) < 0)
386 mpfr_neg (p
, q
, GMP_RNDN
);
388 mpfr_set (p
, q
, GMP_RNDN
);
397 /* Function to return a constant expression node of a given type and kind. */
400 gfc_constant_result (bt type
, int kind
, locus
*where
)
405 gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
407 result
= gfc_get_expr ();
409 result
->expr_type
= EXPR_CONSTANT
;
410 result
->ts
.type
= type
;
411 result
->ts
.kind
= kind
;
412 result
->where
= *where
;
417 mpz_init (result
->value
.integer
);
421 gfc_set_model_kind (kind
);
422 mpfr_init (result
->value
.real
);
426 gfc_set_model_kind (kind
);
427 mpfr_init (result
->value
.complex.r
);
428 mpfr_init (result
->value
.complex.i
);
439 /* Low-level arithmetic functions. All of these subroutines assume
440 that all operands are of the same type and return an operand of the
441 same type. The other thing about these subroutines is that they
442 can fail in various ways -- overflow, underflow, division by zero,
443 zero raised to the zero, etc. */
446 gfc_arith_not (gfc_expr
*op1
, gfc_expr
**resultp
)
450 result
= gfc_constant_result (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
451 result
->value
.logical
= !op1
->value
.logical
;
459 gfc_arith_and (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
463 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
465 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
473 gfc_arith_or (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
477 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
479 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
487 gfc_arith_eqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
491 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
493 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
501 gfc_arith_neqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
505 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
507 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
514 /* Make sure a constant numeric expression is within the range for
515 its type and kind. Note that there's also a gfc_check_range(),
516 but that one deals with the intrinsic RANGE function. */
519 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 rc2
= 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
);
562 gfc_internal_error ("gfc_range_check(): Bad type");
569 /* Several of the following routines use the same set of statements to
570 check the validity of the result. Encapsulate the checking here. */
573 check_result (arith rc
, gfc_expr
*x
, gfc_expr
*r
, gfc_expr
**rp
)
577 if (val
== ARITH_UNDERFLOW
)
579 if (gfc_option
.warn_underflow
)
580 gfc_warning (gfc_arith_error (val
), &x
->where
);
584 if (val
== ARITH_ASYMMETRIC
)
586 gfc_warning (gfc_arith_error (val
), &x
->where
);
599 /* It may seem silly to have a subroutine that actually computes the
600 unary plus of a constant, but it prevents us from making exceptions
601 in the code elsewhere. Used for unary plus and parenthesized
605 gfc_arith_identity (gfc_expr
*op1
, gfc_expr
**resultp
)
607 *resultp
= gfc_copy_expr (op1
);
613 gfc_arith_uminus (gfc_expr
*op1
, gfc_expr
**resultp
)
618 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
620 switch (op1
->ts
.type
)
623 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
627 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
631 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
632 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
636 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
639 rc
= gfc_range_check (result
);
641 return check_result (rc
, op1
, result
, resultp
);
646 gfc_arith_plus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
651 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
653 switch (op1
->ts
.type
)
656 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
660 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
665 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
666 op2
->value
.complex.r
, GFC_RND_MODE
);
668 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
669 op2
->value
.complex.i
, GFC_RND_MODE
);
673 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
676 rc
= gfc_range_check (result
);
678 return check_result (rc
, op1
, result
, resultp
);
683 gfc_arith_minus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
688 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
690 switch (op1
->ts
.type
)
693 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
697 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
702 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
703 op2
->value
.complex.r
, GFC_RND_MODE
);
705 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
706 op2
->value
.complex.i
, GFC_RND_MODE
);
710 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
713 rc
= gfc_range_check (result
);
715 return check_result (rc
, op1
, result
, resultp
);
720 gfc_arith_times (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
726 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
728 switch (op1
->ts
.type
)
731 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
735 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
740 gfc_set_model (op1
->value
.complex.r
);
744 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
745 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
746 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
748 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
749 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
750 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
752 mpfr_clears (x
, y
, NULL
);
756 gfc_internal_error ("gfc_arith_times(): Bad basic type");
759 rc
= gfc_range_check (result
);
761 return check_result (rc
, op1
, result
, resultp
);
766 gfc_arith_divide (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
774 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
776 switch (op1
->ts
.type
)
779 if (mpz_sgn (op2
->value
.integer
) == 0)
785 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
790 if (mpfr_sgn (op2
->value
.real
) == 0 && gfc_option
.flag_range_check
== 1)
796 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
801 if (mpfr_sgn (op2
->value
.complex.r
) == 0
802 && mpfr_sgn (op2
->value
.complex.i
) == 0
803 && gfc_option
.flag_range_check
== 1)
809 gfc_set_model (op1
->value
.complex.r
);
814 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
815 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
816 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
818 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
819 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
820 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
821 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
824 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
825 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
826 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
827 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
830 mpfr_clears (x
, y
, div
, NULL
);
834 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
838 rc
= gfc_range_check (result
);
840 return check_result (rc
, op1
, result
, resultp
);
844 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
847 complex_reciprocal (gfc_expr
*op
)
851 gfc_set_model (op
->value
.complex.r
);
855 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
856 mpfr_mul (tmp
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
857 mpfr_add (mod
, mod
, tmp
, GFC_RND_MODE
);
859 mpfr_div (op
->value
.complex.r
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
861 mpfr_neg (op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
862 mpfr_div (op
->value
.complex.i
, op
->value
.complex.i
, mod
, GFC_RND_MODE
);
864 mpfr_clears (tmp
, mod
, NULL
);
868 /* Raise a complex number to positive power (power > 0).
869 This function will modify the content of power.
871 Use Binary Method, which is not an optimal but a simple and reasonable
872 arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth,
873 "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming",
874 3rd Edition, 1998. */
877 complex_pow (gfc_expr
*result
, gfc_expr
*base
, mpz_t power
)
879 mpfr_t x_r
, x_i
, tmp
, re
, im
;
881 gfc_set_model (base
->value
.complex.r
);
889 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
890 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
893 mpfr_set (x_r
, base
->value
.complex.r
, GFC_RND_MODE
);
894 mpfr_set (x_i
, base
->value
.complex.i
, GFC_RND_MODE
);
896 /* Macro for complex multiplication. We have to take care that
897 res_r/res_i and a_r/a_i can (and will) be the same variable. */
898 #define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \
899 mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \
900 mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \
901 mpfr_sub (re, re, tmp, GFC_RND_MODE), \
903 mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \
904 mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \
905 mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
906 mpfr_set (res_r, re, GFC_RND_MODE)
908 #define res_r result->value.complex.r
909 #define res_i result->value.complex.i
911 /* for (; power > 0; x *= x) */
912 for (; mpz_cmp_si (power
, 0) > 0; CMULT(x_r
,x_i
,x_r
,x_i
,x_r
,x_i
))
914 /* if (power & 1) res = res * x; */
915 if (mpz_congruent_ui_p (power
, 1, 2))
916 CMULT(res_r
,res_i
,res_r
,res_i
,x_r
,x_i
);
919 mpz_fdiv_q_ui (power
, power
, 2);
926 mpfr_clears (x_r
, x_i
, tmp
, re
, im
, NULL
);
930 /* Raise a number to an integer power. */
933 gfc_arith_power (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
939 gcc_assert (op2
->expr_type
== EXPR_CONSTANT
&& op2
->ts
.type
== BT_INTEGER
);
942 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
943 power_sign
= mpz_sgn (op2
->value
.integer
);
947 /* Handle something to the zeroth power. Since we're dealing
948 with integral exponents, there is no ambiguity in the
949 limiting procedure used to determine the value of 0**0. */
950 switch (op1
->ts
.type
)
953 mpz_set_ui (result
->value
.integer
, 1);
957 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
961 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
962 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
966 gfc_internal_error ("gfc_arith_power(): Bad base");
971 switch (op1
->ts
.type
)
977 /* First, we simplify the cases of op1 == 1, 0 or -1. */
978 if (mpz_cmp_si (op1
->value
.integer
, 1) == 0)
981 mpz_set_si (result
->value
.integer
, 1);
983 else if (mpz_cmp_si (op1
->value
.integer
, 0) == 0)
985 /* 0**op2 == 0, if op2 > 0
986 0**op2 overflow, if op2 < 0 ; in that case, we
987 set the result to 0 and return ARITH_DIV0. */
988 mpz_set_si (result
->value
.integer
, 0);
989 if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
992 else if (mpz_cmp_si (op1
->value
.integer
, -1) == 0)
994 /* (-1)**op2 == (-1)**(mod(op2,2)) */
995 unsigned int odd
= mpz_fdiv_ui (op2
->value
.integer
, 2);
997 mpz_set_si (result
->value
.integer
, -1);
999 mpz_set_si (result
->value
.integer
, 1);
1001 /* Then, we take care of op2 < 0. */
1002 else if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
1004 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1005 mpz_set_si (result
->value
.integer
, 0);
1007 else if (gfc_extract_int (op2
, &power
) != NULL
)
1009 /* If op2 doesn't fit in an int, the exponentiation will
1010 overflow, because op2 > 0 and abs(op1) > 1. */
1012 int i
= gfc_validate_kind (BT_INTEGER
, result
->ts
.kind
, false);
1014 if (gfc_option
.flag_range_check
)
1015 rc
= ARITH_OVERFLOW
;
1017 /* Still, we want to give the same value as the processor. */
1019 mpz_add_ui (max
, gfc_integer_kinds
[i
].huge
, 1);
1020 mpz_mul_ui (max
, max
, 2);
1021 mpz_powm (result
->value
.integer
, op1
->value
.integer
,
1022 op2
->value
.integer
, max
);
1026 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, power
);
1031 mpfr_pow_z (result
->value
.real
, op1
->value
.real
, op2
->value
.integer
,
1039 /* Compute op1**abs(op2) */
1041 mpz_abs (apower
, op2
->value
.integer
);
1042 complex_pow (result
, op1
, apower
);
1045 /* If (op2 < 0), compute the inverse. */
1047 complex_reciprocal (result
);
1058 rc
= gfc_range_check (result
);
1060 return check_result (rc
, op1
, result
, resultp
);
1064 /* Concatenate two string constants. */
1067 gfc_arith_concat (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1072 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1075 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1077 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
1078 result
->value
.character
.length
= len
;
1080 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1081 op1
->value
.character
.length
* sizeof (gfc_char_t
));
1083 memcpy (&result
->value
.character
.string
[op1
->value
.character
.length
],
1084 op2
->value
.character
.string
,
1085 op2
->value
.character
.length
* sizeof (gfc_char_t
));
1087 result
->value
.character
.string
[len
] = '\0';
1094 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1095 This function mimics mpr_cmp but takes NaN into account. */
1098 compare_real (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1104 rc
= mpfr_equal_p (op1
->value
.real
, op2
->value
.real
) ? 0 : 1;
1107 rc
= mpfr_greater_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1110 rc
= mpfr_greaterequal_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1113 rc
= mpfr_less_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1116 rc
= mpfr_lessequal_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1119 gfc_internal_error ("compare_real(): Bad operator");
1125 /* Comparison operators. Assumes that the two expression nodes
1126 contain two constants of the same type. The op argument is
1127 needed to handle NaN correctly. */
1130 gfc_compare_expr (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1134 switch (op1
->ts
.type
)
1137 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1141 rc
= compare_real (op1
, op2
, op
);
1145 rc
= gfc_compare_string (op1
, op2
);
1149 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1150 || (op1
->value
.logical
&& !op2
->value
.logical
));
1154 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1161 /* Compare a pair of complex numbers. Naturally, this is only for
1162 equality and nonequality. */
1165 compare_complex (gfc_expr
*op1
, gfc_expr
*op2
)
1167 return (mpfr_equal_p (op1
->value
.complex.r
, op2
->value
.complex.r
)
1168 && mpfr_equal_p (op1
->value
.complex.i
, op2
->value
.complex.i
));
1172 /* Given two constant strings and the inverse collating sequence, compare the
1173 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1174 We use the processor's default collating sequence. */
1177 gfc_compare_string (gfc_expr
*a
, gfc_expr
*b
)
1179 int len
, alen
, blen
, i
;
1182 alen
= a
->value
.character
.length
;
1183 blen
= b
->value
.character
.length
;
1185 len
= MAX(alen
, blen
);
1187 for (i
= 0; i
< len
; i
++)
1189 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1190 bc
= ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1198 /* Strings are equal */
1204 gfc_compare_with_Cstring (gfc_expr
*a
, const char *b
, bool case_sensitive
)
1206 int len
, alen
, blen
, i
;
1209 alen
= a
->value
.character
.length
;
1212 len
= MAX(alen
, blen
);
1214 for (i
= 0; i
< len
; i
++)
1216 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1217 bc
= ((i
< blen
) ? b
[i
] : ' ');
1219 if (!case_sensitive
)
1231 /* Strings are equal */
1236 /* Specific comparison subroutines. */
1239 gfc_arith_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1243 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1245 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1246 ? compare_complex (op1
, op2
)
1247 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) == 0);
1255 gfc_arith_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1259 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1261 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1262 ? !compare_complex (op1
, op2
)
1263 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) != 0);
1271 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1275 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1277 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GT
) > 0);
1285 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1289 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1291 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GE
) >= 0);
1299 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1303 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1305 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LT
) < 0);
1313 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1317 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1319 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LE
) <= 0);
1327 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1330 gfc_constructor
*c
, *head
;
1334 if (op
->expr_type
== EXPR_CONSTANT
)
1335 return eval (op
, result
);
1338 head
= gfc_copy_constructor (op
->value
.constructor
);
1340 for (c
= head
; c
; c
= c
->next
)
1342 rc
= reduce_unary (eval
, c
->expr
, &r
);
1347 gfc_replace_expr (c
->expr
, r
);
1351 gfc_free_constructor (head
);
1354 r
= gfc_get_expr ();
1355 r
->expr_type
= EXPR_ARRAY
;
1356 r
->value
.constructor
= head
;
1357 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1359 r
->ts
= head
->expr
->ts
;
1360 r
->where
= op
->where
;
1371 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1372 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1374 gfc_constructor
*c
, *head
;
1378 head
= gfc_copy_constructor (op1
->value
.constructor
);
1381 for (c
= head
; c
; c
= c
->next
)
1383 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1384 rc
= eval (c
->expr
, op2
, &r
);
1386 rc
= reduce_binary_ac (eval
, c
->expr
, op2
, &r
);
1391 gfc_replace_expr (c
->expr
, r
);
1395 gfc_free_constructor (head
);
1398 r
= gfc_get_expr ();
1399 r
->expr_type
= EXPR_ARRAY
;
1400 r
->value
.constructor
= head
;
1401 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1403 r
->ts
= head
->expr
->ts
;
1404 r
->where
= op1
->where
;
1405 r
->rank
= op1
->rank
;
1415 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1416 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1418 gfc_constructor
*c
, *head
;
1422 head
= gfc_copy_constructor (op2
->value
.constructor
);
1425 for (c
= head
; c
; c
= c
->next
)
1427 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1428 rc
= eval (op1
, c
->expr
, &r
);
1430 rc
= reduce_binary_ca (eval
, op1
, c
->expr
, &r
);
1435 gfc_replace_expr (c
->expr
, r
);
1439 gfc_free_constructor (head
);
1442 r
= gfc_get_expr ();
1443 r
->expr_type
= EXPR_ARRAY
;
1444 r
->value
.constructor
= head
;
1445 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1447 r
->ts
= head
->expr
->ts
;
1448 r
->where
= op2
->where
;
1449 r
->rank
= op2
->rank
;
1458 /* We need a forward declaration of reduce_binary. */
1459 static arith
reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1460 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
);
1464 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1465 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1467 gfc_constructor
*c
, *d
, *head
;
1471 head
= gfc_copy_constructor (op1
->value
.constructor
);
1474 d
= op2
->value
.constructor
;
1476 if (gfc_check_conformance ("elemental binary operation", op1
, op2
)
1478 rc
= ARITH_INCOMMENSURATE
;
1481 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1485 rc
= ARITH_INCOMMENSURATE
;
1489 rc
= reduce_binary (eval
, c
->expr
, d
->expr
, &r
);
1493 gfc_replace_expr (c
->expr
, r
);
1497 rc
= ARITH_INCOMMENSURATE
;
1501 gfc_free_constructor (head
);
1504 r
= gfc_get_expr ();
1505 r
->expr_type
= EXPR_ARRAY
;
1506 r
->value
.constructor
= head
;
1507 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1509 r
->ts
= head
->expr
->ts
;
1510 r
->where
= op1
->where
;
1511 r
->rank
= op1
->rank
;
1521 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1522 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1524 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1525 return eval (op1
, op2
, result
);
1527 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1528 return reduce_binary_ca (eval
, op1
, op2
, result
);
1530 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1531 return reduce_binary_ac (eval
, op1
, op2
, result
);
1533 return reduce_binary_aa (eval
, op1
, op2
, result
);
1539 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1540 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1544 /* High level arithmetic subroutines. These subroutines go into
1545 eval_intrinsic(), which can do one of several things to its
1546 operands. If the operands are incompatible with the intrinsic
1547 operation, we return a node pointing to the operands and hope that
1548 an operator interface is found during resolution.
1550 If the operands are compatible and are constants, then we try doing
1551 the arithmetic. We also handle the cases where either or both
1552 operands are array constructors. */
1555 eval_intrinsic (gfc_intrinsic_op
operator,
1556 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1558 gfc_expr temp
, *result
;
1562 gfc_clear_ts (&temp
.ts
);
1568 if (op1
->ts
.type
!= BT_LOGICAL
)
1571 temp
.ts
.type
= BT_LOGICAL
;
1572 temp
.ts
.kind
= gfc_default_logical_kind
;
1576 /* Logical binary operators */
1579 case INTRINSIC_NEQV
:
1581 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1584 temp
.ts
.type
= BT_LOGICAL
;
1585 temp
.ts
.kind
= gfc_default_logical_kind
;
1590 case INTRINSIC_UPLUS
:
1591 case INTRINSIC_UMINUS
:
1592 if (!gfc_numeric_ts (&op1
->ts
))
1599 case INTRINSIC_PARENTHESES
:
1604 /* Additional restrictions for ordering relations. */
1606 case INTRINSIC_GE_OS
:
1608 case INTRINSIC_LT_OS
:
1610 case INTRINSIC_LE_OS
:
1612 case INTRINSIC_GT_OS
:
1613 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1615 temp
.ts
.type
= BT_LOGICAL
;
1616 temp
.ts
.kind
= gfc_default_logical_kind
;
1622 case INTRINSIC_EQ_OS
:
1624 case INTRINSIC_NE_OS
:
1625 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1628 temp
.ts
.type
= BT_LOGICAL
;
1629 temp
.ts
.kind
= gfc_default_logical_kind
;
1631 /* If kind mismatch, exit and we'll error out later. */
1632 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1639 /* Numeric binary */
1640 case INTRINSIC_PLUS
:
1641 case INTRINSIC_MINUS
:
1642 case INTRINSIC_TIMES
:
1643 case INTRINSIC_DIVIDE
:
1644 case INTRINSIC_POWER
:
1645 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1648 /* Insert any necessary type conversions to make the operands
1651 temp
.expr_type
= EXPR_OP
;
1652 gfc_clear_ts (&temp
.ts
);
1653 temp
.value
.op
.operator = operator;
1655 temp
.value
.op
.op1
= op1
;
1656 temp
.value
.op
.op2
= op2
;
1658 gfc_type_convert_binary (&temp
);
1660 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1661 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1662 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
1663 || operator == INTRINSIC_EQ_OS
|| operator == INTRINSIC_NE_OS
1664 || operator == INTRINSIC_GE_OS
|| operator == INTRINSIC_GT_OS
1665 || operator == INTRINSIC_LE_OS
|| operator == INTRINSIC_LT_OS
)
1667 temp
.ts
.type
= BT_LOGICAL
;
1668 temp
.ts
.kind
= gfc_default_logical_kind
;
1674 /* Character binary */
1675 case INTRINSIC_CONCAT
:
1676 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1677 || op1
->ts
.kind
!= op2
->ts
.kind
)
1680 temp
.ts
.type
= BT_CHARACTER
;
1681 temp
.ts
.kind
= op1
->ts
.kind
;
1685 case INTRINSIC_USER
:
1689 gfc_internal_error ("eval_intrinsic(): Bad operator");
1692 /* Try to combine the operators. */
1693 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1696 if (op1
->expr_type
!= EXPR_CONSTANT
1697 && (op1
->expr_type
!= EXPR_ARRAY
1698 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
)))
1702 && op2
->expr_type
!= EXPR_CONSTANT
1703 && (op2
->expr_type
!= EXPR_ARRAY
1704 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))
1708 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1710 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1713 { /* Something went wrong. */
1714 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1718 gfc_free_expr (op1
);
1719 gfc_free_expr (op2
);
1723 /* Create a run-time expression. */
1724 result
= gfc_get_expr ();
1725 result
->ts
= temp
.ts
;
1727 result
->expr_type
= EXPR_OP
;
1728 result
->value
.op
.operator = operator;
1730 result
->value
.op
.op1
= op1
;
1731 result
->value
.op
.op2
= op2
;
1733 result
->where
= op1
->where
;
1739 /* Modify type of expression for zero size array. */
1742 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1745 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1750 case INTRINSIC_GE_OS
:
1752 case INTRINSIC_LT_OS
:
1754 case INTRINSIC_LE_OS
:
1756 case INTRINSIC_GT_OS
:
1758 case INTRINSIC_EQ_OS
:
1760 case INTRINSIC_NE_OS
:
1761 op
->ts
.type
= BT_LOGICAL
;
1762 op
->ts
.kind
= gfc_default_logical_kind
;
1773 /* Return nonzero if the expression is a zero size array. */
1776 gfc_zero_size_array (gfc_expr
*e
)
1778 if (e
->expr_type
!= EXPR_ARRAY
)
1781 return e
->value
.constructor
== NULL
;
1785 /* Reduce a binary expression where at least one of the operands
1786 involves a zero-length array. Returns NULL if neither of the
1787 operands is a zero-length array. */
1790 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1792 if (gfc_zero_size_array (op1
))
1794 gfc_free_expr (op2
);
1798 if (gfc_zero_size_array (op2
))
1800 gfc_free_expr (op1
);
1809 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1810 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1811 gfc_expr
*op1
, gfc_expr
*op2
)
1818 if (gfc_zero_size_array (op1
))
1819 return eval_type_intrinsic0 (operator, op1
);
1823 result
= reduce_binary0 (op1
, op2
);
1825 return eval_type_intrinsic0 (operator, result
);
1829 return eval_intrinsic (operator, f
, op1
, op2
);
1834 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1835 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1836 gfc_expr
*op1
, gfc_expr
*op2
)
1841 result
= reduce_binary0 (op1
, op2
);
1843 return eval_type_intrinsic0(operator, result
);
1846 return eval_intrinsic (operator, f
, op1
, op2
);
1851 gfc_parentheses (gfc_expr
*op
)
1853 if (gfc_is_constant_expr (op
))
1856 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES
, gfc_arith_identity
,
1861 gfc_uplus (gfc_expr
*op
)
1863 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_identity
, op
, NULL
);
1868 gfc_uminus (gfc_expr
*op
)
1870 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1875 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1877 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1882 gfc_subtract (gfc_expr
*op1
, gfc_expr
*op2
)
1884 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1889 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1891 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1896 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1898 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1903 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1905 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1910 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1912 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1917 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1919 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1924 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1926 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1931 gfc_not (gfc_expr
*op1
)
1933 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1938 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1940 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1945 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1947 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1952 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1954 return eval_intrinsic_f3 (op
, gfc_arith_eq
, op1
, op2
);
1959 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1961 return eval_intrinsic_f3 (op
, gfc_arith_ne
, op1
, op2
);
1966 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1968 return eval_intrinsic_f3 (op
, gfc_arith_gt
, op1
, op2
);
1973 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1975 return eval_intrinsic_f3 (op
, gfc_arith_ge
, op1
, op2
);
1980 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1982 return eval_intrinsic_f3 (op
, gfc_arith_lt
, op1
, op2
);
1987 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1989 return eval_intrinsic_f3 (op
, gfc_arith_le
, op1
, op2
);
1993 /* Convert an integer string to an expression node. */
1996 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
2001 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
2002 /* A leading plus is allowed, but not by mpz_set_str. */
2003 if (buffer
[0] == '+')
2007 mpz_set_str (e
->value
.integer
, t
, radix
);
2013 /* Convert a real string to an expression node. */
2016 gfc_convert_real (const char *buffer
, int kind
, locus
*where
)
2020 e
= gfc_constant_result (BT_REAL
, kind
, where
);
2021 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
2027 /* Convert a pair of real, constant expression nodes to a single
2028 complex expression node. */
2031 gfc_convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
2035 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
2036 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
2037 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
2043 /******* Simplification of intrinsic functions with constant arguments *****/
2046 /* Deal with an arithmetic error. */
2049 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
2054 gfc_error ("Arithmetic OK converting %s to %s at %L",
2055 gfc_typename (from
), gfc_typename (to
), where
);
2057 case ARITH_OVERFLOW
:
2058 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2059 "can be disabled with the option -fno-range-check",
2060 gfc_typename (from
), gfc_typename (to
), where
);
2062 case ARITH_UNDERFLOW
:
2063 gfc_error ("Arithmetic underflow converting %s to %s at %L",
2064 gfc_typename (from
), gfc_typename (to
), where
);
2067 gfc_error ("Arithmetic NaN converting %s to %s at %L",
2068 gfc_typename (from
), gfc_typename (to
), where
);
2071 gfc_error ("Division by zero converting %s to %s at %L",
2072 gfc_typename (from
), gfc_typename (to
), where
);
2074 case ARITH_INCOMMENSURATE
:
2075 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2076 gfc_typename (from
), gfc_typename (to
), where
);
2078 case ARITH_ASYMMETRIC
:
2079 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2080 " converting %s to %s at %L",
2081 gfc_typename (from
), gfc_typename (to
), where
);
2084 gfc_internal_error ("gfc_arith_error(): Bad error code");
2087 /* TODO: Do something about the error, ie, throw exception, return
2092 /* Convert integers to integers. */
2095 gfc_int2int (gfc_expr
*src
, int kind
)
2100 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2102 mpz_set (result
->value
.integer
, src
->value
.integer
);
2104 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2106 if (rc
== ARITH_ASYMMETRIC
)
2108 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2112 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2113 gfc_free_expr (result
);
2122 /* Convert integers to reals. */
2125 gfc_int2real (gfc_expr
*src
, int kind
)
2130 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2132 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2134 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2136 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2137 gfc_free_expr (result
);
2145 /* Convert default integer to default complex. */
2148 gfc_int2complex (gfc_expr
*src
, int kind
)
2153 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2155 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2156 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2158 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2160 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2161 gfc_free_expr (result
);
2169 /* Convert default real to default integer. */
2172 gfc_real2int (gfc_expr
*src
, int kind
)
2177 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2179 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2181 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2183 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2184 gfc_free_expr (result
);
2192 /* Convert real to real. */
2195 gfc_real2real (gfc_expr
*src
, int kind
)
2200 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2202 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2204 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2206 if (rc
== ARITH_UNDERFLOW
)
2208 if (gfc_option
.warn_underflow
)
2209 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2210 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2212 else if (rc
!= ARITH_OK
)
2214 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2215 gfc_free_expr (result
);
2223 /* Convert real to complex. */
2226 gfc_real2complex (gfc_expr
*src
, int kind
)
2231 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2233 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2234 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2236 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2238 if (rc
== ARITH_UNDERFLOW
)
2240 if (gfc_option
.warn_underflow
)
2241 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2242 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2244 else if (rc
!= ARITH_OK
)
2246 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2247 gfc_free_expr (result
);
2255 /* Convert complex to integer. */
2258 gfc_complex2int (gfc_expr
*src
, int kind
)
2263 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2265 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2267 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2269 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2270 gfc_free_expr (result
);
2278 /* Convert complex to real. */
2281 gfc_complex2real (gfc_expr
*src
, int kind
)
2286 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2288 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2290 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2292 if (rc
== ARITH_UNDERFLOW
)
2294 if (gfc_option
.warn_underflow
)
2295 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2296 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2300 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2301 gfc_free_expr (result
);
2309 /* Convert complex to complex. */
2312 gfc_complex2complex (gfc_expr
*src
, int kind
)
2317 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2319 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2320 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2322 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2324 if (rc
== ARITH_UNDERFLOW
)
2326 if (gfc_option
.warn_underflow
)
2327 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2328 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2330 else if (rc
!= ARITH_OK
)
2332 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2333 gfc_free_expr (result
);
2337 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2339 if (rc
== ARITH_UNDERFLOW
)
2341 if (gfc_option
.warn_underflow
)
2342 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2343 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2345 else if (rc
!= ARITH_OK
)
2347 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2348 gfc_free_expr (result
);
2356 /* Logical kind conversion. */
2359 gfc_log2log (gfc_expr
*src
, int kind
)
2363 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2364 result
->value
.logical
= src
->value
.logical
;
2370 /* Convert logical to integer. */
2373 gfc_log2int (gfc_expr
*src
, int kind
)
2377 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2378 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2384 /* Convert integer to logical. */
2387 gfc_int2log (gfc_expr
*src
, int kind
)
2391 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2392 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2398 /* Helper function to set the representation in a Hollerith conversion.
2399 This assumes that the ts.type and ts.kind of the result have already
2403 hollerith2representation (gfc_expr
*result
, gfc_expr
*src
)
2405 int src_len
, result_len
;
2407 src_len
= src
->representation
.length
;
2408 result_len
= gfc_target_expr_size (result
);
2410 if (src_len
> result_len
)
2412 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2413 &src
->where
, gfc_typename(&result
->ts
));
2416 result
->representation
.string
= gfc_getmem (result_len
+ 1);
2417 memcpy (result
->representation
.string
, src
->representation
.string
,
2418 MIN (result_len
, src_len
));
2420 if (src_len
< result_len
)
2421 memset (&result
->representation
.string
[src_len
], ' ', result_len
- src_len
);
2423 result
->representation
.string
[result_len
] = '\0'; /* For debugger */
2424 result
->representation
.length
= result_len
;
2428 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2431 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2435 result
= gfc_get_expr ();
2436 result
->expr_type
= EXPR_CONSTANT
;
2437 result
->ts
.type
= BT_INTEGER
;
2438 result
->ts
.kind
= kind
;
2439 result
->where
= src
->where
;
2441 hollerith2representation (result
, src
);
2442 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2443 result
->representation
.length
, result
->value
.integer
);
2449 /* Convert Hollerith to real. The constant will be padded or truncated. */
2452 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2457 len
= src
->value
.character
.length
;
2459 result
= gfc_get_expr ();
2460 result
->expr_type
= EXPR_CONSTANT
;
2461 result
->ts
.type
= BT_REAL
;
2462 result
->ts
.kind
= kind
;
2463 result
->where
= src
->where
;
2465 hollerith2representation (result
, src
);
2466 gfc_interpret_float (kind
, (unsigned char *) result
->representation
.string
,
2467 result
->representation
.length
, result
->value
.real
);
2473 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2476 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2481 len
= src
->value
.character
.length
;
2483 result
= gfc_get_expr ();
2484 result
->expr_type
= EXPR_CONSTANT
;
2485 result
->ts
.type
= BT_COMPLEX
;
2486 result
->ts
.kind
= kind
;
2487 result
->where
= src
->where
;
2489 hollerith2representation (result
, src
);
2490 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2491 result
->representation
.length
, result
->value
.complex.r
,
2492 result
->value
.complex.i
);
2498 /* Convert Hollerith to character. */
2501 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2505 result
= gfc_copy_expr (src
);
2506 result
->ts
.type
= BT_CHARACTER
;
2507 result
->ts
.kind
= kind
;
2509 result
->value
.character
.length
= result
->representation
.length
;
2510 result
->value
.character
.string
2511 = gfc_char_to_widechar (result
->representation
.string
);
2517 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2520 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2525 len
= src
->value
.character
.length
;
2527 result
= gfc_get_expr ();
2528 result
->expr_type
= EXPR_CONSTANT
;
2529 result
->ts
.type
= BT_LOGICAL
;
2530 result
->ts
.kind
= kind
;
2531 result
->where
= src
->where
;
2533 hollerith2representation (result
, src
);
2534 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2535 result
->representation
.length
, &result
->value
.logical
);
2541 /* Returns an initializer whose value is one higher than the value of the
2542 LAST_INITIALIZER argument. If the argument is NULL, the
2543 initializers value will be set to zero. The initializer's kind
2544 will be set to gfc_c_int_kind.
2546 If -fshort-enums is given, the appropriate kind will be selected
2547 later after all enumerators have been parsed. A warning is issued
2548 here if an initializer exceeds gfc_c_int_kind. */
2551 gfc_enum_initializer (gfc_expr
*last_initializer
, locus where
)
2555 result
= gfc_get_expr ();
2556 result
->expr_type
= EXPR_CONSTANT
;
2557 result
->ts
.type
= BT_INTEGER
;
2558 result
->ts
.kind
= gfc_c_int_kind
;
2559 result
->where
= where
;
2561 mpz_init (result
->value
.integer
);
2563 if (last_initializer
!= NULL
)
2565 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2566 result
->where
= last_initializer
->where
;
2568 if (gfc_check_integer_range (result
->value
.integer
,
2569 gfc_c_int_kind
) != ARITH_OK
)
2571 gfc_error ("Enumerator exceeds the C integer type at %C");
2577 /* Control comes here, if it's the very first enumerator and no
2578 initializer has been given. It will be initialized to zero. */
2579 mpz_set_si (result
->value
.integer
, 0);