Branch data Line data Source code
1 : : /* Compiler arithmetic
2 : : Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
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
10 : : version.
11 : :
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
15 : : for more details.
16 : :
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/>. */
20 : :
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. */
25 : :
26 : : #include "config.h"
27 : : #include "system.h"
28 : : #include "coretypes.h"
29 : : #include "options.h"
30 : : #include "gfortran.h"
31 : : #include "arith.h"
32 : : #include "target-memory.h"
33 : : #include "constructor.h"
34 : :
35 : : bool gfc_seen_div0;
36 : :
37 : : /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
38 : : It's easily implemented with a few calls though. */
39 : :
40 : : void
41 : 865 : gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
42 : : {
43 : 865 : mpfr_exp_t e;
44 : :
45 : 865 : if (mpfr_inf_p (x) || mpfr_nan_p (x))
46 : : {
47 : 1 : gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
48 : : "to INTEGER", where);
49 : 1 : mpz_set_ui (z, 0);
50 : 1 : return;
51 : : }
52 : :
53 : 864 : e = mpfr_get_z_exp (z, x);
54 : :
55 : 864 : if (e > 0)
56 : 24 : mpz_mul_2exp (z, z, e);
57 : : else
58 : 840 : mpz_tdiv_q_2exp (z, z, -e);
59 : : }
60 : :
61 : : /* Reduce an unsigned number to within its range. */
62 : :
63 : : void
64 : 1101 : gfc_reduce_unsigned (gfc_expr *e)
65 : : {
66 : 1101 : int k;
67 : 1101 : gcc_checking_assert (e->expr_type == EXPR_CONSTANT
68 : : && e->ts.type == BT_UNSIGNED);
69 : 1101 : k = gfc_validate_kind (BT_UNSIGNED, e->ts.kind, false);
70 : 1101 : mpz_and (e->value.integer, e->value.integer, gfc_unsigned_kinds[k].huge);
71 : 1101 : }
72 : : /* Set the model number precision by the requested KIND. */
73 : :
74 : : void
75 : 919331 : gfc_set_model_kind (int kind)
76 : : {
77 : 919331 : int index = gfc_validate_kind (BT_REAL, kind, false);
78 : 919331 : int base2prec;
79 : :
80 : 919331 : base2prec = gfc_real_kinds[index].digits;
81 : 919331 : if (gfc_real_kinds[index].radix != 2)
82 : 0 : base2prec *= gfc_real_kinds[index].radix / 2;
83 : 919331 : mpfr_set_default_prec (base2prec);
84 : 919331 : }
85 : :
86 : :
87 : : /* Set the model number precision from mpfr_t x. */
88 : :
89 : : void
90 : 425190 : gfc_set_model (mpfr_t x)
91 : : {
92 : 425190 : mpfr_set_default_prec (mpfr_get_prec (x));
93 : 425190 : }
94 : :
95 : :
96 : : /* Given an arithmetic error code, return a pointer to a string that
97 : : explains the error. */
98 : :
99 : : const char *
100 : 272 : gfc_arith_error (arith code)
101 : : {
102 : 272 : const char *p;
103 : :
104 : 272 : switch (code)
105 : : {
106 : : case ARITH_OK:
107 : : p = G_("Arithmetic OK at %L");
108 : : break;
109 : 113 : case ARITH_OVERFLOW:
110 : 113 : p = G_("Arithmetic overflow at %L");
111 : 113 : break;
112 : 3 : case ARITH_UNDERFLOW:
113 : 3 : p = G_("Arithmetic underflow at %L");
114 : 3 : break;
115 : 20 : case ARITH_NAN:
116 : 20 : p = G_("Arithmetic NaN at %L");
117 : 20 : break;
118 : 33 : case ARITH_DIV0:
119 : 33 : p = G_("Division by zero at %L");
120 : 33 : break;
121 : 0 : case ARITH_INCOMMENSURATE:
122 : 0 : p = G_("Array operands are incommensurate at %L");
123 : 0 : break;
124 : 86 : case ARITH_ASYMMETRIC:
125 : 86 : p = G_("Integer outside symmetric range implied by Standard Fortran"
126 : : " at %L");
127 : 86 : break;
128 : 1 : case ARITH_WRONGCONCAT:
129 : 1 : p = G_("Illegal type in character concatenation at %L");
130 : 1 : break;
131 : 0 : case ARITH_INVALID_TYPE:
132 : 0 : p = G_("Invalid type in arithmetic operation at %L");
133 : 0 : break;
134 : 15 : case ARITH_UNSIGNED_TRUNCATED:
135 : 15 : p = G_("Unsigned constant truncated at %L");
136 : 15 : break;
137 : 1 : case ARITH_UNSIGNED_NEGATIVE:
138 : 1 : p = G_("Negation of unsigned constant at %L not permitted");
139 : 1 : break;
140 : 0 : default:
141 : 0 : gfc_internal_error ("gfc_arith_error(): Bad error code");
142 : : }
143 : :
144 : 272 : return p;
145 : : }
146 : :
147 : :
148 : : /* Check if a certain arithmetic error code is severe enough to prevent
149 : : further simplification, as opposed to errors thrown by the range check
150 : : (e.g. overflow) or arithmetic exceptions that are tolerated with
151 : : -fno-range-check. */
152 : :
153 : : static bool
154 : 11362520 : is_hard_arith_error (arith code)
155 : : {
156 : 0 : switch (code)
157 : : {
158 : : case ARITH_OK:
159 : : case ARITH_OVERFLOW:
160 : : case ARITH_UNDERFLOW:
161 : : case ARITH_NAN:
162 : : case ARITH_DIV0:
163 : : case ARITH_ASYMMETRIC:
164 : : return false;
165 : :
166 : 89 : default:
167 : 0 : return true;
168 : : }
169 : : }
170 : :
171 : :
172 : : /* Get things ready to do math. */
173 : :
174 : : void
175 : 30975 : gfc_arith_init_1 (void)
176 : : {
177 : 30975 : gfc_integer_info *int_info;
178 : 30975 : gfc_unsigned_info *uint_info;
179 : 30975 : gfc_real_info *real_info;
180 : 30975 : mpfr_t a, b;
181 : 30975 : int i;
182 : :
183 : 30975 : mpfr_set_default_prec (128);
184 : 30975 : mpfr_init (a);
185 : :
186 : : /* Convert the minimum and maximum values for each kind into their
187 : : GNU MP representation. */
188 : 216418 : for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
189 : : {
190 : : /* Huge */
191 : 154468 : mpz_init (int_info->huge);
192 : 154468 : mpz_set_ui (int_info->huge, int_info->radix);
193 : 154468 : mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
194 : 154468 : mpz_sub_ui (int_info->huge, int_info->huge, 1);
195 : :
196 : : /* These are the numbers that are actually representable by the
197 : : target. For bases other than two, this needs to be changed. */
198 : 154468 : if (int_info->radix != 2)
199 : 0 : gfc_internal_error ("Fix min_int calculation");
200 : :
201 : : /* See PRs 13490 and 17912, related to integer ranges.
202 : : The pedantic_min_int exists for range checking when a program
203 : : is compiled with -pedantic, and reflects the belief that
204 : : Standard Fortran requires integers to be symmetrical, i.e.
205 : : every negative integer must have a representable positive
206 : : absolute value, and vice versa. */
207 : :
208 : 154468 : mpz_init (int_info->pedantic_min_int);
209 : 154468 : mpz_neg (int_info->pedantic_min_int, int_info->huge);
210 : :
211 : 154468 : mpz_init (int_info->min_int);
212 : 154468 : mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
213 : :
214 : : /* Range */
215 : 154468 : mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
216 : 154468 : mpfr_log10 (a, a, GFC_RND_MODE);
217 : 154468 : mpfr_trunc (a, a);
218 : 154468 : int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
219 : : }
220 : :
221 : : /* Similar, for UNSIGNED. */
222 : 30975 : if (flag_unsigned)
223 : : {
224 : 1470 : for (uint_info = gfc_unsigned_kinds; uint_info->kind != 0; uint_info++)
225 : : {
226 : : /* UNSIGNED is radix 2. */
227 : 1225 : gcc_assert (uint_info->radix == 2);
228 : : /* Huge. */
229 : 1225 : mpz_init (uint_info->huge);
230 : 1225 : mpz_set_ui (uint_info->huge, 2);
231 : 1225 : mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits);
232 : 1225 : mpz_sub_ui (uint_info->huge, uint_info->huge, 1);
233 : :
234 : : /* int_min - the smallest number we can reasonably convert from. */
235 : :
236 : 1225 : mpz_init (uint_info->int_min);
237 : 1225 : mpz_set_ui (uint_info->int_min, 2);
238 : 1225 : mpz_pow_ui (uint_info->int_min, uint_info->int_min,
239 : 1225 : uint_info->digits - 1);
240 : 1225 : mpz_neg (uint_info->int_min, uint_info->int_min);
241 : :
242 : : /* Range. */
243 : 1225 : mpfr_set_z (a, uint_info->huge, GFC_RND_MODE);
244 : 1225 : mpfr_log10 (a, a, GFC_RND_MODE);
245 : 1225 : mpfr_trunc (a,a);
246 : 1225 : uint_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
247 : : }
248 : :
249 : : }
250 : :
251 : 30975 : mpfr_clear (a);
252 : :
253 : 185850 : for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
254 : : {
255 : 123900 : gfc_set_model_kind (real_info->kind);
256 : :
257 : 123900 : mpfr_init (a);
258 : 123900 : mpfr_init (b);
259 : :
260 : : /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
261 : : /* 1 - b**(-p) */
262 : 123900 : mpfr_init (real_info->huge);
263 : 123900 : mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
264 : 123900 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
265 : 123900 : mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
266 : 123900 : mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
267 : :
268 : : /* b**(emax-1) */
269 : 123900 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
270 : 123900 : mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
271 : :
272 : : /* (1 - b**(-p)) * b**(emax-1) */
273 : 123900 : mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
274 : :
275 : : /* (1 - b**(-p)) * b**(emax-1) * b */
276 : 123900 : mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
277 : : GFC_RND_MODE);
278 : :
279 : : /* tiny(x) = b**(emin-1) */
280 : 123900 : mpfr_init (real_info->tiny);
281 : 123900 : mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
282 : 123900 : mpfr_pow_si (real_info->tiny, real_info->tiny,
283 : 123900 : real_info->min_exponent - 1, GFC_RND_MODE);
284 : :
285 : : /* subnormal (x) = b**(emin - digit) */
286 : 123900 : mpfr_init (real_info->subnormal);
287 : 123900 : mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
288 : 123900 : mpfr_pow_si (real_info->subnormal, real_info->subnormal,
289 : 123900 : real_info->min_exponent - real_info->digits, GFC_RND_MODE);
290 : :
291 : : /* epsilon(x) = b**(1-p) */
292 : 123900 : mpfr_init (real_info->epsilon);
293 : 123900 : mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
294 : 123900 : mpfr_pow_si (real_info->epsilon, real_info->epsilon,
295 : 123900 : 1 - real_info->digits, GFC_RND_MODE);
296 : :
297 : : /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
298 : 123900 : mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
299 : 123900 : mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
300 : 123900 : mpfr_neg (b, b, GFC_RND_MODE);
301 : :
302 : : /* a = min(a, b) */
303 : 123900 : mpfr_min (a, a, b, GFC_RND_MODE);
304 : 123900 : mpfr_trunc (a, a);
305 : 123900 : real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
306 : :
307 : : /* precision(x) = int((p - 1) * log10(b)) + k */
308 : 123900 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
309 : 123900 : mpfr_log10 (a, a, GFC_RND_MODE);
310 : 123900 : mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
311 : 123900 : mpfr_trunc (a, a);
312 : 123900 : real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
313 : :
314 : : /* If the radix is an integral power of 10, add one to the precision. */
315 : 123900 : for (i = 10; i <= real_info->radix; i *= 10)
316 : 0 : if (i == real_info->radix)
317 : 0 : real_info->precision++;
318 : :
319 : 123900 : mpfr_clears (a, b, NULL);
320 : : }
321 : 30975 : }
322 : :
323 : :
324 : : /* Clean up, get rid of numeric constants. */
325 : :
326 : : void
327 : 30957 : gfc_arith_done_1 (void)
328 : : {
329 : 30957 : gfc_integer_info *ip;
330 : 30957 : gfc_real_info *rp;
331 : :
332 : 185335 : for (ip = gfc_integer_kinds; ip->kind; ip++)
333 : : {
334 : 154378 : mpz_clear (ip->min_int);
335 : 154378 : mpz_clear (ip->pedantic_min_int);
336 : 154378 : mpz_clear (ip->huge);
337 : : }
338 : :
339 : 154785 : for (rp = gfc_real_kinds; rp->kind; rp++)
340 : 123828 : mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
341 : :
342 : 30957 : mpfr_free_cache ();
343 : 30957 : }
344 : :
345 : :
346 : : /* Given a wide character value and a character kind, determine whether
347 : : the character is representable for that kind. */
348 : : bool
349 : 1762441 : gfc_check_character_range (gfc_char_t c, int kind)
350 : : {
351 : : /* As wide characters are stored as 32-bit values, they're all
352 : : representable in UCS=4. */
353 : 1762441 : if (kind == 4)
354 : : return true;
355 : :
356 : 1587407 : if (kind == 1)
357 : 1587407 : return c <= 255 ? true : false;
358 : :
359 : 0 : gcc_unreachable ();
360 : : }
361 : :
362 : :
363 : : /* Given an integer and a kind, make sure that the integer lies within
364 : : the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
365 : : ARITH_OVERFLOW. */
366 : :
367 : : arith
368 : 15779256 : gfc_check_integer_range (mpz_t p, int kind)
369 : : {
370 : 15779256 : arith result;
371 : 15779256 : int i;
372 : :
373 : 15779256 : i = gfc_validate_kind (BT_INTEGER, kind, false);
374 : 15779256 : result = ARITH_OK;
375 : :
376 : 15779256 : if (pedantic)
377 : : {
378 : 13535496 : if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
379 : 15779256 : result = ARITH_ASYMMETRIC;
380 : : }
381 : :
382 : :
383 : 15779256 : if (flag_range_check == 0)
384 : : return result;
385 : :
386 : 15750210 : if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
387 : 15750210 : || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
388 : 15779256 : result = ARITH_OVERFLOW;
389 : :
390 : : return result;
391 : : }
392 : :
393 : : /* Same as above. */
394 : : arith
395 : 117730 : gfc_check_unsigned_range (mpz_t p, int kind)
396 : : {
397 : 117730 : int i;
398 : :
399 : 117730 : i = gfc_validate_kind (BT_UNSIGNED, kind, false);
400 : :
401 : 117730 : if (pedantic && mpz_cmp_si (p, 0) < 0)
402 : : return ARITH_UNSIGNED_NEGATIVE;
403 : :
404 : 117730 : if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0)
405 : : return ARITH_UNSIGNED_TRUNCATED;
406 : :
407 : 117729 : if (mpz_cmp (p, gfc_unsigned_kinds[i].huge) > 0)
408 : 14 : return ARITH_UNSIGNED_TRUNCATED;
409 : :
410 : : return ARITH_OK;
411 : : }
412 : :
413 : : /* Given a real and a kind, make sure that the real lies within the
414 : : range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
415 : : ARITH_UNDERFLOW. */
416 : :
417 : : static arith
418 : 423712 : gfc_check_real_range (mpfr_t p, int kind)
419 : : {
420 : 423712 : arith retval;
421 : 423712 : mpfr_t q;
422 : 423712 : int i;
423 : :
424 : 423712 : i = gfc_validate_kind (BT_REAL, kind, false);
425 : :
426 : 423712 : gfc_set_model (p);
427 : 423712 : mpfr_init (q);
428 : 423712 : mpfr_abs (q, p, GFC_RND_MODE);
429 : :
430 : 423712 : retval = ARITH_OK;
431 : :
432 : 423712 : if (mpfr_inf_p (p))
433 : : {
434 : 1142 : if (flag_range_check != 0)
435 : 21 : retval = ARITH_OVERFLOW;
436 : : }
437 : 422570 : else if (mpfr_nan_p (p))
438 : : {
439 : 238 : if (flag_range_check != 0)
440 : 358043 : retval = ARITH_NAN;
441 : : }
442 : 422332 : else if (mpfr_sgn (q) == 0)
443 : : {
444 : 65669 : mpfr_clear (q);
445 : 65669 : return retval;
446 : : }
447 : 356663 : else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
448 : : {
449 : 43 : if (flag_range_check == 0)
450 : 39 : mpfr_set_inf (p, mpfr_sgn (p));
451 : : else
452 : : retval = ARITH_OVERFLOW;
453 : : }
454 : 356620 : else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
455 : : {
456 : 22 : if (flag_range_check == 0)
457 : : {
458 : 13 : if (mpfr_sgn (p) < 0)
459 : : {
460 : 6 : mpfr_set_ui (p, 0, GFC_RND_MODE);
461 : 6 : mpfr_set_si (q, -1, GFC_RND_MODE);
462 : 6 : mpfr_copysign (p, p, q, GFC_RND_MODE);
463 : : }
464 : : else
465 : 7 : mpfr_set_ui (p, 0, GFC_RND_MODE);
466 : : }
467 : : else
468 : : retval = ARITH_UNDERFLOW;
469 : : }
470 : 356598 : else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
471 : : {
472 : 151 : mpfr_exp_t emin, emax;
473 : 151 : int en;
474 : :
475 : : /* Save current values of emin and emax. */
476 : 151 : emin = mpfr_get_emin ();
477 : 151 : emax = mpfr_get_emax ();
478 : :
479 : : /* Set emin and emax for the current model number. */
480 : 151 : en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
481 : 151 : mpfr_set_emin ((mpfr_exp_t) en);
482 : 151 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
483 : 151 : mpfr_check_range (q, 0, GFC_RND_MODE);
484 : 151 : mpfr_subnormalize (q, 0, GFC_RND_MODE);
485 : :
486 : : /* Reset emin and emax. */
487 : 151 : mpfr_set_emin (emin);
488 : 151 : mpfr_set_emax (emax);
489 : :
490 : : /* Copy sign if needed. */
491 : 151 : if (mpfr_sgn (p) < 0)
492 : 24 : mpfr_neg (p, q, MPFR_RNDN);
493 : : else
494 : 127 : mpfr_set (p, q, MPFR_RNDN);
495 : : }
496 : :
497 : 358043 : mpfr_clear (q);
498 : :
499 : 358043 : return retval;
500 : : }
501 : :
502 : :
503 : : /* Low-level arithmetic functions. All of these subroutines assume
504 : : that all operands are of the same type and return an operand of the
505 : : same type. The other thing about these subroutines is that they
506 : : can fail in various ways -- overflow, underflow, division by zero,
507 : : zero raised to the zero, etc. */
508 : :
509 : : static arith
510 : 540 : gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
511 : : {
512 : 540 : gfc_expr *result;
513 : :
514 : 540 : if (op1->ts.type != BT_LOGICAL)
515 : : return ARITH_INVALID_TYPE;
516 : :
517 : 540 : result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
518 : 540 : result->value.logical = !op1->value.logical;
519 : 540 : *resultp = result;
520 : :
521 : 540 : return ARITH_OK;
522 : : }
523 : :
524 : :
525 : : static arith
526 : 1542 : gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
527 : : {
528 : 1542 : gfc_expr *result;
529 : :
530 : 1542 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
531 : : return ARITH_INVALID_TYPE;
532 : :
533 : 1541 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
534 : : &op1->where);
535 : 1541 : result->value.logical = op1->value.logical && op2->value.logical;
536 : 1541 : *resultp = result;
537 : :
538 : 1541 : return ARITH_OK;
539 : : }
540 : :
541 : :
542 : : static arith
543 : 7355 : gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
544 : : {
545 : 7355 : gfc_expr *result;
546 : :
547 : 7355 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
548 : : return ARITH_INVALID_TYPE;
549 : :
550 : 7354 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
551 : : &op1->where);
552 : 7354 : result->value.logical = op1->value.logical || op2->value.logical;
553 : 7354 : *resultp = result;
554 : :
555 : 7354 : return ARITH_OK;
556 : : }
557 : :
558 : :
559 : : static arith
560 : 13 : gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
561 : : {
562 : 13 : gfc_expr *result;
563 : :
564 : 13 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
565 : : return ARITH_INVALID_TYPE;
566 : :
567 : 12 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
568 : : &op1->where);
569 : 12 : result->value.logical = op1->value.logical == op2->value.logical;
570 : 12 : *resultp = result;
571 : :
572 : 12 : return ARITH_OK;
573 : : }
574 : :
575 : :
576 : : static arith
577 : 1443 : gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
578 : : {
579 : 1443 : gfc_expr *result;
580 : :
581 : 1443 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
582 : : return ARITH_INVALID_TYPE;
583 : :
584 : 1442 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
585 : : &op1->where);
586 : 1442 : result->value.logical = op1->value.logical != op2->value.logical;
587 : 1442 : *resultp = result;
588 : :
589 : 1442 : return ARITH_OK;
590 : : }
591 : :
592 : :
593 : : /* Make sure a constant numeric expression is within the range for
594 : : its type and kind. Note that there's also a gfc_check_range(),
595 : : but that one deals with the intrinsic RANGE function. */
596 : :
597 : : arith
598 : 16132257 : gfc_range_check (gfc_expr *e)
599 : : {
600 : 16132257 : arith rc;
601 : 16132257 : arith rc2;
602 : :
603 : 16132257 : switch (e->ts.type)
604 : : {
605 : 15707628 : case BT_INTEGER:
606 : 15707628 : rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
607 : 15707628 : break;
608 : :
609 : 117718 : case BT_UNSIGNED:
610 : 117718 : rc = gfc_check_unsigned_range (e->value.integer, e->ts.kind);
611 : 117718 : break;
612 : :
613 : 299766 : case BT_REAL:
614 : 299766 : rc = gfc_check_real_range (e->value.real, e->ts.kind);
615 : 299766 : if (rc == ARITH_UNDERFLOW)
616 : 9 : mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
617 : 299766 : if (rc == ARITH_OVERFLOW)
618 : 16 : mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
619 : 299766 : if (rc == ARITH_NAN)
620 : 19 : mpfr_set_nan (e->value.real);
621 : : break;
622 : :
623 : 7145 : case BT_COMPLEX:
624 : 7145 : rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
625 : 7145 : if (rc == ARITH_UNDERFLOW)
626 : 0 : mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
627 : 7145 : if (rc == ARITH_OVERFLOW)
628 : 2 : mpfr_set_inf (mpc_realref (e->value.complex),
629 : 2 : mpfr_sgn (mpc_realref (e->value.complex)));
630 : 7145 : if (rc == ARITH_NAN)
631 : 4 : mpfr_set_nan (mpc_realref (e->value.complex));
632 : :
633 : 7145 : rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
634 : 7145 : if (rc == ARITH_UNDERFLOW)
635 : 0 : mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
636 : 7145 : if (rc == ARITH_OVERFLOW)
637 : 2 : mpfr_set_inf (mpc_imagref (e->value.complex),
638 : 2 : mpfr_sgn (mpc_imagref (e->value.complex)));
639 : 7145 : if (rc == ARITH_NAN)
640 : 4 : mpfr_set_nan (mpc_imagref (e->value.complex));
641 : :
642 : 7145 : if (rc == ARITH_OK)
643 : 7139 : rc = rc2;
644 : : break;
645 : :
646 : 0 : default:
647 : 0 : gfc_internal_error ("gfc_range_check(): Bad type");
648 : : }
649 : :
650 : 16132257 : return rc;
651 : : }
652 : :
653 : :
654 : : /* Several of the following routines use the same set of statements to
655 : : check the validity of the result. Encapsulate the checking here. */
656 : :
657 : : static arith
658 : 11340628 : check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
659 : : {
660 : 11340628 : arith val = rc;
661 : :
662 : 11340628 : if (val == ARITH_UNDERFLOW)
663 : : {
664 : 9 : if (warn_underflow)
665 : 3 : gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
666 : : val = ARITH_OK;
667 : : }
668 : :
669 : 11340619 : if (val == ARITH_ASYMMETRIC)
670 : : {
671 : 86 : gfc_warning (0, gfc_arith_error (val), &x->where);
672 : 86 : val = ARITH_OK;
673 : : }
674 : :
675 : 11340628 : if (is_hard_arith_error (val))
676 : 1 : gfc_free_expr (r);
677 : : else
678 : 11340627 : *rp = r;
679 : :
680 : 11340628 : return val;
681 : : }
682 : :
683 : :
684 : : /* It may seem silly to have a subroutine that actually computes the
685 : : unary plus of a constant, but it prevents us from making exceptions
686 : : in the code elsewhere. Used for unary plus and parenthesized
687 : : expressions. */
688 : :
689 : : static arith
690 : 351 : gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
691 : : {
692 : 351 : *resultp = gfc_copy_expr (op1);
693 : 351 : return ARITH_OK;
694 : : }
695 : :
696 : :
697 : : static arith
698 : 131142 : gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
699 : : {
700 : 131142 : gfc_expr *result;
701 : 131142 : arith rc;
702 : :
703 : 131142 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
704 : :
705 : 131142 : switch (op1->ts.type)
706 : : {
707 : 100061 : case BT_INTEGER:
708 : 100061 : mpz_neg (result->value.integer, op1->value.integer);
709 : 100061 : break;
710 : :
711 : 33 : case BT_UNSIGNED:
712 : 33 : {
713 : 33 : if (pedantic)
714 : 1 : return check_result (ARITH_UNSIGNED_NEGATIVE, op1, result, resultp);
715 : :
716 : 32 : mpz_neg (result->value.integer, op1->value.integer);
717 : : }
718 : 32 : break;
719 : :
720 : 31048 : case BT_REAL:
721 : 31048 : mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
722 : 31048 : break;
723 : :
724 : 0 : case BT_COMPLEX:
725 : 0 : mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
726 : 0 : break;
727 : :
728 : 0 : default:
729 : 0 : gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
730 : : }
731 : :
732 : 131141 : rc = gfc_range_check (result);
733 : 131141 : if (op1->ts.type == BT_UNSIGNED)
734 : : {
735 : 32 : if (rc != ARITH_OK)
736 : : {
737 : 1 : gfc_warning (0, gfc_arith_error (rc), &op1->where);
738 : 1 : rc = ARITH_OK;
739 : : }
740 : 32 : gfc_reduce_unsigned (result);
741 : : }
742 : 131141 : return check_result (rc, op1, result, resultp);
743 : : }
744 : :
745 : :
746 : : static arith
747 : 10356725 : gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
748 : : {
749 : 10356725 : gfc_expr *result;
750 : 10356725 : arith rc;
751 : :
752 : 10356725 : if (op1->ts.type != op2->ts.type)
753 : : return ARITH_INVALID_TYPE;
754 : :
755 : 10356724 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
756 : :
757 : 10356724 : switch (op1->ts.type)
758 : : {
759 : 10353582 : case BT_INTEGER:
760 : 10353582 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
761 : 10353582 : break;
762 : :
763 : 224 : case BT_UNSIGNED:
764 : 224 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
765 : 224 : gfc_reduce_unsigned (result);
766 : 224 : break;
767 : :
768 : 2902 : case BT_REAL:
769 : 2902 : mpfr_add (result->value.real, op1->value.real, op2->value.real,
770 : : GFC_RND_MODE);
771 : 2902 : break;
772 : :
773 : 16 : case BT_COMPLEX:
774 : 16 : mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
775 : : GFC_MPC_RND_MODE);
776 : 16 : break;
777 : :
778 : 0 : default:
779 : 0 : gfc_internal_error ("gfc_arith_plus(): Bad basic type");
780 : : }
781 : :
782 : 10356724 : rc = gfc_range_check (result);
783 : :
784 : 10356724 : return check_result (rc, op1, result, resultp);
785 : : }
786 : :
787 : :
788 : : static arith
789 : 511843 : gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
790 : : {
791 : 511843 : gfc_expr *result;
792 : 511843 : arith rc;
793 : :
794 : 511843 : if (op1->ts.type != op2->ts.type)
795 : : return ARITH_INVALID_TYPE;
796 : :
797 : 511842 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
798 : :
799 : 511842 : switch (op1->ts.type)
800 : : {
801 : 510754 : case BT_INTEGER:
802 : 510754 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
803 : 510754 : break;
804 : :
805 : 69 : case BT_UNSIGNED:
806 : 69 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
807 : 69 : gfc_reduce_unsigned (result);
808 : 69 : break;
809 : :
810 : 919 : case BT_REAL:
811 : 919 : mpfr_sub (result->value.real, op1->value.real, op2->value.real,
812 : : GFC_RND_MODE);
813 : 919 : break;
814 : :
815 : 100 : case BT_COMPLEX:
816 : 100 : mpc_sub (result->value.complex, op1->value.complex,
817 : 100 : op2->value.complex, GFC_MPC_RND_MODE);
818 : 100 : break;
819 : :
820 : 0 : default:
821 : 0 : gfc_internal_error ("gfc_arith_minus(): Bad basic type");
822 : : }
823 : :
824 : 511842 : rc = gfc_range_check (result);
825 : :
826 : 511842 : return check_result (rc, op1, result, resultp);
827 : : }
828 : :
829 : :
830 : : static arith
831 : 311872 : gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
832 : : {
833 : 311872 : gfc_expr *result;
834 : 311872 : arith rc;
835 : :
836 : 311872 : if (op1->ts.type != op2->ts.type)
837 : : return ARITH_INVALID_TYPE;
838 : :
839 : 311870 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
840 : :
841 : 311870 : switch (op1->ts.type)
842 : : {
843 : 299496 : case BT_INTEGER:
844 : 299496 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
845 : 299496 : break;
846 : :
847 : 209 : case BT_UNSIGNED:
848 : 209 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
849 : 209 : gfc_reduce_unsigned (result);
850 : 209 : break;
851 : :
852 : 10962 : case BT_REAL:
853 : 10962 : mpfr_mul (result->value.real, op1->value.real, op2->value.real,
854 : : GFC_RND_MODE);
855 : 10962 : break;
856 : :
857 : 1203 : case BT_COMPLEX:
858 : 1203 : gfc_set_model (mpc_realref (op1->value.complex));
859 : 1203 : mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
860 : : GFC_MPC_RND_MODE);
861 : 1203 : break;
862 : :
863 : 0 : default:
864 : 0 : gfc_internal_error ("gfc_arith_times(): Bad basic type");
865 : : }
866 : :
867 : 311870 : rc = gfc_range_check (result);
868 : :
869 : 311870 : return check_result (rc, op1, result, resultp);
870 : : }
871 : :
872 : :
873 : : static arith
874 : 7831 : gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
875 : : {
876 : 7831 : gfc_expr *result;
877 : 7831 : arith rc;
878 : :
879 : 7831 : if (op1->ts.type != op2->ts.type)
880 : : return ARITH_INVALID_TYPE;
881 : :
882 : 7829 : rc = ARITH_OK;
883 : :
884 : 7829 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
885 : :
886 : 7829 : switch (op1->ts.type)
887 : : {
888 : 3637 : case BT_INTEGER:
889 : 3637 : case BT_UNSIGNED:
890 : 3637 : if (mpz_sgn (op2->value.integer) == 0)
891 : : {
892 : : rc = ARITH_DIV0;
893 : : break;
894 : : }
895 : :
896 : 3616 : if (warn_integer_division)
897 : : {
898 : 49 : mpz_t r;
899 : 49 : mpz_init (r);
900 : 49 : mpz_tdiv_qr (result->value.integer, r, op1->value.integer,
901 : 49 : op2->value.integer);
902 : :
903 : 49 : if (mpz_cmp_si (r, 0) != 0)
904 : : {
905 : 6 : char *p;
906 : 6 : p = mpz_get_str (NULL, 10, result->value.integer);
907 : 6 : gfc_warning (OPT_Winteger_division, "Integer division "
908 : : "truncated to constant %qs at %L", p,
909 : : &op1->where);
910 : 6 : free (p);
911 : : }
912 : 49 : mpz_clear (r);
913 : : }
914 : : else
915 : 3567 : mpz_tdiv_q (result->value.integer, op1->value.integer,
916 : 3567 : op2->value.integer);
917 : :
918 : : break;
919 : :
920 : 4151 : case BT_REAL:
921 : : /* Set "Division by zero" only for regular numerator. */
922 : 4151 : if (flag_range_check == 1
923 : 3583 : && mpfr_zero_p (op2->value.real)
924 : 22 : && mpfr_regular_p (op1->value.real))
925 : 4151 : rc = ARITH_DIV0;
926 : :
927 : 4151 : mpfr_div (result->value.real, op1->value.real, op2->value.real,
928 : : GFC_RND_MODE);
929 : 4151 : break;
930 : :
931 : 41 : case BT_COMPLEX:
932 : : /* Set "Division by zero" only for regular numerator. */
933 : 41 : if (flag_range_check == 1
934 : 15 : && mpfr_zero_p (mpc_realref (op2->value.complex))
935 : 6 : && mpfr_zero_p (mpc_imagref (op2->value.complex))
936 : 46 : && ((mpfr_regular_p (mpc_realref (op1->value.complex))
937 : 3 : && mpfr_number_p (mpc_imagref (op1->value.complex)))
938 : 2 : || (mpfr_regular_p (mpc_imagref (op1->value.complex))
939 : 0 : && mpfr_number_p (mpc_realref (op1->value.complex)))))
940 : : rc = ARITH_DIV0;
941 : :
942 : 41 : gfc_set_model (mpc_realref (op1->value.complex));
943 : 41 : if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
944 : : {
945 : : /* In Fortran, return (NaN + NaN I) for any zero divisor. See
946 : : PR 40318. */
947 : 20 : mpfr_set_nan (mpc_realref (result->value.complex));
948 : 20 : mpfr_set_nan (mpc_imagref (result->value.complex));
949 : : }
950 : : else
951 : 21 : mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
952 : : GFC_MPC_RND_MODE);
953 : : break;
954 : :
955 : 0 : default:
956 : 0 : gfc_internal_error ("gfc_arith_divide(): Bad basic type");
957 : : }
958 : :
959 : 7808 : if (rc == ARITH_OK)
960 : 7799 : rc = gfc_range_check (result);
961 : :
962 : 7829 : return check_result (rc, op1, result, resultp);
963 : : }
964 : :
965 : : /* Raise a number to a power. */
966 : :
967 : : static arith
968 : 21226 : arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
969 : : {
970 : 21226 : int power_sign;
971 : 21226 : gfc_expr *result;
972 : 21226 : arith rc;
973 : :
974 : 21226 : if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
975 : 4 : return ARITH_INVALID_TYPE;
976 : :
977 : : /* The result type is derived from op1 and must be compatible with the
978 : : result of the simplification. Otherwise postpone simplification until
979 : : after operand conversions usually done by gfc_type_convert_binary. */
980 : 21222 : if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
981 : 21222 : || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
982 : : return ARITH_NOT_REDUCED;
983 : :
984 : 21222 : rc = ARITH_OK;
985 : 21222 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
986 : :
987 : 21222 : switch (op2->ts.type)
988 : : {
989 : 5780 : case BT_INTEGER:
990 : 5780 : power_sign = mpz_sgn (op2->value.integer);
991 : :
992 : 5704 : if (power_sign == 0)
993 : : {
994 : : /* Handle something to the zeroth power. Since we're dealing
995 : : with integral exponents, there is no ambiguity in the
996 : : limiting procedure used to determine the value of 0**0. */
997 : 84 : switch (op1->ts.type)
998 : : {
999 : 35 : case BT_INTEGER:
1000 : 35 : mpz_set_ui (result->value.integer, 1);
1001 : 35 : break;
1002 : :
1003 : 10 : case BT_REAL:
1004 : 10 : mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
1005 : 10 : break;
1006 : :
1007 : 39 : case BT_COMPLEX:
1008 : 39 : mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
1009 : 39 : break;
1010 : :
1011 : 0 : default:
1012 : 0 : gfc_internal_error ("arith_power(): Bad base");
1013 : : }
1014 : : }
1015 : : else
1016 : : {
1017 : 5696 : switch (op1->ts.type)
1018 : : {
1019 : 5364 : case BT_INTEGER:
1020 : 5364 : {
1021 : : /* First, we simplify the cases of op1 == 1, 0 or -1. */
1022 : 5364 : if (mpz_cmp_si (op1->value.integer, 1) == 0)
1023 : : {
1024 : : /* 1**op2 == 1 */
1025 : 810 : mpz_set_si (result->value.integer, 1);
1026 : : }
1027 : 4554 : else if (mpz_cmp_si (op1->value.integer, 0) == 0)
1028 : : {
1029 : : /* 0**op2 == 0, if op2 > 0
1030 : : 0**op2 overflow, if op2 < 0 ; in that case, we
1031 : : set the result to 0 and return ARITH_DIV0. */
1032 : 6 : mpz_set_si (result->value.integer, 0);
1033 : 6 : if (mpz_cmp_si (op2->value.integer, 0) < 0)
1034 : : rc = ARITH_DIV0;
1035 : : }
1036 : 4548 : else if (mpz_cmp_si (op1->value.integer, -1) == 0)
1037 : : {
1038 : : /* (-1)**op2 == (-1)**(mod(op2,2)) */
1039 : 24 : unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
1040 : 24 : if (odd)
1041 : 12 : mpz_set_si (result->value.integer, -1);
1042 : : else
1043 : 12 : mpz_set_si (result->value.integer, 1);
1044 : : }
1045 : : /* Then, we take care of op2 < 0. */
1046 : 4524 : else if (mpz_cmp_si (op2->value.integer, 0) < 0)
1047 : : {
1048 : : /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1049 : 9 : mpz_set_si (result->value.integer, 0);
1050 : 9 : if (warn_integer_division)
1051 : 1 : gfc_warning_now (OPT_Winteger_division, "Negative "
1052 : : "exponent of integer has zero "
1053 : : "result at %L", &result->where);
1054 : : }
1055 : : else
1056 : : {
1057 : : /* We have abs(op1) > 1 and op2 > 1.
1058 : : If op2 > bit_size(op1), we'll have an out-of-range
1059 : : result. */
1060 : 4515 : int k, power;
1061 : :
1062 : 4515 : k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
1063 : 4515 : power = gfc_integer_kinds[k].bit_size;
1064 : 4515 : if (mpz_cmp_si (op2->value.integer, power) < 0)
1065 : : {
1066 : 4496 : gfc_extract_int (op2, &power);
1067 : 4496 : mpz_pow_ui (result->value.integer, op1->value.integer,
1068 : : power);
1069 : 4496 : rc = gfc_range_check (result);
1070 : 4496 : if (rc == ARITH_OVERFLOW)
1071 : 2 : gfc_error_now ("Result of exponentiation at %L "
1072 : : "exceeds the range of %s", &op1->where,
1073 : : gfc_typename (&(op1->ts)));
1074 : : }
1075 : : else
1076 : : {
1077 : : /* Provide a nonsense value to propagate up. */
1078 : 19 : mpz_set (result->value.integer,
1079 : 19 : gfc_integer_kinds[k].huge);
1080 : 19 : mpz_add_ui (result->value.integer,
1081 : : result->value.integer, 1);
1082 : 19 : rc = ARITH_OVERFLOW;
1083 : : }
1084 : : }
1085 : : }
1086 : : break;
1087 : :
1088 : 285 : case BT_REAL:
1089 : 285 : mpfr_pow_z (result->value.real, op1->value.real,
1090 : 285 : op2->value.integer, GFC_RND_MODE);
1091 : 285 : break;
1092 : :
1093 : 47 : case BT_COMPLEX:
1094 : 47 : mpc_pow_z (result->value.complex, op1->value.complex,
1095 : 47 : op2->value.integer, GFC_MPC_RND_MODE);
1096 : 47 : break;
1097 : :
1098 : : default:
1099 : : break;
1100 : : }
1101 : : }
1102 : : break;
1103 : :
1104 : 273 : case BT_REAL:
1105 : :
1106 : 273 : if (gfc_init_expr_flag)
1107 : : {
1108 : 92 : if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
1109 : : "exponent in an initialization "
1110 : : "expression at %L", &op2->where))
1111 : : {
1112 : 1 : gfc_free_expr (result);
1113 : 1 : return ARITH_PROHIBIT;
1114 : : }
1115 : : }
1116 : :
1117 : 272 : if (mpfr_cmp_si (op1->value.real, 0) < 0)
1118 : : {
1119 : 0 : gfc_error ("Raising a negative REAL at %L to "
1120 : : "a REAL power is prohibited", &op1->where);
1121 : 0 : gfc_free_expr (result);
1122 : 0 : return ARITH_PROHIBIT;
1123 : : }
1124 : :
1125 : 272 : mpfr_pow (result->value.real, op1->value.real, op2->value.real,
1126 : : GFC_RND_MODE);
1127 : 272 : break;
1128 : :
1129 : 48 : case BT_COMPLEX:
1130 : 48 : {
1131 : 48 : if (gfc_init_expr_flag)
1132 : : {
1133 : 41 : if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
1134 : : "exponent in an initialization "
1135 : : "expression at %L", &op2->where))
1136 : : {
1137 : 0 : gfc_free_expr (result);
1138 : 0 : return ARITH_PROHIBIT;
1139 : : }
1140 : : }
1141 : :
1142 : 48 : mpc_pow (result->value.complex, op1->value.complex,
1143 : 48 : op2->value.complex, GFC_MPC_RND_MODE);
1144 : : }
1145 : 48 : break;
1146 : 15121 : case BT_UNSIGNED:
1147 : 15121 : {
1148 : 15121 : int k;
1149 : 15121 : mpz_t x;
1150 : 15121 : gcc_assert (op1->ts.type == BT_UNSIGNED);
1151 : 15121 : k = gfc_validate_kind (BT_UNSIGNED, op1->ts.kind, false);
1152 : : /* Exponentiation is performed modulo x = 2**n. */
1153 : 15121 : mpz_init (x);
1154 : 15121 : mpz_add_ui (x, gfc_unsigned_kinds[k].huge, 1);
1155 : 15121 : mpz_powm (result->value.integer, op1->value.integer,
1156 : 15121 : op2->value.integer, x);
1157 : 15121 : mpz_clear (x);
1158 : : }
1159 : 15121 : break;
1160 : 0 : default:
1161 : 0 : gfc_internal_error ("arith_power(): unknown type");
1162 : : }
1163 : :
1164 : 21207 : if (rc == ARITH_OK)
1165 : 21197 : rc = gfc_range_check (result);
1166 : :
1167 : 21221 : return check_result (rc, op1, result, resultp);
1168 : : }
1169 : :
1170 : :
1171 : : /* Concatenate two string constants. */
1172 : :
1173 : : static arith
1174 : 4909 : gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1175 : : {
1176 : 4909 : gfc_expr *result;
1177 : 4909 : size_t len;
1178 : :
1179 : : /* By cleverly playing around with constructors, it is possible
1180 : : to get mismatching types here. */
1181 : 4909 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1182 : 4908 : || op1->ts.kind != op2->ts.kind)
1183 : : return ARITH_WRONGCONCAT;
1184 : :
1185 : 4908 : result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1186 : : &op1->where);
1187 : :
1188 : 4908 : len = op1->value.character.length + op2->value.character.length;
1189 : :
1190 : 4908 : result->value.character.string = gfc_get_wide_string (len + 1);
1191 : 4908 : result->value.character.length = len;
1192 : :
1193 : 4908 : memcpy (result->value.character.string, op1->value.character.string,
1194 : 4908 : op1->value.character.length * sizeof (gfc_char_t));
1195 : :
1196 : 4908 : memcpy (&result->value.character.string[op1->value.character.length],
1197 : 4908 : op2->value.character.string,
1198 : 4908 : op2->value.character.length * sizeof (gfc_char_t));
1199 : :
1200 : 4908 : result->value.character.string[len] = '\0';
1201 : :
1202 : 4908 : *resultp = result;
1203 : :
1204 : 4908 : return ARITH_OK;
1205 : : }
1206 : :
1207 : : /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1208 : : This function mimics mpfr_cmp but takes NaN into account. */
1209 : :
1210 : : static int
1211 : 3299 : compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1212 : : {
1213 : 3299 : int rc;
1214 : 3299 : switch (op)
1215 : : {
1216 : 1859 : case INTRINSIC_EQ:
1217 : 1859 : rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1218 : 1859 : break;
1219 : 872 : case INTRINSIC_GT:
1220 : 872 : rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1221 : : break;
1222 : 72 : case INTRINSIC_GE:
1223 : 1236 : rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1224 : : break;
1225 : 60 : case INTRINSIC_LT:
1226 : 60 : rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1227 : : break;
1228 : 436 : case INTRINSIC_LE:
1229 : 495 : rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1230 : : break;
1231 : 0 : default:
1232 : 0 : gfc_internal_error ("compare_real(): Bad operator");
1233 : : }
1234 : :
1235 : 3299 : return rc;
1236 : : }
1237 : :
1238 : : /* Comparison operators. Assumes that the two expression nodes
1239 : : contain two constants of the same type. The op argument is
1240 : : needed to handle NaN correctly. */
1241 : :
1242 : : int
1243 : 42461 : gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1244 : : {
1245 : 42461 : int rc;
1246 : :
1247 : 42461 : switch (op1->ts.type)
1248 : : {
1249 : 32487 : case BT_INTEGER:
1250 : 32487 : case BT_UNSIGNED:
1251 : 32487 : rc = mpz_cmp (op1->value.integer, op2->value.integer);
1252 : 32487 : break;
1253 : :
1254 : 3299 : case BT_REAL:
1255 : 3299 : rc = compare_real (op1, op2, op);
1256 : 3299 : break;
1257 : :
1258 : 6627 : case BT_CHARACTER:
1259 : 6627 : rc = gfc_compare_string (op1, op2);
1260 : 6627 : break;
1261 : :
1262 : 38 : case BT_LOGICAL:
1263 : 0 : rc = ((!op1->value.logical && op2->value.logical)
1264 : 38 : || (op1->value.logical && !op2->value.logical));
1265 : 38 : break;
1266 : :
1267 : 10 : case BT_COMPLEX:
1268 : 10 : gcc_assert (op == INTRINSIC_EQ);
1269 : 10 : rc = mpc_cmp (op1->value.complex, op2->value.complex);
1270 : 10 : break;
1271 : :
1272 : 0 : default:
1273 : 0 : gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1274 : : }
1275 : :
1276 : 42461 : return rc;
1277 : : }
1278 : :
1279 : :
1280 : : /* Compare a pair of complex numbers. Naturally, this is only for
1281 : : equality and inequality. */
1282 : :
1283 : : static int
1284 : 196 : compare_complex (gfc_expr *op1, gfc_expr *op2)
1285 : : {
1286 : 196 : return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1287 : : }
1288 : :
1289 : :
1290 : : /* Given two constant strings and the inverse collating sequence, compare the
1291 : : strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1292 : : We use the processor's default collating sequence. */
1293 : :
1294 : : int
1295 : 7155 : gfc_compare_string (gfc_expr *a, gfc_expr *b)
1296 : : {
1297 : 7155 : size_t len, alen, blen, i;
1298 : 7155 : gfc_char_t ac, bc;
1299 : :
1300 : 7155 : alen = a->value.character.length;
1301 : 7155 : blen = b->value.character.length;
1302 : :
1303 : 7155 : len = MAX(alen, blen);
1304 : :
1305 : 17006 : for (i = 0; i < len; i++)
1306 : : {
1307 : 12424 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1308 : 12424 : bc = ((i < blen) ? b->value.character.string[i] : ' ');
1309 : :
1310 : 12424 : if (ac < bc)
1311 : : return -1;
1312 : 11494 : if (ac > bc)
1313 : : return 1;
1314 : : }
1315 : :
1316 : : /* Strings are equal */
1317 : : return 0;
1318 : : }
1319 : :
1320 : :
1321 : : int
1322 : 420 : gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1323 : : {
1324 : 420 : size_t len, alen, blen, i;
1325 : 420 : gfc_char_t ac, bc;
1326 : :
1327 : 420 : alen = a->value.character.length;
1328 : 420 : blen = strlen (b);
1329 : :
1330 : 420 : len = MAX(alen, blen);
1331 : :
1332 : 1539 : for (i = 0; i < len; i++)
1333 : : {
1334 : 1398 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1335 : 1398 : bc = ((i < blen) ? b[i] : ' ');
1336 : :
1337 : 1398 : if (!case_sensitive)
1338 : : {
1339 : 1398 : ac = TOLOWER (ac);
1340 : 1398 : bc = TOLOWER (bc);
1341 : : }
1342 : :
1343 : 1398 : if (ac < bc)
1344 : : return -1;
1345 : 1319 : if (ac > bc)
1346 : : return 1;
1347 : : }
1348 : :
1349 : : /* Strings are equal */
1350 : : return 0;
1351 : : }
1352 : :
1353 : :
1354 : : /* Specific comparison subroutines. */
1355 : :
1356 : : static arith
1357 : 3426 : gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1358 : : {
1359 : 3426 : gfc_expr *result;
1360 : :
1361 : 3426 : if (op1->ts.type != op2->ts.type)
1362 : : return ARITH_INVALID_TYPE;
1363 : :
1364 : 3424 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1365 : : &op1->where);
1366 : 6848 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1367 : 3424 : ? compare_complex (op1, op2)
1368 : 3424 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1369 : :
1370 : 3424 : *resultp = result;
1371 : 3424 : return ARITH_OK;
1372 : : }
1373 : :
1374 : :
1375 : : static arith
1376 : 32352 : gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1377 : : {
1378 : 32352 : gfc_expr *result;
1379 : :
1380 : 32352 : if (op1->ts.type != op2->ts.type)
1381 : : return ARITH_INVALID_TYPE;
1382 : :
1383 : 32350 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1384 : : &op1->where);
1385 : 64700 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1386 : 32546 : ? !compare_complex (op1, op2)
1387 : 32154 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1388 : :
1389 : 32350 : *resultp = result;
1390 : 32350 : return ARITH_OK;
1391 : : }
1392 : :
1393 : :
1394 : : static arith
1395 : 3044 : gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1396 : : {
1397 : 3044 : gfc_expr *result;
1398 : :
1399 : 3044 : if (op1->ts.type != op2->ts.type)
1400 : : return ARITH_INVALID_TYPE;
1401 : :
1402 : 3042 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1403 : : &op1->where);
1404 : 3042 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1405 : 3042 : *resultp = result;
1406 : :
1407 : 3042 : return ARITH_OK;
1408 : : }
1409 : :
1410 : :
1411 : : static arith
1412 : 266 : gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1413 : : {
1414 : 266 : gfc_expr *result;
1415 : :
1416 : 266 : if (op1->ts.type != op2->ts.type)
1417 : : return ARITH_INVALID_TYPE;
1418 : :
1419 : 264 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1420 : : &op1->where);
1421 : 264 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1422 : 264 : *resultp = result;
1423 : :
1424 : 264 : return ARITH_OK;
1425 : : }
1426 : :
1427 : :
1428 : : static arith
1429 : 454 : gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1430 : : {
1431 : 454 : gfc_expr *result;
1432 : :
1433 : 454 : if (op1->ts.type != op2->ts.type)
1434 : : return ARITH_INVALID_TYPE;
1435 : :
1436 : 452 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1437 : : &op1->where);
1438 : 452 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1439 : 452 : *resultp = result;
1440 : :
1441 : 452 : return ARITH_OK;
1442 : : }
1443 : :
1444 : :
1445 : : static arith
1446 : 616 : gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1447 : : {
1448 : 616 : gfc_expr *result;
1449 : :
1450 : 616 : if (op1->ts.type != op2->ts.type)
1451 : : return ARITH_INVALID_TYPE;
1452 : :
1453 : 614 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1454 : : &op1->where);
1455 : 614 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1456 : 614 : *resultp = result;
1457 : :
1458 : 614 : return ARITH_OK;
1459 : : }
1460 : :
1461 : :
1462 : : static arith
1463 : 132338 : reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1464 : : gfc_expr **result)
1465 : : {
1466 : 132338 : gfc_constructor_base head;
1467 : 132338 : gfc_constructor *c;
1468 : 132338 : gfc_expr *r;
1469 : 132338 : arith rc;
1470 : :
1471 : 132338 : if (op->expr_type == EXPR_CONSTANT)
1472 : 132033 : return eval (op, result);
1473 : :
1474 : 305 : if (op->expr_type != EXPR_ARRAY)
1475 : : return ARITH_NOT_REDUCED;
1476 : :
1477 : 298 : rc = ARITH_OK;
1478 : 298 : head = gfc_constructor_copy (op->value.constructor);
1479 : 1210 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1480 : : {
1481 : 921 : arith rc_tmp = reduce_unary (eval, c->expr, &r);
1482 : :
1483 : : /* Remember first recoverable ("soft") error encountered during
1484 : : reduction and continue, but terminate on serious errors. */
1485 : 921 : if (is_hard_arith_error (rc_tmp))
1486 : : {
1487 : : rc = rc_tmp;
1488 : : break;
1489 : : }
1490 : 912 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1491 : 4 : rc = rc_tmp;
1492 : :
1493 : 912 : gfc_replace_expr (c->expr, r);
1494 : : }
1495 : :
1496 : 298 : if (is_hard_arith_error (rc))
1497 : 9 : gfc_constructor_free (head);
1498 : : else
1499 : : {
1500 : 289 : gfc_constructor *c = gfc_constructor_first (head);
1501 : 289 : if (c == NULL)
1502 : : {
1503 : : /* Handle zero-sized arrays. */
1504 : 30 : r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
1505 : : }
1506 : : else
1507 : : {
1508 : 259 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1509 : : &op->where);
1510 : : }
1511 : 289 : r->shape = gfc_copy_shape (op->shape, op->rank);
1512 : 289 : r->rank = op->rank;
1513 : 289 : r->corank = op->corank;
1514 : 289 : r->value.constructor = head;
1515 : 289 : *result = r;
1516 : : }
1517 : :
1518 : : return rc;
1519 : : }
1520 : :
1521 : :
1522 : : static arith
1523 : 1516 : reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1524 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1525 : : {
1526 : 1516 : gfc_constructor_base head;
1527 : 1516 : gfc_constructor *c;
1528 : 1516 : gfc_expr *r;
1529 : 1516 : arith rc = ARITH_OK;
1530 : :
1531 : 1516 : head = gfc_constructor_copy (op1->value.constructor);
1532 : 9901 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1533 : : {
1534 : 8427 : arith rc_tmp;
1535 : :
1536 : 8427 : gfc_simplify_expr (c->expr, 0);
1537 : :
1538 : 8427 : if (c->expr->expr_type == EXPR_CONSTANT)
1539 : 8336 : rc_tmp = eval (c->expr, op2, &r);
1540 : 91 : else if (c->expr->expr_type != EXPR_ARRAY)
1541 : : rc_tmp = ARITH_NOT_REDUCED;
1542 : : else
1543 : 81 : rc_tmp = reduce_binary_ac (eval, c->expr, op2, &r);
1544 : :
1545 : : /* Remember first recoverable ("soft") error encountered during
1546 : : reduction and continue, but terminate on serious errors. */
1547 : 8417 : if (is_hard_arith_error (rc_tmp))
1548 : : {
1549 : : rc = rc_tmp;
1550 : : break;
1551 : : }
1552 : 8385 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1553 : 5 : rc = rc_tmp;
1554 : :
1555 : 8385 : gfc_replace_expr (c->expr, r);
1556 : : }
1557 : :
1558 : 1516 : if (is_hard_arith_error (rc))
1559 : 42 : gfc_constructor_free (head);
1560 : : else
1561 : : {
1562 : 1474 : gfc_constructor *c = gfc_constructor_first (head);
1563 : 1474 : if (c)
1564 : : {
1565 : 1474 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1566 : : &op1->where);
1567 : 1474 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1568 : 1474 : if (c->expr->ts.type == BT_CHARACTER)
1569 : 116 : r->ts.u.cl = c->expr->ts.u.cl;
1570 : : }
1571 : : else
1572 : : {
1573 : 0 : gcc_assert (op1->ts.type != BT_UNKNOWN);
1574 : 0 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
1575 : : &op1->where);
1576 : 0 : r->shape = gfc_get_shape (op1->rank);
1577 : 0 : if (op1->ts.type == BT_CHARACTER)
1578 : 0 : r->ts.u.cl = op1->ts.u.cl;
1579 : : }
1580 : 1474 : r->rank = op1->rank;
1581 : 1474 : r->corank = op1->corank;
1582 : 1474 : r->value.constructor = head;
1583 : 1474 : *result = r;
1584 : : }
1585 : :
1586 : 1516 : return rc;
1587 : : }
1588 : :
1589 : :
1590 : : static arith
1591 : 939 : reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1592 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1593 : : {
1594 : 939 : gfc_constructor_base head;
1595 : 939 : gfc_constructor *c;
1596 : 939 : gfc_expr *r;
1597 : 939 : arith rc = ARITH_OK;
1598 : :
1599 : 939 : head = gfc_constructor_copy (op2->value.constructor);
1600 : 4681 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1601 : : {
1602 : 3774 : arith rc_tmp;
1603 : :
1604 : 3774 : gfc_simplify_expr (c->expr, 0);
1605 : :
1606 : 3774 : if (c->expr->expr_type == EXPR_CONSTANT)
1607 : 3620 : rc_tmp = eval (op1, c->expr, &r);
1608 : 154 : else if (c->expr->expr_type != EXPR_ARRAY)
1609 : : rc_tmp = ARITH_NOT_REDUCED;
1610 : : else
1611 : 144 : rc_tmp = reduce_binary_ca (eval, op1, c->expr, &r);
1612 : :
1613 : : /* Remember first recoverable ("soft") error encountered during
1614 : : reduction and continue, but terminate on serious errors. */
1615 : 3764 : if (is_hard_arith_error (rc_tmp))
1616 : : {
1617 : : rc = rc_tmp;
1618 : : break;
1619 : : }
1620 : 3742 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1621 : 3 : rc = rc_tmp;
1622 : :
1623 : 3742 : gfc_replace_expr (c->expr, r);
1624 : : }
1625 : :
1626 : 939 : if (is_hard_arith_error (rc))
1627 : 32 : gfc_constructor_free (head);
1628 : : else
1629 : : {
1630 : 907 : gfc_constructor *c = gfc_constructor_first (head);
1631 : 907 : if (c)
1632 : : {
1633 : 817 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1634 : : &op2->where);
1635 : 817 : r->shape = gfc_copy_shape (op2->shape, op2->rank);
1636 : 817 : if (c->expr->ts.type == BT_CHARACTER)
1637 : 70 : r->ts.u.cl = c->expr->ts.u.cl;
1638 : : }
1639 : : else
1640 : : {
1641 : 90 : gcc_assert (op2->ts.type != BT_UNKNOWN);
1642 : 90 : r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
1643 : : &op2->where);
1644 : 90 : r->shape = gfc_get_shape (op2->rank);
1645 : 90 : if (op2->ts.type == BT_CHARACTER)
1646 : 0 : r->ts.u.cl = op2->ts.u.cl;
1647 : : }
1648 : 907 : r->rank = op2->rank;
1649 : 907 : r->corank = op2->corank;
1650 : 907 : r->value.constructor = head;
1651 : 907 : *result = r;
1652 : : }
1653 : :
1654 : 939 : return rc;
1655 : : }
1656 : :
1657 : :
1658 : : /* We need a forward declaration of reduce_binary. */
1659 : : static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1660 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1661 : :
1662 : :
1663 : : static arith
1664 : 1565 : reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1665 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1666 : : {
1667 : 1565 : gfc_constructor_base head;
1668 : 1565 : gfc_constructor *c, *d;
1669 : 1565 : gfc_expr *r;
1670 : 1565 : arith rc = ARITH_OK;
1671 : :
1672 : 1565 : if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1673 : : return ARITH_INCOMMENSURATE;
1674 : :
1675 : 1565 : head = gfc_constructor_copy (op1->value.constructor);
1676 : 3130 : for (c = gfc_constructor_first (head),
1677 : 1565 : d = gfc_constructor_first (op2->value.constructor);
1678 : 6032 : c && d;
1679 : 4467 : c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1680 : : {
1681 : 4472 : arith rc_tmp = reduce_binary (eval, c->expr, d->expr, &r);
1682 : :
1683 : : /* Remember first recoverable ("soft") error encountered during
1684 : : reduction and continue, but terminate on serious errors. */
1685 : 4472 : if (is_hard_arith_error (rc_tmp))
1686 : : {
1687 : : rc = rc_tmp;
1688 : : break;
1689 : : }
1690 : 4467 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1691 : 8 : rc = rc_tmp;
1692 : :
1693 : 4467 : gfc_replace_expr (c->expr, r);
1694 : : }
1695 : :
1696 : 1565 : if (rc == ARITH_OK && (c || d))
1697 : : rc = ARITH_INCOMMENSURATE;
1698 : :
1699 : 1565 : if (is_hard_arith_error (rc))
1700 : 5 : gfc_constructor_free (head);
1701 : : else
1702 : : {
1703 : 1560 : gfc_constructor *c = gfc_constructor_first (head);
1704 : 1560 : if (c == NULL)
1705 : : {
1706 : : /* Handle zero-sized arrays. */
1707 : 132 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
1708 : 132 : if (op1->ts.type == BT_CHARACTER)
1709 : 0 : r->ts.u.cl = op1->ts.u.cl;
1710 : : }
1711 : : else
1712 : : {
1713 : 1428 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1714 : : &op1->where);
1715 : 1428 : if (c->expr->ts.type == BT_CHARACTER)
1716 : 6 : r->ts.u.cl = c->expr->ts.u.cl;
1717 : : }
1718 : 1560 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1719 : 1560 : r->rank = op1->rank;
1720 : 1560 : r->corank = op1->corank;
1721 : 1560 : r->value.constructor = head;
1722 : 1560 : *result = r;
1723 : : }
1724 : :
1725 : : return rc;
1726 : : }
1727 : :
1728 : :
1729 : : static arith
1730 : 11256760 : reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1731 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1732 : : {
1733 : 11256760 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1734 : 11252961 : return eval (op1, op2, result);
1735 : :
1736 : 3799 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1737 : 795 : return reduce_binary_ca (eval, op1, op2, result);
1738 : :
1739 : 3004 : if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1740 : 1435 : return reduce_binary_ac (eval, op1, op2, result);
1741 : :
1742 : 1569 : if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1743 : : return ARITH_NOT_REDUCED;
1744 : :
1745 : 1565 : return reduce_binary_aa (eval, op1, op2, result);
1746 : : }
1747 : :
1748 : :
1749 : : typedef union
1750 : : {
1751 : : arith (*f2)(gfc_expr *, gfc_expr **);
1752 : : arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1753 : : }
1754 : : eval_f;
1755 : :
1756 : : /* High level arithmetic subroutines. These subroutines go into
1757 : : eval_intrinsic(), which can do one of several things to its
1758 : : operands. If the operands are incompatible with the intrinsic
1759 : : operation, we return a node pointing to the operands and hope that
1760 : : an operator interface is found during resolution.
1761 : :
1762 : : If the operands are compatible and are constants, then we try doing
1763 : : the arithmetic. We also handle the cases where either or both
1764 : : operands are array constructors. */
1765 : :
1766 : : static gfc_expr *
1767 : 12893177 : eval_intrinsic (gfc_intrinsic_op op,
1768 : : eval_f eval, gfc_expr *op1, gfc_expr *op2)
1769 : : {
1770 : 12893177 : gfc_expr temp, *result;
1771 : 12893177 : int unary;
1772 : 12893177 : arith rc;
1773 : :
1774 : 12893177 : if (!op1)
1775 : : return NULL;
1776 : :
1777 : 12893173 : gfc_clear_ts (&temp.ts);
1778 : :
1779 : 12893173 : switch (op)
1780 : : {
1781 : : /* Logical unary */
1782 : 77812 : case INTRINSIC_NOT:
1783 : 77812 : if (op1->ts.type != BT_LOGICAL)
1784 : 70002 : goto runtime;
1785 : :
1786 : 7810 : temp.ts.type = BT_LOGICAL;
1787 : 7810 : temp.ts.kind = gfc_default_logical_kind;
1788 : 7810 : unary = 1;
1789 : 7810 : break;
1790 : :
1791 : : /* Logical binary operators */
1792 : 249586 : case INTRINSIC_OR:
1793 : 249586 : case INTRINSIC_AND:
1794 : 249586 : case INTRINSIC_NEQV:
1795 : 249586 : case INTRINSIC_EQV:
1796 : 249586 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1797 : 62552 : goto runtime;
1798 : :
1799 : 187034 : temp.ts.type = BT_LOGICAL;
1800 : 187034 : temp.ts.kind = gfc_default_logical_kind;
1801 : 187034 : unary = 0;
1802 : 187034 : break;
1803 : :
1804 : : /* Numeric unary */
1805 : 151944 : case INTRINSIC_UPLUS:
1806 : 151944 : case INTRINSIC_UMINUS:
1807 : 151944 : if (!gfc_numeric_ts (&op1->ts))
1808 : 6966 : goto runtime;
1809 : :
1810 : 144978 : temp.ts = op1->ts;
1811 : 144978 : unary = 1;
1812 : 144978 : break;
1813 : :
1814 : 0 : case INTRINSIC_PARENTHESES:
1815 : 0 : temp.ts = op1->ts;
1816 : 0 : unary = 1;
1817 : 0 : break;
1818 : :
1819 : : /* Additional restrictions for ordering relations. */
1820 : 65366 : case INTRINSIC_GE:
1821 : 65366 : case INTRINSIC_GE_OS:
1822 : 65366 : case INTRINSIC_LT:
1823 : 65366 : case INTRINSIC_LT_OS:
1824 : 65366 : case INTRINSIC_LE:
1825 : 65366 : case INTRINSIC_LE_OS:
1826 : 65366 : case INTRINSIC_GT:
1827 : 65366 : case INTRINSIC_GT_OS:
1828 : 65366 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1829 : : {
1830 : 36 : temp.ts.type = BT_LOGICAL;
1831 : 36 : temp.ts.kind = gfc_default_logical_kind;
1832 : 36 : goto runtime;
1833 : : }
1834 : :
1835 : : /* Fall through */
1836 : 960292 : case INTRINSIC_EQ:
1837 : 960292 : case INTRINSIC_EQ_OS:
1838 : 960292 : case INTRINSIC_NE:
1839 : 960292 : case INTRINSIC_NE_OS:
1840 : 960292 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1841 : : {
1842 : 101242 : unary = 0;
1843 : 101242 : temp.ts.type = BT_LOGICAL;
1844 : 101242 : temp.ts.kind = gfc_default_logical_kind;
1845 : :
1846 : : /* If kind mismatch, exit and we'll error out later. */
1847 : 101242 : if (op1->ts.kind != op2->ts.kind)
1848 : 40 : goto runtime;
1849 : :
1850 : : break;
1851 : : }
1852 : :
1853 : 931981 : gcc_fallthrough ();
1854 : : /* Numeric binary */
1855 : 931981 : case INTRINSIC_POWER:
1856 : 931981 : if (pedantic && (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED))
1857 : : {
1858 : 48 : gfc_error ("Unsigned exponentiation not permitted with -pedantic "
1859 : : "at %L", &op1->where);
1860 : 48 : goto runtime;
1861 : : }
1862 : :
1863 : 12304576 : gcc_fallthrough ();
1864 : :
1865 : 12304576 : case INTRINSIC_PLUS:
1866 : 12304576 : case INTRINSIC_MINUS:
1867 : 12304576 : case INTRINSIC_TIMES:
1868 : 12304576 : case INTRINSIC_DIVIDE:
1869 : 12304576 : if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1870 : 483311 : goto runtime;
1871 : :
1872 : 11821265 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
1873 : 4 : goto runtime;
1874 : :
1875 : : /* Do not perform conversions if operands are not conformable as
1876 : : required for the binary intrinsic operators (F2018:10.1.5).
1877 : : Defer to a possibly overloading user-defined operator. */
1878 : 11821261 : if (!gfc_op_rank_conformable (op1, op2))
1879 : 220 : goto runtime;
1880 : :
1881 : : /* Insert any necessary type conversions to make the operands
1882 : : compatible. */
1883 : :
1884 : 11821041 : temp.expr_type = EXPR_OP;
1885 : 11821041 : gfc_clear_ts (&temp.ts);
1886 : 11821041 : temp.value.op.op = op;
1887 : :
1888 : 11821041 : temp.value.op.op1 = op1;
1889 : 11821041 : temp.value.op.op2 = op2;
1890 : :
1891 : 11823185 : gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1892 : :
1893 : 11821041 : if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1894 : 11821041 : || op == INTRINSIC_GE || op == INTRINSIC_GT
1895 : 11497849 : || op == INTRINSIC_LE || op == INTRINSIC_LT
1896 : 11487269 : || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1897 : 11475861 : || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1898 : 11389703 : || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1899 : : {
1900 : 441090 : temp.ts.type = BT_LOGICAL;
1901 : 441090 : temp.ts.kind = gfc_default_logical_kind;
1902 : : }
1903 : :
1904 : : unary = 0;
1905 : : break;
1906 : :
1907 : : /* Character binary */
1908 : 7929 : case INTRINSIC_CONCAT:
1909 : 7929 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1910 : 6354 : || op1->ts.kind != op2->ts.kind)
1911 : 1584 : goto runtime;
1912 : :
1913 : 6345 : temp.ts.type = BT_CHARACTER;
1914 : 6345 : temp.ts.kind = op1->ts.kind;
1915 : 6345 : unary = 0;
1916 : 6345 : break;
1917 : :
1918 : 0 : case INTRINSIC_USER:
1919 : 0 : goto runtime;
1920 : :
1921 : 0 : default:
1922 : 0 : gfc_internal_error ("eval_intrinsic(): Bad operator");
1923 : : }
1924 : :
1925 : 12268410 : if (op1->expr_type != EXPR_CONSTANT
1926 : 12268410 : && (op1->expr_type != EXPR_ARRAY
1927 : 3155 : || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1928 : 841346 : goto runtime;
1929 : :
1930 : 11427064 : if (op2 != NULL
1931 : 11295647 : && op2->expr_type != EXPR_CONSTANT
1932 : 11472649 : && (op2->expr_type != EXPR_ARRAY
1933 : 2226 : || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1934 : 43359 : goto runtime;
1935 : :
1936 : : /* For array constructors with explicit type-spec, ensure elements are
1937 : : converted to the specified type before any operations. This handles
1938 : : cases like [integer :: ([1.0])] ** 2 where parentheses would otherwise
1939 : : cause the type-spec to be lost during constant folding. */
1940 : 11383705 : if (op1->expr_type == EXPR_ARRAY && op1->ts.type != BT_UNKNOWN)
1941 : 3128 : gfc_check_constructor_type (op1);
1942 : 11383705 : if (op2 != NULL && op2->expr_type == EXPR_ARRAY && op2->ts.type != BT_UNKNOWN)
1943 : 2226 : gfc_check_constructor_type (op2);
1944 : :
1945 : : /* For CONCAT operations, also resolve character array constructors to
1946 : : ensure elements are padded to the specified length before concatenation.
1947 : : This ensures [character(16):: 'a','b'] // '|' pads to 16 chars first. */
1948 : 11383705 : if (op == INTRINSIC_CONCAT)
1949 : : {
1950 : 4779 : if (op1->expr_type == EXPR_ARRAY && op1->ts.type == BT_CHARACTER
1951 : 92 : && op1->ts.u.cl && op1->ts.u.cl->length_from_typespec)
1952 : 54 : gfc_resolve_character_array_constructor (op1);
1953 : 4779 : if (op2 != NULL && op2->expr_type == EXPR_ARRAY
1954 : 53 : && op2->ts.type == BT_CHARACTER
1955 : 53 : && op2->ts.u.cl && op2->ts.u.cl->length_from_typespec)
1956 : 43 : gfc_resolve_character_array_constructor (op2);
1957 : : }
1958 : :
1959 : 11383705 : if (unary)
1960 : 131417 : rc = reduce_unary (eval.f2, op1, &result);
1961 : : else
1962 : 11252288 : rc = reduce_binary (eval.f3, op1, op2, &result);
1963 : :
1964 : 11383705 : if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1965 : 57 : goto runtime;
1966 : :
1967 : : /* Something went wrong. */
1968 : 11383648 : if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1969 : : return NULL;
1970 : :
1971 : 11383647 : if (rc != ARITH_OK)
1972 : : {
1973 : 168 : gfc_error (gfc_arith_error (rc), &op1->where);
1974 : 168 : if (rc == ARITH_OVERFLOW)
1975 : 113 : goto done;
1976 : :
1977 : 55 : if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1978 : 24 : gfc_seen_div0 = true;
1979 : :
1980 : 55 : return NULL;
1981 : : }
1982 : :
1983 : 11383479 : done:
1984 : :
1985 : 11383592 : gfc_free_expr (op1);
1986 : 11383592 : gfc_free_expr (op2);
1987 : 11383592 : return result;
1988 : :
1989 : 1509525 : runtime:
1990 : : /* Create a run-time expression. */
1991 : 1509525 : result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1992 : 1509525 : result->ts = temp.ts;
1993 : 1509525 : return result;
1994 : : }
1995 : :
1996 : :
1997 : : /* Modify type of expression for zero size array. */
1998 : :
1999 : : static gfc_expr *
2000 : 65 : eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
2001 : : {
2002 : 65 : if (op == NULL)
2003 : 0 : gfc_internal_error ("eval_type_intrinsic0(): op NULL");
2004 : :
2005 : 65 : switch (iop)
2006 : : {
2007 : 64 : case INTRINSIC_GE:
2008 : 64 : case INTRINSIC_GE_OS:
2009 : 64 : case INTRINSIC_LT:
2010 : 64 : case INTRINSIC_LT_OS:
2011 : 64 : case INTRINSIC_LE:
2012 : 64 : case INTRINSIC_LE_OS:
2013 : 64 : case INTRINSIC_GT:
2014 : 64 : case INTRINSIC_GT_OS:
2015 : 64 : case INTRINSIC_EQ:
2016 : 64 : case INTRINSIC_EQ_OS:
2017 : 64 : case INTRINSIC_NE:
2018 : 64 : case INTRINSIC_NE_OS:
2019 : 64 : op->ts.type = BT_LOGICAL;
2020 : 64 : op->ts.kind = gfc_default_logical_kind;
2021 : 64 : break;
2022 : :
2023 : : default:
2024 : : break;
2025 : : }
2026 : :
2027 : 65 : return op;
2028 : : }
2029 : :
2030 : :
2031 : : /* Return nonzero if the expression is a zero size array. */
2032 : :
2033 : : static bool
2034 : 25556664 : gfc_zero_size_array (gfc_expr *e)
2035 : : {
2036 : 25556660 : if (e == NULL || e->expr_type != EXPR_ARRAY)
2037 : : return false;
2038 : :
2039 : 0 : return e->value.constructor == NULL;
2040 : : }
2041 : :
2042 : :
2043 : : /* Reduce a binary expression where at least one of the operands
2044 : : involves a zero-length array. Returns NULL if neither of the
2045 : : operands is a zero-length array. */
2046 : :
2047 : : static gfc_expr *
2048 : 12663486 : reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
2049 : : {
2050 : 12668377 : if (gfc_zero_size_array (op1))
2051 : : {
2052 : 64 : gfc_free_expr (op2);
2053 : 64 : return op1;
2054 : : }
2055 : :
2056 : 12737386 : if (gfc_zero_size_array (op2))
2057 : : {
2058 : 1 : gfc_free_expr (op1);
2059 : 1 : return op2;
2060 : : }
2061 : :
2062 : : return NULL;
2063 : : }
2064 : :
2065 : :
2066 : : static gfc_expr *
2067 : 229756 : eval_intrinsic_f2 (gfc_intrinsic_op op,
2068 : : arith (*eval) (gfc_expr *, gfc_expr **),
2069 : : gfc_expr *op1, gfc_expr *op2)
2070 : : {
2071 : 229756 : gfc_expr *result;
2072 : 229756 : eval_f f;
2073 : :
2074 : 229756 : if (op2 == NULL)
2075 : : {
2076 : 230033 : if (gfc_zero_size_array (op1))
2077 : 0 : return eval_type_intrinsic0 (op, op1);
2078 : : }
2079 : : else
2080 : : {
2081 : 0 : result = reduce_binary0 (op1, op2);
2082 : 0 : if (result != NULL)
2083 : 0 : return eval_type_intrinsic0 (op, result);
2084 : : }
2085 : :
2086 : 229756 : f.f2 = eval;
2087 : 229756 : return eval_intrinsic (op, f, op1, op2);
2088 : : }
2089 : :
2090 : :
2091 : : static gfc_expr *
2092 : 12663495 : eval_intrinsic_f3 (gfc_intrinsic_op op,
2093 : : arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
2094 : : gfc_expr *op1, gfc_expr *op2)
2095 : : {
2096 : 12663495 : gfc_expr *result;
2097 : 12663495 : eval_f f;
2098 : :
2099 : 12663495 : if (!op1 && !op2)
2100 : : return NULL;
2101 : :
2102 : 12663486 : result = reduce_binary0 (op1, op2);
2103 : 12663486 : if (result != NULL)
2104 : 65 : return eval_type_intrinsic0(op, result);
2105 : :
2106 : 12663421 : f.f3 = eval;
2107 : 12663421 : return eval_intrinsic (op, f, op1, op2);
2108 : : }
2109 : :
2110 : :
2111 : : gfc_expr *
2112 : 5256793 : gfc_parentheses (gfc_expr *op)
2113 : : {
2114 : 5256793 : if (gfc_is_constant_expr (op))
2115 : : return op;
2116 : :
2117 : 0 : return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
2118 : 0 : op, NULL);
2119 : : }
2120 : :
2121 : : gfc_expr *
2122 : 407 : gfc_uplus (gfc_expr *op)
2123 : : {
2124 : 407 : return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
2125 : : }
2126 : :
2127 : :
2128 : : gfc_expr *
2129 : 151537 : gfc_uminus (gfc_expr *op)
2130 : : {
2131 : 151537 : return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
2132 : : }
2133 : :
2134 : :
2135 : : gfc_expr *
2136 : 10411197 : gfc_add (gfc_expr *op1, gfc_expr *op2)
2137 : : {
2138 : 10411197 : return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
2139 : : }
2140 : :
2141 : :
2142 : : gfc_expr *
2143 : 575377 : gfc_subtract (gfc_expr *op1, gfc_expr *op2)
2144 : : {
2145 : 575377 : return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
2146 : : }
2147 : :
2148 : :
2149 : : gfc_expr *
2150 : 367311 : gfc_multiply (gfc_expr *op1, gfc_expr *op2)
2151 : : {
2152 : 367311 : return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
2153 : : }
2154 : :
2155 : :
2156 : : gfc_expr *
2157 : 18772 : gfc_divide (gfc_expr *op1, gfc_expr *op2)
2158 : : {
2159 : 18772 : return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
2160 : : }
2161 : :
2162 : :
2163 : : gfc_expr *
2164 : 72931 : gfc_power (gfc_expr *op1, gfc_expr *op2)
2165 : : {
2166 : 72931 : return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
2167 : : }
2168 : :
2169 : :
2170 : : gfc_expr *
2171 : 7929 : gfc_concat (gfc_expr *op1, gfc_expr *op2)
2172 : : {
2173 : 7929 : return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
2174 : : }
2175 : :
2176 : :
2177 : : gfc_expr *
2178 : 18330 : gfc_and (gfc_expr *op1, gfc_expr *op2)
2179 : : {
2180 : 18330 : return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
2181 : : }
2182 : :
2183 : :
2184 : : gfc_expr *
2185 : 205712 : gfc_or (gfc_expr *op1, gfc_expr *op2)
2186 : : {
2187 : 205712 : return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
2188 : : }
2189 : :
2190 : :
2191 : : gfc_expr *
2192 : 77812 : gfc_not (gfc_expr *op1)
2193 : : {
2194 : 77812 : return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
2195 : : }
2196 : :
2197 : :
2198 : : gfc_expr *
2199 : 1998 : gfc_eqv (gfc_expr *op1, gfc_expr *op2)
2200 : : {
2201 : 1998 : return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
2202 : : }
2203 : :
2204 : :
2205 : : gfc_expr *
2206 : 23546 : gfc_neqv (gfc_expr *op1, gfc_expr *op2)
2207 : : {
2208 : 23546 : return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
2209 : : }
2210 : :
2211 : :
2212 : : gfc_expr *
2213 : 33785 : gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2214 : : {
2215 : 33785 : return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
2216 : : }
2217 : :
2218 : :
2219 : : gfc_expr *
2220 : 861189 : gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2221 : : {
2222 : 861189 : return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
2223 : : }
2224 : :
2225 : :
2226 : : gfc_expr *
2227 : 41718 : gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2228 : : {
2229 : 41718 : return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
2230 : : }
2231 : :
2232 : :
2233 : : gfc_expr *
2234 : 4732 : gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2235 : : {
2236 : 4732 : return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2237 : : }
2238 : :
2239 : :
2240 : : gfc_expr *
2241 : 11173 : gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2242 : : {
2243 : 11173 : return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2244 : : }
2245 : :
2246 : :
2247 : : gfc_expr *
2248 : 7795 : gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2249 : : {
2250 : 7795 : return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
2251 : : }
2252 : :
2253 : :
2254 : : /******* Simplification of intrinsic functions with constant arguments *****/
2255 : :
2256 : :
2257 : : /* Deal with an arithmetic error. */
2258 : :
2259 : : static void
2260 : 6 : arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2261 : : {
2262 : 6 : switch (rc)
2263 : : {
2264 : 0 : case ARITH_OK:
2265 : 0 : gfc_error ("Arithmetic OK converting %s to %s at %L",
2266 : : gfc_typename (from), gfc_typename (to), where);
2267 : 0 : break;
2268 : 6 : case ARITH_OVERFLOW:
2269 : 6 : gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2270 : : "can be disabled with the option %<-fno-range-check%>",
2271 : : gfc_typename (from), gfc_typename (to), where);
2272 : 6 : break;
2273 : 0 : case ARITH_UNDERFLOW:
2274 : 0 : gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
2275 : : "can be disabled with the option %<-fno-range-check%>",
2276 : : gfc_typename (from), gfc_typename (to), where);
2277 : 0 : break;
2278 : 0 : case ARITH_NAN:
2279 : 0 : gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
2280 : : "can be disabled with the option %<-fno-range-check%>",
2281 : : gfc_typename (from), gfc_typename (to), where);
2282 : 0 : break;
2283 : 0 : case ARITH_DIV0:
2284 : 0 : gfc_error ("Division by zero converting %s to %s at %L",
2285 : : gfc_typename (from), gfc_typename (to), where);
2286 : 0 : break;
2287 : 0 : case ARITH_INCOMMENSURATE:
2288 : 0 : gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2289 : : gfc_typename (from), gfc_typename (to), where);
2290 : 0 : break;
2291 : 0 : case ARITH_ASYMMETRIC:
2292 : 0 : gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2293 : : " converting %s to %s at %L",
2294 : : gfc_typename (from), gfc_typename (to), where);
2295 : 0 : break;
2296 : 0 : default:
2297 : 0 : gfc_internal_error ("gfc_arith_error(): Bad error code");
2298 : : }
2299 : :
2300 : : /* TODO: Do something about the error, i.e., throw exception, return
2301 : : NaN, etc. */
2302 : 6 : }
2303 : :
2304 : : /* Returns true if significant bits were lost when converting real
2305 : : constant r from from_kind to to_kind. */
2306 : :
2307 : : static bool
2308 : 19 : wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2309 : : {
2310 : 19 : mpfr_t rv, diff;
2311 : 19 : bool ret;
2312 : :
2313 : 19 : gfc_set_model_kind (to_kind);
2314 : 19 : mpfr_init (rv);
2315 : 19 : gfc_set_model_kind (from_kind);
2316 : 19 : mpfr_init (diff);
2317 : :
2318 : 19 : mpfr_set (rv, r, GFC_RND_MODE);
2319 : 19 : mpfr_sub (diff, rv, r, GFC_RND_MODE);
2320 : :
2321 : 19 : ret = ! mpfr_zero_p (diff);
2322 : 19 : mpfr_clear (rv);
2323 : 19 : mpfr_clear (diff);
2324 : 19 : return ret;
2325 : : }
2326 : :
2327 : : /* Return true if conversion from an integer to a real loses precision. */
2328 : :
2329 : : static bool
2330 : 82 : wprecision_int_real (mpz_t n, mpfr_t r)
2331 : : {
2332 : 82 : bool ret;
2333 : 82 : mpz_t i;
2334 : 82 : mpz_init (i);
2335 : 82 : mpfr_get_z (i, r, GFC_RND_MODE);
2336 : 82 : mpz_sub (i, i, n);
2337 : 82 : ret = mpz_cmp_si (i, 0) != 0;
2338 : 82 : mpz_clear (i);
2339 : 82 : return ret;
2340 : : }
2341 : :
2342 : : /* Convert integers to integers; we can reuse this for also converting
2343 : : unsigneds. */
2344 : :
2345 : : gfc_expr *
2346 : 69577 : gfc_int2int (gfc_expr *src, int kind)
2347 : : {
2348 : 69577 : gfc_expr *result;
2349 : 69577 : arith rc;
2350 : :
2351 : 69577 : if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
2352 : : return NULL;
2353 : :
2354 : 69577 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2355 : :
2356 : 69577 : mpz_set (result->value.integer, src->value.integer);
2357 : :
2358 : 69577 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2359 : : {
2360 : 5 : if (rc == ARITH_ASYMMETRIC)
2361 : : {
2362 : 0 : gfc_warning (0, gfc_arith_error (rc), &src->where);
2363 : : }
2364 : : else
2365 : : {
2366 : 5 : arith_error (rc, &src->ts, &result->ts, &src->where);
2367 : 5 : gfc_free_expr (result);
2368 : 5 : return NULL;
2369 : : }
2370 : : }
2371 : :
2372 : : /* If we do not trap numeric overflow, we need to convert the number to
2373 : : signed, throwing away high-order bits if necessary. */
2374 : 69572 : if (flag_range_check == 0)
2375 : : {
2376 : 132 : int k;
2377 : :
2378 : 132 : k = gfc_validate_kind (BT_INTEGER, kind, false);
2379 : 132 : gfc_convert_mpz_to_signed (result->value.integer,
2380 : : gfc_integer_kinds[k].bit_size);
2381 : :
2382 : 132 : if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2383 : 1 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2384 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2385 : : &src->where);
2386 : : }
2387 : : return result;
2388 : : }
2389 : :
2390 : :
2391 : : /* Convert integers to reals. */
2392 : :
2393 : : gfc_expr *
2394 : 97907 : gfc_int2real (gfc_expr *src, int kind)
2395 : : {
2396 : 97907 : gfc_expr *result;
2397 : 97907 : arith rc;
2398 : :
2399 : 97907 : if (src->ts.type != BT_INTEGER)
2400 : : return NULL;
2401 : :
2402 : 97906 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2403 : :
2404 : 97906 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2405 : :
2406 : 97906 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2407 : : {
2408 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2409 : 0 : gfc_free_expr (result);
2410 : 0 : return NULL;
2411 : : }
2412 : :
2413 : 97906 : if (warn_conversion
2414 : 97906 : && wprecision_int_real (src->value.integer, result->value.real))
2415 : 4 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2416 : : "from %qs to %qs at %L",
2417 : : gfc_typename (&src->ts),
2418 : : gfc_typename (&result->ts),
2419 : : &src->where);
2420 : :
2421 : : return result;
2422 : : }
2423 : :
2424 : :
2425 : : /* Convert default integer to default complex. */
2426 : :
2427 : : gfc_expr *
2428 : 883 : gfc_int2complex (gfc_expr *src, int kind)
2429 : : {
2430 : 883 : gfc_expr *result;
2431 : 883 : arith rc;
2432 : :
2433 : 883 : if (src->ts.type != BT_INTEGER)
2434 : : return NULL;
2435 : :
2436 : 880 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2437 : :
2438 : 880 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2439 : :
2440 : 880 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2441 : : != ARITH_OK)
2442 : : {
2443 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2444 : 0 : gfc_free_expr (result);
2445 : 0 : return NULL;
2446 : : }
2447 : :
2448 : 880 : if (warn_conversion
2449 : 880 : && wprecision_int_real (src->value.integer,
2450 : : mpc_realref (result->value.complex)))
2451 : 1 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2452 : : "from %qs to %qs at %L",
2453 : : gfc_typename (&src->ts),
2454 : : gfc_typename (&result->ts),
2455 : : &src->where);
2456 : :
2457 : : return result;
2458 : : }
2459 : :
2460 : : /* Convert unsigned to unsigned, or integer to unsigned. */
2461 : :
2462 : : gfc_expr *
2463 : 441 : gfc_uint2uint (gfc_expr *src, int kind)
2464 : : {
2465 : 441 : gfc_expr *result;
2466 : 441 : arith rc;
2467 : :
2468 : 441 : if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
2469 : : return NULL;
2470 : :
2471 : 441 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2472 : 441 : mpz_set (result->value.integer, src->value.integer);
2473 : :
2474 : 441 : rc = gfc_range_check (result);
2475 : 441 : if (rc != ARITH_OK)
2476 : 12 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2477 : :
2478 : 441 : gfc_reduce_unsigned (result);
2479 : 441 : return result;
2480 : : }
2481 : :
2482 : : gfc_expr *
2483 : 152 : gfc_int2uint (gfc_expr *src, int kind)
2484 : : {
2485 : 152 : return gfc_uint2uint (src, kind);
2486 : : }
2487 : :
2488 : : gfc_expr *
2489 : 325 : gfc_uint2int (gfc_expr *src, int kind)
2490 : : {
2491 : 325 : return gfc_int2int (src, kind);
2492 : : }
2493 : :
2494 : : /* Convert UNSIGNED to reals. */
2495 : :
2496 : : gfc_expr *
2497 : 48 : gfc_uint2real (gfc_expr *src, int kind)
2498 : : {
2499 : 48 : gfc_expr *result;
2500 : 48 : arith rc;
2501 : :
2502 : 48 : if (src->ts.type != BT_UNSIGNED)
2503 : : return NULL;
2504 : :
2505 : 48 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2506 : :
2507 : 48 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2508 : :
2509 : 48 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2510 : : {
2511 : : /* This should be rare, just in case. */
2512 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2513 : 0 : gfc_free_expr (result);
2514 : 0 : return NULL;
2515 : : }
2516 : :
2517 : 48 : if (warn_conversion
2518 : 48 : && wprecision_int_real (src->value.integer, result->value.real))
2519 : 0 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2520 : : "from %qs to %qs at %L",
2521 : : gfc_typename (&src->ts),
2522 : : gfc_typename (&result->ts),
2523 : : &src->where);
2524 : :
2525 : : return result;
2526 : : }
2527 : :
2528 : : /* Convert default integer to default complex. */
2529 : :
2530 : : gfc_expr *
2531 : 0 : gfc_uint2complex (gfc_expr *src, int kind)
2532 : : {
2533 : 0 : gfc_expr *result;
2534 : 0 : arith rc;
2535 : :
2536 : 0 : if (src->ts.type != BT_UNSIGNED)
2537 : : return NULL;
2538 : :
2539 : 0 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2540 : :
2541 : 0 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2542 : :
2543 : 0 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2544 : : != ARITH_OK)
2545 : : {
2546 : : /* This should be rare, just in case. */
2547 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2548 : 0 : gfc_free_expr (result);
2549 : 0 : return NULL;
2550 : : }
2551 : :
2552 : 0 : if (warn_conversion
2553 : 0 : && wprecision_int_real (src->value.integer,
2554 : : mpc_realref (result->value.complex)))
2555 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2556 : : "from %qs to %qs at %L",
2557 : : gfc_typename (&src->ts),
2558 : : gfc_typename (&result->ts),
2559 : : &src->where);
2560 : :
2561 : : return result;
2562 : : }
2563 : :
2564 : : /* Convert default real to default integer. */
2565 : :
2566 : : gfc_expr *
2567 : 399 : gfc_real2int (gfc_expr *src, int kind)
2568 : : {
2569 : 399 : gfc_expr *result;
2570 : 399 : arith rc;
2571 : 399 : bool did_warn = false;
2572 : :
2573 : 399 : if (src->ts.type != BT_REAL)
2574 : : return NULL;
2575 : :
2576 : 399 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2577 : :
2578 : 399 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2579 : :
2580 : 399 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2581 : : {
2582 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2583 : 0 : gfc_free_expr (result);
2584 : 0 : return NULL;
2585 : : }
2586 : :
2587 : : /* If there was a fractional part, warn about this. */
2588 : :
2589 : 399 : if (warn_conversion)
2590 : : {
2591 : 4 : mpfr_t f;
2592 : 4 : mpfr_init (f);
2593 : 4 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2594 : 4 : if (mpfr_cmp_si (f, 0) != 0)
2595 : : {
2596 : 2 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2597 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2598 : : gfc_typename (&result->ts), &src->where);
2599 : 2 : did_warn = true;
2600 : : }
2601 : 4 : mpfr_clear (f);
2602 : : }
2603 : 399 : if (!did_warn && warn_conversion_extra)
2604 : : {
2605 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2606 : : "at %L", gfc_typename (&src->ts),
2607 : : gfc_typename (&result->ts), &src->where);
2608 : : }
2609 : :
2610 : : return result;
2611 : : }
2612 : :
2613 : : /* Convert real to unsigned. */
2614 : :
2615 : : gfc_expr *
2616 : 6 : gfc_real2uint (gfc_expr *src, int kind)
2617 : : {
2618 : 6 : gfc_expr *result;
2619 : 6 : arith rc;
2620 : 6 : bool did_warn = false;
2621 : :
2622 : 6 : if (src->ts.type != BT_REAL)
2623 : : return NULL;
2624 : :
2625 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2626 : :
2627 : 6 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2628 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2629 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2630 : :
2631 : 6 : gfc_reduce_unsigned (result);
2632 : :
2633 : : /* If there was a fractional part, warn about this. */
2634 : :
2635 : 6 : if (warn_conversion)
2636 : : {
2637 : 0 : mpfr_t f;
2638 : 0 : mpfr_init (f);
2639 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2640 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2641 : : {
2642 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2643 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2644 : : gfc_typename (&result->ts), &src->where);
2645 : 0 : did_warn = true;
2646 : : }
2647 : 0 : mpfr_clear (f);
2648 : : }
2649 : 6 : if (!did_warn && warn_conversion_extra)
2650 : : {
2651 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2652 : : "at %L", gfc_typename (&src->ts),
2653 : : gfc_typename (&result->ts), &src->where);
2654 : : }
2655 : :
2656 : : return result;
2657 : : }
2658 : :
2659 : : /* Convert real to real. */
2660 : :
2661 : : gfc_expr *
2662 : 7912 : gfc_real2real (gfc_expr *src, int kind)
2663 : : {
2664 : 7912 : gfc_expr *result;
2665 : 7912 : arith rc;
2666 : 7912 : bool did_warn = false;
2667 : :
2668 : 7912 : if (src->ts.type != BT_REAL)
2669 : : return NULL;
2670 : :
2671 : 7908 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2672 : :
2673 : 7908 : mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2674 : :
2675 : 7908 : rc = gfc_check_real_range (result->value.real, kind);
2676 : :
2677 : 7908 : if (rc == ARITH_UNDERFLOW)
2678 : : {
2679 : 0 : if (warn_underflow)
2680 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2681 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2682 : : }
2683 : 7908 : else if (rc != ARITH_OK)
2684 : : {
2685 : 1 : arith_error (rc, &src->ts, &result->ts, &src->where);
2686 : 1 : gfc_free_expr (result);
2687 : 1 : return NULL;
2688 : : }
2689 : :
2690 : : /* As a special bonus, don't warn about REAL values which are not changed by
2691 : : the conversion if -Wconversion is specified and -Wconversion-extra is
2692 : : not. */
2693 : :
2694 : 7907 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2695 : : {
2696 : 11 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2697 : :
2698 : : /* Calculate the difference between the constant and the rounded
2699 : : value and check it against zero. */
2700 : :
2701 : 11 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2702 : : {
2703 : 2 : gfc_warning_now (w, "Change of value in conversion from "
2704 : : "%qs to %qs at %L",
2705 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2706 : : &src->where);
2707 : : /* Make sure the conversion warning is not emitted again. */
2708 : 2 : did_warn = true;
2709 : : }
2710 : : }
2711 : :
2712 : 7907 : if (!did_warn && warn_conversion_extra)
2713 : 8 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2714 : : "at %L", gfc_typename(&src->ts),
2715 : : gfc_typename(&result->ts), &src->where);
2716 : :
2717 : : return result;
2718 : : }
2719 : :
2720 : :
2721 : : /* Convert real to complex. */
2722 : :
2723 : : gfc_expr *
2724 : 1354 : gfc_real2complex (gfc_expr *src, int kind)
2725 : : {
2726 : 1354 : gfc_expr *result;
2727 : 1354 : arith rc;
2728 : 1354 : bool did_warn = false;
2729 : :
2730 : 1354 : if (src->ts.type != BT_REAL)
2731 : : return NULL;
2732 : :
2733 : 1349 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2734 : :
2735 : 1349 : mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2736 : :
2737 : 1349 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2738 : :
2739 : 1349 : if (rc == ARITH_UNDERFLOW)
2740 : : {
2741 : 0 : if (warn_underflow)
2742 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2743 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2744 : : }
2745 : 1349 : else if (rc != ARITH_OK)
2746 : : {
2747 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2748 : 0 : gfc_free_expr (result);
2749 : 0 : return NULL;
2750 : : }
2751 : :
2752 : 1349 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2753 : : {
2754 : 2 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2755 : :
2756 : 2 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2757 : : {
2758 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2759 : : "%qs to %qs at %L",
2760 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2761 : : &src->where);
2762 : : /* Make sure the conversion warning is not emitted again. */
2763 : 1 : did_warn = true;
2764 : : }
2765 : : }
2766 : :
2767 : 1349 : if (!did_warn && warn_conversion_extra)
2768 : 2 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2769 : : "at %L", gfc_typename(&src->ts),
2770 : : gfc_typename(&result->ts), &src->where);
2771 : :
2772 : : return result;
2773 : : }
2774 : :
2775 : :
2776 : : /* Convert complex to integer. */
2777 : :
2778 : : gfc_expr *
2779 : 80 : gfc_complex2int (gfc_expr *src, int kind)
2780 : : {
2781 : 80 : gfc_expr *result;
2782 : 80 : arith rc;
2783 : 80 : bool did_warn = false;
2784 : :
2785 : 80 : if (src->ts.type != BT_COMPLEX)
2786 : : return NULL;
2787 : :
2788 : 80 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2789 : :
2790 : 80 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2791 : : &src->where);
2792 : :
2793 : 80 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2794 : : {
2795 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2796 : 0 : gfc_free_expr (result);
2797 : 0 : return NULL;
2798 : : }
2799 : :
2800 : 80 : if (warn_conversion || warn_conversion_extra)
2801 : : {
2802 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2803 : :
2804 : : /* See if we discarded an imaginary part. */
2805 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2806 : : {
2807 : 2 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2808 : : "in conversion from %qs to %qs at %L",
2809 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2810 : : &src->where);
2811 : 2 : did_warn = true;
2812 : : }
2813 : :
2814 : : else {
2815 : 2 : mpfr_t f;
2816 : :
2817 : 2 : mpfr_init (f);
2818 : 2 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2819 : 2 : if (mpfr_cmp_si (f, 0) != 0)
2820 : : {
2821 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2822 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2823 : : gfc_typename (&result->ts), &src->where);
2824 : 1 : did_warn = true;
2825 : : }
2826 : 2 : mpfr_clear (f);
2827 : : }
2828 : :
2829 : 4 : if (!did_warn && warn_conversion_extra)
2830 : : {
2831 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2832 : : "at %L", gfc_typename (&src->ts),
2833 : : gfc_typename (&result->ts), &src->where);
2834 : : }
2835 : : }
2836 : :
2837 : : return result;
2838 : : }
2839 : :
2840 : : /* Convert complex to integer. */
2841 : :
2842 : : gfc_expr *
2843 : 6 : gfc_complex2uint (gfc_expr *src, int kind)
2844 : : {
2845 : 6 : gfc_expr *result;
2846 : 6 : arith rc;
2847 : 6 : bool did_warn = false;
2848 : :
2849 : 6 : if (src->ts.type != BT_COMPLEX)
2850 : : return NULL;
2851 : :
2852 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2853 : :
2854 : 6 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2855 : : &src->where);
2856 : :
2857 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2858 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2859 : :
2860 : 6 : gfc_reduce_unsigned (result);
2861 : :
2862 : 6 : if (warn_conversion || warn_conversion_extra)
2863 : : {
2864 : 0 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2865 : :
2866 : : /* See if we discarded an imaginary part. */
2867 : 0 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2868 : : {
2869 : 0 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2870 : : "in conversion from %qs to %qs at %L",
2871 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2872 : : &src->where);
2873 : 0 : did_warn = true;
2874 : : }
2875 : :
2876 : : else
2877 : : {
2878 : 0 : mpfr_t f;
2879 : :
2880 : 0 : mpfr_init (f);
2881 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2882 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2883 : : {
2884 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2885 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2886 : : gfc_typename (&result->ts), &src->where);
2887 : 0 : did_warn = true;
2888 : : }
2889 : 0 : mpfr_clear (f);
2890 : : }
2891 : :
2892 : 0 : if (!did_warn && warn_conversion_extra)
2893 : : {
2894 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2895 : : "at %L", gfc_typename (&src->ts),
2896 : : gfc_typename (&result->ts), &src->where);
2897 : : }
2898 : : }
2899 : :
2900 : : return result;
2901 : : }
2902 : :
2903 : :
2904 : : /* Convert complex to real. */
2905 : :
2906 : : gfc_expr *
2907 : 229 : gfc_complex2real (gfc_expr *src, int kind)
2908 : : {
2909 : 229 : gfc_expr *result;
2910 : 229 : arith rc;
2911 : 229 : bool did_warn = false;
2912 : :
2913 : 229 : if (src->ts.type != BT_COMPLEX)
2914 : : return NULL;
2915 : :
2916 : 229 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2917 : :
2918 : 229 : mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2919 : :
2920 : 229 : rc = gfc_check_real_range (result->value.real, kind);
2921 : :
2922 : 229 : if (rc == ARITH_UNDERFLOW)
2923 : : {
2924 : 0 : if (warn_underflow)
2925 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2926 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2927 : : }
2928 : 229 : if (rc != ARITH_OK)
2929 : : {
2930 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2931 : 0 : gfc_free_expr (result);
2932 : 0 : return NULL;
2933 : : }
2934 : :
2935 : 229 : if (warn_conversion || warn_conversion_extra)
2936 : : {
2937 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2938 : :
2939 : : /* See if we discarded an imaginary part. */
2940 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2941 : : {
2942 : 4 : gfc_warning (w, "Non-zero imaginary part discarded "
2943 : : "in conversion from %qs to %qs at %L",
2944 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2945 : : &src->where);
2946 : 4 : did_warn = true;
2947 : : }
2948 : :
2949 : : /* Calculate the difference between the real constant and the rounded
2950 : : value and check it against zero. */
2951 : :
2952 : 4 : if (kind > src->ts.kind
2953 : 4 : && wprecision_real_real (mpc_realref (src->value.complex),
2954 : : src->ts.kind, kind))
2955 : : {
2956 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2957 : : "%qs to %qs at %L",
2958 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2959 : : &src->where);
2960 : : /* Make sure the conversion warning is not emitted again. */
2961 : 0 : did_warn = true;
2962 : : }
2963 : : }
2964 : :
2965 : 229 : if (!did_warn && warn_conversion_extra)
2966 : 0 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2967 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2968 : : &src->where);
2969 : :
2970 : : return result;
2971 : : }
2972 : :
2973 : :
2974 : : /* Convert complex to complex. */
2975 : :
2976 : : gfc_expr *
2977 : 672 : gfc_complex2complex (gfc_expr *src, int kind)
2978 : : {
2979 : 672 : gfc_expr *result;
2980 : 672 : arith rc;
2981 : 672 : bool did_warn = false;
2982 : :
2983 : 672 : if (src->ts.type != BT_COMPLEX)
2984 : : return NULL;
2985 : :
2986 : 668 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2987 : :
2988 : 668 : mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2989 : :
2990 : 668 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2991 : :
2992 : 668 : if (rc == ARITH_UNDERFLOW)
2993 : : {
2994 : 0 : if (warn_underflow)
2995 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2996 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2997 : : }
2998 : 668 : else if (rc != ARITH_OK)
2999 : : {
3000 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
3001 : 0 : gfc_free_expr (result);
3002 : 0 : return NULL;
3003 : : }
3004 : :
3005 : 668 : rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
3006 : :
3007 : 668 : if (rc == ARITH_UNDERFLOW)
3008 : : {
3009 : 0 : if (warn_underflow)
3010 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
3011 : 0 : mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
3012 : : }
3013 : 668 : else if (rc != ARITH_OK)
3014 : : {
3015 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
3016 : 0 : gfc_free_expr (result);
3017 : 0 : return NULL;
3018 : : }
3019 : :
3020 : 668 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
3021 : 671 : && (wprecision_real_real (mpc_realref (src->value.complex),
3022 : : src->ts.kind, kind)
3023 : 3 : || wprecision_real_real (mpc_imagref (src->value.complex),
3024 : : src->ts.kind, kind)))
3025 : : {
3026 : 3 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
3027 : :
3028 : 3 : gfc_warning_now (w, "Change of value in conversion from "
3029 : : "%qs to %qs at %L",
3030 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
3031 : : &src->where);
3032 : 3 : did_warn = true;
3033 : : }
3034 : :
3035 : 668 : if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
3036 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
3037 : : "at %L", gfc_typename(&src->ts),
3038 : : gfc_typename (&result->ts), &src->where);
3039 : :
3040 : : return result;
3041 : : }
3042 : :
3043 : :
3044 : : /* Logical kind conversion. */
3045 : :
3046 : : gfc_expr *
3047 : 788 : gfc_log2log (gfc_expr *src, int kind)
3048 : : {
3049 : 788 : gfc_expr *result;
3050 : :
3051 : 788 : if (src->ts.type != BT_LOGICAL)
3052 : : return NULL;
3053 : :
3054 : 788 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3055 : 788 : result->value.logical = src->value.logical;
3056 : :
3057 : 788 : return result;
3058 : : }
3059 : :
3060 : :
3061 : : /* Convert logical to integer. */
3062 : :
3063 : : gfc_expr *
3064 : 14 : gfc_log2int (gfc_expr *src, int kind)
3065 : : {
3066 : 14 : gfc_expr *result;
3067 : :
3068 : 14 : if (src->ts.type != BT_LOGICAL)
3069 : : return NULL;
3070 : :
3071 : 14 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3072 : 14 : mpz_set_si (result->value.integer, src->value.logical);
3073 : :
3074 : 14 : return result;
3075 : : }
3076 : :
3077 : : /* Convert logical to unsigned. */
3078 : :
3079 : : gfc_expr *
3080 : 0 : gfc_log2uint (gfc_expr *src, int kind)
3081 : : {
3082 : 0 : gfc_expr *result;
3083 : :
3084 : 0 : if (src->ts.type != BT_LOGICAL)
3085 : : return NULL;
3086 : :
3087 : 0 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
3088 : 0 : mpz_set_si (result->value.integer, src->value.logical);
3089 : :
3090 : 0 : return result;
3091 : : }
3092 : :
3093 : :
3094 : : /* Convert integer to logical. */
3095 : :
3096 : : gfc_expr *
3097 : 0 : gfc_int2log (gfc_expr *src, int kind)
3098 : : {
3099 : 0 : gfc_expr *result;
3100 : :
3101 : 0 : if (src->ts.type != BT_INTEGER)
3102 : : return NULL;
3103 : :
3104 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3105 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3106 : :
3107 : 0 : return result;
3108 : : }
3109 : :
3110 : : /* Convert unsigned to logical. */
3111 : :
3112 : : gfc_expr *
3113 : 0 : gfc_uint2log (gfc_expr *src, int kind)
3114 : : {
3115 : 0 : gfc_expr *result;
3116 : :
3117 : 0 : if (src->ts.type != BT_UNSIGNED)
3118 : : return NULL;
3119 : :
3120 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3121 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3122 : :
3123 : 0 : return result;
3124 : : }
3125 : :
3126 : : /* Convert character to character. We only use wide strings internally,
3127 : : so we only set the kind. */
3128 : :
3129 : : gfc_expr *
3130 : 0 : gfc_character2character (gfc_expr *src, int kind)
3131 : : {
3132 : 0 : gfc_expr *result;
3133 : 0 : result = gfc_copy_expr (src);
3134 : 0 : result->ts.kind = kind;
3135 : :
3136 : 0 : return result;
3137 : : }
3138 : :
3139 : : /* Helper function to set the representation in a Hollerith conversion.
3140 : : This assumes that the ts.type and ts.kind of the result have already
3141 : : been set. */
3142 : :
3143 : : static void
3144 : 1187 : hollerith2representation (gfc_expr *result, gfc_expr *src)
3145 : : {
3146 : 1187 : size_t src_len, result_len;
3147 : :
3148 : 1187 : src_len = src->representation.length - src->ts.u.pad;
3149 : 1187 : gfc_target_expr_size (result, &result_len);
3150 : :
3151 : 1187 : if (src_len > result_len)
3152 : : {
3153 : 248 : gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
3154 : : "is truncated in conversion to %qs", &src->where,
3155 : : gfc_typename(&result->ts));
3156 : : }
3157 : :
3158 : 1187 : result->representation.string = XCNEWVEC (char, result_len + 1);
3159 : 1187 : memcpy (result->representation.string, src->representation.string,
3160 : 1187 : MIN (result_len, src_len));
3161 : :
3162 : 1187 : if (src_len < result_len)
3163 : 294 : memset (&result->representation.string[src_len], ' ', result_len - src_len);
3164 : :
3165 : 1187 : result->representation.string[result_len] = '\0'; /* For debugger */
3166 : 1187 : result->representation.length = result_len;
3167 : 1187 : }
3168 : :
3169 : :
3170 : : /* Helper function to set the representation in a character conversion.
3171 : : This assumes that the ts.type and ts.kind of the result have already
3172 : : been set. */
3173 : :
3174 : : static void
3175 : 747 : character2representation (gfc_expr *result, gfc_expr *src)
3176 : : {
3177 : 747 : size_t src_len, result_len, i;
3178 : 747 : src_len = src->value.character.length;
3179 : 747 : gfc_target_expr_size (result, &result_len);
3180 : :
3181 : 747 : if (src_len > result_len)
3182 : 240 : gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
3183 : : "truncated in conversion to %s", &src->where,
3184 : : gfc_typename(&result->ts));
3185 : :
3186 : 747 : result->representation.string = XCNEWVEC (char, result_len + 1);
3187 : :
3188 : 3991 : for (i = 0; i < MIN (result_len, src_len); i++)
3189 : 3244 : result->representation.string[i] = (char) src->value.character.string[i];
3190 : :
3191 : 747 : if (src_len < result_len)
3192 : 246 : memset (&result->representation.string[src_len], ' ',
3193 : : result_len - src_len);
3194 : :
3195 : 747 : result->representation.string[result_len] = '\0'; /* For debugger. */
3196 : 747 : result->representation.length = result_len;
3197 : 747 : }
3198 : :
3199 : : /* Convert Hollerith to integer. The constant will be padded or truncated. */
3200 : :
3201 : : gfc_expr *
3202 : 377 : gfc_hollerith2int (gfc_expr *src, int kind)
3203 : : {
3204 : 377 : gfc_expr *result;
3205 : 377 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3206 : :
3207 : 377 : hollerith2representation (result, src);
3208 : 377 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3209 : 377 : result->representation.length, result->value.integer);
3210 : :
3211 : 377 : return result;
3212 : : }
3213 : :
3214 : : /* Convert character to integer. The constant will be padded or truncated. */
3215 : :
3216 : : gfc_expr *
3217 : 187 : gfc_character2int (gfc_expr *src, int kind)
3218 : : {
3219 : 187 : gfc_expr *result;
3220 : 187 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3221 : :
3222 : 187 : character2representation (result, src);
3223 : 187 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3224 : 187 : result->representation.length, result->value.integer);
3225 : 187 : return result;
3226 : : }
3227 : :
3228 : : /* Convert Hollerith to real. The constant will be padded or truncated. */
3229 : :
3230 : : gfc_expr *
3231 : 327 : gfc_hollerith2real (gfc_expr *src, int kind)
3232 : : {
3233 : 327 : gfc_expr *result;
3234 : 327 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3235 : :
3236 : 327 : hollerith2representation (result, src);
3237 : 327 : if (gfc_interpret_float (kind,
3238 : 327 : (unsigned char *) result->representation.string,
3239 : 327 : result->representation.length, result->value.real))
3240 : : return result;
3241 : : else
3242 : 0 : return NULL;
3243 : : }
3244 : :
3245 : : /* Convert character to real. The constant will be padded or truncated. */
3246 : :
3247 : : gfc_expr *
3248 : 187 : gfc_character2real (gfc_expr *src, int kind)
3249 : : {
3250 : 187 : gfc_expr *result;
3251 : 187 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3252 : :
3253 : 187 : character2representation (result, src);
3254 : 187 : gfc_interpret_float (kind, (unsigned char *) result->representation.string,
3255 : 187 : result->representation.length, result->value.real);
3256 : :
3257 : 187 : return result;
3258 : : }
3259 : :
3260 : :
3261 : : /* Convert Hollerith to complex. The constant will be padded or truncated. */
3262 : :
3263 : : gfc_expr *
3264 : 288 : gfc_hollerith2complex (gfc_expr *src, int kind)
3265 : : {
3266 : 288 : gfc_expr *result;
3267 : 288 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3268 : :
3269 : 288 : hollerith2representation (result, src);
3270 : 288 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3271 : 288 : result->representation.length, result->value.complex);
3272 : :
3273 : 288 : return result;
3274 : : }
3275 : :
3276 : : /* Convert character to complex. The constant will be padded or truncated. */
3277 : :
3278 : : gfc_expr *
3279 : 187 : gfc_character2complex (gfc_expr *src, int kind)
3280 : : {
3281 : 187 : gfc_expr *result;
3282 : 187 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3283 : :
3284 : 187 : character2representation (result, src);
3285 : 187 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3286 : 187 : result->representation.length, result->value.complex);
3287 : :
3288 : 187 : return result;
3289 : : }
3290 : :
3291 : :
3292 : : /* Convert Hollerith to character. */
3293 : :
3294 : : gfc_expr *
3295 : 164 : gfc_hollerith2character (gfc_expr *src, int kind)
3296 : : {
3297 : 164 : gfc_expr *result;
3298 : :
3299 : 164 : result = gfc_copy_expr (src);
3300 : 164 : result->ts.type = BT_CHARACTER;
3301 : 164 : result->ts.kind = kind;
3302 : 164 : result->ts.u.pad = 0;
3303 : :
3304 : 164 : result->value.character.length = result->representation.length;
3305 : 164 : result->value.character.string
3306 : 164 : = gfc_char_to_widechar (result->representation.string);
3307 : :
3308 : 164 : return result;
3309 : : }
3310 : :
3311 : :
3312 : : /* Convert Hollerith to logical. The constant will be padded or truncated. */
3313 : :
3314 : : gfc_expr *
3315 : 195 : gfc_hollerith2logical (gfc_expr *src, int kind)
3316 : : {
3317 : 195 : gfc_expr *result;
3318 : 195 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3319 : :
3320 : 195 : hollerith2representation (result, src);
3321 : 195 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3322 : 195 : result->representation.length, &result->value.logical);
3323 : :
3324 : 195 : return result;
3325 : : }
3326 : :
3327 : : /* Convert character to logical. The constant will be padded or truncated. */
3328 : :
3329 : : gfc_expr *
3330 : 186 : gfc_character2logical (gfc_expr *src, int kind)
3331 : : {
3332 : 186 : gfc_expr *result;
3333 : 186 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3334 : :
3335 : 186 : character2representation (result, src);
3336 : 186 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3337 : 186 : result->representation.length, &result->value.logical);
3338 : :
3339 : 186 : return result;
3340 : : }
|
