2 Copyright (C) 2000-2023 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* Since target arithmetic must be done on the host, there has to
22 be some way of evaluating arithmetic expressions as the host
23 would evaluate them. We use the GNU MP library and the MPFR
24 library to do arithmetic, and this file provides the interface. */
28 #include "coretypes.h"
32 #include "target-memory.h"
33 #include "constructor.h"
37 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
38 It's easily implemented with a few calls though. */
41 gfc_mpfr_to_mpz (mpz_t z
, mpfr_t x
, locus
*where
)
45 if (mpfr_inf_p (x
) || mpfr_nan_p (x
))
47 gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
53 e
= mpfr_get_z_exp (z
, x
);
56 mpz_mul_2exp (z
, z
, e
);
58 mpz_tdiv_q_2exp (z
, z
, -e
);
62 /* Set the model number precision by the requested KIND. */
65 gfc_set_model_kind (int kind
)
67 int index
= gfc_validate_kind (BT_REAL
, kind
, false);
70 base2prec
= gfc_real_kinds
[index
].digits
;
71 if (gfc_real_kinds
[index
].radix
!= 2)
72 base2prec
*= gfc_real_kinds
[index
].radix
/ 2;
73 mpfr_set_default_prec (base2prec
);
77 /* Set the model number precision from mpfr_t x. */
80 gfc_set_model (mpfr_t x
)
82 mpfr_set_default_prec (mpfr_get_prec (x
));
86 /* Given an arithmetic error code, return a pointer to a string that
87 explains the error. */
90 gfc_arith_error (arith code
)
97 p
= G_("Arithmetic OK at %L");
100 p
= G_("Arithmetic overflow at %L");
102 case ARITH_UNDERFLOW
:
103 p
= G_("Arithmetic underflow at %L");
106 p
= G_("Arithmetic NaN at %L");
109 p
= G_("Division by zero at %L");
111 case ARITH_INCOMMENSURATE
:
112 p
= G_("Array operands are incommensurate at %L");
114 case ARITH_ASYMMETRIC
:
115 p
= G_("Integer outside symmetric range implied by Standard Fortran"
118 case ARITH_WRONGCONCAT
:
119 p
= G_("Illegal type in character concatenation at %L");
121 case ARITH_INVALID_TYPE
:
122 p
= G_("Invalid type in arithmetic operation at %L");
126 gfc_internal_error ("gfc_arith_error(): Bad error code");
133 /* Get things ready to do math. */
136 gfc_arith_init_1 (void)
138 gfc_integer_info
*int_info
;
139 gfc_real_info
*real_info
;
143 mpfr_set_default_prec (128);
146 /* Convert the minimum and maximum values for each kind into their
147 GNU MP representation. */
148 for (int_info
= gfc_integer_kinds
; int_info
->kind
!= 0; int_info
++)
151 mpz_init (int_info
->huge
);
152 mpz_set_ui (int_info
->huge
, int_info
->radix
);
153 mpz_pow_ui (int_info
->huge
, int_info
->huge
, int_info
->digits
);
154 mpz_sub_ui (int_info
->huge
, int_info
->huge
, 1);
156 /* These are the numbers that are actually representable by the
157 target. For bases other than two, this needs to be changed. */
158 if (int_info
->radix
!= 2)
159 gfc_internal_error ("Fix min_int calculation");
161 /* See PRs 13490 and 17912, related to integer ranges.
162 The pedantic_min_int exists for range checking when a program
163 is compiled with -pedantic, and reflects the belief that
164 Standard Fortran requires integers to be symmetrical, i.e.
165 every negative integer must have a representable positive
166 absolute value, and vice versa. */
168 mpz_init (int_info
->pedantic_min_int
);
169 mpz_neg (int_info
->pedantic_min_int
, int_info
->huge
);
171 mpz_init (int_info
->min_int
);
172 mpz_sub_ui (int_info
->min_int
, int_info
->pedantic_min_int
, 1);
175 mpfr_set_z (a
, int_info
->huge
, GFC_RND_MODE
);
176 mpfr_log10 (a
, a
, GFC_RND_MODE
);
178 int_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
183 for (real_info
= gfc_real_kinds
; real_info
->kind
!= 0; real_info
++)
185 gfc_set_model_kind (real_info
->kind
);
190 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
192 mpfr_init (real_info
->huge
);
193 mpfr_set_ui (real_info
->huge
, 1, GFC_RND_MODE
);
194 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
195 mpfr_pow_si (a
, a
, -real_info
->digits
, GFC_RND_MODE
);
196 mpfr_sub (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
199 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
200 mpfr_pow_ui (a
, a
, real_info
->max_exponent
- 1, GFC_RND_MODE
);
202 /* (1 - b**(-p)) * b**(emax-1) */
203 mpfr_mul (real_info
->huge
, real_info
->huge
, a
, GFC_RND_MODE
);
205 /* (1 - b**(-p)) * b**(emax-1) * b */
206 mpfr_mul_ui (real_info
->huge
, real_info
->huge
, real_info
->radix
,
209 /* tiny(x) = b**(emin-1) */
210 mpfr_init (real_info
->tiny
);
211 mpfr_set_ui (real_info
->tiny
, real_info
->radix
, GFC_RND_MODE
);
212 mpfr_pow_si (real_info
->tiny
, real_info
->tiny
,
213 real_info
->min_exponent
- 1, GFC_RND_MODE
);
215 /* subnormal (x) = b**(emin - digit) */
216 mpfr_init (real_info
->subnormal
);
217 mpfr_set_ui (real_info
->subnormal
, real_info
->radix
, GFC_RND_MODE
);
218 mpfr_pow_si (real_info
->subnormal
, real_info
->subnormal
,
219 real_info
->min_exponent
- real_info
->digits
, GFC_RND_MODE
);
221 /* epsilon(x) = b**(1-p) */
222 mpfr_init (real_info
->epsilon
);
223 mpfr_set_ui (real_info
->epsilon
, real_info
->radix
, GFC_RND_MODE
);
224 mpfr_pow_si (real_info
->epsilon
, real_info
->epsilon
,
225 1 - real_info
->digits
, GFC_RND_MODE
);
227 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
228 mpfr_log10 (a
, real_info
->huge
, GFC_RND_MODE
);
229 mpfr_log10 (b
, real_info
->tiny
, GFC_RND_MODE
);
230 mpfr_neg (b
, b
, GFC_RND_MODE
);
233 mpfr_min (a
, a
, b
, GFC_RND_MODE
);
235 real_info
->range
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
237 /* precision(x) = int((p - 1) * log10(b)) + k */
238 mpfr_set_ui (a
, real_info
->radix
, GFC_RND_MODE
);
239 mpfr_log10 (a
, a
, GFC_RND_MODE
);
240 mpfr_mul_ui (a
, a
, real_info
->digits
- 1, GFC_RND_MODE
);
242 real_info
->precision
= (int) mpfr_get_si (a
, GFC_RND_MODE
);
244 /* If the radix is an integral power of 10, add one to the precision. */
245 for (i
= 10; i
<= real_info
->radix
; i
*= 10)
246 if (i
== real_info
->radix
)
247 real_info
->precision
++;
249 mpfr_clears (a
, b
, NULL
);
254 /* Clean up, get rid of numeric constants. */
257 gfc_arith_done_1 (void)
259 gfc_integer_info
*ip
;
262 for (ip
= gfc_integer_kinds
; ip
->kind
; ip
++)
264 mpz_clear (ip
->min_int
);
265 mpz_clear (ip
->pedantic_min_int
);
266 mpz_clear (ip
->huge
);
269 for (rp
= gfc_real_kinds
; rp
->kind
; rp
++)
270 mpfr_clears (rp
->epsilon
, rp
->huge
, rp
->tiny
, rp
->subnormal
, NULL
);
276 /* Given a wide character value and a character kind, determine whether
277 the character is representable for that kind. */
279 gfc_check_character_range (gfc_char_t c
, int kind
)
281 /* As wide characters are stored as 32-bit values, they're all
282 representable in UCS=4. */
287 return c
<= 255 ? true : false;
293 /* Given an integer and a kind, make sure that the integer lies within
294 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
298 gfc_check_integer_range (mpz_t p
, int kind
)
303 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
308 if (mpz_cmp (p
, gfc_integer_kinds
[i
].pedantic_min_int
) < 0)
309 result
= ARITH_ASYMMETRIC
;
313 if (flag_range_check
== 0)
316 if (mpz_cmp (p
, gfc_integer_kinds
[i
].min_int
) < 0
317 || mpz_cmp (p
, gfc_integer_kinds
[i
].huge
) > 0)
318 result
= ARITH_OVERFLOW
;
324 /* Given a real and a kind, make sure that the real lies within the
325 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
329 gfc_check_real_range (mpfr_t p
, int kind
)
335 i
= gfc_validate_kind (BT_REAL
, kind
, false);
339 mpfr_abs (q
, p
, GFC_RND_MODE
);
345 if (flag_range_check
!= 0)
346 retval
= ARITH_OVERFLOW
;
348 else if (mpfr_nan_p (p
))
350 if (flag_range_check
!= 0)
353 else if (mpfr_sgn (q
) == 0)
358 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].huge
) > 0)
360 if (flag_range_check
== 0)
361 mpfr_set_inf (p
, mpfr_sgn (p
));
363 retval
= ARITH_OVERFLOW
;
365 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].subnormal
) < 0)
367 if (flag_range_check
== 0)
369 if (mpfr_sgn (p
) < 0)
371 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
372 mpfr_set_si (q
, -1, GFC_RND_MODE
);
373 mpfr_copysign (p
, p
, q
, GFC_RND_MODE
);
376 mpfr_set_ui (p
, 0, GFC_RND_MODE
);
379 retval
= ARITH_UNDERFLOW
;
381 else if (mpfr_cmp (q
, gfc_real_kinds
[i
].tiny
) < 0)
383 mpfr_exp_t emin
, emax
;
386 /* Save current values of emin and emax. */
387 emin
= mpfr_get_emin ();
388 emax
= mpfr_get_emax ();
390 /* Set emin and emax for the current model number. */
391 en
= gfc_real_kinds
[i
].min_exponent
- gfc_real_kinds
[i
].digits
+ 1;
392 mpfr_set_emin ((mpfr_exp_t
) en
);
393 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[i
].max_exponent
);
394 mpfr_check_range (q
, 0, GFC_RND_MODE
);
395 mpfr_subnormalize (q
, 0, GFC_RND_MODE
);
397 /* Reset emin and emax. */
398 mpfr_set_emin (emin
);
399 mpfr_set_emax (emax
);
401 /* Copy sign if needed. */
402 if (mpfr_sgn (p
) < 0)
403 mpfr_neg (p
, q
, MPFR_RNDN
);
405 mpfr_set (p
, q
, MPFR_RNDN
);
414 /* Low-level arithmetic functions. All of these subroutines assume
415 that all operands are of the same type and return an operand of the
416 same type. The other thing about these subroutines is that they
417 can fail in various ways -- overflow, underflow, division by zero,
418 zero raised to the zero, etc. */
421 gfc_arith_not (gfc_expr
*op1
, gfc_expr
**resultp
)
425 if (op1
->ts
.type
!= BT_LOGICAL
)
426 return ARITH_INVALID_TYPE
;
428 result
= gfc_get_constant_expr (BT_LOGICAL
, op1
->ts
.kind
, &op1
->where
);
429 result
->value
.logical
= !op1
->value
.logical
;
437 gfc_arith_and (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
441 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
442 return ARITH_INVALID_TYPE
;
444 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
446 result
->value
.logical
= op1
->value
.logical
&& op2
->value
.logical
;
454 gfc_arith_or (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
458 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
459 return ARITH_INVALID_TYPE
;
461 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
463 result
->value
.logical
= op1
->value
.logical
|| op2
->value
.logical
;
471 gfc_arith_eqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
475 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
476 return ARITH_INVALID_TYPE
;
478 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
480 result
->value
.logical
= op1
->value
.logical
== op2
->value
.logical
;
488 gfc_arith_neqv (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
492 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
493 return ARITH_INVALID_TYPE
;
495 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_kind_max (op1
, op2
),
497 result
->value
.logical
= op1
->value
.logical
!= op2
->value
.logical
;
504 /* Make sure a constant numeric expression is within the range for
505 its type and kind. Note that there's also a gfc_check_range(),
506 but that one deals with the intrinsic RANGE function. */
509 gfc_range_check (gfc_expr
*e
)
517 rc
= gfc_check_integer_range (e
->value
.integer
, e
->ts
.kind
);
521 rc
= gfc_check_real_range (e
->value
.real
, e
->ts
.kind
);
522 if (rc
== ARITH_UNDERFLOW
)
523 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
524 if (rc
== ARITH_OVERFLOW
)
525 mpfr_set_inf (e
->value
.real
, mpfr_sgn (e
->value
.real
));
527 mpfr_set_nan (e
->value
.real
);
531 rc
= gfc_check_real_range (mpc_realref (e
->value
.complex), e
->ts
.kind
);
532 if (rc
== ARITH_UNDERFLOW
)
533 mpfr_set_ui (mpc_realref (e
->value
.complex), 0, GFC_RND_MODE
);
534 if (rc
== ARITH_OVERFLOW
)
535 mpfr_set_inf (mpc_realref (e
->value
.complex),
536 mpfr_sgn (mpc_realref (e
->value
.complex)));
538 mpfr_set_nan (mpc_realref (e
->value
.complex));
540 rc2
= gfc_check_real_range (mpc_imagref (e
->value
.complex), e
->ts
.kind
);
541 if (rc
== ARITH_UNDERFLOW
)
542 mpfr_set_ui (mpc_imagref (e
->value
.complex), 0, GFC_RND_MODE
);
543 if (rc
== ARITH_OVERFLOW
)
544 mpfr_set_inf (mpc_imagref (e
->value
.complex),
545 mpfr_sgn (mpc_imagref (e
->value
.complex)));
547 mpfr_set_nan (mpc_imagref (e
->value
.complex));
554 gfc_internal_error ("gfc_range_check(): Bad type");
561 /* Several of the following routines use the same set of statements to
562 check the validity of the result. Encapsulate the checking here. */
565 check_result (arith rc
, gfc_expr
*x
, gfc_expr
*r
, gfc_expr
**rp
)
569 if (val
== ARITH_UNDERFLOW
)
572 gfc_warning (OPT_Wunderflow
, gfc_arith_error (val
), &x
->where
);
576 if (val
== ARITH_ASYMMETRIC
)
578 gfc_warning (0, gfc_arith_error (val
), &x
->where
);
582 if (val
== ARITH_OK
|| val
== ARITH_OVERFLOW
)
591 /* It may seem silly to have a subroutine that actually computes the
592 unary plus of a constant, but it prevents us from making exceptions
593 in the code elsewhere. Used for unary plus and parenthesized
597 gfc_arith_identity (gfc_expr
*op1
, gfc_expr
**resultp
)
599 *resultp
= gfc_copy_expr (op1
);
605 gfc_arith_uminus (gfc_expr
*op1
, gfc_expr
**resultp
)
610 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
612 switch (op1
->ts
.type
)
615 mpz_neg (result
->value
.integer
, op1
->value
.integer
);
619 mpfr_neg (result
->value
.real
, op1
->value
.real
, GFC_RND_MODE
);
623 mpc_neg (result
->value
.complex, op1
->value
.complex, GFC_MPC_RND_MODE
);
627 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
630 rc
= gfc_range_check (result
);
632 return check_result (rc
, op1
, result
, resultp
);
637 gfc_arith_plus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
642 if (op1
->ts
.type
!= op2
->ts
.type
)
643 return ARITH_INVALID_TYPE
;
645 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
647 switch (op1
->ts
.type
)
650 mpz_add (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
654 mpfr_add (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
659 mpc_add (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
664 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
667 rc
= gfc_range_check (result
);
669 return check_result (rc
, op1
, result
, resultp
);
674 gfc_arith_minus (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
679 if (op1
->ts
.type
!= op2
->ts
.type
)
680 return ARITH_INVALID_TYPE
;
682 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
684 switch (op1
->ts
.type
)
687 mpz_sub (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
691 mpfr_sub (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
696 mpc_sub (result
->value
.complex, op1
->value
.complex,
697 op2
->value
.complex, GFC_MPC_RND_MODE
);
701 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
704 rc
= gfc_range_check (result
);
706 return check_result (rc
, op1
, result
, resultp
);
711 gfc_arith_times (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
716 if (op1
->ts
.type
!= op2
->ts
.type
)
717 return ARITH_INVALID_TYPE
;
719 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
721 switch (op1
->ts
.type
)
724 mpz_mul (result
->value
.integer
, op1
->value
.integer
, op2
->value
.integer
);
728 mpfr_mul (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
733 gfc_set_model (mpc_realref (op1
->value
.complex));
734 mpc_mul (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
739 gfc_internal_error ("gfc_arith_times(): Bad basic type");
742 rc
= gfc_range_check (result
);
744 return check_result (rc
, op1
, result
, resultp
);
749 gfc_arith_divide (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
754 if (op1
->ts
.type
!= op2
->ts
.type
)
755 return ARITH_INVALID_TYPE
;
759 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
761 switch (op1
->ts
.type
)
764 if (mpz_sgn (op2
->value
.integer
) == 0)
770 if (warn_integer_division
)
774 mpz_tdiv_qr (result
->value
.integer
, r
, op1
->value
.integer
,
777 if (mpz_cmp_si (r
, 0) != 0)
780 p
= mpz_get_str (NULL
, 10, result
->value
.integer
);
781 gfc_warning (OPT_Winteger_division
, "Integer division "
782 "truncated to constant %qs at %L", p
,
789 mpz_tdiv_q (result
->value
.integer
, op1
->value
.integer
,
795 if (mpfr_sgn (op2
->value
.real
) == 0 && flag_range_check
== 1)
801 mpfr_div (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
806 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0
807 && flag_range_check
== 1)
813 gfc_set_model (mpc_realref (op1
->value
.complex));
814 if (mpc_cmp_si_si (op2
->value
.complex, 0, 0) == 0)
816 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
818 mpfr_set_nan (mpc_realref (result
->value
.complex));
819 mpfr_set_nan (mpc_imagref (result
->value
.complex));
822 mpc_div (result
->value
.complex, op1
->value
.complex, op2
->value
.complex,
827 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
831 rc
= gfc_range_check (result
);
833 return check_result (rc
, op1
, result
, resultp
);
836 /* Raise a number to a power. */
839 arith_power (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
845 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
846 return ARITH_INVALID_TYPE
;
848 /* The result type is derived from op1 and must be compatible with the
849 result of the simplification. Otherwise postpone simplification until
850 after operand conversions usually done by gfc_type_convert_binary. */
851 if ((op1
->ts
.type
== BT_INTEGER
&& op2
->ts
.type
!= BT_INTEGER
)
852 || (op1
->ts
.type
== BT_REAL
&& op2
->ts
.type
== BT_COMPLEX
))
853 return ARITH_NOT_REDUCED
;
856 result
= gfc_get_constant_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
858 switch (op2
->ts
.type
)
861 power_sign
= mpz_sgn (op2
->value
.integer
);
865 /* Handle something to the zeroth power. Since we're dealing
866 with integral exponents, there is no ambiguity in the
867 limiting procedure used to determine the value of 0**0. */
868 switch (op1
->ts
.type
)
871 mpz_set_ui (result
->value
.integer
, 1);
875 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
879 mpc_set_ui (result
->value
.complex, 1, GFC_MPC_RND_MODE
);
883 gfc_internal_error ("arith_power(): Bad base");
888 switch (op1
->ts
.type
)
892 /* First, we simplify the cases of op1 == 1, 0 or -1. */
893 if (mpz_cmp_si (op1
->value
.integer
, 1) == 0)
896 mpz_set_si (result
->value
.integer
, 1);
898 else if (mpz_cmp_si (op1
->value
.integer
, 0) == 0)
900 /* 0**op2 == 0, if op2 > 0
901 0**op2 overflow, if op2 < 0 ; in that case, we
902 set the result to 0 and return ARITH_DIV0. */
903 mpz_set_si (result
->value
.integer
, 0);
904 if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
907 else if (mpz_cmp_si (op1
->value
.integer
, -1) == 0)
909 /* (-1)**op2 == (-1)**(mod(op2,2)) */
910 unsigned int odd
= mpz_fdiv_ui (op2
->value
.integer
, 2);
912 mpz_set_si (result
->value
.integer
, -1);
914 mpz_set_si (result
->value
.integer
, 1);
916 /* Then, we take care of op2 < 0. */
917 else if (mpz_cmp_si (op2
->value
.integer
, 0) < 0)
919 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
920 mpz_set_si (result
->value
.integer
, 0);
921 if (warn_integer_division
)
922 gfc_warning_now (OPT_Winteger_division
, "Negative "
923 "exponent of integer has zero "
924 "result at %L", &result
->where
);
928 /* We have abs(op1) > 1 and op2 > 1.
929 If op2 > bit_size(op1), we'll have an out-of-range
933 k
= gfc_validate_kind (BT_INTEGER
, op1
->ts
.kind
, false);
934 power
= gfc_integer_kinds
[k
].bit_size
;
935 if (mpz_cmp_si (op2
->value
.integer
, power
) < 0)
937 gfc_extract_int (op2
, &power
);
938 mpz_pow_ui (result
->value
.integer
, op1
->value
.integer
,
940 rc
= gfc_range_check (result
);
941 if (rc
== ARITH_OVERFLOW
)
942 gfc_error_now ("Result of exponentiation at %L "
943 "exceeds the range of %s", &op1
->where
,
944 gfc_typename (&(op1
->ts
)));
948 /* Provide a nonsense value to propagate up. */
949 mpz_set (result
->value
.integer
,
950 gfc_integer_kinds
[k
].huge
);
951 mpz_add_ui (result
->value
.integer
,
952 result
->value
.integer
, 1);
960 mpfr_pow_z (result
->value
.real
, op1
->value
.real
,
961 op2
->value
.integer
, GFC_RND_MODE
);
965 mpc_pow_z (result
->value
.complex, op1
->value
.complex,
966 op2
->value
.integer
, GFC_MPC_RND_MODE
);
977 if (gfc_init_expr_flag
)
979 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
980 "exponent in an initialization "
981 "expression at %L", &op2
->where
))
983 gfc_free_expr (result
);
984 return ARITH_PROHIBIT
;
988 if (mpfr_cmp_si (op1
->value
.real
, 0) < 0)
990 gfc_error ("Raising a negative REAL at %L to "
991 "a REAL power is prohibited", &op1
->where
);
992 gfc_free_expr (result
);
993 return ARITH_PROHIBIT
;
996 mpfr_pow (result
->value
.real
, op1
->value
.real
, op2
->value
.real
,
1002 if (gfc_init_expr_flag
)
1004 if (!gfc_notify_std (GFC_STD_F2003
, "Noninteger "
1005 "exponent in an initialization "
1006 "expression at %L", &op2
->where
))
1008 gfc_free_expr (result
);
1009 return ARITH_PROHIBIT
;
1013 mpc_pow (result
->value
.complex, op1
->value
.complex,
1014 op2
->value
.complex, GFC_MPC_RND_MODE
);
1018 gfc_internal_error ("arith_power(): unknown type");
1022 rc
= gfc_range_check (result
);
1024 return check_result (rc
, op1
, result
, resultp
);
1028 /* Concatenate two string constants. */
1031 gfc_arith_concat (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1036 /* By cleverly playing around with constructors, it is possible
1037 to get mismatching types here. */
1038 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1039 || op1
->ts
.kind
!= op2
->ts
.kind
)
1040 return ARITH_WRONGCONCAT
;
1042 result
= gfc_get_constant_expr (BT_CHARACTER
, op1
->ts
.kind
,
1045 len
= op1
->value
.character
.length
+ op2
->value
.character
.length
;
1047 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
1048 result
->value
.character
.length
= len
;
1050 memcpy (result
->value
.character
.string
, op1
->value
.character
.string
,
1051 op1
->value
.character
.length
* sizeof (gfc_char_t
));
1053 memcpy (&result
->value
.character
.string
[op1
->value
.character
.length
],
1054 op2
->value
.character
.string
,
1055 op2
->value
.character
.length
* sizeof (gfc_char_t
));
1057 result
->value
.character
.string
[len
] = '\0';
1064 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1065 This function mimics mpfr_cmp but takes NaN into account. */
1068 compare_real (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1074 rc
= mpfr_equal_p (op1
->value
.real
, op2
->value
.real
) ? 0 : 1;
1077 rc
= mpfr_greater_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1080 rc
= mpfr_greaterequal_p (op1
->value
.real
, op2
->value
.real
) ? 1 : -1;
1083 rc
= mpfr_less_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1086 rc
= mpfr_lessequal_p (op1
->value
.real
, op2
->value
.real
) ? -1 : 1;
1089 gfc_internal_error ("compare_real(): Bad operator");
1095 /* Comparison operators. Assumes that the two expression nodes
1096 contain two constants of the same type. The op argument is
1097 needed to handle NaN correctly. */
1100 gfc_compare_expr (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1104 switch (op1
->ts
.type
)
1107 rc
= mpz_cmp (op1
->value
.integer
, op2
->value
.integer
);
1111 rc
= compare_real (op1
, op2
, op
);
1115 rc
= gfc_compare_string (op1
, op2
);
1119 rc
= ((!op1
->value
.logical
&& op2
->value
.logical
)
1120 || (op1
->value
.logical
&& !op2
->value
.logical
));
1124 gcc_assert (op
== INTRINSIC_EQ
);
1125 rc
= mpc_cmp (op1
->value
.complex, op2
->value
.complex);
1129 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1136 /* Compare a pair of complex numbers. Naturally, this is only for
1137 equality and inequality. */
1140 compare_complex (gfc_expr
*op1
, gfc_expr
*op2
)
1142 return mpc_cmp (op1
->value
.complex, op2
->value
.complex) == 0;
1146 /* Given two constant strings and the inverse collating sequence, compare the
1147 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1148 We use the processor's default collating sequence. */
1151 gfc_compare_string (gfc_expr
*a
, gfc_expr
*b
)
1153 size_t len
, alen
, blen
, i
;
1156 alen
= a
->value
.character
.length
;
1157 blen
= b
->value
.character
.length
;
1159 len
= MAX(alen
, blen
);
1161 for (i
= 0; i
< len
; i
++)
1163 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1164 bc
= ((i
< blen
) ? b
->value
.character
.string
[i
] : ' ');
1172 /* Strings are equal */
1178 gfc_compare_with_Cstring (gfc_expr
*a
, const char *b
, bool case_sensitive
)
1180 size_t len
, alen
, blen
, i
;
1183 alen
= a
->value
.character
.length
;
1186 len
= MAX(alen
, blen
);
1188 for (i
= 0; i
< len
; i
++)
1190 ac
= ((i
< alen
) ? a
->value
.character
.string
[i
] : ' ');
1191 bc
= ((i
< blen
) ? b
[i
] : ' ');
1193 if (!case_sensitive
)
1205 /* Strings are equal */
1210 /* Specific comparison subroutines. */
1213 gfc_arith_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1217 if (op1
->ts
.type
!= op2
->ts
.type
)
1218 return ARITH_INVALID_TYPE
;
1220 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1222 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1223 ? compare_complex (op1
, op2
)
1224 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) == 0);
1232 gfc_arith_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1236 if (op1
->ts
.type
!= op2
->ts
.type
)
1237 return ARITH_INVALID_TYPE
;
1239 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1241 result
->value
.logical
= (op1
->ts
.type
== BT_COMPLEX
)
1242 ? !compare_complex (op1
, op2
)
1243 : (gfc_compare_expr (op1
, op2
, INTRINSIC_EQ
) != 0);
1251 gfc_arith_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1255 if (op1
->ts
.type
!= op2
->ts
.type
)
1256 return ARITH_INVALID_TYPE
;
1258 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1260 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GT
) > 0);
1268 gfc_arith_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1272 if (op1
->ts
.type
!= op2
->ts
.type
)
1273 return ARITH_INVALID_TYPE
;
1275 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1277 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_GE
) >= 0);
1285 gfc_arith_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1289 if (op1
->ts
.type
!= op2
->ts
.type
)
1290 return ARITH_INVALID_TYPE
;
1292 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1294 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LT
) < 0);
1302 gfc_arith_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**resultp
)
1306 if (op1
->ts
.type
!= op2
->ts
.type
)
1307 return ARITH_INVALID_TYPE
;
1309 result
= gfc_get_constant_expr (BT_LOGICAL
, gfc_default_logical_kind
,
1311 result
->value
.logical
= (gfc_compare_expr (op1
, op2
, INTRINSIC_LE
) <= 0);
1319 reduce_unary (arith (*eval
) (gfc_expr
*, gfc_expr
**), gfc_expr
*op
,
1322 gfc_constructor_base head
;
1327 if (op
->expr_type
== EXPR_CONSTANT
)
1328 return eval (op
, result
);
1330 if (op
->expr_type
!= EXPR_ARRAY
)
1331 return ARITH_NOT_REDUCED
;
1334 head
= gfc_constructor_copy (op
->value
.constructor
);
1335 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1337 rc
= reduce_unary (eval
, c
->expr
, &r
);
1342 gfc_replace_expr (c
->expr
, r
);
1346 gfc_constructor_free (head
);
1349 gfc_constructor
*c
= gfc_constructor_first (head
);
1352 /* Handle zero-sized arrays. */
1353 r
= gfc_get_array_expr (op
->ts
.type
, op
->ts
.kind
, &op
->where
);
1357 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1360 r
->shape
= gfc_copy_shape (op
->shape
, op
->rank
);
1362 r
->value
.constructor
= head
;
1371 reduce_binary_ac (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1372 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1374 gfc_constructor_base head
;
1377 arith rc
= ARITH_OK
;
1379 head
= gfc_constructor_copy (op1
->value
.constructor
);
1380 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1382 gfc_simplify_expr (c
->expr
, 0);
1384 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1385 rc
= eval (c
->expr
, op2
, &r
);
1386 else if (c
->expr
->expr_type
!= EXPR_ARRAY
)
1387 rc
= ARITH_NOT_REDUCED
;
1389 rc
= reduce_binary_ac (eval
, c
->expr
, op2
, &r
);
1394 gfc_replace_expr (c
->expr
, r
);
1398 gfc_constructor_free (head
);
1401 gfc_constructor
*c
= gfc_constructor_first (head
);
1404 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1406 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1410 gcc_assert (op1
->ts
.type
!= BT_UNKNOWN
);
1411 r
= gfc_get_array_expr (op1
->ts
.type
, op1
->ts
.kind
,
1413 r
->shape
= gfc_get_shape (op1
->rank
);
1415 r
->rank
= op1
->rank
;
1416 r
->value
.constructor
= head
;
1425 reduce_binary_ca (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1426 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1428 gfc_constructor_base head
;
1431 arith rc
= ARITH_OK
;
1433 head
= gfc_constructor_copy (op2
->value
.constructor
);
1434 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1436 gfc_simplify_expr (c
->expr
, 0);
1438 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1439 rc
= eval (op1
, c
->expr
, &r
);
1440 else if (c
->expr
->expr_type
!= EXPR_ARRAY
)
1441 rc
= ARITH_NOT_REDUCED
;
1443 rc
= reduce_binary_ca (eval
, op1
, c
->expr
, &r
);
1448 gfc_replace_expr (c
->expr
, r
);
1452 gfc_constructor_free (head
);
1455 gfc_constructor
*c
= gfc_constructor_first (head
);
1458 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1460 r
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1464 gcc_assert (op2
->ts
.type
!= BT_UNKNOWN
);
1465 r
= gfc_get_array_expr (op2
->ts
.type
, op2
->ts
.kind
,
1467 r
->shape
= gfc_get_shape (op2
->rank
);
1469 r
->rank
= op2
->rank
;
1470 r
->value
.constructor
= head
;
1478 /* We need a forward declaration of reduce_binary. */
1479 static arith
reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1480 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
);
1484 reduce_binary_aa (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1485 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1487 gfc_constructor_base head
;
1488 gfc_constructor
*c
, *d
;
1490 arith rc
= ARITH_OK
;
1492 if (!gfc_check_conformance (op1
, op2
, _("elemental binary operation")))
1493 return ARITH_INCOMMENSURATE
;
1495 head
= gfc_constructor_copy (op1
->value
.constructor
);
1496 for (c
= gfc_constructor_first (head
),
1497 d
= gfc_constructor_first (op2
->value
.constructor
);
1499 c
= gfc_constructor_next (c
), d
= gfc_constructor_next (d
))
1501 rc
= reduce_binary (eval
, c
->expr
, d
->expr
, &r
);
1506 gfc_replace_expr (c
->expr
, r
);
1509 if (rc
== ARITH_OK
&& (c
|| d
))
1510 rc
= ARITH_INCOMMENSURATE
;
1513 gfc_constructor_free (head
);
1516 gfc_constructor
*c
= gfc_constructor_first (head
);
1519 /* Handle zero-sized arrays. */
1520 r
= gfc_get_array_expr (op1
->ts
.type
, op1
->ts
.kind
, &op1
->where
);
1524 r
= gfc_get_array_expr (c
->expr
->ts
.type
, c
->expr
->ts
.kind
,
1527 r
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1528 r
->rank
= op1
->rank
;
1529 r
->value
.constructor
= head
;
1538 reduce_binary (arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1539 gfc_expr
*op1
, gfc_expr
*op2
, gfc_expr
**result
)
1541 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_CONSTANT
)
1542 return eval (op1
, op2
, result
);
1544 if (op1
->expr_type
== EXPR_CONSTANT
&& op2
->expr_type
== EXPR_ARRAY
)
1545 return reduce_binary_ca (eval
, op1
, op2
, result
);
1547 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->expr_type
== EXPR_CONSTANT
)
1548 return reduce_binary_ac (eval
, op1
, op2
, result
);
1550 if (op1
->expr_type
!= EXPR_ARRAY
|| op2
->expr_type
!= EXPR_ARRAY
)
1551 return ARITH_NOT_REDUCED
;
1553 return reduce_binary_aa (eval
, op1
, op2
, result
);
1559 arith (*f2
)(gfc_expr
*, gfc_expr
**);
1560 arith (*f3
)(gfc_expr
*, gfc_expr
*, gfc_expr
**);
1564 /* High level arithmetic subroutines. These subroutines go into
1565 eval_intrinsic(), which can do one of several things to its
1566 operands. If the operands are incompatible with the intrinsic
1567 operation, we return a node pointing to the operands and hope that
1568 an operator interface is found during resolution.
1570 If the operands are compatible and are constants, then we try doing
1571 the arithmetic. We also handle the cases where either or both
1572 operands are array constructors. */
1575 eval_intrinsic (gfc_intrinsic_op op
,
1576 eval_f eval
, gfc_expr
*op1
, gfc_expr
*op2
)
1578 gfc_expr temp
, *result
;
1585 gfc_clear_ts (&temp
.ts
);
1591 if (op1
->ts
.type
!= BT_LOGICAL
)
1594 temp
.ts
.type
= BT_LOGICAL
;
1595 temp
.ts
.kind
= gfc_default_logical_kind
;
1599 /* Logical binary operators */
1602 case INTRINSIC_NEQV
:
1604 if (op1
->ts
.type
!= BT_LOGICAL
|| op2
->ts
.type
!= BT_LOGICAL
)
1607 temp
.ts
.type
= BT_LOGICAL
;
1608 temp
.ts
.kind
= gfc_default_logical_kind
;
1613 case INTRINSIC_UPLUS
:
1614 case INTRINSIC_UMINUS
:
1615 if (!gfc_numeric_ts (&op1
->ts
))
1622 case INTRINSIC_PARENTHESES
:
1627 /* Additional restrictions for ordering relations. */
1629 case INTRINSIC_GE_OS
:
1631 case INTRINSIC_LT_OS
:
1633 case INTRINSIC_LE_OS
:
1635 case INTRINSIC_GT_OS
:
1636 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1638 temp
.ts
.type
= BT_LOGICAL
;
1639 temp
.ts
.kind
= gfc_default_logical_kind
;
1645 case INTRINSIC_EQ_OS
:
1647 case INTRINSIC_NE_OS
:
1648 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1651 temp
.ts
.type
= BT_LOGICAL
;
1652 temp
.ts
.kind
= gfc_default_logical_kind
;
1654 /* If kind mismatch, exit and we'll error out later. */
1655 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1662 /* Numeric binary */
1663 case INTRINSIC_PLUS
:
1664 case INTRINSIC_MINUS
:
1665 case INTRINSIC_TIMES
:
1666 case INTRINSIC_DIVIDE
:
1667 case INTRINSIC_POWER
:
1668 if (!gfc_numeric_ts (&op1
->ts
) || !gfc_numeric_ts (&op2
->ts
))
1671 /* Do not perform conversions if operands are not conformable as
1672 required for the binary intrinsic operators (F2018:10.1.5).
1673 Defer to a possibly overloading user-defined operator. */
1674 if (!gfc_op_rank_conformable (op1
, op2
))
1677 /* Insert any necessary type conversions to make the operands
1680 temp
.expr_type
= EXPR_OP
;
1681 gfc_clear_ts (&temp
.ts
);
1682 temp
.value
.op
.op
= op
;
1684 temp
.value
.op
.op1
= op1
;
1685 temp
.value
.op
.op2
= op2
;
1687 gfc_type_convert_binary (&temp
, warn_conversion
|| warn_conversion_extra
);
1689 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
1690 || op
== INTRINSIC_GE
|| op
== INTRINSIC_GT
1691 || op
== INTRINSIC_LE
|| op
== INTRINSIC_LT
1692 || op
== INTRINSIC_EQ_OS
|| op
== INTRINSIC_NE_OS
1693 || op
== INTRINSIC_GE_OS
|| op
== INTRINSIC_GT_OS
1694 || op
== INTRINSIC_LE_OS
|| op
== INTRINSIC_LT_OS
)
1696 temp
.ts
.type
= BT_LOGICAL
;
1697 temp
.ts
.kind
= gfc_default_logical_kind
;
1703 /* Character binary */
1704 case INTRINSIC_CONCAT
:
1705 if (op1
->ts
.type
!= BT_CHARACTER
|| op2
->ts
.type
!= BT_CHARACTER
1706 || op1
->ts
.kind
!= op2
->ts
.kind
)
1709 temp
.ts
.type
= BT_CHARACTER
;
1710 temp
.ts
.kind
= op1
->ts
.kind
;
1714 case INTRINSIC_USER
:
1718 gfc_internal_error ("eval_intrinsic(): Bad operator");
1721 if (op1
->expr_type
!= EXPR_CONSTANT
1722 && (op1
->expr_type
!= EXPR_ARRAY
1723 || !gfc_is_constant_expr (op1
) || !gfc_expanded_ac (op1
)))
1727 && op2
->expr_type
!= EXPR_CONSTANT
1728 && (op2
->expr_type
!= EXPR_ARRAY
1729 || !gfc_is_constant_expr (op2
) || !gfc_expanded_ac (op2
)))
1733 rc
= reduce_unary (eval
.f2
, op1
, &result
);
1735 rc
= reduce_binary (eval
.f3
, op1
, op2
, &result
);
1737 if (rc
== ARITH_INVALID_TYPE
|| rc
== ARITH_NOT_REDUCED
)
1740 /* Something went wrong. */
1741 if (op
== INTRINSIC_POWER
&& rc
== ARITH_PROHIBIT
)
1746 gfc_error (gfc_arith_error (rc
), &op1
->where
);
1747 if (rc
== ARITH_OVERFLOW
)
1750 if (rc
== ARITH_DIV0
&& op2
->ts
.type
== BT_INTEGER
)
1751 gfc_seen_div0
= true;
1758 gfc_free_expr (op1
);
1759 gfc_free_expr (op2
);
1763 /* Create a run-time expression. */
1764 result
= gfc_get_operator_expr (&op1
->where
, op
, op1
, op2
);
1765 result
->ts
= temp
.ts
;
1771 /* Modify type of expression for zero size array. */
1774 eval_type_intrinsic0 (gfc_intrinsic_op iop
, gfc_expr
*op
)
1777 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1782 case INTRINSIC_GE_OS
:
1784 case INTRINSIC_LT_OS
:
1786 case INTRINSIC_LE_OS
:
1788 case INTRINSIC_GT_OS
:
1790 case INTRINSIC_EQ_OS
:
1792 case INTRINSIC_NE_OS
:
1793 op
->ts
.type
= BT_LOGICAL
;
1794 op
->ts
.kind
= gfc_default_logical_kind
;
1805 /* Return nonzero if the expression is a zero size array. */
1808 gfc_zero_size_array (gfc_expr
*e
)
1810 if (e
== NULL
|| e
->expr_type
!= EXPR_ARRAY
)
1813 return e
->value
.constructor
== NULL
;
1817 /* Reduce a binary expression where at least one of the operands
1818 involves a zero-length array. Returns NULL if neither of the
1819 operands is a zero-length array. */
1822 reduce_binary0 (gfc_expr
*op1
, gfc_expr
*op2
)
1824 if (gfc_zero_size_array (op1
))
1826 gfc_free_expr (op2
);
1830 if (gfc_zero_size_array (op2
))
1832 gfc_free_expr (op1
);
1841 eval_intrinsic_f2 (gfc_intrinsic_op op
,
1842 arith (*eval
) (gfc_expr
*, gfc_expr
**),
1843 gfc_expr
*op1
, gfc_expr
*op2
)
1850 if (gfc_zero_size_array (op1
))
1851 return eval_type_intrinsic0 (op
, op1
);
1855 result
= reduce_binary0 (op1
, op2
);
1857 return eval_type_intrinsic0 (op
, result
);
1861 return eval_intrinsic (op
, f
, op1
, op2
);
1866 eval_intrinsic_f3 (gfc_intrinsic_op op
,
1867 arith (*eval
) (gfc_expr
*, gfc_expr
*, gfc_expr
**),
1868 gfc_expr
*op1
, gfc_expr
*op2
)
1876 result
= reduce_binary0 (op1
, op2
);
1878 return eval_type_intrinsic0(op
, result
);
1881 return eval_intrinsic (op
, f
, op1
, op2
);
1886 gfc_parentheses (gfc_expr
*op
)
1888 if (gfc_is_constant_expr (op
))
1891 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES
, gfc_arith_identity
,
1896 gfc_uplus (gfc_expr
*op
)
1898 return eval_intrinsic_f2 (INTRINSIC_UPLUS
, gfc_arith_identity
, op
, NULL
);
1903 gfc_uminus (gfc_expr
*op
)
1905 return eval_intrinsic_f2 (INTRINSIC_UMINUS
, gfc_arith_uminus
, op
, NULL
);
1910 gfc_add (gfc_expr
*op1
, gfc_expr
*op2
)
1912 return eval_intrinsic_f3 (INTRINSIC_PLUS
, gfc_arith_plus
, op1
, op2
);
1917 gfc_subtract (gfc_expr
*op1
, gfc_expr
*op2
)
1919 return eval_intrinsic_f3 (INTRINSIC_MINUS
, gfc_arith_minus
, op1
, op2
);
1924 gfc_multiply (gfc_expr
*op1
, gfc_expr
*op2
)
1926 return eval_intrinsic_f3 (INTRINSIC_TIMES
, gfc_arith_times
, op1
, op2
);
1931 gfc_divide (gfc_expr
*op1
, gfc_expr
*op2
)
1933 return eval_intrinsic_f3 (INTRINSIC_DIVIDE
, gfc_arith_divide
, op1
, op2
);
1938 gfc_power (gfc_expr
*op1
, gfc_expr
*op2
)
1940 return eval_intrinsic_f3 (INTRINSIC_POWER
, arith_power
, op1
, op2
);
1945 gfc_concat (gfc_expr
*op1
, gfc_expr
*op2
)
1947 return eval_intrinsic_f3 (INTRINSIC_CONCAT
, gfc_arith_concat
, op1
, op2
);
1952 gfc_and (gfc_expr
*op1
, gfc_expr
*op2
)
1954 return eval_intrinsic_f3 (INTRINSIC_AND
, gfc_arith_and
, op1
, op2
);
1959 gfc_or (gfc_expr
*op1
, gfc_expr
*op2
)
1961 return eval_intrinsic_f3 (INTRINSIC_OR
, gfc_arith_or
, op1
, op2
);
1966 gfc_not (gfc_expr
*op1
)
1968 return eval_intrinsic_f2 (INTRINSIC_NOT
, gfc_arith_not
, op1
, NULL
);
1973 gfc_eqv (gfc_expr
*op1
, gfc_expr
*op2
)
1975 return eval_intrinsic_f3 (INTRINSIC_EQV
, gfc_arith_eqv
, op1
, op2
);
1980 gfc_neqv (gfc_expr
*op1
, gfc_expr
*op2
)
1982 return eval_intrinsic_f3 (INTRINSIC_NEQV
, gfc_arith_neqv
, op1
, op2
);
1987 gfc_eq (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1989 return eval_intrinsic_f3 (op
, gfc_arith_eq
, op1
, op2
);
1994 gfc_ne (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
1996 return eval_intrinsic_f3 (op
, gfc_arith_ne
, op1
, op2
);
2001 gfc_gt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
2003 return eval_intrinsic_f3 (op
, gfc_arith_gt
, op1
, op2
);
2008 gfc_ge (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
2010 return eval_intrinsic_f3 (op
, gfc_arith_ge
, op1
, op2
);
2015 gfc_lt (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
2017 return eval_intrinsic_f3 (op
, gfc_arith_lt
, op1
, op2
);
2022 gfc_le (gfc_expr
*op1
, gfc_expr
*op2
, gfc_intrinsic_op op
)
2024 return eval_intrinsic_f3 (op
, gfc_arith_le
, op1
, op2
);
2028 /******* Simplification of intrinsic functions with constant arguments *****/
2031 /* Deal with an arithmetic error. */
2034 arith_error (arith rc
, gfc_typespec
*from
, gfc_typespec
*to
, locus
*where
)
2039 gfc_error ("Arithmetic OK converting %s to %s at %L",
2040 gfc_typename (from
), gfc_typename (to
), where
);
2042 case ARITH_OVERFLOW
:
2043 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2044 "can be disabled with the option %<-fno-range-check%>",
2045 gfc_typename (from
), gfc_typename (to
), where
);
2047 case ARITH_UNDERFLOW
:
2048 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
2049 "can be disabled with the option %<-fno-range-check%>",
2050 gfc_typename (from
), gfc_typename (to
), where
);
2053 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
2054 "can be disabled with the option %<-fno-range-check%>",
2055 gfc_typename (from
), gfc_typename (to
), where
);
2058 gfc_error ("Division by zero converting %s to %s at %L",
2059 gfc_typename (from
), gfc_typename (to
), where
);
2061 case ARITH_INCOMMENSURATE
:
2062 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2063 gfc_typename (from
), gfc_typename (to
), where
);
2065 case ARITH_ASYMMETRIC
:
2066 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2067 " converting %s to %s at %L",
2068 gfc_typename (from
), gfc_typename (to
), where
);
2071 gfc_internal_error ("gfc_arith_error(): Bad error code");
2074 /* TODO: Do something about the error, i.e., throw exception, return
2078 /* Returns true if significant bits were lost when converting real
2079 constant r from from_kind to to_kind. */
2082 wprecision_real_real (mpfr_t r
, int from_kind
, int to_kind
)
2087 gfc_set_model_kind (to_kind
);
2089 gfc_set_model_kind (from_kind
);
2092 mpfr_set (rv
, r
, GFC_RND_MODE
);
2093 mpfr_sub (diff
, rv
, r
, GFC_RND_MODE
);
2095 ret
= ! mpfr_zero_p (diff
);
2101 /* Return true if conversion from an integer to a real loses precision. */
2104 wprecision_int_real (mpz_t n
, mpfr_t r
)
2109 mpfr_get_z (i
, r
, GFC_RND_MODE
);
2111 ret
= mpz_cmp_si (i
, 0) != 0;
2116 /* Convert integers to integers. */
2119 gfc_int2int (gfc_expr
*src
, int kind
)
2124 if (src
->ts
.type
!= BT_INTEGER
)
2127 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2129 mpz_set (result
->value
.integer
, src
->value
.integer
);
2131 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2133 if (rc
== ARITH_ASYMMETRIC
)
2135 gfc_warning (0, gfc_arith_error (rc
), &src
->where
);
2139 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2140 gfc_free_expr (result
);
2145 /* If we do not trap numeric overflow, we need to convert the number to
2146 signed, throwing away high-order bits if necessary. */
2147 if (flag_range_check
== 0)
2151 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
2152 gfc_convert_mpz_to_signed (result
->value
.integer
,
2153 gfc_integer_kinds
[k
].bit_size
);
2155 if (warn_conversion
&& !src
->do_not_warn
&& kind
< src
->ts
.kind
)
2156 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2157 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2164 /* Convert integers to reals. */
2167 gfc_int2real (gfc_expr
*src
, int kind
)
2172 if (src
->ts
.type
!= BT_INTEGER
)
2175 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2177 mpfr_set_z (result
->value
.real
, src
->value
.integer
, GFC_RND_MODE
);
2179 if ((rc
= gfc_check_real_range (result
->value
.real
, kind
)) != ARITH_OK
)
2181 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2182 gfc_free_expr (result
);
2187 && wprecision_int_real (src
->value
.integer
, result
->value
.real
))
2188 gfc_warning (OPT_Wconversion
, "Change of value in conversion "
2189 "from %qs to %qs at %L",
2190 gfc_typename (&src
->ts
),
2191 gfc_typename (&result
->ts
),
2198 /* Convert default integer to default complex. */
2201 gfc_int2complex (gfc_expr
*src
, int kind
)
2206 if (src
->ts
.type
!= BT_INTEGER
)
2209 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2211 mpc_set_z (result
->value
.complex, src
->value
.integer
, GFC_MPC_RND_MODE
);
2213 if ((rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
))
2216 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2217 gfc_free_expr (result
);
2222 && wprecision_int_real (src
->value
.integer
,
2223 mpc_realref (result
->value
.complex)))
2224 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2225 "from %qs to %qs at %L",
2226 gfc_typename (&src
->ts
),
2227 gfc_typename (&result
->ts
),
2234 /* Convert default real to default integer. */
2237 gfc_real2int (gfc_expr
*src
, int kind
)
2241 bool did_warn
= false;
2243 if (src
->ts
.type
!= BT_REAL
)
2246 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2248 gfc_mpfr_to_mpz (result
->value
.integer
, src
->value
.real
, &src
->where
);
2250 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2252 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2253 gfc_free_expr (result
);
2257 /* If there was a fractional part, warn about this. */
2259 if (warn_conversion
)
2263 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2264 if (mpfr_cmp_si (f
, 0) != 0)
2266 gfc_warning_now (OPT_Wconversion
, "Change of value in conversion "
2267 "from %qs to %qs at %L", gfc_typename (&src
->ts
),
2268 gfc_typename (&result
->ts
), &src
->where
);
2273 if (!did_warn
&& warn_conversion_extra
)
2275 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2276 "at %L", gfc_typename (&src
->ts
),
2277 gfc_typename (&result
->ts
), &src
->where
);
2284 /* Convert real to real. */
2287 gfc_real2real (gfc_expr
*src
, int kind
)
2291 bool did_warn
= false;
2293 if (src
->ts
.type
!= BT_REAL
)
2296 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2298 mpfr_set (result
->value
.real
, src
->value
.real
, GFC_RND_MODE
);
2300 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2302 if (rc
== ARITH_UNDERFLOW
)
2305 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2306 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2308 else if (rc
!= ARITH_OK
)
2310 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2311 gfc_free_expr (result
);
2315 /* As a special bonus, don't warn about REAL values which are not changed by
2316 the conversion if -Wconversion is specified and -Wconversion-extra is
2319 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2321 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2323 /* Calculate the difference between the constant and the rounded
2324 value and check it against zero. */
2326 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2328 gfc_warning_now (w
, "Change of value in conversion from "
2330 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2332 /* Make sure the conversion warning is not emitted again. */
2337 if (!did_warn
&& warn_conversion_extra
)
2338 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2339 "at %L", gfc_typename(&src
->ts
),
2340 gfc_typename(&result
->ts
), &src
->where
);
2346 /* Convert real to complex. */
2349 gfc_real2complex (gfc_expr
*src
, int kind
)
2353 bool did_warn
= false;
2355 if (src
->ts
.type
!= BT_REAL
)
2358 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2360 mpc_set_fr (result
->value
.complex, src
->value
.real
, GFC_MPC_RND_MODE
);
2362 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2364 if (rc
== ARITH_UNDERFLOW
)
2367 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2368 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2370 else if (rc
!= ARITH_OK
)
2372 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2373 gfc_free_expr (result
);
2377 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
)
2379 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2381 if (wprecision_real_real (src
->value
.real
, src
->ts
.kind
, kind
))
2383 gfc_warning_now (w
, "Change of value in conversion from "
2385 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2387 /* Make sure the conversion warning is not emitted again. */
2392 if (!did_warn
&& warn_conversion_extra
)
2393 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2394 "at %L", gfc_typename(&src
->ts
),
2395 gfc_typename(&result
->ts
), &src
->where
);
2401 /* Convert complex to integer. */
2404 gfc_complex2int (gfc_expr
*src
, int kind
)
2408 bool did_warn
= false;
2410 if (src
->ts
.type
!= BT_COMPLEX
)
2413 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2415 gfc_mpfr_to_mpz (result
->value
.integer
, mpc_realref (src
->value
.complex),
2418 if ((rc
= gfc_check_integer_range (result
->value
.integer
, kind
)) != ARITH_OK
)
2420 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2421 gfc_free_expr (result
);
2425 if (warn_conversion
|| warn_conversion_extra
)
2427 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2429 /* See if we discarded an imaginary part. */
2430 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2432 gfc_warning_now (w
, "Non-zero imaginary part discarded "
2433 "in conversion from %qs to %qs at %L",
2434 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2443 mpfr_frac (f
, src
->value
.real
, GFC_RND_MODE
);
2444 if (mpfr_cmp_si (f
, 0) != 0)
2446 gfc_warning_now (w
, "Change of value in conversion from "
2447 "%qs to %qs at %L", gfc_typename (&src
->ts
),
2448 gfc_typename (&result
->ts
), &src
->where
);
2454 if (!did_warn
&& warn_conversion_extra
)
2456 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2457 "at %L", gfc_typename (&src
->ts
),
2458 gfc_typename (&result
->ts
), &src
->where
);
2466 /* Convert complex to real. */
2469 gfc_complex2real (gfc_expr
*src
, int kind
)
2473 bool did_warn
= false;
2475 if (src
->ts
.type
!= BT_COMPLEX
)
2478 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2480 mpc_real (result
->value
.real
, src
->value
.complex, GFC_RND_MODE
);
2482 rc
= gfc_check_real_range (result
->value
.real
, kind
);
2484 if (rc
== ARITH_UNDERFLOW
)
2487 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2488 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2492 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2493 gfc_free_expr (result
);
2497 if (warn_conversion
|| warn_conversion_extra
)
2499 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2501 /* See if we discarded an imaginary part. */
2502 if (mpfr_cmp_si (mpc_imagref (src
->value
.complex), 0) != 0)
2504 gfc_warning (w
, "Non-zero imaginary part discarded "
2505 "in conversion from %qs to %qs at %L",
2506 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2511 /* Calculate the difference between the real constant and the rounded
2512 value and check it against zero. */
2514 if (kind
> src
->ts
.kind
2515 && wprecision_real_real (mpc_realref (src
->value
.complex),
2516 src
->ts
.kind
, kind
))
2518 gfc_warning_now (w
, "Change of value in conversion from "
2520 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2522 /* Make sure the conversion warning is not emitted again. */
2527 if (!did_warn
&& warn_conversion_extra
)
2528 gfc_warning_now (OPT_Wconversion
, "Conversion from %qs to %qs at %L",
2529 gfc_typename(&src
->ts
), gfc_typename (&result
->ts
),
2536 /* Convert complex to complex. */
2539 gfc_complex2complex (gfc_expr
*src
, int kind
)
2543 bool did_warn
= false;
2545 if (src
->ts
.type
!= BT_COMPLEX
)
2548 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2550 mpc_set (result
->value
.complex, src
->value
.complex, GFC_MPC_RND_MODE
);
2552 rc
= gfc_check_real_range (mpc_realref (result
->value
.complex), kind
);
2554 if (rc
== ARITH_UNDERFLOW
)
2557 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2558 mpfr_set_ui (mpc_realref (result
->value
.complex), 0, GFC_RND_MODE
);
2560 else if (rc
!= ARITH_OK
)
2562 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2563 gfc_free_expr (result
);
2567 rc
= gfc_check_real_range (mpc_imagref (result
->value
.complex), kind
);
2569 if (rc
== ARITH_UNDERFLOW
)
2572 gfc_warning (OPT_Woverflow
, gfc_arith_error (rc
), &src
->where
);
2573 mpfr_set_ui (mpc_imagref (result
->value
.complex), 0, GFC_RND_MODE
);
2575 else if (rc
!= ARITH_OK
)
2577 arith_error (rc
, &src
->ts
, &result
->ts
, &src
->where
);
2578 gfc_free_expr (result
);
2582 if ((warn_conversion
|| warn_conversion_extra
) && src
->ts
.kind
> kind
2583 && (wprecision_real_real (mpc_realref (src
->value
.complex),
2585 || wprecision_real_real (mpc_imagref (src
->value
.complex),
2586 src
->ts
.kind
, kind
)))
2588 int w
= warn_conversion
? OPT_Wconversion
: OPT_Wconversion_extra
;
2590 gfc_warning_now (w
, "Change of value in conversion from "
2592 gfc_typename (&src
->ts
), gfc_typename (&result
->ts
),
2597 if (!did_warn
&& warn_conversion_extra
&& src
->ts
.kind
!= kind
)
2598 gfc_warning_now (OPT_Wconversion_extra
, "Conversion from %qs to %qs "
2599 "at %L", gfc_typename(&src
->ts
),
2600 gfc_typename (&result
->ts
), &src
->where
);
2606 /* Logical kind conversion. */
2609 gfc_log2log (gfc_expr
*src
, int kind
)
2613 if (src
->ts
.type
!= BT_LOGICAL
)
2616 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2617 result
->value
.logical
= src
->value
.logical
;
2623 /* Convert logical to integer. */
2626 gfc_log2int (gfc_expr
*src
, int kind
)
2630 if (src
->ts
.type
!= BT_LOGICAL
)
2633 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2634 mpz_set_si (result
->value
.integer
, src
->value
.logical
);
2640 /* Convert integer to logical. */
2643 gfc_int2log (gfc_expr
*src
, int kind
)
2647 if (src
->ts
.type
!= BT_INTEGER
)
2650 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2651 result
->value
.logical
= (mpz_cmp_si (src
->value
.integer
, 0) != 0);
2656 /* Convert character to character. We only use wide strings internally,
2657 so we only set the kind. */
2660 gfc_character2character (gfc_expr
*src
, int kind
)
2663 result
= gfc_copy_expr (src
);
2664 result
->ts
.kind
= kind
;
2669 /* Helper function to set the representation in a Hollerith conversion.
2670 This assumes that the ts.type and ts.kind of the result have already
2674 hollerith2representation (gfc_expr
*result
, gfc_expr
*src
)
2676 size_t src_len
, result_len
;
2678 src_len
= src
->representation
.length
- src
->ts
.u
.pad
;
2679 gfc_target_expr_size (result
, &result_len
);
2681 if (src_len
> result_len
)
2683 gfc_warning (OPT_Wcharacter_truncation
, "The Hollerith constant at %L "
2684 "is truncated in conversion to %qs", &src
->where
,
2685 gfc_typename(&result
->ts
));
2688 result
->representation
.string
= XCNEWVEC (char, result_len
+ 1);
2689 memcpy (result
->representation
.string
, src
->representation
.string
,
2690 MIN (result_len
, src_len
));
2692 if (src_len
< result_len
)
2693 memset (&result
->representation
.string
[src_len
], ' ', result_len
- src_len
);
2695 result
->representation
.string
[result_len
] = '\0'; /* For debugger */
2696 result
->representation
.length
= result_len
;
2700 /* Helper function to set the representation in a character conversion.
2701 This assumes that the ts.type and ts.kind of the result have already
2705 character2representation (gfc_expr
*result
, gfc_expr
*src
)
2707 size_t src_len
, result_len
, i
;
2708 src_len
= src
->value
.character
.length
;
2709 gfc_target_expr_size (result
, &result_len
);
2711 if (src_len
> result_len
)
2712 gfc_warning (OPT_Wcharacter_truncation
, "The character constant at %L is "
2713 "truncated in conversion to %s", &src
->where
,
2714 gfc_typename(&result
->ts
));
2716 result
->representation
.string
= XCNEWVEC (char, result_len
+ 1);
2718 for (i
= 0; i
< MIN (result_len
, src_len
); i
++)
2719 result
->representation
.string
[i
] = (char) src
->value
.character
.string
[i
];
2721 if (src_len
< result_len
)
2722 memset (&result
->representation
.string
[src_len
], ' ',
2723 result_len
- src_len
);
2725 result
->representation
.string
[result_len
] = '\0'; /* For debugger. */
2726 result
->representation
.length
= result_len
;
2729 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2732 gfc_hollerith2int (gfc_expr
*src
, int kind
)
2735 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2737 hollerith2representation (result
, src
);
2738 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2739 result
->representation
.length
, result
->value
.integer
);
2744 /* Convert character to integer. The constant will be padded or truncated. */
2747 gfc_character2int (gfc_expr
*src
, int kind
)
2750 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &src
->where
);
2752 character2representation (result
, src
);
2753 gfc_interpret_integer (kind
, (unsigned char *) result
->representation
.string
,
2754 result
->representation
.length
, result
->value
.integer
);
2758 /* Convert Hollerith to real. The constant will be padded or truncated. */
2761 gfc_hollerith2real (gfc_expr
*src
, int kind
)
2764 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2766 hollerith2representation (result
, src
);
2767 if (gfc_interpret_float (kind
,
2768 (unsigned char *) result
->representation
.string
,
2769 result
->representation
.length
, result
->value
.real
))
2775 /* Convert character to real. The constant will be padded or truncated. */
2778 gfc_character2real (gfc_expr
*src
, int kind
)
2781 result
= gfc_get_constant_expr (BT_REAL
, kind
, &src
->where
);
2783 character2representation (result
, src
);
2784 gfc_interpret_float (kind
, (unsigned char *) result
->representation
.string
,
2785 result
->representation
.length
, result
->value
.real
);
2791 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2794 gfc_hollerith2complex (gfc_expr
*src
, int kind
)
2797 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2799 hollerith2representation (result
, src
);
2800 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2801 result
->representation
.length
, result
->value
.complex);
2806 /* Convert character to complex. The constant will be padded or truncated. */
2809 gfc_character2complex (gfc_expr
*src
, int kind
)
2812 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &src
->where
);
2814 character2representation (result
, src
);
2815 gfc_interpret_complex (kind
, (unsigned char *) result
->representation
.string
,
2816 result
->representation
.length
, result
->value
.complex);
2822 /* Convert Hollerith to character. */
2825 gfc_hollerith2character (gfc_expr
*src
, int kind
)
2829 result
= gfc_copy_expr (src
);
2830 result
->ts
.type
= BT_CHARACTER
;
2831 result
->ts
.kind
= kind
;
2832 result
->ts
.u
.pad
= 0;
2834 result
->value
.character
.length
= result
->representation
.length
;
2835 result
->value
.character
.string
2836 = gfc_char_to_widechar (result
->representation
.string
);
2842 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2845 gfc_hollerith2logical (gfc_expr
*src
, int kind
)
2848 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2850 hollerith2representation (result
, src
);
2851 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2852 result
->representation
.length
, &result
->value
.logical
);
2857 /* Convert character to logical. The constant will be padded or truncated. */
2860 gfc_character2logical (gfc_expr
*src
, int kind
)
2863 result
= gfc_get_constant_expr (BT_LOGICAL
, kind
, &src
->where
);
2865 character2representation (result
, src
);
2866 gfc_interpret_logical (kind
, (unsigned char *) result
->representation
.string
,
2867 result
->representation
.length
, &result
->value
.logical
);