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
))
1511 case INTRINSIC_LT
: /* Additional restrictions */
1512 case INTRINSIC_LE
: /* for ordering relations. */
1514 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1516 temp
.ts
.type
= BT_LOGICAL
;
1517 temp
.ts
.kind
= gfc_default_logical_kind
;
1521 /* else fall through */
1525 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1528 temp
.ts
.type
= BT_LOGICAL
;
1529 temp
.ts
.kind
= gfc_default_logical_kind
;
1533 /* else fall through */
1535 case INTRINSIC_PLUS
:
1536 case INTRINSIC_MINUS
:
1537 case INTRINSIC_TIMES
:
1538 case INTRINSIC_DIVIDE
:
1539 case INTRINSIC_POWER
: /* Numeric binary */
1540 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1543 /* Insert any necessary type conversions to make the operands compatible. */
1545 temp
.expr_type
= EXPR_OP
;
1546 gfc_clear_ts (&temp
.ts
);
1547 temp
.value
.op
.operator = operator;
1549 temp
.value
.op
.op1
= op1
;
1550 temp
.value
.op
.op2
= op2
;
1552 gfc_type_convert_binary (&temp
);
1554 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1555 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1556 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1558 temp
.ts
.type
= BT_LOGICAL
;
1559 temp
.ts
.kind
= gfc_default_logical_kind
;
1565 case INTRINSIC_CONCAT
: /* Character binary */
1566 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1569 temp
.ts
.type
= BT_CHARACTER
;
1570 temp
.ts
.kind
= gfc_default_character_kind
;
1575 case INTRINSIC_USER
:
1579 gfc_internal_error ("eval_intrinsic(): Bad operator");
1582 /* Try to combine the operators. */
1583 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1587 || (op1
->expr_type
!= EXPR_CONSTANT
1588 && (op1
->expr_type
!= EXPR_ARRAY
1589 || !gfc_is_constant_expr (op1
)
1590 || !gfc_expanded_ac (op1
))))
1595 || (op2
->expr_type
!= EXPR_CONSTANT
1596 && (op2
->expr_type
!= EXPR_ARRAY
1597 || !gfc_is_constant_expr (op2
)
1598 || !gfc_expanded_ac (op2
)))))
1602 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1604 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1607 { /* Something went wrong */
1608 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1612 gfc_free_expr (op1
);
1613 gfc_free_expr (op2
);
1617 /* Create a run-time expression */
1618 result
= gfc_get_expr ();
1619 result
->ts
= temp
.ts
;
1621 result
->expr_type
= EXPR_OP
;
1622 result
->value
.op
.operator = operator;
1624 result
->value
.op
.op1
= op1
;
1625 result
->value
.op
.op2
= op2
;
1627 result
->where
= op1
->where
;
1633 /* Modify type of expression for zero size array. */
1635 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
*op
)
1638 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1648 op
->ts
.type
= BT_LOGICAL
;
1649 op
->ts
.kind
= gfc_default_logical_kind
;
1660 /* Return nonzero if the expression is a zero size array. */
1663 gfc_zero_size_array (gfc_expr
* e
)
1665 if (e
->expr_type
!= EXPR_ARRAY
)
1668 return e
->value
.constructor
== NULL
;
1672 /* Reduce a binary expression where at least one of the operands
1673 involves a zero-length array. Returns NULL if neither of the
1674 operands is a zero-length array. */
1677 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1679 if (gfc_zero_size_array (op1
))
1681 gfc_free_expr (op2
);
1685 if (gfc_zero_size_array (op2
))
1687 gfc_free_expr (op1
);
1696 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1697 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1698 gfc_expr
* op1
, gfc_expr
* op2
)
1705 if (gfc_zero_size_array (op1
))
1706 return eval_type_intrinsic0 (operator, op1
);
1710 result
= reduce_binary0 (op1
, op2
);
1712 return eval_type_intrinsic0 (operator, result
);
1716 return eval_intrinsic (operator, f
, op1
, op2
);
1721 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1722 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1723 gfc_expr
* op1
, gfc_expr
* op2
)
1728 result
= reduce_binary0 (op1
, op2
);
1730 return eval_type_intrinsic0(operator, result
);
1733 return eval_intrinsic (operator, f
, op1
, op2
);
1739 gfc_uplus (gfc_expr
* op
)
1741 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1745 gfc_uminus (gfc_expr
* op
)
1747 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1751 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1753 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1757 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1759 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1763 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1765 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1769 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1771 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1775 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1777 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1781 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1783 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1787 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1789 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1793 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1795 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1799 gfc_not (gfc_expr
* op1
)
1801 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1805 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1807 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1811 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1813 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1817 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1819 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1823 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1825 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1829 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1831 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1835 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1837 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1841 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1843 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1847 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1849 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1853 /* Convert an integer string to an expression node. */
1856 gfc_convert_integer (const char *buffer
, int kind
, int radix
, locus
* where
)
1861 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1862 /* a leading plus is allowed, but not by mpz_set_str */
1863 if (buffer
[0] == '+')
1867 mpz_set_str (e
->value
.integer
, t
, radix
);
1873 /* Convert a real string to an expression node. */
1876 gfc_convert_real (const char *buffer
, int kind
, locus
* where
)
1880 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1881 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1887 /* Convert a pair of real, constant expression nodes to a single
1888 complex expression node. */
1891 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1895 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1896 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1897 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1903 /******* Simplification of intrinsic functions with constant arguments *****/
1906 /* Deal with an arithmetic error. */
1909 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1914 gfc_error ("Arithmetic OK converting %s to %s at %L",
1915 gfc_typename (from
), gfc_typename (to
), where
);
1917 case ARITH_OVERFLOW
:
1918 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1919 gfc_typename (from
), gfc_typename (to
), where
);
1921 case ARITH_UNDERFLOW
:
1922 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1923 gfc_typename (from
), gfc_typename (to
), where
);
1926 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1927 gfc_typename (from
), gfc_typename (to
), where
);
1930 gfc_error ("Division by zero converting %s to %s at %L",
1931 gfc_typename (from
), gfc_typename (to
), where
);
1933 case ARITH_INCOMMENSURATE
:
1934 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1935 gfc_typename (from
), gfc_typename (to
), where
);
1937 case ARITH_ASYMMETRIC
:
1938 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1939 " converting %s to %s at %L",
1940 gfc_typename (from
), gfc_typename (to
), where
);
1943 gfc_internal_error ("gfc_arith_error(): Bad error code");
1946 /* TODO: Do something about the error, ie, throw exception, return
1950 /* Convert integers to integers. */
1953 gfc_int2int (gfc_expr
* src
, int kind
)
1958 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
1960 mpz_set (result
->value
.integer
, src
->value
.integer
);
1962 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
1965 if (rc
== ARITH_ASYMMETRIC
)
1967 gfc_warning (gfc_arith_error (rc
), &src
->where
);
1971 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1972 gfc_free_expr (result
);
1981 /* Convert integers to reals. */
1984 gfc_int2real (gfc_expr
* src
, int kind
)
1989 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
1991 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
1993 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
1995 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
1996 gfc_free_expr (result
);
2004 /* Convert default integer to default complex. */
2007 gfc_int2complex (gfc_expr
* src
, int kind
)
2012 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2014 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2015 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2017 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2019 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2020 gfc_free_expr (result
);
2028 /* Convert default real to default integer. */
2031 gfc_real2int (gfc_expr
* src
, int kind
)
2036 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2038 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2040 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2043 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2044 gfc_free_expr (result
);
2052 /* Convert real to real. */
2055 gfc_real2real (gfc_expr
* src
, int kind
)
2060 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2062 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2064 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2066 if (rc
== ARITH_UNDERFLOW
)
2068 if (gfc_option
.warn_underflow
)
2069 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2070 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2072 else if (rc
!= ARITH_OK
)
2074 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2075 gfc_free_expr (result
);
2083 /* Convert real to complex. */
2086 gfc_real2complex (gfc_expr
* src
, int kind
)
2091 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2093 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2094 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2096 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2098 if (rc
== ARITH_UNDERFLOW
)
2100 if (gfc_option
.warn_underflow
)
2101 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2102 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2104 else if (rc
!= ARITH_OK
)
2106 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2107 gfc_free_expr (result
);
2115 /* Convert complex to integer. */
2118 gfc_complex2int (gfc_expr
* src
, int kind
)
2123 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2125 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2127 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2130 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2131 gfc_free_expr (result
);
2139 /* Convert complex to real. */
2142 gfc_complex2real (gfc_expr
* src
, int kind
)
2147 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2149 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2151 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2153 if (rc
== ARITH_UNDERFLOW
)
2155 if (gfc_option
.warn_underflow
)
2156 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2157 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2161 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2162 gfc_free_expr (result
);
2170 /* Convert complex to complex. */
2173 gfc_complex2complex (gfc_expr
* src
, int kind
)
2178 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2180 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2181 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2183 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2185 if (rc
== ARITH_UNDERFLOW
)
2187 if (gfc_option
.warn_underflow
)
2188 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2189 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2191 else if (rc
!= ARITH_OK
)
2193 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2194 gfc_free_expr (result
);
2198 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2200 if (rc
== ARITH_UNDERFLOW
)
2202 if (gfc_option
.warn_underflow
)
2203 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2204 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2206 else if (rc
!= ARITH_OK
)
2208 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2209 gfc_free_expr (result
);
2217 /* Logical kind conversion. */
2220 gfc_log2log (gfc_expr
* src
, int kind
)
2224 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2225 result
->value
.logical
= src
->value
.logical
;
2230 /* Convert logical to integer. */
2233 gfc_log2int (gfc_expr
*src
, int kind
)
2236 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2237 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2241 /* Convert integer to logical. */
2244 gfc_int2log (gfc_expr
*src
, int kind
)
2247 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2248 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2252 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2255 gfc_hollerith2int (gfc_expr
* src
, int kind
)
2260 len
= src
->value
.character
.length
;
2262 result
= gfc_get_expr ();
2263 result
->expr_type
= EXPR_CONSTANT
;
2264 result
->ts
.type
= BT_INTEGER
;
2265 result
->ts
.kind
= kind
;
2266 result
->where
= src
->where
;
2271 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2272 &src
->where
, gfc_typename(&result
->ts
));
2274 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2275 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2279 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2281 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2282 result
->value
.character
.length
= kind
;
2287 /* Convert Hollerith to real. The constant will be padded or truncated. */
2290 gfc_hollerith2real (gfc_expr
* src
, int kind
)
2295 len
= src
->value
.character
.length
;
2297 result
= gfc_get_expr ();
2298 result
->expr_type
= EXPR_CONSTANT
;
2299 result
->ts
.type
= BT_REAL
;
2300 result
->ts
.kind
= kind
;
2301 result
->where
= src
->where
;
2306 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2307 &src
->where
, gfc_typename(&result
->ts
));
2309 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2310 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2314 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2316 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2317 result
->value
.character
.length
= kind
;
2322 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2325 gfc_hollerith2complex (gfc_expr
* src
, int kind
)
2330 len
= src
->value
.character
.length
;
2332 result
= gfc_get_expr ();
2333 result
->expr_type
= EXPR_CONSTANT
;
2334 result
->ts
.type
= BT_COMPLEX
;
2335 result
->ts
.kind
= kind
;
2336 result
->where
= src
->where
;
2343 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2344 &src
->where
, gfc_typename(&result
->ts
));
2346 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2347 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2351 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2353 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2354 result
->value
.character
.length
= kind
;
2359 /* Convert Hollerith to character. */
2362 gfc_hollerith2character (gfc_expr
* src
, int kind
)
2366 result
= gfc_copy_expr (src
);
2367 result
->ts
.type
= BT_CHARACTER
;
2368 result
->ts
.kind
= kind
;
2374 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2377 gfc_hollerith2logical (gfc_expr
* src
, int kind
)
2382 len
= src
->value
.character
.length
;
2384 result
= gfc_get_expr ();
2385 result
->expr_type
= EXPR_CONSTANT
;
2386 result
->ts
.type
= BT_LOGICAL
;
2387 result
->ts
.kind
= kind
;
2388 result
->where
= src
->where
;
2393 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2394 &src
->where
, gfc_typename(&result
->ts
));
2396 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2397 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2401 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2403 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2404 result
->value
.character
.length
= kind
;
2409 /* Returns an initializer whose value is one higher than the value of the
2410 LAST_INITIALIZER argument. If that is argument is NULL, the
2411 initializers value will be set to zero. The initializer's kind
2412 will be set to gfc_c_int_kind.
2414 If -fshort-enums is given, the appropriate kind will be selected
2415 later after all enumerators have been parsed. A warning is issued
2416 here if an initializer exceeds gfc_c_int_kind. */
2419 gfc_enum_initializer (gfc_expr
*last_initializer
, locus where
)
2423 result
= gfc_get_expr ();
2424 result
->expr_type
= EXPR_CONSTANT
;
2425 result
->ts
.type
= BT_INTEGER
;
2426 result
->ts
.kind
= gfc_c_int_kind
;
2427 result
->where
= where
;
2429 mpz_init (result
->value
.integer
);
2431 if (last_initializer
!= NULL
)
2433 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2434 result
->where
= last_initializer
->where
;
2436 if (gfc_check_integer_range (result
->value
.integer
,
2437 gfc_c_int_kind
) != ARITH_OK
)
2439 gfc_error ("Enumerator exceeds the C integer type at %C");
2445 /* Control comes here, if it's the very first enumerator and no
2446 initializer has been given. It will be initialized to ZERO (0). */
2447 mpz_set_si (result
->value
.integer
, 0);