2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
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
));
78 #if MPFR_VERSION_MAJOR < 2 || (MPFR_VERSION_MAJOR == 2 && MPFR_VERSION_MINOR < 2)
79 /* Calculate atan2 (y, x)
81 atan2(y, x) = atan(y/x) if x > 0,
82 sign(y)*(pi - atan(|y/x|)) if x < 0,
84 sign(y)*pi/2 if x = 0 && y != 0.
88 arctangent2 (mpfr_t y
, mpfr_t x
, mpfr_t result
)
100 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
101 mpfr_atan (result
, t
, GFC_RND_MODE
);
105 mpfr_const_pi (result
, GFC_RND_MODE
);
106 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
107 mpfr_abs (t
, t
, GFC_RND_MODE
);
108 mpfr_atan (t
, t
, GFC_RND_MODE
);
109 mpfr_sub (result
, result
, t
, GFC_RND_MODE
);
110 if (mpfr_sgn (y
) < 0)
111 mpfr_neg (result
, result
, GFC_RND_MODE
);
115 if (mpfr_sgn (y
) == 0)
116 mpfr_set_ui (result
, 0, GFC_RND_MODE
);
119 mpfr_const_pi (result
, GFC_RND_MODE
);
120 mpfr_div_ui (result
, result
, 2, GFC_RND_MODE
);
121 if (mpfr_sgn (y
) < 0)
122 mpfr_neg (result
, result
, GFC_RND_MODE
);
130 /* Given an arithmetic error code, return a pointer to a string that
131 explains the error. */
134 gfc_arith_error (arith code
)
141 p
= _("Arithmetic OK at %L");
144 p
= _("Arithmetic overflow at %L");
146 case ARITH_UNDERFLOW
:
147 p
= _("Arithmetic underflow at %L");
150 p
= _("Arithmetic NaN at %L");
153 p
= _("Division by zero at %L");
155 case ARITH_INCOMMENSURATE
:
156 p
= _("Array operands are incommensurate at %L");
158 case ARITH_ASYMMETRIC
:
160 _("Integer outside symmetric range implied by Standard Fortran at %L");
163 gfc_internal_error ("gfc_arith_error(): Bad error code");
170 /* Get things ready to do math. */
173 gfc_arith_init_1 (void)
175 gfc_integer_info
*int_info
;
176 gfc_real_info
*real_info
;
181 mpfr_set_default_prec (128);
185 /* Convert the minimum and maximum values for each kind into their
186 GNU MP representation. */
187 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
190 mpz_set_ui (r
, int_info
->radix
);
191 mpz_pow_ui (r
, r
, int_info
->digits
);
193 mpz_init (int_info
->huge
);
194 mpz_sub_ui (int_info
->huge
, r
, 1);
196 /* These are the numbers that are actually representable by the
197 target. For bases other than two, this needs to be changed. */
198 if (int_info
->radix
!= 2)
199 gfc_internal_error ("Fix min_int calculation");
201 /* See PRs 13490 and 17912, related to integer ranges.
202 The pedantic_min_int exists for range checking when a program
203 is compiled with -pedantic, and reflects the belief that
204 Standard Fortran requires integers to be symmetrical, i.e.
205 every negative integer must have a representable positive
206 absolute value, and vice versa. */
208 mpz_init (int_info
->pedantic_min_int
);
209 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
211 mpz_init (int_info
->min_int
);
212 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
215 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
216 mpfr_log10 (a
, a
, GFC_RND_MODE
);
218 gfc_mpfr_to_mpz (r
, a
);
219 int_info
->range
= mpz_get_si (r
);
224 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
226 gfc_set_model_kind (real_info
->kind
);
232 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
233 /* a = 1 - b**(-p) */
234 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
235 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
236 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
237 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
239 /* c = b**(emax-1) */
240 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
241 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
243 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
244 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
246 /* a = (1 - b**(-p)) * b**(emax-1) * b */
247 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
249 mpfr_init (real_info
->huge
);
250 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
252 /* tiny(x) = b**(emin-1) */
253 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
254 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
256 mpfr_init (real_info
->tiny
);
257 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
259 /* subnormal (x) = b**(emin - digit) */
260 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
261 mpfr_pow_si (b
, b
, real_info
->min_exponent
- real_info
->digits
,
264 mpfr_init (real_info
->subnormal
);
265 mpfr_set (real_info
->subnormal
, b
, GFC_RND_MODE
);
267 /* epsilon(x) = b**(1-p) */
268 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
269 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
271 mpfr_init (real_info
->epsilon
);
272 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
274 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
275 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
276 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
277 mpfr_neg (b
, b
, GFC_RND_MODE
);
280 if (mpfr_cmp (a
, b
) > 0)
281 mpfr_set (a
, b
, GFC_RND_MODE
);
284 gfc_mpfr_to_mpz (r
, a
);
285 real_info
->range
= mpz_get_si (r
);
287 /* precision(x) = int((p - 1) * log10(b)) + k */
288 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
289 mpfr_log10 (a
, a
, GFC_RND_MODE
);
291 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
293 gfc_mpfr_to_mpz (r
, a
);
294 real_info
->precision
= mpz_get_si (r
);
296 /* If the radix is an integral power of 10, add one to the precision. */
297 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
298 if (i
== real_info
->radix
)
299 real_info
->precision
++;
310 /* Clean up, get rid of numeric constants. */
313 gfc_arith_done_1 (void)
315 gfc_integer_info
*ip
;
318 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
320 mpz_clear (ip
->min_int
);
321 mpz_clear (ip
->pedantic_min_int
);
322 mpz_clear (ip
->huge
);
325 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
327 mpfr_clear (rp
->epsilon
);
328 mpfr_clear (rp
->huge
);
329 mpfr_clear (rp
->tiny
);
330 mpfr_clear (rp
->subnormal
);
335 /* Given an integer and a kind, make sure that the integer lies within
336 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
340 gfc_check_integer_range (mpz_t p
, int kind
)
345 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
350 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
351 result
= ARITH_ASYMMETRIC
;
355 if (gfc_option
.flag_range_check
== 0)
358 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
359 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
360 result
= ARITH_OVERFLOW
;
366 /* Given a real and a kind, make sure that the real lies within the
367 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
371 gfc_check_real_range (mpfr_t p
, int kind
)
377 i
= gfc_validate_kind (BT_REAL
, kind
, false);
381 mpfr_abs (q
, p
, GFC_RND_MODE
);
385 if (gfc_option
.flag_range_check
== 0)
388 retval
= ARITH_OVERFLOW
;
390 else if (mpfr_nan_p (p
))
392 if (gfc_option
.flag_range_check
== 0)
397 else if (mpfr_sgn (q
) == 0)
399 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
401 if (gfc_option
.flag_range_check
== 0)
404 retval
= ARITH_OVERFLOW
;
406 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
408 if (gfc_option
.flag_range_check
== 0)
411 retval
= ARITH_UNDERFLOW
;
413 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
415 #if MPFR_VERSION_MAJOR < 2 || (MPFR_VERSION_MAJOR == 2 && MPFR_VERSION_MINOR < 2)
416 /* MPFR operates on a number with a given precision and enormous
417 exponential range. To represent subnormal numbers, the exponent is
418 allowed to become smaller than emin, but always retains the full
419 precision. This code resets unused bits to 0 to alleviate
420 rounding problems. Note, a future version of MPFR will have a
421 mpfr_subnormalize() function, which handles this truncation in a
422 more efficient and robust way. */
428 bin
= mpfr_get_str (NULL
, &e
, gfc_real_kinds
[i
].radix
, 0, q
, GMP_RNDN
);
429 k
= gfc_real_kinds
[i
].digits
- (gfc_real_kinds
[i
].min_exponent
- e
);
430 for (j
= k
; j
< gfc_real_kinds
[i
].digits
; j
++)
432 /* Need space for '0.', bin, 'E', and e */
433 s
= (char *) gfc_getmem (strlen(bin
) + 10);
434 sprintf (s
, "0.%sE%d", bin
, (int) e
);
435 mpfr_set_str (q
, s
, gfc_real_kinds
[i
].radix
, GMP_RNDN
);
442 /* Save current values of emin and emax. */
443 emin
= mpfr_get_emin ();
444 emax
= mpfr_get_emax ();
446 /* Set emin and emax for the current model number. */
447 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[i
].min_exponent
- 1);
448 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[i
].max_exponent
- 1);
449 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
451 /* Reset emin and emax. */
452 mpfr_set_emin (emin
);
453 mpfr_set_emax (emax
);
456 /* Copy sign if needed. */
457 if (mpfr_sgn (p
) < 0)
458 mpfr_neg (p
, q
, GMP_RNDN
);
460 mpfr_set (p
, q
, GMP_RNDN
);
473 /* Function to return a constant expression node of a given type and kind. */
476 gfc_constant_result (bt type
, int kind
, locus
* where
)
482 ("gfc_constant_result(): locus 'where' cannot be NULL");
484 result
= gfc_get_expr ();
486 result
->expr_type
= EXPR_CONSTANT
;
487 result
->ts
.type
= type
;
488 result
->ts
.kind
= kind
;
489 result
->where
= *where
;
494 mpz_init (result
->value
.integer
);
498 gfc_set_model_kind (kind
);
499 mpfr_init (result
->value
.real
);
503 gfc_set_model_kind (kind
);
504 mpfr_init (result
->value
.complex.r
);
505 mpfr_init (result
->value
.complex.i
);
516 /* Low-level arithmetic functions. All of these subroutines assume
517 that all operands are of the same type and return an operand of the
518 same type. The other thing about these subroutines is that they
519 can fail in various ways -- overflow, underflow, division by zero,
520 zero raised to the zero, etc. */
523 gfc_arith_not (gfc_expr
* op1
, gfc_expr
** resultp
)
527 result
= gfc_constant_result (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
528 result
->value
.logical
= !op1
->value
.logical
;
536 gfc_arith_and (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
540 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
542 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
550 gfc_arith_or (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
554 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
556 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
564 gfc_arith_eqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
568 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
570 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
578 gfc_arith_neqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
582 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
584 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
591 /* Make sure a constant numeric expression is within the range for
592 its type and kind. Note that there's also a gfc_check_range(),
593 but that one deals with the intrinsic RANGE function. */
596 gfc_range_check (gfc_expr
* e
)
603 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
607 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
608 if (rc
== ARITH_UNDERFLOW
)
609 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
610 if (rc
== ARITH_OVERFLOW
)
611 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
613 mpfr_set_nan (e
->value
.real
);
617 rc
= gfc_check_real_range (e
->value
.complex.r
, e
->ts
.kind
);
618 if (rc
== ARITH_UNDERFLOW
)
619 mpfr_set_ui (e
->value
.complex.r
, 0, GFC_RND_MODE
);
620 if (rc
== ARITH_OVERFLOW
)
621 mpfr_set_inf (e
->value
.complex.r
, mpfr_sgn (e
->value
.complex.r
));
623 mpfr_set_nan (e
->value
.complex.r
);
625 rc
= gfc_check_real_range (e
->value
.complex.i
, e
->ts
.kind
);
626 if (rc
== ARITH_UNDERFLOW
)
627 mpfr_set_ui (e
->value
.complex.i
, 0, GFC_RND_MODE
);
628 if (rc
== ARITH_OVERFLOW
)
629 mpfr_set_inf (e
->value
.complex.i
, mpfr_sgn (e
->value
.complex.i
));
631 mpfr_set_nan (e
->value
.complex.i
);
635 gfc_internal_error ("gfc_range_check(): Bad type");
642 /* Several of the following routines use the same set of statements to
643 check the validity of the result. Encapsulate the checking here. */
646 check_result (arith rc
, gfc_expr
* x
, gfc_expr
* r
, gfc_expr
** rp
)
650 if (val
== ARITH_UNDERFLOW
)
652 if (gfc_option
.warn_underflow
)
653 gfc_warning (gfc_arith_error (val
), &x
->where
);
657 if (val
== ARITH_ASYMMETRIC
)
659 gfc_warning (gfc_arith_error (val
), &x
->where
);
672 /* It may seem silly to have a subroutine that actually computes the
673 unary plus of a constant, but it prevents us from making exceptions
674 in the code elsewhere. */
677 gfc_arith_uplus (gfc_expr
* op1
, gfc_expr
** resultp
)
679 *resultp
= gfc_copy_expr (op1
);
685 gfc_arith_uminus (gfc_expr
* op1
, gfc_expr
** resultp
)
690 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
692 switch (op1
->ts
.type
)
695 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
699 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
703 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
704 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
708 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
711 rc
= gfc_range_check (result
);
713 return check_result (rc
, op1
, result
, resultp
);
718 gfc_arith_plus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
723 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
725 switch (op1
->ts
.type
)
728 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
732 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
737 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
738 op2
->value
.complex.r
, GFC_RND_MODE
);
740 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
741 op2
->value
.complex.i
, GFC_RND_MODE
);
745 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
748 rc
= gfc_range_check (result
);
750 return check_result (rc
, op1
, result
, resultp
);
755 gfc_arith_minus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
760 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
762 switch (op1
->ts
.type
)
765 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
769 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
774 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
775 op2
->value
.complex.r
, GFC_RND_MODE
);
777 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
778 op2
->value
.complex.i
, GFC_RND_MODE
);
782 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
785 rc
= gfc_range_check (result
);
787 return check_result (rc
, op1
, result
, resultp
);
792 gfc_arith_times (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
798 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
800 switch (op1
->ts
.type
)
803 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
807 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
812 gfc_set_model (op1
->value
.complex.r
);
816 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
817 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
818 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
820 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
821 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
822 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
829 gfc_internal_error ("gfc_arith_times(): Bad basic type");
832 rc
= gfc_range_check (result
);
834 return check_result (rc
, op1
, result
, resultp
);
839 gfc_arith_divide (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
847 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
849 switch (op1
->ts
.type
)
852 if (mpz_sgn (op2
->value
.integer
) == 0)
858 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
863 if (mpfr_sgn (op2
->value
.real
) == 0
864 && gfc_option
.flag_range_check
== 1)
870 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
875 if (mpfr_sgn (op2
->value
.complex.r
) == 0
876 && mpfr_sgn (op2
->value
.complex.i
) == 0
877 && gfc_option
.flag_range_check
== 1)
883 gfc_set_model (op1
->value
.complex.r
);
888 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
889 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
890 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
892 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
893 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
894 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
895 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
898 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
899 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
900 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
901 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
910 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
914 rc
= gfc_range_check (result
);
916 return check_result (rc
, op1
, result
, resultp
);
920 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
923 complex_reciprocal (gfc_expr
* op
)
925 mpfr_t mod
, a
, re
, im
;
927 gfc_set_model (op
->value
.complex.r
);
933 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
934 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
935 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
937 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
939 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
940 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
942 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
943 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
952 /* Raise a complex number to positive power. */
955 complex_pow_ui (gfc_expr
* base
, int power
, gfc_expr
* result
)
959 gfc_set_model (base
->value
.complex.r
);
964 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
965 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
967 for (; power
> 0; power
--)
969 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
971 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
973 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
975 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
977 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
979 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
981 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
982 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
991 /* Raise a number to an integer power. */
994 gfc_arith_power (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1004 if (gfc_extract_int (op2
, &power
) != NULL
)
1005 gfc_internal_error ("gfc_arith_power(): Bad exponent");
1007 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
1011 /* Handle something to the zeroth power. Since we're dealing
1012 with integral exponents, there is no ambiguity in the
1013 limiting procedure used to determine the value of 0**0. */
1014 switch (op1
->ts
.type
)
1017 mpz_set_ui (result
->value
.integer
, 1);
1021 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
1025 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
1026 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
1030 gfc_internal_error ("gfc_arith_power(): Bad base");
1039 switch (op1
->ts
.type
)
1042 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
1046 mpz_init_set_ui (unity_z
, 1);
1047 mpz_tdiv_q (result
->value
.integer
, unity_z
,
1048 result
->value
.integer
);
1049 mpz_clear (unity_z
);
1054 mpfr_pow_ui (result
->value
.real
, op1
->value
.real
, apower
,
1059 gfc_set_model (op1
->value
.real
);
1060 mpfr_init (unity_f
);
1061 mpfr_set_ui (unity_f
, 1, GFC_RND_MODE
);
1062 mpfr_div (result
->value
.real
, unity_f
, result
->value
.real
,
1064 mpfr_clear (unity_f
);
1069 complex_pow_ui (op1
, apower
, result
);
1071 complex_reciprocal (result
);
1080 rc
= gfc_range_check (result
);
1082 return check_result (rc
, op1
, result
, resultp
);
1086 /* Concatenate two string constants. */
1089 gfc_arith_concat (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1094 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1097 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1099 result
->value
.character
.string
= gfc_getmem (len
+ 1);
1100 result
->value
.character
.length
= len
;
1102 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1103 op1
->value
.character
.length
);
1105 memcpy (result
->value
.character
.string
+ op1
->value
.character
.length
,
1106 op2
->value
.character
.string
, op2
->value
.character
.length
);
1108 result
->value
.character
.string
[len
] = '\0';
1116 /* Comparison operators. Assumes that the two expression nodes
1117 contain two constants of the same type. */
1120 gfc_compare_expr (gfc_expr
* op1
, gfc_expr
* op2
)
1124 switch (op1
->ts
.type
)
1127 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1131 rc
= mpfr_cmp (op1
->value
.real
, op2
->value
.real
);
1135 rc
= gfc_compare_string (op1
, op2
, NULL
);
1139 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1140 || (op1
->value
.logical
&& !op2
->value
.logical
));
1144 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1151 /* Compare a pair of complex numbers. Naturally, this is only for
1152 equality and nonequality. */
1155 compare_complex (gfc_expr
* op1
, gfc_expr
* op2
)
1157 return (mpfr_cmp (op1
->value
.complex.r
, op2
->value
.complex.r
) == 0
1158 && mpfr_cmp (op1
->value
.complex.i
, op2
->value
.complex.i
) == 0);
1162 /* Given two constant strings and the inverse collating sequence, compare the
1163 strings. We return -1 for a < b, 0 for a == b and 1 for a > b. If the
1164 xcoll_table is NULL, we use the processor's default collating sequence. */
1167 gfc_compare_string (gfc_expr
* a
, gfc_expr
* b
, const int * xcoll_table
)
1169 int len
, alen
, blen
, i
, ac
, bc
;
1171 alen
= a
->value
.character
.length
;
1172 blen
= b
->value
.character
.length
;
1174 len
= (alen
> blen
) ? alen
: blen
;
1176 for (i
= 0; i
< len
; i
++)
1178 /* We cast to unsigned char because default char, if it is signed,
1179 would lead to ac < 0 for string[i] > 127. */
1180 ac
= (unsigned char) ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1181 bc
= (unsigned char) ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1183 if (xcoll_table
!= NULL
)
1185 ac
= xcoll_table
[ac
];
1186 bc
= xcoll_table
[bc
];
1195 /* Strings are equal */
1201 /* Specific comparison subroutines. */
1204 gfc_arith_eq (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1208 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1210 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1211 compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) == 0);
1219 gfc_arith_ne (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1223 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1225 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1226 !compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) != 0);
1234 gfc_arith_gt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1238 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1240 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1248 gfc_arith_ge (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1252 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1254 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1262 gfc_arith_lt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1266 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1268 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1276 gfc_arith_le (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1280 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1282 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1290 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
* op
,
1293 gfc_constructor
*c
, *head
;
1297 if (op
->expr_type
== EXPR_CONSTANT
)
1298 return eval (op
, result
);
1301 head
= gfc_copy_constructor (op
->value
.constructor
);
1303 for (c
= head
; c
; c
= c
->next
)
1305 rc
= eval (c
->expr
, &r
);
1309 gfc_replace_expr (c
->expr
, r
);
1313 gfc_free_constructor (head
);
1316 r
= gfc_get_expr ();
1317 r
->expr_type
= EXPR_ARRAY
;
1318 r
->value
.constructor
= head
;
1319 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1321 r
->ts
= head
->expr
->ts
;
1322 r
->where
= op
->where
;
1333 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1334 gfc_expr
* op1
, gfc_expr
* op2
,
1337 gfc_constructor
*c
, *head
;
1341 head
= gfc_copy_constructor (op1
->value
.constructor
);
1344 for (c
= head
; c
; c
= c
->next
)
1346 rc
= eval (c
->expr
, op2
, &r
);
1350 gfc_replace_expr (c
->expr
, r
);
1354 gfc_free_constructor (head
);
1357 r
= gfc_get_expr ();
1358 r
->expr_type
= EXPR_ARRAY
;
1359 r
->value
.constructor
= head
;
1360 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1362 r
->ts
= head
->expr
->ts
;
1363 r
->where
= op1
->where
;
1364 r
->rank
= op1
->rank
;
1374 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1375 gfc_expr
* op1
, gfc_expr
* op2
,
1378 gfc_constructor
*c
, *head
;
1382 head
= gfc_copy_constructor (op2
->value
.constructor
);
1385 for (c
= head
; c
; c
= c
->next
)
1387 rc
= eval (op1
, c
->expr
, &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 (op2
->shape
, op2
->rank
);
1403 r
->ts
= head
->expr
->ts
;
1404 r
->where
= op2
->where
;
1405 r
->rank
= op2
->rank
;
1415 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1416 gfc_expr
* op1
, gfc_expr
* op2
,
1419 gfc_constructor
*c
, *d
, *head
;
1423 head
= gfc_copy_constructor (op1
->value
.constructor
);
1426 d
= op2
->value
.constructor
;
1428 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1430 rc
= ARITH_INCOMMENSURATE
;
1434 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1438 rc
= ARITH_INCOMMENSURATE
;
1442 rc
= eval (c
->expr
, d
->expr
, &r
);
1446 gfc_replace_expr (c
->expr
, r
);
1450 rc
= ARITH_INCOMMENSURATE
;
1454 gfc_free_constructor (head
);
1457 r
= gfc_get_expr ();
1458 r
->expr_type
= EXPR_ARRAY
;
1459 r
->value
.constructor
= head
;
1460 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1462 r
->ts
= head
->expr
->ts
;
1463 r
->where
= op1
->where
;
1464 r
->rank
= op1
->rank
;
1474 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1475 gfc_expr
* op1
, gfc_expr
* op2
,
1478 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1479 return eval (op1
, op2
, result
);
1481 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1482 return reduce_binary_ca (eval
, op1
, op2
, result
);
1484 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1485 return reduce_binary_ac (eval
, op1
, op2
, result
);
1487 return reduce_binary_aa (eval
, op1
, op2
, result
);
1493 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1494 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1498 /* High level arithmetic subroutines. These subroutines go into
1499 eval_intrinsic(), which can do one of several things to its
1500 operands. If the operands are incompatible with the intrinsic
1501 operation, we return a node pointing to the operands and hope that
1502 an operator interface is found during resolution.
1504 If the operands are compatible and are constants, then we try doing
1505 the arithmetic. We also handle the cases where either or both
1506 operands are array constructors. */
1509 eval_intrinsic (gfc_intrinsic_op
operator,
1510 eval_f eval
, gfc_expr
* op1
, gfc_expr
* op2
)
1512 gfc_expr temp
, *result
;
1516 gfc_clear_ts (&temp
.ts
);
1522 if (op1
->ts
.type
!= BT_LOGICAL
)
1525 temp
.ts
.type
= BT_LOGICAL
;
1526 temp
.ts
.kind
= gfc_default_logical_kind
;
1531 /* Logical binary operators */
1534 case INTRINSIC_NEQV
:
1536 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1539 temp
.ts
.type
= BT_LOGICAL
;
1540 temp
.ts
.kind
= gfc_default_logical_kind
;
1546 case INTRINSIC_UPLUS
:
1547 case INTRINSIC_UMINUS
:
1548 if (!gfc_numeric_ts (&op1
->ts
))
1556 case INTRINSIC_PARENTHESES
:
1562 /* Additional restrictions for ordering relations. */
1567 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1569 temp
.ts
.type
= BT_LOGICAL
;
1570 temp
.ts
.kind
= gfc_default_logical_kind
;
1577 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1580 temp
.ts
.type
= BT_LOGICAL
;
1581 temp
.ts
.kind
= gfc_default_logical_kind
;
1586 /* Numeric binary */
1587 case INTRINSIC_PLUS
:
1588 case INTRINSIC_MINUS
:
1589 case INTRINSIC_TIMES
:
1590 case INTRINSIC_DIVIDE
:
1591 case INTRINSIC_POWER
:
1592 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1595 /* Insert any necessary type conversions to make the operands
1598 temp
.expr_type
= EXPR_OP
;
1599 gfc_clear_ts (&temp
.ts
);
1600 temp
.value
.op
.operator = operator;
1602 temp
.value
.op
.op1
= op1
;
1603 temp
.value
.op
.op2
= op2
;
1605 gfc_type_convert_binary (&temp
);
1607 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1608 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1609 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1611 temp
.ts
.type
= BT_LOGICAL
;
1612 temp
.ts
.kind
= gfc_default_logical_kind
;
1618 /* Character binary */
1619 case INTRINSIC_CONCAT
:
1620 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1623 temp
.ts
.type
= BT_CHARACTER
;
1624 temp
.ts
.kind
= gfc_default_character_kind
;
1629 case INTRINSIC_USER
:
1633 gfc_internal_error ("eval_intrinsic(): Bad operator");
1636 /* Try to combine the operators. */
1637 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1641 || (op1
->expr_type
!= EXPR_CONSTANT
1642 && (op1
->expr_type
!= EXPR_ARRAY
1643 || !gfc_is_constant_expr (op1
)
1644 || !gfc_expanded_ac (op1
))))
1649 || (op2
->expr_type
!= EXPR_CONSTANT
1650 && (op2
->expr_type
!= EXPR_ARRAY
1651 || !gfc_is_constant_expr (op2
)
1652 || !gfc_expanded_ac (op2
)))))
1656 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1658 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1661 { /* Something went wrong. */
1662 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1666 gfc_free_expr (op1
);
1667 gfc_free_expr (op2
);
1671 /* Create a run-time expression. */
1672 result
= gfc_get_expr ();
1673 result
->ts
= temp
.ts
;
1675 result
->expr_type
= EXPR_OP
;
1676 result
->value
.op
.operator = operator;
1678 result
->value
.op
.op1
= op1
;
1679 result
->value
.op
.op2
= op2
;
1681 result
->where
= op1
->where
;
1687 /* Modify type of expression for zero size array. */
1690 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
* op
)
1693 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1703 op
->ts
.type
= BT_LOGICAL
;
1704 op
->ts
.kind
= gfc_default_logical_kind
;
1715 /* Return nonzero if the expression is a zero size array. */
1718 gfc_zero_size_array (gfc_expr
* e
)
1720 if (e
->expr_type
!= EXPR_ARRAY
)
1723 return e
->value
.constructor
== NULL
;
1727 /* Reduce a binary expression where at least one of the operands
1728 involves a zero-length array. Returns NULL if neither of the
1729 operands is a zero-length array. */
1732 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1734 if (gfc_zero_size_array (op1
))
1736 gfc_free_expr (op2
);
1740 if (gfc_zero_size_array (op2
))
1742 gfc_free_expr (op1
);
1751 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1752 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1753 gfc_expr
* op1
, gfc_expr
* op2
)
1760 if (gfc_zero_size_array (op1
))
1761 return eval_type_intrinsic0 (operator, op1
);
1765 result
= reduce_binary0 (op1
, op2
);
1767 return eval_type_intrinsic0 (operator, result
);
1771 return eval_intrinsic (operator, f
, op1
, op2
);
1776 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1777 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1778 gfc_expr
* op1
, gfc_expr
* op2
)
1783 result
= reduce_binary0 (op1
, op2
);
1785 return eval_type_intrinsic0(operator, result
);
1788 return eval_intrinsic (operator, f
, op1
, op2
);
1793 gfc_uplus (gfc_expr
* op
)
1795 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1800 gfc_uminus (gfc_expr
* op
)
1802 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1807 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1809 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1814 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1816 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1821 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1823 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1828 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1830 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1835 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1837 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1842 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1844 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1849 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1851 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1856 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1858 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1863 gfc_not (gfc_expr
* op1
)
1865 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1870 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1872 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1877 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1879 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1884 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1886 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1891 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1893 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1898 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1900 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1905 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1907 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1912 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1914 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1919 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1921 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1925 /* Convert an integer string to an expression node. */
1928 gfc_convert_integer (const char * buffer
, int kind
, int radix
, locus
* where
)
1933 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1934 /* A leading plus is allowed, but not by mpz_set_str. */
1935 if (buffer
[0] == '+')
1939 mpz_set_str (e
->value
.integer
, t
, radix
);
1945 /* Convert a real string to an expression node. */
1948 gfc_convert_real (const char * buffer
, int kind
, locus
* where
)
1952 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1953 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1959 /* Convert a pair of real, constant expression nodes to a single
1960 complex expression node. */
1963 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1967 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1968 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1969 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1975 /******* Simplification of intrinsic functions with constant arguments *****/
1978 /* Deal with an arithmetic error. */
1981 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1986 gfc_error ("Arithmetic OK converting %s to %s at %L",
1987 gfc_typename (from
), gfc_typename (to
), where
);
1989 case ARITH_OVERFLOW
:
1990 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1991 gfc_typename (from
), gfc_typename (to
), where
);
1993 case ARITH_UNDERFLOW
:
1994 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1995 gfc_typename (from
), gfc_typename (to
), where
);
1998 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1999 gfc_typename (from
), gfc_typename (to
), where
);
2002 gfc_error ("Division by zero converting %s to %s at %L",
2003 gfc_typename (from
), gfc_typename (to
), where
);
2005 case ARITH_INCOMMENSURATE
:
2006 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2007 gfc_typename (from
), gfc_typename (to
), where
);
2009 case ARITH_ASYMMETRIC
:
2010 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2011 " converting %s to %s at %L",
2012 gfc_typename (from
), gfc_typename (to
), where
);
2015 gfc_internal_error ("gfc_arith_error(): Bad error code");
2018 /* TODO: Do something about the error, ie, throw exception, return
2023 /* Convert integers to integers. */
2026 gfc_int2int (gfc_expr
* src
, int kind
)
2031 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2033 mpz_set (result
->value
.integer
, src
->value
.integer
);
2035 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2038 if (rc
== ARITH_ASYMMETRIC
)
2040 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2044 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2045 gfc_free_expr (result
);
2054 /* Convert integers to reals. */
2057 gfc_int2real (gfc_expr
* src
, int kind
)
2062 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2064 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2066 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2068 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2069 gfc_free_expr (result
);
2077 /* Convert default integer to default complex. */
2080 gfc_int2complex (gfc_expr
* src
, int kind
)
2085 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2087 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2088 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2090 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2092 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2093 gfc_free_expr (result
);
2101 /* Convert default real to default integer. */
2104 gfc_real2int (gfc_expr
* src
, int kind
)
2109 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2111 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2113 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2116 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2117 gfc_free_expr (result
);
2125 /* Convert real to real. */
2128 gfc_real2real (gfc_expr
* src
, int kind
)
2133 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2135 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2137 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2139 if (rc
== ARITH_UNDERFLOW
)
2141 if (gfc_option
.warn_underflow
)
2142 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2143 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2145 else if (rc
!= ARITH_OK
)
2147 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2148 gfc_free_expr (result
);
2156 /* Convert real to complex. */
2159 gfc_real2complex (gfc_expr
* src
, int kind
)
2164 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2166 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2167 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2169 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2171 if (rc
== ARITH_UNDERFLOW
)
2173 if (gfc_option
.warn_underflow
)
2174 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2175 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2177 else if (rc
!= ARITH_OK
)
2179 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2180 gfc_free_expr (result
);
2188 /* Convert complex to integer. */
2191 gfc_complex2int (gfc_expr
* src
, int kind
)
2196 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2198 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2200 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2203 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2204 gfc_free_expr (result
);
2212 /* Convert complex to real. */
2215 gfc_complex2real (gfc_expr
* src
, int kind
)
2220 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2222 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2224 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2226 if (rc
== ARITH_UNDERFLOW
)
2228 if (gfc_option
.warn_underflow
)
2229 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2230 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2234 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2235 gfc_free_expr (result
);
2243 /* Convert complex to complex. */
2246 gfc_complex2complex (gfc_expr
* src
, int kind
)
2251 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2253 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2254 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2256 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2258 if (rc
== ARITH_UNDERFLOW
)
2260 if (gfc_option
.warn_underflow
)
2261 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2262 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2264 else if (rc
!= ARITH_OK
)
2266 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2267 gfc_free_expr (result
);
2271 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2273 if (rc
== ARITH_UNDERFLOW
)
2275 if (gfc_option
.warn_underflow
)
2276 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2277 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2279 else if (rc
!= ARITH_OK
)
2281 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2282 gfc_free_expr (result
);
2290 /* Logical kind conversion. */
2293 gfc_log2log (gfc_expr
* src
, int kind
)
2297 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2298 result
->value
.logical
= src
->value
.logical
;
2304 /* Convert logical to integer. */
2307 gfc_log2int (gfc_expr
*src
, int kind
)
2311 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2312 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2318 /* Convert integer to logical. */
2321 gfc_int2log (gfc_expr
*src
, int kind
)
2325 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2326 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2332 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2335 gfc_hollerith2int (gfc_expr
* src
, int kind
)
2340 len
= src
->value
.character
.length
;
2342 result
= gfc_get_expr ();
2343 result
->expr_type
= EXPR_CONSTANT
;
2344 result
->ts
.type
= BT_INTEGER
;
2345 result
->ts
.kind
= kind
;
2346 result
->where
= src
->where
;
2351 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2352 &src
->where
, gfc_typename(&result
->ts
));
2354 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2355 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2359 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2361 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2362 result
->value
.character
.length
= kind
;
2368 /* Convert Hollerith to real. The constant will be padded or truncated. */
2371 gfc_hollerith2real (gfc_expr
* src
, int kind
)
2376 len
= src
->value
.character
.length
;
2378 result
= gfc_get_expr ();
2379 result
->expr_type
= EXPR_CONSTANT
;
2380 result
->ts
.type
= BT_REAL
;
2381 result
->ts
.kind
= kind
;
2382 result
->where
= src
->where
;
2387 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2388 &src
->where
, gfc_typename(&result
->ts
));
2390 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2391 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2395 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2397 result
->value
.character
.string
[kind
] = '\0'; /* For debugger. */
2398 result
->value
.character
.length
= kind
;
2404 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2407 gfc_hollerith2complex (gfc_expr
* src
, int kind
)
2412 len
= src
->value
.character
.length
;
2414 result
= gfc_get_expr ();
2415 result
->expr_type
= EXPR_CONSTANT
;
2416 result
->ts
.type
= BT_COMPLEX
;
2417 result
->ts
.kind
= kind
;
2418 result
->where
= src
->where
;
2425 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2426 &src
->where
, gfc_typename(&result
->ts
));
2428 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2429 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2433 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2435 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2436 result
->value
.character
.length
= kind
;
2442 /* Convert Hollerith to character. */
2445 gfc_hollerith2character (gfc_expr
* src
, int kind
)
2449 result
= gfc_copy_expr (src
);
2450 result
->ts
.type
= BT_CHARACTER
;
2451 result
->ts
.kind
= kind
;
2458 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2461 gfc_hollerith2logical (gfc_expr
* src
, int kind
)
2466 len
= src
->value
.character
.length
;
2468 result
= gfc_get_expr ();
2469 result
->expr_type
= EXPR_CONSTANT
;
2470 result
->ts
.type
= BT_LOGICAL
;
2471 result
->ts
.kind
= kind
;
2472 result
->where
= src
->where
;
2477 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2478 &src
->where
, gfc_typename(&result
->ts
));
2480 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2481 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2485 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2487 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2488 result
->value
.character
.length
= kind
;
2494 /* Returns an initializer whose value is one higher than the value of the
2495 LAST_INITIALIZER argument. If the argument is NULL, the
2496 initializers value will be set to zero. The initializer's kind
2497 will be set to gfc_c_int_kind.
2499 If -fshort-enums is given, the appropriate kind will be selected
2500 later after all enumerators have been parsed. A warning is issued
2501 here if an initializer exceeds gfc_c_int_kind. */
2504 gfc_enum_initializer (gfc_expr
* last_initializer
, locus where
)
2508 result
= gfc_get_expr ();
2509 result
->expr_type
= EXPR_CONSTANT
;
2510 result
->ts
.type
= BT_INTEGER
;
2511 result
->ts
.kind
= gfc_c_int_kind
;
2512 result
->where
= where
;
2514 mpz_init (result
->value
.integer
);
2516 if (last_initializer
!= NULL
)
2518 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2519 result
->where
= last_initializer
->where
;
2521 if (gfc_check_integer_range (result
->value
.integer
,
2522 gfc_c_int_kind
) != ARITH_OK
)
2524 gfc_error ("Enumerator exceeds the C integer type at %C");
2530 /* Control comes here, if it's the very first enumerator and no
2531 initializer has been given. It will be initialized to zero. */
2532 mpz_set_si (result
->value
.integer
, 0);