2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* Since target arithmetic must be done on the host, there has to
24 be some way of evaluating arithmetic expressions as the host
25 would evaluate them. We use the GNU MP library and the MPFR
26 library to do arithmetic, and this file provides the interface. */
34 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
35 It's easily implemented with a few calls though. */
38 gfc_mpfr_to_mpz (mpz_t z
, mpfr_t x
)
42 e
= mpfr_get_z_exp (z
, x
);
43 /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
44 may set the sign of z incorrectly. Work around that here. */
45 if (mpfr_sgn (x
) != mpz_sgn (z
))
49 mpz_mul_2exp (z
, z
, e
);
51 mpz_tdiv_q_2exp (z
, z
, -e
);
55 /* Set the model number precision by the requested KIND. */
58 gfc_set_model_kind (int kind
)
60 int index
= gfc_validate_kind (BT_REAL
, kind
, false);
63 base2prec
= gfc_real_kinds
[index
].digits
;
64 if (gfc_real_kinds
[index
].radix
!= 2)
65 base2prec
*= gfc_real_kinds
[index
].radix
/ 2;
66 mpfr_set_default_prec (base2prec
);
70 /* Set the model number precision from mpfr_t x. */
73 gfc_set_model (mpfr_t x
)
75 mpfr_set_default_prec (mpfr_get_prec (x
));
78 /* 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
);
129 /* Given an arithmetic error code, return a pointer to a string that
130 explains the error. */
133 gfc_arith_error (arith code
)
140 p
= _("Arithmetic OK at %L");
143 p
= _("Arithmetic overflow at %L");
145 case ARITH_UNDERFLOW
:
146 p
= _("Arithmetic underflow at %L");
149 p
= _("Arithmetic NaN at %L");
152 p
= _("Division by zero at %L");
154 case ARITH_INCOMMENSURATE
:
155 p
= _("Array operands are incommensurate at %L");
157 case ARITH_ASYMMETRIC
:
159 _("Integer outside symmetric range implied by Standard Fortran at %L");
162 gfc_internal_error ("gfc_arith_error(): Bad error code");
169 /* Get things ready to do math. */
172 gfc_arith_init_1 (void)
174 gfc_integer_info
*int_info
;
175 gfc_real_info
*real_info
;
180 mpfr_set_default_prec (128);
184 /* Convert the minimum and maximum values for each kind into their
185 GNU MP representation. */
186 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
189 mpz_set_ui (r
, int_info
->radix
);
190 mpz_pow_ui (r
, r
, int_info
->digits
);
192 mpz_init (int_info
->huge
);
193 mpz_sub_ui (int_info
->huge
, r
, 1);
195 /* These are the numbers that are actually representable by the
196 target. For bases other than two, this needs to be changed. */
197 if (int_info
->radix
!= 2)
198 gfc_internal_error ("Fix min_int calculation");
200 /* See PRs 13490 and 17912, related to integer ranges.
201 The pedantic_min_int exists for range checking when a program
202 is compiled with -pedantic, and reflects the belief that
203 Standard Fortran requires integers to be symmetrical, i.e.
204 every negative integer must have a representable positive
205 absolute value, and vice versa. */
207 mpz_init (int_info
->pedantic_min_int
);
208 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
210 mpz_init (int_info
->min_int
);
211 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
214 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
215 mpfr_log10 (a
, a
, GFC_RND_MODE
);
217 gfc_mpfr_to_mpz (r
, a
);
218 int_info
->range
= mpz_get_si (r
);
223 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
225 gfc_set_model_kind (real_info
->kind
);
231 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
232 /* a = 1 - b**(-p) */
233 mpfr_set_ui (a
, 1, GFC_RND_MODE
);
234 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
235 mpfr_pow_si (b
, b
, -real_info
->digits
, GFC_RND_MODE
);
236 mpfr_sub (a
, a
, b
, GFC_RND_MODE
);
238 /* c = b**(emax-1) */
239 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
240 mpfr_pow_ui (c
, b
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
242 /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
243 mpfr_mul (a
, a
, c
, GFC_RND_MODE
);
245 /* a = (1 - b**(-p)) * b**(emax-1) * b */
246 mpfr_mul_ui (a
, a
, real_info
->radix
, GFC_RND_MODE
);
248 mpfr_init (real_info
->huge
);
249 mpfr_set (real_info
->huge
, a
, GFC_RND_MODE
);
251 /* tiny(x) = b**(emin-1) */
252 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
253 mpfr_pow_si (b
, b
, real_info
->min_exponent
- 1, GFC_RND_MODE
);
255 mpfr_init (real_info
->tiny
);
256 mpfr_set (real_info
->tiny
, b
, GFC_RND_MODE
);
258 /* subnormal (x) = b**(emin - digit) */
259 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
260 mpfr_pow_si (b
, b
, real_info
->min_exponent
- real_info
->digits
,
263 mpfr_init (real_info
->subnormal
);
264 mpfr_set (real_info
->subnormal
, b
, GFC_RND_MODE
);
266 /* epsilon(x) = b**(1-p) */
267 mpfr_set_ui (b
, real_info
->radix
, GFC_RND_MODE
);
268 mpfr_pow_si (b
, b
, 1 - real_info
->digits
, GFC_RND_MODE
);
270 mpfr_init (real_info
->epsilon
);
271 mpfr_set (real_info
->epsilon
, b
, GFC_RND_MODE
);
273 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
274 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
275 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
276 mpfr_neg (b
, b
, GFC_RND_MODE
);
279 if (mpfr_cmp (a
, b
) > 0)
280 mpfr_set (a
, b
, GFC_RND_MODE
);
283 gfc_mpfr_to_mpz (r
, a
);
284 real_info
->range
= mpz_get_si (r
);
286 /* precision(x) = int((p - 1) * log10(b)) + k */
287 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
288 mpfr_log10 (a
, a
, GFC_RND_MODE
);
290 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
292 gfc_mpfr_to_mpz (r
, a
);
293 real_info
->precision
= mpz_get_si (r
);
295 /* If the radix is an integral power of 10, add one to the precision. */
296 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
297 if (i
== real_info
->radix
)
298 real_info
->precision
++;
309 /* Clean up, get rid of numeric constants. */
312 gfc_arith_done_1 (void)
314 gfc_integer_info
*ip
;
317 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
319 mpz_clear (ip
->min_int
);
320 mpz_clear (ip
->pedantic_min_int
);
321 mpz_clear (ip
->huge
);
324 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
326 mpfr_clear (rp
->epsilon
);
327 mpfr_clear (rp
->huge
);
328 mpfr_clear (rp
->tiny
);
329 mpfr_clear (rp
->subnormal
);
334 /* Given an integer and a kind, make sure that the integer lies within
335 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
339 gfc_check_integer_range (mpz_t p
, int kind
)
344 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
349 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
350 result
= ARITH_ASYMMETRIC
;
353 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
354 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
355 result
= ARITH_OVERFLOW
;
361 /* Given a real and a kind, make sure that the real lies within the
362 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
366 gfc_check_real_range (mpfr_t p
, int kind
)
372 i
= gfc_validate_kind (BT_REAL
, kind
, false);
376 mpfr_abs (q
, p
, GFC_RND_MODE
);
380 if (gfc_option
.flag_range_check
== 0)
383 retval
= ARITH_OVERFLOW
;
385 else if (mpfr_nan_p (p
))
387 if (gfc_option
.flag_range_check
== 0)
392 else if (mpfr_sgn (q
) == 0)
394 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
396 if (gfc_option
.flag_range_check
== 0)
399 retval
= ARITH_OVERFLOW
;
401 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
403 if (gfc_option
.flag_range_check
== 0)
406 retval
= ARITH_UNDERFLOW
;
408 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
410 /* MPFR operates on a number with a given precision and enormous
411 exponential range. To represent subnormal numbers, the exponent is
412 allowed to become smaller than emin, but always retains the full
413 precision. This code resets unused bits to 0 to alleviate
414 rounding problems. Note, a future version of MPFR will have a
415 mpfr_subnormalize() function, which handles this truncation in a
416 more efficient and robust way. */
422 bin
= mpfr_get_str (NULL
, &e
, gfc_real_kinds
[i
].radix
, 0, q
, GMP_RNDN
);
423 k
= gfc_real_kinds
[i
].digits
- (gfc_real_kinds
[i
].min_exponent
- e
);
424 for (j
= k
; j
< gfc_real_kinds
[i
].digits
; j
++)
426 /* Need space for '0.', bin, 'E', and e */
427 s
= (char *) gfc_getmem (strlen(bin
) + 10);
428 sprintf (s
, "0.%sE%d", bin
, (int) e
);
429 mpfr_set_str (q
, s
, gfc_real_kinds
[i
].radix
, GMP_RNDN
);
431 if (mpfr_sgn (p
) < 0)
432 mpfr_neg (p
, q
, GMP_RNDN
);
434 mpfr_set (p
, q
, GMP_RNDN
);
450 /* Function to return a constant expression node of a given type and kind. */
453 gfc_constant_result (bt type
, int kind
, locus
* where
)
459 ("gfc_constant_result(): locus 'where' cannot be NULL");
461 result
= gfc_get_expr ();
463 result
->expr_type
= EXPR_CONSTANT
;
464 result
->ts
.type
= type
;
465 result
->ts
.kind
= kind
;
466 result
->where
= *where
;
471 mpz_init (result
->value
.integer
);
475 gfc_set_model_kind (kind
);
476 mpfr_init (result
->value
.real
);
480 gfc_set_model_kind (kind
);
481 mpfr_init (result
->value
.complex.r
);
482 mpfr_init (result
->value
.complex.i
);
493 /* Low-level arithmetic functions. All of these subroutines assume
494 that all operands are of the same type and return an operand of the
495 same type. The other thing about these subroutines is that they
496 can fail in various ways -- overflow, underflow, division by zero,
497 zero raised to the zero, etc. */
500 gfc_arith_not (gfc_expr
* op1
, gfc_expr
** resultp
)
504 result
= gfc_constant_result (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
505 result
->value
.logical
= !op1
->value
.logical
;
513 gfc_arith_and (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
517 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
519 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
527 gfc_arith_or (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
531 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
533 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
541 gfc_arith_eqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
545 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
547 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
555 gfc_arith_neqv (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
559 result
= gfc_constant_result (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
561 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
568 /* Make sure a constant numeric expression is within the range for
569 its type and kind. Note that there's also a gfc_check_range(),
570 but that one deals with the intrinsic RANGE function. */
573 gfc_range_check (gfc_expr
* e
)
580 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
584 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
585 if (rc
== ARITH_UNDERFLOW
)
586 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
587 if (rc
== ARITH_OVERFLOW
)
588 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
590 mpfr_set_nan (e
->value
.real
);
594 rc
= gfc_check_real_range (e
->value
.complex.r
, e
->ts
.kind
);
595 if (rc
== ARITH_UNDERFLOW
)
596 mpfr_set_ui (e
->value
.complex.r
, 0, GFC_RND_MODE
);
597 if (rc
== ARITH_OVERFLOW
)
598 mpfr_set_inf (e
->value
.complex.r
, mpfr_sgn (e
->value
.complex.r
));
600 mpfr_set_nan (e
->value
.complex.r
);
602 rc
= gfc_check_real_range (e
->value
.complex.i
, e
->ts
.kind
);
603 if (rc
== ARITH_UNDERFLOW
)
604 mpfr_set_ui (e
->value
.complex.i
, 0, GFC_RND_MODE
);
605 if (rc
== ARITH_OVERFLOW
)
606 mpfr_set_inf (e
->value
.complex.i
, mpfr_sgn (e
->value
.complex.i
));
608 mpfr_set_nan (e
->value
.complex.i
);
612 gfc_internal_error ("gfc_range_check(): Bad type");
619 /* Several of the following routines use the same set of statements to
620 check the validity of the result. Encapsulate the checking here. */
623 check_result (arith rc
, gfc_expr
* x
, gfc_expr
* r
, gfc_expr
** rp
)
627 if (val
== ARITH_UNDERFLOW
)
629 if (gfc_option
.warn_underflow
)
630 gfc_warning (gfc_arith_error (val
), &x
->where
);
634 if (val
== ARITH_ASYMMETRIC
)
636 gfc_warning (gfc_arith_error (val
), &x
->where
);
649 /* It may seem silly to have a subroutine that actually computes the
650 unary plus of a constant, but it prevents us from making exceptions
651 in the code elsewhere. */
654 gfc_arith_uplus (gfc_expr
* op1
, gfc_expr
** resultp
)
656 *resultp
= gfc_copy_expr (op1
);
662 gfc_arith_uminus (gfc_expr
* op1
, gfc_expr
** resultp
)
667 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
669 switch (op1
->ts
.type
)
672 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
676 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
680 mpfr_neg (result
->value
.complex.r
, op1
->value
.complex.r
, GFC_RND_MODE
);
681 mpfr_neg (result
->value
.complex.i
, op1
->value
.complex.i
, GFC_RND_MODE
);
685 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
688 rc
= gfc_range_check (result
);
690 return check_result (rc
, op1
, result
, resultp
);
695 gfc_arith_plus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
700 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
702 switch (op1
->ts
.type
)
705 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
709 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
714 mpfr_add (result
->value
.complex.r
, op1
->value
.complex.r
,
715 op2
->value
.complex.r
, GFC_RND_MODE
);
717 mpfr_add (result
->value
.complex.i
, op1
->value
.complex.i
,
718 op2
->value
.complex.i
, GFC_RND_MODE
);
722 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
725 rc
= gfc_range_check (result
);
727 return check_result (rc
, op1
, result
, resultp
);
732 gfc_arith_minus (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
737 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
739 switch (op1
->ts
.type
)
742 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
746 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
751 mpfr_sub (result
->value
.complex.r
, op1
->value
.complex.r
,
752 op2
->value
.complex.r
, GFC_RND_MODE
);
754 mpfr_sub (result
->value
.complex.i
, op1
->value
.complex.i
,
755 op2
->value
.complex.i
, GFC_RND_MODE
);
759 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
762 rc
= gfc_range_check (result
);
764 return check_result (rc
, op1
, result
, resultp
);
769 gfc_arith_times (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
775 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
777 switch (op1
->ts
.type
)
780 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
784 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
789 gfc_set_model (op1
->value
.complex.r
);
793 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
794 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
795 mpfr_sub (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
797 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
798 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
799 mpfr_add (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
806 gfc_internal_error ("gfc_arith_times(): Bad basic type");
809 rc
= gfc_range_check (result
);
811 return check_result (rc
, op1
, result
, resultp
);
816 gfc_arith_divide (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
824 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
826 switch (op1
->ts
.type
)
829 if (mpz_sgn (op2
->value
.integer
) == 0)
835 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
840 if (mpfr_sgn (op2
->value
.real
) == 0
841 && gfc_option
.flag_range_check
== 1)
847 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
852 if (mpfr_sgn (op2
->value
.complex.r
) == 0
853 && mpfr_sgn (op2
->value
.complex.i
) == 0
854 && gfc_option
.flag_range_check
== 1)
860 gfc_set_model (op1
->value
.complex.r
);
865 mpfr_mul (x
, op2
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
866 mpfr_mul (y
, op2
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
867 mpfr_add (div
, x
, y
, GFC_RND_MODE
);
869 mpfr_mul (x
, op1
->value
.complex.r
, op2
->value
.complex.r
, GFC_RND_MODE
);
870 mpfr_mul (y
, op1
->value
.complex.i
, op2
->value
.complex.i
, GFC_RND_MODE
);
871 mpfr_add (result
->value
.complex.r
, x
, y
, GFC_RND_MODE
);
872 mpfr_div (result
->value
.complex.r
, result
->value
.complex.r
, div
,
875 mpfr_mul (x
, op1
->value
.complex.i
, op2
->value
.complex.r
, GFC_RND_MODE
);
876 mpfr_mul (y
, op1
->value
.complex.r
, op2
->value
.complex.i
, GFC_RND_MODE
);
877 mpfr_sub (result
->value
.complex.i
, x
, y
, GFC_RND_MODE
);
878 mpfr_div (result
->value
.complex.i
, result
->value
.complex.i
, div
,
887 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
891 rc
= gfc_range_check (result
);
893 return check_result (rc
, op1
, result
, resultp
);
897 /* Compute the reciprocal of a complex number (guaranteed nonzero). */
900 complex_reciprocal (gfc_expr
* op
)
902 mpfr_t mod
, a
, re
, im
;
904 gfc_set_model (op
->value
.complex.r
);
910 mpfr_mul (mod
, op
->value
.complex.r
, op
->value
.complex.r
, GFC_RND_MODE
);
911 mpfr_mul (a
, op
->value
.complex.i
, op
->value
.complex.i
, GFC_RND_MODE
);
912 mpfr_add (mod
, mod
, a
, GFC_RND_MODE
);
914 mpfr_div (re
, op
->value
.complex.r
, mod
, GFC_RND_MODE
);
916 mpfr_neg (im
, op
->value
.complex.i
, GFC_RND_MODE
);
917 mpfr_div (im
, im
, mod
, GFC_RND_MODE
);
919 mpfr_set (op
->value
.complex.r
, re
, GFC_RND_MODE
);
920 mpfr_set (op
->value
.complex.i
, im
, GFC_RND_MODE
);
929 /* Raise a complex number to positive power. */
932 complex_pow_ui (gfc_expr
* base
, int power
, gfc_expr
* result
)
936 gfc_set_model (base
->value
.complex.r
);
941 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
942 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
944 for (; power
> 0; power
--)
946 mpfr_mul (re
, base
->value
.complex.r
, result
->value
.complex.r
,
948 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.i
,
950 mpfr_sub (re
, re
, a
, GFC_RND_MODE
);
952 mpfr_mul (im
, base
->value
.complex.r
, result
->value
.complex.i
,
954 mpfr_mul (a
, base
->value
.complex.i
, result
->value
.complex.r
,
956 mpfr_add (im
, im
, a
, GFC_RND_MODE
);
958 mpfr_set (result
->value
.complex.r
, re
, GFC_RND_MODE
);
959 mpfr_set (result
->value
.complex.i
, im
, GFC_RND_MODE
);
968 /* Raise a number to an integer power. */
971 gfc_arith_power (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
981 if (gfc_extract_int (op2
, &power
) != NULL
)
982 gfc_internal_error ("gfc_arith_power(): Bad exponent");
984 result
= gfc_constant_result (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
988 /* Handle something to the zeroth power. Since we're dealing
989 with integral exponents, there is no ambiguity in the
990 limiting procedure used to determine the value of 0**0. */
991 switch (op1
->ts
.type
)
994 mpz_set_ui (result
->value
.integer
, 1);
998 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
1002 mpfr_set_ui (result
->value
.complex.r
, 1, GFC_RND_MODE
);
1003 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
1007 gfc_internal_error ("gfc_arith_power(): Bad base");
1016 switch (op1
->ts
.type
)
1019 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
, apower
);
1023 mpz_init_set_ui (unity_z
, 1);
1024 mpz_tdiv_q (result
->value
.integer
, unity_z
,
1025 result
->value
.integer
);
1026 mpz_clear (unity_z
);
1031 mpfr_pow_ui (result
->value
.real
, op1
->value
.real
, apower
,
1036 gfc_set_model (op1
->value
.real
);
1037 mpfr_init (unity_f
);
1038 mpfr_set_ui (unity_f
, 1, GFC_RND_MODE
);
1039 mpfr_div (result
->value
.real
, unity_f
, result
->value
.real
,
1041 mpfr_clear (unity_f
);
1046 complex_pow_ui (op1
, apower
, result
);
1048 complex_reciprocal (result
);
1057 rc
= gfc_range_check (result
);
1059 return check_result (rc
, op1
, result
, resultp
);
1063 /* Concatenate two string constants. */
1066 gfc_arith_concat (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1071 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
1074 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1076 result
->value
.character
.string
= gfc_getmem (len
+ 1);
1077 result
->value
.character
.length
= len
;
1079 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1080 op1
->value
.character
.length
);
1082 memcpy (result
->value
.character
.string
+ op1
->value
.character
.length
,
1083 op2
->value
.character
.string
, op2
->value
.character
.length
);
1085 result
->value
.character
.string
[len
] = '\0';
1093 /* Comparison operators. Assumes that the two expression nodes
1094 contain two constants of the same type. */
1097 gfc_compare_expr (gfc_expr
* op1
, gfc_expr
* op2
)
1101 switch (op1
->ts
.type
)
1104 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1108 rc
= mpfr_cmp (op1
->value
.real
, op2
->value
.real
);
1112 rc
= gfc_compare_string (op1
, op2
, NULL
);
1116 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1117 || (op1
->value
.logical
&& !op2
->value
.logical
));
1121 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1128 /* Compare a pair of complex numbers. Naturally, this is only for
1129 equality and nonequality. */
1132 compare_complex (gfc_expr
* op1
, gfc_expr
* op2
)
1134 return (mpfr_cmp (op1
->value
.complex.r
, op2
->value
.complex.r
) == 0
1135 && mpfr_cmp (op1
->value
.complex.i
, op2
->value
.complex.i
) == 0);
1139 /* Given two constant strings and the inverse collating sequence, compare the
1140 strings. We return -1 for a < b, 0 for a == b and 1 for a > b. If the
1141 xcoll_table is NULL, we use the processor's default collating sequence. */
1144 gfc_compare_string (gfc_expr
* a
, gfc_expr
* b
, const int * xcoll_table
)
1146 int len
, alen
, blen
, i
, ac
, bc
;
1148 alen
= a
->value
.character
.length
;
1149 blen
= b
->value
.character
.length
;
1151 len
= (alen
> blen
) ? alen
: blen
;
1153 for (i
= 0; i
< len
; i
++)
1155 /* We cast to unsigned char because default char, if it is signed,
1156 would lead to ac < 0 for string[i] > 127. */
1157 ac
= (unsigned char) ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1158 bc
= (unsigned char) ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1160 if (xcoll_table
!= NULL
)
1162 ac
= xcoll_table
[ac
];
1163 bc
= xcoll_table
[bc
];
1172 /* Strings are equal */
1178 /* Specific comparison subroutines. */
1181 gfc_arith_eq (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1185 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1187 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1188 compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) == 0);
1196 gfc_arith_ne (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1200 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1202 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
) ?
1203 !compare_complex (op1
, op2
) : (gfc_compare_expr (op1
, op2
) != 0);
1211 gfc_arith_gt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1215 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1217 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) > 0);
1225 gfc_arith_ge (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1229 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1231 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) >= 0);
1239 gfc_arith_lt (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1243 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1245 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) < 0);
1253 gfc_arith_le (gfc_expr
* op1
, gfc_expr
* op2
, gfc_expr
** resultp
)
1257 result
= gfc_constant_result (BT_LOGICAL
, gfc_default_logical_kind
,
1259 result
->value
.logical
= (gfc_compare_expr (op1
, op2
) <= 0);
1267 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
* op
,
1270 gfc_constructor
*c
, *head
;
1274 if (op
->expr_type
== EXPR_CONSTANT
)
1275 return eval (op
, result
);
1278 head
= gfc_copy_constructor (op
->value
.constructor
);
1280 for (c
= head
; c
; c
= c
->next
)
1282 rc
= eval (c
->expr
, &r
);
1286 gfc_replace_expr (c
->expr
, r
);
1290 gfc_free_constructor (head
);
1293 r
= gfc_get_expr ();
1294 r
->expr_type
= EXPR_ARRAY
;
1295 r
->value
.constructor
= head
;
1296 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1298 r
->ts
= head
->expr
->ts
;
1299 r
->where
= op
->where
;
1310 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1311 gfc_expr
* op1
, gfc_expr
* op2
,
1314 gfc_constructor
*c
, *head
;
1318 head
= gfc_copy_constructor (op1
->value
.constructor
);
1321 for (c
= head
; c
; c
= c
->next
)
1323 rc
= eval (c
->expr
, op2
, &r
);
1327 gfc_replace_expr (c
->expr
, r
);
1331 gfc_free_constructor (head
);
1334 r
= gfc_get_expr ();
1335 r
->expr_type
= EXPR_ARRAY
;
1336 r
->value
.constructor
= head
;
1337 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1339 r
->ts
= head
->expr
->ts
;
1340 r
->where
= op1
->where
;
1341 r
->rank
= op1
->rank
;
1351 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1352 gfc_expr
* op1
, gfc_expr
* op2
,
1355 gfc_constructor
*c
, *head
;
1359 head
= gfc_copy_constructor (op2
->value
.constructor
);
1362 for (c
= head
; c
; c
= c
->next
)
1364 rc
= eval (op1
, c
->expr
, &r
);
1368 gfc_replace_expr (c
->expr
, r
);
1372 gfc_free_constructor (head
);
1375 r
= gfc_get_expr ();
1376 r
->expr_type
= EXPR_ARRAY
;
1377 r
->value
.constructor
= head
;
1378 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1380 r
->ts
= head
->expr
->ts
;
1381 r
->where
= op2
->where
;
1382 r
->rank
= op2
->rank
;
1392 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1393 gfc_expr
* op1
, gfc_expr
* op2
,
1396 gfc_constructor
*c
, *d
, *head
;
1400 head
= gfc_copy_constructor (op1
->value
.constructor
);
1403 d
= op2
->value
.constructor
;
1405 if (gfc_check_conformance ("Elemental binary operation", op1
, op2
)
1407 rc
= ARITH_INCOMMENSURATE
;
1411 for (c
= head
; c
; c
= c
->next
, d
= d
->next
)
1415 rc
= ARITH_INCOMMENSURATE
;
1419 rc
= eval (c
->expr
, d
->expr
, &r
);
1423 gfc_replace_expr (c
->expr
, r
);
1427 rc
= ARITH_INCOMMENSURATE
;
1431 gfc_free_constructor (head
);
1434 r
= gfc_get_expr ();
1435 r
->expr_type
= EXPR_ARRAY
;
1436 r
->value
.constructor
= head
;
1437 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1439 r
->ts
= head
->expr
->ts
;
1440 r
->where
= op1
->where
;
1441 r
->rank
= op1
->rank
;
1451 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1452 gfc_expr
* op1
, gfc_expr
* op2
,
1455 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1456 return eval (op1
, op2
, result
);
1458 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1459 return reduce_binary_ca (eval
, op1
, op2
, result
);
1461 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1462 return reduce_binary_ac (eval
, op1
, op2
, result
);
1464 return reduce_binary_aa (eval
, op1
, op2
, result
);
1470 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1471 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1475 /* High level arithmetic subroutines. These subroutines go into
1476 eval_intrinsic(), which can do one of several things to its
1477 operands. If the operands are incompatible with the intrinsic
1478 operation, we return a node pointing to the operands and hope that
1479 an operator interface is found during resolution.
1481 If the operands are compatible and are constants, then we try doing
1482 the arithmetic. We also handle the cases where either or both
1483 operands are array constructors. */
1486 eval_intrinsic (gfc_intrinsic_op
operator,
1487 eval_f eval
, gfc_expr
* op1
, gfc_expr
* op2
)
1489 gfc_expr temp
, *result
;
1493 gfc_clear_ts (&temp
.ts
);
1499 if (op1
->ts
.type
!= BT_LOGICAL
)
1502 temp
.ts
.type
= BT_LOGICAL
;
1503 temp
.ts
.kind
= gfc_default_logical_kind
;
1508 /* Logical binary operators */
1511 case INTRINSIC_NEQV
:
1513 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1516 temp
.ts
.type
= BT_LOGICAL
;
1517 temp
.ts
.kind
= gfc_default_logical_kind
;
1523 case INTRINSIC_UPLUS
:
1524 case INTRINSIC_UMINUS
:
1525 if (!gfc_numeric_ts (&op1
->ts
))
1533 case INTRINSIC_PARENTHESES
:
1539 /* Additional restrictions for ordering relations. */
1544 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1546 temp
.ts
.type
= BT_LOGICAL
;
1547 temp
.ts
.kind
= gfc_default_logical_kind
;
1554 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1557 temp
.ts
.type
= BT_LOGICAL
;
1558 temp
.ts
.kind
= gfc_default_logical_kind
;
1563 /* Numeric binary */
1564 case INTRINSIC_PLUS
:
1565 case INTRINSIC_MINUS
:
1566 case INTRINSIC_TIMES
:
1567 case INTRINSIC_DIVIDE
:
1568 case INTRINSIC_POWER
:
1569 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1572 /* Insert any necessary type conversions to make the operands
1575 temp
.expr_type
= EXPR_OP
;
1576 gfc_clear_ts (&temp
.ts
);
1577 temp
.value
.op
.operator = operator;
1579 temp
.value
.op
.op1
= op1
;
1580 temp
.value
.op
.op2
= op2
;
1582 gfc_type_convert_binary (&temp
);
1584 if (operator == INTRINSIC_EQ
|| operator == INTRINSIC_NE
1585 || operator == INTRINSIC_GE
|| operator == INTRINSIC_GT
1586 || operator == INTRINSIC_LE
|| operator == INTRINSIC_LT
)
1588 temp
.ts
.type
= BT_LOGICAL
;
1589 temp
.ts
.kind
= gfc_default_logical_kind
;
1595 /* Character binary */
1596 case INTRINSIC_CONCAT
:
1597 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
)
1600 temp
.ts
.type
= BT_CHARACTER
;
1601 temp
.ts
.kind
= gfc_default_character_kind
;
1606 case INTRINSIC_USER
:
1610 gfc_internal_error ("eval_intrinsic(): Bad operator");
1613 /* Try to combine the operators. */
1614 if (operator == INTRINSIC_POWER
&& op2
->ts
.type
!= BT_INTEGER
)
1618 || (op1
->expr_type
!= EXPR_CONSTANT
1619 && (op1
->expr_type
!= EXPR_ARRAY
1620 || !gfc_is_constant_expr (op1
)
1621 || !gfc_expanded_ac (op1
))))
1626 || (op2
->expr_type
!= EXPR_CONSTANT
1627 && (op2
->expr_type
!= EXPR_ARRAY
1628 || !gfc_is_constant_expr (op2
)
1629 || !gfc_expanded_ac (op2
)))))
1633 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1635 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1638 { /* Something went wrong. */
1639 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1643 gfc_free_expr (op1
);
1644 gfc_free_expr (op2
);
1648 /* Create a run-time expression. */
1649 result
= gfc_get_expr ();
1650 result
->ts
= temp
.ts
;
1652 result
->expr_type
= EXPR_OP
;
1653 result
->value
.op
.operator = operator;
1655 result
->value
.op
.op1
= op1
;
1656 result
->value
.op
.op2
= op2
;
1658 result
->where
= op1
->where
;
1664 /* Modify type of expression for zero size array. */
1667 eval_type_intrinsic0 (gfc_intrinsic_op
operator, gfc_expr
* op
)
1670 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1680 op
->ts
.type
= BT_LOGICAL
;
1681 op
->ts
.kind
= gfc_default_logical_kind
;
1692 /* Return nonzero if the expression is a zero size array. */
1695 gfc_zero_size_array (gfc_expr
* e
)
1697 if (e
->expr_type
!= EXPR_ARRAY
)
1700 return e
->value
.constructor
== NULL
;
1704 /* Reduce a binary expression where at least one of the operands
1705 involves a zero-length array. Returns NULL if neither of the
1706 operands is a zero-length array. */
1709 reduce_binary0 (gfc_expr
* op1
, gfc_expr
* op2
)
1711 if (gfc_zero_size_array (op1
))
1713 gfc_free_expr (op2
);
1717 if (gfc_zero_size_array (op2
))
1719 gfc_free_expr (op1
);
1728 eval_intrinsic_f2 (gfc_intrinsic_op
operator,
1729 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1730 gfc_expr
* op1
, gfc_expr
* op2
)
1737 if (gfc_zero_size_array (op1
))
1738 return eval_type_intrinsic0 (operator, op1
);
1742 result
= reduce_binary0 (op1
, op2
);
1744 return eval_type_intrinsic0 (operator, result
);
1748 return eval_intrinsic (operator, f
, op1
, op2
);
1753 eval_intrinsic_f3 (gfc_intrinsic_op
operator,
1754 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1755 gfc_expr
* op1
, gfc_expr
* op2
)
1760 result
= reduce_binary0 (op1
, op2
);
1762 return eval_type_intrinsic0(operator, result
);
1765 return eval_intrinsic (operator, f
, op1
, op2
);
1770 gfc_uplus (gfc_expr
* op
)
1772 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_uplus
, op
, NULL
);
1777 gfc_uminus (gfc_expr
* op
)
1779 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1784 gfc_add (gfc_expr
* op1
, gfc_expr
* op2
)
1786 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1791 gfc_subtract (gfc_expr
* op1
, gfc_expr
* op2
)
1793 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1798 gfc_multiply (gfc_expr
* op1
, gfc_expr
* op2
)
1800 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1805 gfc_divide (gfc_expr
* op1
, gfc_expr
* op2
)
1807 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1812 gfc_power (gfc_expr
* op1
, gfc_expr
* op2
)
1814 return eval_intrinsic_f3 (INTRINSIC_POWER
, gfc_arith_power
, op1
, op2
);
1819 gfc_concat (gfc_expr
* op1
, gfc_expr
* op2
)
1821 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1826 gfc_and (gfc_expr
* op1
, gfc_expr
* op2
)
1828 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1833 gfc_or (gfc_expr
* op1
, gfc_expr
* op2
)
1835 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1840 gfc_not (gfc_expr
* op1
)
1842 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1847 gfc_eqv (gfc_expr
* op1
, gfc_expr
* op2
)
1849 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1854 gfc_neqv (gfc_expr
* op1
, gfc_expr
* op2
)
1856 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1861 gfc_eq (gfc_expr
* op1
, gfc_expr
* op2
)
1863 return eval_intrinsic_f3 (INTRINSIC_EQ
, gfc_arith_eq
, op1
, op2
);
1868 gfc_ne (gfc_expr
* op1
, gfc_expr
* op2
)
1870 return eval_intrinsic_f3 (INTRINSIC_NE
, gfc_arith_ne
, op1
, op2
);
1875 gfc_gt (gfc_expr
* op1
, gfc_expr
* op2
)
1877 return eval_intrinsic_f3 (INTRINSIC_GT
, gfc_arith_gt
, op1
, op2
);
1882 gfc_ge (gfc_expr
* op1
, gfc_expr
* op2
)
1884 return eval_intrinsic_f3 (INTRINSIC_GE
, gfc_arith_ge
, op1
, op2
);
1889 gfc_lt (gfc_expr
* op1
, gfc_expr
* op2
)
1891 return eval_intrinsic_f3 (INTRINSIC_LT
, gfc_arith_lt
, op1
, op2
);
1896 gfc_le (gfc_expr
* op1
, gfc_expr
* op2
)
1898 return eval_intrinsic_f3 (INTRINSIC_LE
, gfc_arith_le
, op1
, op2
);
1902 /* Convert an integer string to an expression node. */
1905 gfc_convert_integer (const char * buffer
, int kind
, int radix
, locus
* where
)
1910 e
= gfc_constant_result (BT_INTEGER
, kind
, where
);
1911 /* A leading plus is allowed, but not by mpz_set_str. */
1912 if (buffer
[0] == '+')
1916 mpz_set_str (e
->value
.integer
, t
, radix
);
1922 /* Convert a real string to an expression node. */
1925 gfc_convert_real (const char * buffer
, int kind
, locus
* where
)
1929 e
= gfc_constant_result (BT_REAL
, kind
, where
);
1930 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
1936 /* Convert a pair of real, constant expression nodes to a single
1937 complex expression node. */
1940 gfc_convert_complex (gfc_expr
* real
, gfc_expr
* imag
, int kind
)
1944 e
= gfc_constant_result (BT_COMPLEX
, kind
, &real
->where
);
1945 mpfr_set (e
->value
.complex.r
, real
->value
.real
, GFC_RND_MODE
);
1946 mpfr_set (e
->value
.complex.i
, imag
->value
.real
, GFC_RND_MODE
);
1952 /******* Simplification of intrinsic functions with constant arguments *****/
1955 /* Deal with an arithmetic error. */
1958 arith_error (arith rc
, gfc_typespec
* from
, gfc_typespec
* to
, locus
* where
)
1963 gfc_error ("Arithmetic OK converting %s to %s at %L",
1964 gfc_typename (from
), gfc_typename (to
), where
);
1966 case ARITH_OVERFLOW
:
1967 gfc_error ("Arithmetic overflow converting %s to %s at %L",
1968 gfc_typename (from
), gfc_typename (to
), where
);
1970 case ARITH_UNDERFLOW
:
1971 gfc_error ("Arithmetic underflow converting %s to %s at %L",
1972 gfc_typename (from
), gfc_typename (to
), where
);
1975 gfc_error ("Arithmetic NaN converting %s to %s at %L",
1976 gfc_typename (from
), gfc_typename (to
), where
);
1979 gfc_error ("Division by zero converting %s to %s at %L",
1980 gfc_typename (from
), gfc_typename (to
), where
);
1982 case ARITH_INCOMMENSURATE
:
1983 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1984 gfc_typename (from
), gfc_typename (to
), where
);
1986 case ARITH_ASYMMETRIC
:
1987 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1988 " converting %s to %s at %L",
1989 gfc_typename (from
), gfc_typename (to
), where
);
1992 gfc_internal_error ("gfc_arith_error(): Bad error code");
1995 /* TODO: Do something about the error, ie, throw exception, return
2000 /* Convert integers to integers. */
2003 gfc_int2int (gfc_expr
* src
, int kind
)
2008 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2010 mpz_set (result
->value
.integer
, src
->value
.integer
);
2012 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2015 if (rc
== ARITH_ASYMMETRIC
)
2017 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2021 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2022 gfc_free_expr (result
);
2031 /* Convert integers to reals. */
2034 gfc_int2real (gfc_expr
* src
, int kind
)
2039 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2041 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2043 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2045 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2046 gfc_free_expr (result
);
2054 /* Convert default integer to default complex. */
2057 gfc_int2complex (gfc_expr
* src
, int kind
)
2062 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2064 mpfr_set_z (result
->value
.complex.r
, src
->value
.integer
, GFC_RND_MODE
);
2065 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2067 if ((rc
= gfc_check_real_range (result
->value
.complex.r
, kind
)) != ARITH_OK
)
2069 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2070 gfc_free_expr (result
);
2078 /* Convert default real to default integer. */
2081 gfc_real2int (gfc_expr
* src
, int kind
)
2086 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2088 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
);
2090 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2093 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2094 gfc_free_expr (result
);
2102 /* Convert real to real. */
2105 gfc_real2real (gfc_expr
* src
, int kind
)
2110 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2112 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2114 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2116 if (rc
== ARITH_UNDERFLOW
)
2118 if (gfc_option
.warn_underflow
)
2119 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2120 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2122 else if (rc
!= ARITH_OK
)
2124 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2125 gfc_free_expr (result
);
2133 /* Convert real to complex. */
2136 gfc_real2complex (gfc_expr
* src
, int kind
)
2141 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2143 mpfr_set (result
->value
.complex.r
, src
->value
.real
, GFC_RND_MODE
);
2144 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2146 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2148 if (rc
== ARITH_UNDERFLOW
)
2150 if (gfc_option
.warn_underflow
)
2151 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2152 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2154 else if (rc
!= ARITH_OK
)
2156 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2157 gfc_free_expr (result
);
2165 /* Convert complex to integer. */
2168 gfc_complex2int (gfc_expr
* src
, int kind
)
2173 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2175 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.complex.r
);
2177 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
))
2180 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2181 gfc_free_expr (result
);
2189 /* Convert complex to real. */
2192 gfc_complex2real (gfc_expr
* src
, int kind
)
2197 result
= gfc_constant_result (BT_REAL
, kind
, &src
->where
);
2199 mpfr_set (result
->value
.real
, src
->value
.complex.r
, GFC_RND_MODE
);
2201 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2203 if (rc
== ARITH_UNDERFLOW
)
2205 if (gfc_option
.warn_underflow
)
2206 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2207 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2211 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2212 gfc_free_expr (result
);
2220 /* Convert complex to complex. */
2223 gfc_complex2complex (gfc_expr
* src
, int kind
)
2228 result
= gfc_constant_result (BT_COMPLEX
, kind
, &src
->where
);
2230 mpfr_set (result
->value
.complex.r
, src
->value
.complex.r
, GFC_RND_MODE
);
2231 mpfr_set (result
->value
.complex.i
, src
->value
.complex.i
, GFC_RND_MODE
);
2233 rc
= gfc_check_real_range (result
->value
.complex.r
, kind
);
2235 if (rc
== ARITH_UNDERFLOW
)
2237 if (gfc_option
.warn_underflow
)
2238 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2239 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
2241 else if (rc
!= ARITH_OK
)
2243 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2244 gfc_free_expr (result
);
2248 rc
= gfc_check_real_range (result
->value
.complex.i
, kind
);
2250 if (rc
== ARITH_UNDERFLOW
)
2252 if (gfc_option
.warn_underflow
)
2253 gfc_warning (gfc_arith_error (rc
), &src
->where
);
2254 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
2256 else if (rc
!= ARITH_OK
)
2258 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2259 gfc_free_expr (result
);
2267 /* Logical kind conversion. */
2270 gfc_log2log (gfc_expr
* src
, int kind
)
2274 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2275 result
->value
.logical
= src
->value
.logical
;
2281 /* Convert logical to integer. */
2284 gfc_log2int (gfc_expr
*src
, int kind
)
2288 result
= gfc_constant_result (BT_INTEGER
, kind
, &src
->where
);
2289 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2295 /* Convert integer to logical. */
2298 gfc_int2log (gfc_expr
*src
, int kind
)
2302 result
= gfc_constant_result (BT_LOGICAL
, kind
, &src
->where
);
2303 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2309 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2312 gfc_hollerith2int (gfc_expr
* src
, int kind
)
2317 len
= src
->value
.character
.length
;
2319 result
= gfc_get_expr ();
2320 result
->expr_type
= EXPR_CONSTANT
;
2321 result
->ts
.type
= BT_INTEGER
;
2322 result
->ts
.kind
= kind
;
2323 result
->where
= src
->where
;
2328 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2329 &src
->where
, gfc_typename(&result
->ts
));
2331 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2332 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2336 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2338 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2339 result
->value
.character
.length
= kind
;
2345 /* Convert Hollerith to real. The constant will be padded or truncated. */
2348 gfc_hollerith2real (gfc_expr
* src
, int kind
)
2353 len
= src
->value
.character
.length
;
2355 result
= gfc_get_expr ();
2356 result
->expr_type
= EXPR_CONSTANT
;
2357 result
->ts
.type
= BT_REAL
;
2358 result
->ts
.kind
= kind
;
2359 result
->where
= src
->where
;
2364 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2365 &src
->where
, gfc_typename(&result
->ts
));
2367 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2368 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2372 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2374 result
->value
.character
.string
[kind
] = '\0'; /* For debugger. */
2375 result
->value
.character
.length
= kind
;
2381 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2384 gfc_hollerith2complex (gfc_expr
* src
, int kind
)
2389 len
= src
->value
.character
.length
;
2391 result
= gfc_get_expr ();
2392 result
->expr_type
= EXPR_CONSTANT
;
2393 result
->ts
.type
= BT_COMPLEX
;
2394 result
->ts
.kind
= kind
;
2395 result
->where
= src
->where
;
2402 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2403 &src
->where
, gfc_typename(&result
->ts
));
2405 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2406 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2410 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2412 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2413 result
->value
.character
.length
= kind
;
2419 /* Convert Hollerith to character. */
2422 gfc_hollerith2character (gfc_expr
* src
, int kind
)
2426 result
= gfc_copy_expr (src
);
2427 result
->ts
.type
= BT_CHARACTER
;
2428 result
->ts
.kind
= kind
;
2435 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2438 gfc_hollerith2logical (gfc_expr
* src
, int kind
)
2443 len
= src
->value
.character
.length
;
2445 result
= gfc_get_expr ();
2446 result
->expr_type
= EXPR_CONSTANT
;
2447 result
->ts
.type
= BT_LOGICAL
;
2448 result
->ts
.kind
= kind
;
2449 result
->where
= src
->where
;
2454 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2455 &src
->where
, gfc_typename(&result
->ts
));
2457 result
->value
.character
.string
= gfc_getmem (kind
+ 1);
2458 memcpy (result
->value
.character
.string
, src
->value
.character
.string
,
2462 memset (&result
->value
.character
.string
[len
], ' ', kind
- len
);
2464 result
->value
.character
.string
[kind
] = '\0'; /* For debugger */
2465 result
->value
.character
.length
= kind
;
2471 /* Returns an initializer whose value is one higher than the value of the
2472 LAST_INITIALIZER argument. If the argument is NULL, the
2473 initializers value will be set to zero. The initializer's kind
2474 will be set to gfc_c_int_kind.
2476 If -fshort-enums is given, the appropriate kind will be selected
2477 later after all enumerators have been parsed. A warning is issued
2478 here if an initializer exceeds gfc_c_int_kind. */
2481 gfc_enum_initializer (gfc_expr
* last_initializer
, locus where
)
2485 result
= gfc_get_expr ();
2486 result
->expr_type
= EXPR_CONSTANT
;
2487 result
->ts
.type
= BT_INTEGER
;
2488 result
->ts
.kind
= gfc_c_int_kind
;
2489 result
->where
= where
;
2491 mpz_init (result
->value
.integer
);
2493 if (last_initializer
!= NULL
)
2495 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
2496 result
->where
= last_initializer
->where
;
2498 if (gfc_check_integer_range (result
->value
.integer
,
2499 gfc_c_int_kind
) != ARITH_OK
)
2501 gfc_error ("Enumerator exceeds the C integer type at %C");
2507 /* Control comes here, if it's the very first enumerator and no
2508 initializer has been given. It will be initialized to zero. */
2509 mpz_set_si (result
->value
.integer
, 0);