2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 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 to do arithmetic,
26 and this file provides the interface. */
34 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
35 It's easily implemented with a few calls though. */
38 gfc_mpfr_to_mpz (mpz_t z
, mpfr_t x
)
42 e
= mpfr_get_z_exp (z
, x
);
43 /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
44 may set the sign of z incorrectly. Work around that here. */
45 if (mpfr_sgn (x
) != mpz_sgn (z
))
49 mpz_mul_2exp (z
, z
, e
);
51 mpz_tdiv_q_2exp (z
, z
, -e
);
55 /* Set the model number precision by the requested KIND. */
58 gfc_set_model_kind (int kind
)
60 int index
= gfc_validate_kind (BT_REAL
, kind
, false);
63 base2prec
= gfc_real_kinds
[index
].digits
;
64 if (gfc_real_kinds
[index
].radix
!= 2)
65 base2prec
*= gfc_real_kinds
[index
].radix
/ 2;
66 mpfr_set_default_prec (base2prec
);
70 /* Set the model number precision from mpfr_t x. */
73 gfc_set_model (mpfr_t x
)
75 mpfr_set_default_prec (mpfr_get_prec (x
));
78 /* Calculate atan2 (y, x)
80 atan2(y, x) = atan(y/x) if x > 0,
81 sign(y)*(pi - atan(|y/x|)) if x < 0,
83 sign(y)*pi/2 if x = 0 && y != 0.
87 arctangent2 (mpfr_t y
, mpfr_t x
, mpfr_t result
)
99 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
100 mpfr_atan (result
, t
, GFC_RND_MODE
);
104 mpfr_const_pi (result
, GFC_RND_MODE
);
105 mpfr_div (t
, y
, x
, GFC_RND_MODE
);
106 mpfr_abs (t
, t
, GFC_RND_MODE
);
107 mpfr_atan (t
, t
, GFC_RND_MODE
);
108 mpfr_sub (result
, result
, t
, GFC_RND_MODE
);
109 if (mpfr_sgn (y
) < 0)
110 mpfr_neg (result
, result
, GFC_RND_MODE
);
114 if (mpfr_sgn (y
) == 0)
115 mpfr_set_ui (result
, 0, GFC_RND_MODE
);
118 mpfr_const_pi (result
, GFC_RND_MODE
);
119 mpfr_div_ui (result
, result
, 2, GFC_RND_MODE
);
120 if (mpfr_sgn (y
) < 0)
121 mpfr_neg (result
, result
, GFC_RND_MODE
);
130 /* Given an arithmetic error code, return a pointer to a string that
131 explains the error. */
134 gfc_arith_error (arith code
)
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/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, max_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);
214 mpz_init (int_info
->max_int
);
215 mpz_add (int_info
->max_int
, int_info
->huge
, int_info
->huge
);
216 mpz_add_ui (int_info
->max_int
, int_info
->max_int
, 1);
219 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
220 mpfr_log10 (a
, a
, GFC_RND_MODE
);
222 gfc_mpfr_to_mpz (r
, a
);
223 int_info
->range
= mpz_get_si (r
);
228 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
230 gfc_set_model_kind (real_info
->kind
);
236 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
237 /* a = 1 - b**(-p) */
238 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
239 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
240 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
241 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
243 /* c = b**(emax-1) */
244 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
245 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
247 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
248 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
250 /* a = (1 - b**(-p)) * b**(emax-1) * b */
251 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
253 mpfr_init (real_info
->huge
);
254 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
256 /* tiny(x) = b**(emin-1) */
257 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
258 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
260 mpfr_init (real_info
->tiny
);
261 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
263 /* subnormal (x) = b**(emin - digit) */
264 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
265 mpfr_pow_si (b
, b
, real_info
->min_exponent
- real_info
->digits
,
268 mpfr_init (real_info
->subnormal
);
269 mpfr_set (real_info
->subnormal
, b
, GFC_RND_MODE
);
271 /* epsilon(x) = b**(1-p) */
272 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
273 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
275 mpfr_init (real_info
->epsilon
);
276 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
278 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
279 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
280 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
281 mpfr_neg (b
, b
, GFC_RND_MODE
);
283 if (mpfr_cmp (a
, b
) > 0)
284 mpfr_set (a
, b
, GFC_RND_MODE
); /* a = min(a, b) */
287 gfc_mpfr_to_mpz (r
, a
);
288 real_info
->range
= mpz_get_si (r
);
290 /* precision(x) = int((p - 1) * log10(b)) + k */
291 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
292 mpfr_log10 (a
, a
, GFC_RND_MODE
);
294 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
296 gfc_mpfr_to_mpz (r
, a
);
297 real_info
->precision
= mpz_get_si (r
);
299 /* If the radix is an integral power of 10, add one to the
301 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
302 if (i
== real_info
->radix
)
303 real_info
->precision
++;
314 /* Clean up, get rid of numeric constants. */
317 gfc_arith_done_1 (void)
319 gfc_integer_info
*ip
;
322 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
324 mpz_clear (ip
->min_int
);
325 mpz_clear (ip
->max_int
);
326 mpz_clear (ip
->huge
);
329 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
331 mpfr_clear (rp
->epsilon
);
332 mpfr_clear (rp
->huge
);
333 mpfr_clear (rp
->tiny
);
338 /* Given an integer and a kind, make sure that the integer lies within
339 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
343 gfc_check_integer_range (mpz_t p
, int kind
)
348 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
353 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
354 result
= ARITH_ASYMMETRIC
;
357 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
358 || mpz_cmp (p
, gfc_integer_kinds
[i
].max_int
) > 0)
359 result
= ARITH_OVERFLOW
;
365 /* Given a real and a kind, make sure that the real lies within the
366 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
370 gfc_check_real_range (mpfr_t p
, int kind
)
376 i
= gfc_validate_kind (BT_REAL
, kind
, false);
380 mpfr_abs (q
, p
, GFC_RND_MODE
);
382 if (mpfr_sgn (q
) == 0)
384 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
385 retval
= ARITH_OVERFLOW
;
386 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
387 retval
= ARITH_UNDERFLOW
;
388 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
390 /* MPFR operates on a numbers with a given precision and enormous
391 exponential range. To represent subnormal numbers the exponent is
392 allowed to become smaller than emin, but always retains the full
393 precision. This function resets unused bits to 0 to alleviate
394 rounding problems. Note, a future version of MPFR will have a
395 mpfr_subnormalize() function, which handles this truncation in a
396 more efficient and robust way. */
402 bin
= mpfr_get_str (NULL
, &e
, gfc_real_kinds
[i
].radix
, 0, q
, GMP_RNDN
);
403 k
= gfc_real_kinds
[i
].digits
- (gfc_real_kinds
[i
].min_exponent
- e
);
404 for (j
= k
; j
< gfc_real_kinds
[i
].digits
; j
++)
406 /* Need space for '0.', bin, 'E', and e */
407 s
= (char *) gfc_getmem (strlen(bin
)+10);
408 sprintf (s
, "0.%sE%d", bin
, (int) e
);
409 mpfr_set_str (q
, s
, gfc_real_kinds
[i
].radix
, GMP_RNDN
);
411 if (mpfr_sgn (p
) < 0)
412 mpfr_neg (p
, q
, GMP_RNDN
);
414 mpfr_set (p
, q
, GMP_RNDN
);
430 /* Function to return a constant expression node of a given type and
434 gfc_constant_result (bt type
, int kind
, locus
* where
)
440 ("gfc_constant_result(): locus 'where' cannot be NULL");
442 result
= gfc_get_expr ();
444 result
->expr_type
= EXPR_CONSTANT
;
445 result
->ts
.type
= type
;
446 result
->ts
.kind
= kind
;
447 result
->where
= *where
;
452 mpz_init (result
->value
.integer
);
456 gfc_set_model_kind (kind
);
457 mpfr_init (result
->value
.real
);
461 gfc_set_model_kind (kind
);
462 mpfr_init (result
->value
.complex.r
);
463 mpfr_init (result
->value
.complex.i
);
474 /* Low-level arithmetic functions. All of these subroutines assume
475 that all operands are of the same type and return an operand of the
476 same type. The other thing about these subroutines is that they
477 can fail in various ways -- overflow, underflow, division by zero,
478 zero raised to the zero, etc. */
481 gfc_arith_not (gfc_expr
* op1
, gfc_expr
** resultp
)
485 result
= gfc_constant_result (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
486 result
->value
.logical
= !op1
->value
.logical
;
494 gfc_arith_and (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
498 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
500 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
508 gfc_arith_or (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
512 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
514 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
522 gfc_arith_eqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
526 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
528 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
536 gfc_arith_neqv (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
;
549 /* Make sure a constant numeric expression is within the range for
550 its type and kind. Note that there's also a gfc_check_range(),
551 but that one deals with the intrinsic RANGE function. */
554 gfc_range_check (gfc_expr
* e
)
561 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
565 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
566 if (rc
== ARITH_UNDERFLOW
)
567 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
571 rc
= gfc_check_real_range (e
->value
.complex.r
, e
->ts
.kind
);
572 if (rc
== ARITH_UNDERFLOW
)
573 mpfr_set_ui (e
->value
.complex.r
, 0, GFC_RND_MODE
);
574 if (rc
== ARITH_OK
|| rc
== ARITH_UNDERFLOW
)
576 rc
= gfc_check_real_range (e
->value
.complex.i
, e
->ts
.kind
);
577 if (rc
== ARITH_UNDERFLOW
)
578 mpfr_set_ui (e
->value
.complex.i
, 0, GFC_RND_MODE
);
584 gfc_internal_error ("gfc_range_check(): Bad type");
591 /* Several of the following routines use the same set of statements to
592 check the validity of the result. Encapsulate the checking here. */
595 check_result (arith rc
, gfc_expr
* x
, gfc_expr
* r
, gfc_expr
** rp
)
599 if (val
== ARITH_UNDERFLOW
)
601 if (gfc_option
.warn_underflow
)
602 gfc_warning (gfc_arith_error (val
), &x
->where
);
606 if (val
== ARITH_ASYMMETRIC
)
608 gfc_warning (gfc_arith_error (val
), &x
->where
);
621 /* It may seem silly to have a subroutine that actually computes the
622 unary plus of a constant, but it prevents us from making exceptions
623 in the code elsewhere. */
626 gfc_arith_uplus (gfc_expr
* op1
, gfc_expr
** resultp
)
628 *resultp
= gfc_copy_expr (op1
);
634 gfc_arith_uminus (gfc_expr
* op1
, gfc_expr
** resultp
)
639 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
641 switch (op1
->ts
.type
)
644 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
648 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
652 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
653 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
657 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
660 rc
= gfc_range_check (result
);
662 return check_result (rc
, op1
, result
, resultp
);
667 gfc_arith_plus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
672 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
674 switch (op1
->ts
.type
)
677 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
681 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
686 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
687 op2
->value
.complex.r
, GFC_RND_MODE
);
689 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
690 op2
->value
.complex.i
, GFC_RND_MODE
);
694 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
697 rc
= gfc_range_check (result
);
699 return check_result (rc
, op1
, result
, resultp
);
704 gfc_arith_minus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
709 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
711 switch (op1
->ts
.type
)
714 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
718 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
723 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
724 op2
->value
.complex.r
, GFC_RND_MODE
);
726 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
727 op2
->value
.complex.i
, GFC_RND_MODE
);
731 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
734 rc
= gfc_range_check (result
);
736 return check_result (rc
, op1
, result
, resultp
);
741 gfc_arith_times (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
747 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
749 switch (op1
->ts
.type
)
752 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
756 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
762 /* FIXME: possible numericals problem. */
764 gfc_set_model (op1
->value
.complex.r
);
768 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
769 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
770 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
772 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
773 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
774 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
782 gfc_internal_error ("gfc_arith_times(): Bad basic type");
785 rc
= gfc_range_check (result
);
787 return check_result (rc
, op1
, result
, resultp
);
792 gfc_arith_divide (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
800 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
802 switch (op1
->ts
.type
)
805 if (mpz_sgn (op2
->value
.integer
) == 0)
811 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
816 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
817 if (mpfr_sgn (op2
->value
.real
) == 0)
823 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
828 /* FIXME: MPFR correctly generates NaN. This may not be needed. */
829 if (mpfr_sgn (op2
->value
.complex.r
) == 0
830 && mpfr_sgn (op2
->value
.complex.i
) == 0)
836 gfc_set_model (op1
->value
.complex.r
);
841 /* FIXME: possible numerical problems. */
842 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
843 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
844 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
846 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
847 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
848 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
849 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
852 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
853 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
854 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
855 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
865 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
869 rc
= gfc_range_check (result
);
871 return check_result (rc
, op1
, result
, resultp
);
875 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
878 complex_reciprocal (gfc_expr
* op
)
880 mpfr_t mod
, a
, re
, im
;
882 gfc_set_model (op
->value
.complex.r
);
888 /* FIXME: another possible numerical problem. */
889 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
890 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
891 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
893 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
895 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
896 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
898 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
899 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
908 /* Raise a complex number to positive power. */
911 complex_pow_ui (gfc_expr
* base
, int power
, gfc_expr
* result
)
915 gfc_set_model (base
->value
.complex.r
);
920 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
921 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
923 for (; power
> 0; power
--)
925 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
927 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
929 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
931 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
933 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
935 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
937 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
938 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
947 /* Raise a number to an integer power. */
950 gfc_arith_power (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
960 if (gfc_extract_int (op2
, &power
) != NULL
)
961 gfc_internal_error ("gfc_arith_power(): Bad exponent");
963 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
967 /* Handle something to the zeroth power. Since we're dealing
968 with integral exponents, there is no ambiguity in the
969 limiting procedure used to determine the value of 0**0. */
970 switch (op1
->ts
.type
)
973 mpz_set_ui (result
->value
.integer
, 1);
977 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
981 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
982 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
986 gfc_internal_error ("gfc_arith_power(): Bad base");
995 switch (op1
->ts
.type
)
998 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
1002 mpz_init_set_ui (unity_z
, 1);
1003 mpz_tdiv_q (result
->value
.integer
, unity_z
,
1004 result
->value
.integer
);
1005 mpz_clear (unity_z
);
1011 mpfr_pow_ui (result
->value
.real
, op1
->value
.real
, apower
,
1016 gfc_set_model (op1
->value
.real
);
1017 mpfr_init (unity_f
);
1018 mpfr_set_ui (unity_f
, 1, GFC_RND_MODE
);
1019 mpfr_div (result
->value
.real
, unity_f
, result
->value
.real
,
1021 mpfr_clear (unity_f
);
1026 complex_pow_ui (op1
, apower
, result
);
1028 complex_reciprocal (result
);
1037 rc
= gfc_range_check (result
);
1039 return check_result (rc
, op1
, result
, resultp
);
1043 /* Concatenate two string constants. */
1046 gfc_arith_concat (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1051 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1054 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1056 result
->value
.character
.string
= gfc_getmem (len
+ 1);
1057 result
->value
.character
.length
= len
;
1059 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1060 op1
->value
.character
.length
);
1062 memcpy (result
->value
.character
.string
+ op1
->value
.character
.length
,
1063 op2
->value
.character
.string
, op2
->value
.character
.length
);
1065 result
->value
.character
.string
[len
] = '\0';
1073 /* Comparison operators. Assumes that the two expression nodes
1074 contain two constants of the same type. */
1077 gfc_compare_expr (gfc_expr
* op1
, gfc_expr
* op2
)
1081 switch (op1
->ts
.type
)
1084 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1088 rc
= mpfr_cmp (op1
->value
.real
, op2
->value
.real
);
1092 rc
= gfc_compare_string (op1
, op2
, NULL
);
1096 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1097 || (op1
->value
.logical
&& !op2
->value
.logical
));
1101 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1108 /* Compare a pair of complex numbers. Naturally, this is only for
1109 equality/nonequality. */
1112 compare_complex (gfc_expr
* op1
, gfc_expr
* op2
)
1114 return (mpfr_cmp (op1
->value
.complex.r
, op2
->value
.complex.r
) == 0
1115 && mpfr_cmp (op1
->value
.complex.i
, op2
->value
.complex.i
) == 0);
1119 /* Given two constant strings and the inverse collating sequence,
1120 compare the strings. We return -1 for a<b, 0 for a==b and 1 for
1121 a>b. If the xcoll_table is NULL, we use the processor's default
1122 collating sequence. */
1125 gfc_compare_string (gfc_expr
* a
, gfc_expr
* b
, const int *xcoll_table
)
1127 int len
, alen
, blen
, i
, ac
, bc
;
1129 alen
= a
->value
.character
.length
;
1130 blen
= b
->value
.character
.length
;
1132 len
= (alen
> blen
) ? alen
: blen
;
1134 for (i
= 0; i
< len
; i
++)
1136 ac
= (i
< alen
) ? a
->value
.character
.string
[i
] : ' ';
1137 bc
= (i
< blen
) ? b
->value
.character
.string
[i
] : ' ';
1139 if (xcoll_table
!= NULL
)
1141 ac
= xcoll_table
[ac
];
1142 bc
= xcoll_table
[bc
];
1151 /* Strings are equal */
1157 /* Specific comparison subroutines. */
1160 gfc_arith_eq (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1164 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1166 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1167 compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) == 0);
1175 gfc_arith_ne (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1179 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1181 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1182 !compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) != 0);
1190 gfc_arith_gt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1194 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1196 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1204 gfc_arith_ge (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1208 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1210 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1218 gfc_arith_lt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1222 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1224 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1232 gfc_arith_le (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1236 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1238 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1246 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
* op
,
1249 gfc_constructor
*c
, *head
;
1253 if (op
->expr_type
== EXPR_CONSTANT
)
1254 return eval (op
, result
);
1257 head
= gfc_copy_constructor (op
->value
.constructor
);
1259 for (c
= head
; c
; c
= c
->next
)
1261 rc
= eval (c
->expr
, &r
);
1265 gfc_replace_expr (c
->expr
, r
);
1269 gfc_free_constructor (head
);
1272 r
= gfc_get_expr ();
1273 r
->expr_type
= EXPR_ARRAY
;
1274 r
->value
.constructor
= head
;
1275 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1277 r
->ts
= head
->expr
->ts
;
1278 r
->where
= op
->where
;
1289 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1290 gfc_expr
* op1
, gfc_expr
* op2
,
1293 gfc_constructor
*c
, *head
;
1297 head
= gfc_copy_constructor (op1
->value
.constructor
);
1300 for (c
= head
; c
; c
= c
->next
)
1302 rc
= eval (c
->expr
, op2
, &r
);
1306 gfc_replace_expr (c
->expr
, r
);
1310 gfc_free_constructor (head
);
1313 r
= gfc_get_expr ();
1314 r
->expr_type
= EXPR_ARRAY
;
1315 r
->value
.constructor
= head
;
1316 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1318 r
->ts
= head
->expr
->ts
;
1319 r
->where
= op1
->where
;
1320 r
->rank
= op1
->rank
;
1330 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1331 gfc_expr
* op1
, gfc_expr
* op2
,
1334 gfc_constructor
*c
, *head
;
1338 head
= gfc_copy_constructor (op2
->value
.constructor
);
1341 for (c
= head
; c
; c
= c
->next
)
1343 rc
= eval (op1
, 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 (op2
->shape
, op2
->rank
);
1359 r
->ts
= head
->expr
->ts
;
1360 r
->where
= op2
->where
;
1361 r
->rank
= op2
->rank
;
1371 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1372 gfc_expr
* op1
, gfc_expr
* op2
,
1375 gfc_constructor
*c
, *d
, *head
;
1379 head
= gfc_copy_constructor (op1
->value
.constructor
);
1382 d
= op2
->value
.constructor
;
1384 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1386 rc
= ARITH_INCOMMENSURATE
;
1390 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1394 rc
= ARITH_INCOMMENSURATE
;
1398 rc
= eval (c
->expr
, d
->expr
, &r
);
1402 gfc_replace_expr (c
->expr
, r
);
1406 rc
= ARITH_INCOMMENSURATE
;
1410 gfc_free_constructor (head
);
1413 r
= gfc_get_expr ();
1414 r
->expr_type
= EXPR_ARRAY
;
1415 r
->value
.constructor
= head
;
1416 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1418 r
->ts
= head
->expr
->ts
;
1419 r
->where
= op1
->where
;
1420 r
->rank
= op1
->rank
;
1430 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1431 gfc_expr
* op1
, gfc_expr
* op2
,
1434 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1435 return eval (op1
, op2
, result
);
1437 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1438 return reduce_binary_ca (eval
, op1
, op2
, result
);
1440 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1441 return reduce_binary_ac (eval
, op1
, op2
, result
);
1443 return reduce_binary_aa (eval
, op1
, op2
, result
);
1449 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1450 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1454 /* High level arithmetic subroutines. These subroutines go into
1455 eval_intrinsic(), which can do one of several things to its
1456 operands. If the operands are incompatible with the intrinsic
1457 operation, we return a node pointing to the operands and hope that
1458 an operator interface is found during resolution.
1460 If the operands are compatible and are constants, then we try doing
1461 the arithmetic. We also handle the cases where either or both
1462 operands are array constructors. */
1465 eval_intrinsic (gfc_intrinsic_op
operator,
1466 eval_f eval
, gfc_expr
* op1
, gfc_expr
* op2
)
1468 gfc_expr temp
, *result
;
1472 gfc_clear_ts (&temp
.ts
);
1476 case INTRINSIC_NOT
: /* Logical unary */
1477 if (op1
->ts
.type
!= BT_LOGICAL
)
1480 temp
.ts
.type
= BT_LOGICAL
;
1481 temp
.ts
.kind
= gfc_default_logical_kind
;
1486 /* Logical binary operators */
1489 case INTRINSIC_NEQV
:
1491 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1494 temp
.ts
.type
= BT_LOGICAL
;
1495 temp
.ts
.kind
= gfc_default_logical_kind
;
1500 case INTRINSIC_UPLUS
:
1501 case INTRINSIC_UMINUS
: /* Numeric unary */
1502 if (!gfc_numeric_ts (&op1
->ts
))
1510 case INTRINSIC_PARENTHESES
:
1517 case INTRINSIC_LT
: /* Additional restrictions */
1518 case INTRINSIC_LE
: /* for ordering relations. */
1520 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1522 temp
.ts
.type
= BT_LOGICAL
;
1523 temp
.ts
.kind
= gfc_default_logical_kind
;
1527 /* else fall through */
1531 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1534 temp
.ts
.type
= BT_LOGICAL
;
1535 temp
.ts
.kind
= gfc_default_logical_kind
;
1539 /* else fall through */
1541 case INTRINSIC_PLUS
:
1542 case INTRINSIC_MINUS
:
1543 case INTRINSIC_TIMES
:
1544 case INTRINSIC_DIVIDE
:
1545 case INTRINSIC_POWER
: /* Numeric binary */
1546 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1549 /* Insert any necessary type conversions to make the operands compatible. */
1551 temp
.expr_type
= EXPR_OP
;
1552 gfc_clear_ts (&temp
.ts
);
1553 temp
.value
.op
.operator = operator;
1555 temp
.value
.op
.op1
= op1
;
1556 temp
.value
.op
.op2
= op2
;
1558 gfc_type_convert_binary (&temp
);
1560 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1561 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1562 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1564 temp
.ts
.type
= BT_LOGICAL
;
1565 temp
.ts
.kind
= gfc_default_logical_kind
;
1571 case INTRINSIC_CONCAT
: /* Character binary */
1572 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1575 temp
.ts
.type
= BT_CHARACTER
;
1576 temp
.ts
.kind
= gfc_default_character_kind
;
1581 case INTRINSIC_USER
:
1585 gfc_internal_error ("eval_intrinsic(): Bad operator");
1588 /* Try to combine the operators. */
1589 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1593 || (op1
->expr_type
!= EXPR_CONSTANT
1594 && (op1
->expr_type
!= EXPR_ARRAY
1595 || !gfc_is_constant_expr (op1
)
1596 || !gfc_expanded_ac (op1
))))
1601 || (op2
->expr_type
!= EXPR_CONSTANT
1602 && (op2
->expr_type
!= EXPR_ARRAY
1603 || !gfc_is_constant_expr (op2
)
1604 || !gfc_expanded_ac (op2
)))))
1608 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1610 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1613 { /* Something went wrong */
1614 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1618 gfc_free_expr (op1
);
1619 gfc_free_expr (op2
);
1623 /* Create a run-time expression */
1624 result
= gfc_get_expr ();
1625 result
->ts
= temp
.ts
;
1627 result
->expr_type
= EXPR_OP
;
1628 result
->value
.op
.operator = operator;
1630 result
->value
.op
.op1
= op1
;
1631 result
->value
.op
.op2
= op2
;
1633 result
->where
= op1
->where
;
1639 /* Modify type of expression for zero size array. */
1641 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1644 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1654 op
->ts
.type
= BT_LOGICAL
;
1655 op
->ts
.kind
= gfc_default_logical_kind
;
1666 /* Return nonzero if the expression is a zero size array. */
1669 gfc_zero_size_array (gfc_expr
* e
)
1671 if (e
->expr_type
!= EXPR_ARRAY
)
1674 return e
->value
.constructor
== NULL
;
1678 /* Reduce a binary expression where at least one of the operands
1679 involves a zero-length array. Returns NULL if neither of the
1680 operands is a zero-length array. */
1683 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1685 if (gfc_zero_size_array (op1
))
1687 gfc_free_expr (op2
);
1691 if (gfc_zero_size_array (op2
))
1693 gfc_free_expr (op1
);
1702 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1703 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1704 gfc_expr
* op1
, gfc_expr
* op2
)
1711 if (gfc_zero_size_array (op1
))
1712 return eval_type_intrinsic0 (operator, op1
);
1716 result
= reduce_binary0 (op1
, op2
);
1718 return eval_type_intrinsic0 (operator, result
);
1722 return eval_intrinsic (operator, f
, op1
, op2
);
1727 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1728 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1729 gfc_expr
* op1
, gfc_expr
* op2
)
1734 result
= reduce_binary0 (op1
, op2
);
1736 return eval_type_intrinsic0(operator, result
);
1739 return eval_intrinsic (operator, f
, op1
, op2
);
1745 gfc_uplus (gfc_expr
* op
)
1747 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1751 gfc_uminus (gfc_expr
* op
)
1753 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1757 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1759 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1763 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1765 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1769 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1771 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1775 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1777 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1781 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1783 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1787 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1789 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1793 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1795 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1799 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1801 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1805 gfc_not (gfc_expr
* op1
)
1807 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1811 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1813 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1817 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1819 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1823 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1825 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1829 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1831 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1835 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1837 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1841 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1843 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1847 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1849 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1853 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1855 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1859 /* Convert an integer string to an expression node. */
1862 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
* where
)
1867 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1868 /* a leading plus is allowed, but not by mpz_set_str */
1869 if (buffer
[0] == '+')
1873 mpz_set_str (e
->value
.integer
, t
, radix
);
1879 /* Convert a real string to an expression node. */
1882 gfc_convert_real (const char *buffer
, int kind
, locus
* where
)
1886 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1887 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1893 /* Convert a pair of real, constant expression nodes to a single
1894 complex expression node. */
1897 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1901 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1902 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1903 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1909 /******* Simplification of intrinsic functions with constant arguments *****/
1912 /* Deal with an arithmetic error. */
1915 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1920 gfc_error ("Arithmetic OK converting %s to %s at %L",
1921 gfc_typename (from
), gfc_typename (to
), where
);
1923 case ARITH_OVERFLOW
:
1924 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1925 gfc_typename (from
), gfc_typename (to
), where
);
1927 case ARITH_UNDERFLOW
:
1928 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1929 gfc_typename (from
), gfc_typename (to
), where
);
1932 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1933 gfc_typename (from
), gfc_typename (to
), where
);
1936 gfc_error ("Division by zero converting %s to %s at %L",
1937 gfc_typename (from
), gfc_typename (to
), where
);
1939 case ARITH_INCOMMENSURATE
:
1940 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1941 gfc_typename (from
), gfc_typename (to
), where
);
1943 case ARITH_ASYMMETRIC
:
1944 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1945 " converting %s to %s at %L",
1946 gfc_typename (from
), gfc_typename (to
), where
);
1949 gfc_internal_error ("gfc_arith_error(): Bad error code");
1952 /* TODO: Do something about the error, ie, throw exception, return
1956 /* Convert integers to integers. */
1959 gfc_int2int (gfc_expr
* src
, int kind
)
1964 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1966 mpz_set (result
->value
.integer
, src
->value
.integer
);
1968 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
1971 if (rc
== ARITH_ASYMMETRIC
)
1973 gfc_warning (gfc_arith_error (rc
), &src
->where
);
1977 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1978 gfc_free_expr (result
);
1987 /* Convert integers to reals. */
1990 gfc_int2real (gfc_expr
* src
, int kind
)
1995 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
1997 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
1999 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2001 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2002 gfc_free_expr (result
);
2010 /* Convert default integer to default complex. */
2013 gfc_int2complex (gfc_expr
* src
, int kind
)
2018 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2020 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2021 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2023 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2025 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2026 gfc_free_expr (result
);
2034 /* Convert default real to default integer. */
2037 gfc_real2int (gfc_expr
* src
, int kind
)
2042 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2044 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2046 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2049 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2050 gfc_free_expr (result
);
2058 /* Convert real to real. */
2061 gfc_real2real (gfc_expr
* src
, int kind
)
2066 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2068 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2070 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2072 if (rc
== ARITH_UNDERFLOW
)
2074 if (gfc_option
.warn_underflow
)
2075 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2076 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2078 else if (rc
!= ARITH_OK
)
2080 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2081 gfc_free_expr (result
);
2089 /* Convert real to complex. */
2092 gfc_real2complex (gfc_expr
* src
, int kind
)
2097 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2099 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2100 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2102 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2104 if (rc
== ARITH_UNDERFLOW
)
2106 if (gfc_option
.warn_underflow
)
2107 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2108 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2110 else if (rc
!= ARITH_OK
)
2112 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2113 gfc_free_expr (result
);
2121 /* Convert complex to integer. */
2124 gfc_complex2int (gfc_expr
* src
, int kind
)
2129 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2131 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2133 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2136 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2137 gfc_free_expr (result
);
2145 /* Convert complex to real. */
2148 gfc_complex2real (gfc_expr
* src
, int kind
)
2153 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2155 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2157 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2159 if (rc
== ARITH_UNDERFLOW
)
2161 if (gfc_option
.warn_underflow
)
2162 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2163 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2167 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2168 gfc_free_expr (result
);
2176 /* Convert complex to complex. */
2179 gfc_complex2complex (gfc_expr
* src
, int kind
)
2184 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2186 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2187 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2189 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2191 if (rc
== ARITH_UNDERFLOW
)
2193 if (gfc_option
.warn_underflow
)
2194 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2195 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2197 else if (rc
!= ARITH_OK
)
2199 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2200 gfc_free_expr (result
);
2204 rc
= gfc_check_real_range (result
->value
.complex.i
, 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
.complex.i
, 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 /* Logical kind conversion. */
2226 gfc_log2log (gfc_expr
* src
, int kind
)
2230 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2231 result
->value
.logical
= src
->value
.logical
;
2236 /* Convert logical to integer. */
2239 gfc_log2int (gfc_expr
*src
, int kind
)
2242 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2243 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2247 /* Convert integer to logical. */
2250 gfc_int2log (gfc_expr
*src
, int kind
)
2253 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2254 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2258 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2261 gfc_hollerith2int (gfc_expr
* src
, int kind
)
2266 len
= src
->value
.character
.length
;
2268 result
= gfc_get_expr ();
2269 result
->expr_type
= EXPR_CONSTANT
;
2270 result
->ts
.type
= BT_INTEGER
;
2271 result
->ts
.kind
= kind
;
2272 result
->where
= src
->where
;
2277 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2278 &src
->where
, gfc_typename(&result
->ts
));
2280 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2281 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2285 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2287 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2288 result
->value
.character
.length
= kind
;
2293 /* Convert Hollerith to real. The constant will be padded or truncated. */
2296 gfc_hollerith2real (gfc_expr
* src
, int kind
)
2301 len
= src
->value
.character
.length
;
2303 result
= gfc_get_expr ();
2304 result
->expr_type
= EXPR_CONSTANT
;
2305 result
->ts
.type
= BT_REAL
;
2306 result
->ts
.kind
= kind
;
2307 result
->where
= src
->where
;
2312 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2313 &src
->where
, gfc_typename(&result
->ts
));
2315 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2316 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2320 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2322 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2323 result
->value
.character
.length
= kind
;
2328 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2331 gfc_hollerith2complex (gfc_expr
* src
, int kind
)
2336 len
= src
->value
.character
.length
;
2338 result
= gfc_get_expr ();
2339 result
->expr_type
= EXPR_CONSTANT
;
2340 result
->ts
.type
= BT_COMPLEX
;
2341 result
->ts
.kind
= kind
;
2342 result
->where
= src
->where
;
2349 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2350 &src
->where
, gfc_typename(&result
->ts
));
2352 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2353 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2357 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2359 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2360 result
->value
.character
.length
= kind
;
2365 /* Convert Hollerith to character. */
2368 gfc_hollerith2character (gfc_expr
* src
, int kind
)
2372 result
= gfc_copy_expr (src
);
2373 result
->ts
.type
= BT_CHARACTER
;
2374 result
->ts
.kind
= kind
;
2380 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2383 gfc_hollerith2logical (gfc_expr
* src
, int kind
)
2388 len
= src
->value
.character
.length
;
2390 result
= gfc_get_expr ();
2391 result
->expr_type
= EXPR_CONSTANT
;
2392 result
->ts
.type
= BT_LOGICAL
;
2393 result
->ts
.kind
= kind
;
2394 result
->where
= src
->where
;
2399 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2400 &src
->where
, gfc_typename(&result
->ts
));
2402 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2403 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2407 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2409 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2410 result
->value
.character
.length
= kind
;
2415 /* Returns an initializer whose value is one higher than the value of the
2416 LAST_INITIALIZER argument. If that is argument is NULL, the
2417 initializers value will be set to zero. The initializer's kind
2418 will be set to gfc_c_int_kind.
2420 If -fshort-enums is given, the appropriate kind will be selected
2421 later after all enumerators have been parsed. A warning is issued
2422 here if an initializer exceeds gfc_c_int_kind. */
2425 gfc_enum_initializer (gfc_expr
*last_initializer
, locus where
)
2429 result
= gfc_get_expr ();
2430 result
->expr_type
= EXPR_CONSTANT
;
2431 result
->ts
.type
= BT_INTEGER
;
2432 result
->ts
.kind
= gfc_c_int_kind
;
2433 result
->where
= where
;
2435 mpz_init (result
->value
.integer
);
2437 if (last_initializer
!= NULL
)
2439 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2440 result
->where
= last_initializer
->where
;
2442 if (gfc_check_integer_range (result
->value
.integer
,
2443 gfc_c_int_kind
) != ARITH_OK
)
2445 gfc_error ("Enumerator exceeds the C integer type at %C");
2451 /* Control comes here, if it's the very first enumerator and no
2452 initializer has been given. It will be initialized to ZERO (0). */
2453 mpz_set_si (result
->value
.integer
, 0);