Line data Source code
1 : /* Compiler arithmetic
2 : Copyright (C) 2000-2026 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 929858 : gfc_set_model_kind (int kind)
76 : {
77 929858 : int index = gfc_validate_kind (BT_REAL, kind, false);
78 929858 : int base2prec;
79 :
80 929858 : base2prec = gfc_real_kinds[index].digits;
81 929858 : if (gfc_real_kinds[index].radix != 2)
82 0 : base2prec *= gfc_real_kinds[index].radix / 2;
83 929858 : mpfr_set_default_prec (base2prec);
84 929858 : }
85 :
86 :
87 : /* Set the model number precision from mpfr_t x. */
88 :
89 : void
90 431163 : gfc_set_model (mpfr_t x)
91 : {
92 431163 : mpfr_set_default_prec (mpfr_get_prec (x));
93 431163 : }
94 :
95 :
96 : /* Given an arithmetic error code, return a pointer to a string that
97 : explains the error. */
98 :
99 : const char *
100 282 : gfc_arith_error (arith code)
101 : {
102 282 : const char *p;
103 :
104 282 : 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 13 : case ARITH_UNDERFLOW:
113 13 : p = G_("Arithmetic underflow at %L");
114 13 : 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 282 : 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 11365163 : 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 31306 : gfc_arith_init_1 (void)
176 : {
177 31306 : gfc_integer_info *int_info;
178 31306 : gfc_unsigned_info *uint_info;
179 31306 : gfc_real_info *real_info;
180 31306 : mpfr_t a, b;
181 31306 : int i;
182 :
183 31306 : mpfr_set_default_prec (128);
184 31306 : mpfr_init (a);
185 :
186 : /* Convert the minimum and maximum values for each kind into their
187 : GNU MP representation. */
188 218735 : for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
189 : {
190 : /* Huge */
191 156123 : mpz_init (int_info->huge);
192 156123 : mpz_set_ui (int_info->huge, int_info->radix);
193 156123 : mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
194 156123 : 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 156123 : 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 156123 : mpz_init (int_info->pedantic_min_int);
209 156123 : mpz_neg (int_info->pedantic_min_int, int_info->huge);
210 :
211 156123 : mpz_init (int_info->min_int);
212 156123 : mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
213 :
214 : /* Range */
215 156123 : mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
216 156123 : mpfr_log10 (a, a, GFC_RND_MODE);
217 156123 : mpfr_trunc (a, a);
218 156123 : int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
219 : }
220 :
221 : /* Similar, for UNSIGNED. */
222 31306 : 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 31306 : mpfr_clear (a);
252 :
253 187836 : for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
254 : {
255 125224 : gfc_set_model_kind (real_info->kind);
256 :
257 125224 : mpfr_init (a);
258 125224 : mpfr_init (b);
259 :
260 : /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
261 : /* 1 - b**(-p) */
262 125224 : mpfr_init (real_info->huge);
263 125224 : mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
264 125224 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
265 125224 : mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
266 125224 : mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
267 :
268 : /* b**(emax-1) */
269 125224 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
270 125224 : mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
271 :
272 : /* (1 - b**(-p)) * b**(emax-1) */
273 125224 : mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
274 :
275 : /* (1 - b**(-p)) * b**(emax-1) * b */
276 125224 : mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
277 : GFC_RND_MODE);
278 :
279 : /* tiny(x) = b**(emin-1) */
280 125224 : mpfr_init (real_info->tiny);
281 125224 : mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
282 125224 : mpfr_pow_si (real_info->tiny, real_info->tiny,
283 125224 : real_info->min_exponent - 1, GFC_RND_MODE);
284 :
285 : /* subnormal (x) = b**(emin - digit) */
286 125224 : mpfr_init (real_info->subnormal);
287 125224 : mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
288 125224 : mpfr_pow_si (real_info->subnormal, real_info->subnormal,
289 125224 : real_info->min_exponent - real_info->digits, GFC_RND_MODE);
290 :
291 : /* epsilon(x) = b**(1-p) */
292 125224 : mpfr_init (real_info->epsilon);
293 125224 : mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
294 125224 : mpfr_pow_si (real_info->epsilon, real_info->epsilon,
295 125224 : 1 - real_info->digits, GFC_RND_MODE);
296 :
297 : /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
298 125224 : mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
299 125224 : mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
300 125224 : mpfr_neg (b, b, GFC_RND_MODE);
301 :
302 : /* a = min(a, b) */
303 125224 : mpfr_min (a, a, b, GFC_RND_MODE);
304 125224 : mpfr_trunc (a, a);
305 125224 : real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
306 :
307 : /* precision(x) = int((p - 1) * log10(b)) + k */
308 125224 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
309 125224 : mpfr_log10 (a, a, GFC_RND_MODE);
310 125224 : mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
311 125224 : mpfr_trunc (a, a);
312 125224 : 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 125224 : for (i = 10; i <= real_info->radix; i *= 10)
316 0 : if (i == real_info->radix)
317 0 : real_info->precision++;
318 :
319 125224 : mpfr_clears (a, b, NULL);
320 : }
321 31306 : }
322 :
323 :
324 : /* Clean up, get rid of numeric constants. */
325 :
326 : void
327 31287 : gfc_arith_done_1 (void)
328 : {
329 31287 : gfc_integer_info *ip;
330 31287 : gfc_real_info *rp;
331 :
332 187315 : for (ip = gfc_integer_kinds; ip->kind; ip++)
333 : {
334 156028 : mpz_clear (ip->min_int);
335 156028 : mpz_clear (ip->pedantic_min_int);
336 156028 : mpz_clear (ip->huge);
337 : }
338 :
339 156435 : for (rp = gfc_real_kinds; rp->kind; rp++)
340 125148 : mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
341 :
342 31287 : mpfr_free_cache ();
343 31287 : }
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 1782089 : 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 1782089 : if (kind == 4)
354 : return true;
355 :
356 1600885 : if (kind == 1)
357 1600885 : 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 15826724 : gfc_check_integer_range (mpz_t p, int kind)
369 : {
370 15826724 : arith result;
371 15826724 : int i;
372 :
373 15826724 : i = gfc_validate_kind (BT_INTEGER, kind, false);
374 15826724 : result = ARITH_OK;
375 :
376 15826724 : if (pedantic)
377 : {
378 13534364 : if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
379 15826724 : result = ARITH_ASYMMETRIC;
380 : }
381 :
382 :
383 15826724 : if (flag_range_check == 0)
384 : return result;
385 :
386 15796888 : if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
387 15796888 : || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
388 15826724 : 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 429685 : gfc_check_real_range (mpfr_t p, int kind)
419 : {
420 429685 : arith retval;
421 429685 : mpfr_t q;
422 429685 : int i;
423 :
424 429685 : i = gfc_validate_kind (BT_REAL, kind, false);
425 :
426 429685 : gfc_set_model (p);
427 429685 : mpfr_init (q);
428 429685 : mpfr_abs (q, p, GFC_RND_MODE);
429 :
430 429685 : retval = ARITH_OK;
431 :
432 429685 : if (mpfr_inf_p (p))
433 : {
434 1157 : if (flag_range_check != 0)
435 21 : retval = ARITH_OVERFLOW;
436 : }
437 428528 : else if (mpfr_nan_p (p))
438 : {
439 238 : if (flag_range_check != 0)
440 363621 : retval = ARITH_NAN;
441 : }
442 428290 : else if (mpfr_sgn (q) == 0)
443 : {
444 66064 : mpfr_clear (q);
445 66064 : return retval;
446 : }
447 362226 : else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
448 : {
449 48 : if (flag_range_check == 0)
450 44 : mpfr_set_inf (p, mpfr_sgn (p));
451 : else
452 : retval = ARITH_OVERFLOW;
453 : }
454 362178 : else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
455 : {
456 32 : 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 362146 : 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 363621 : mpfr_clear (q);
498 :
499 363621 : 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 7452 : gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
544 : {
545 7452 : gfc_expr *result;
546 :
547 7452 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
548 : return ARITH_INVALID_TYPE;
549 :
550 7451 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
551 : &op1->where);
552 7451 : result->value.logical = op1->value.logical || op2->value.logical;
553 7451 : *resultp = result;
554 :
555 7451 : 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 16183608 : gfc_range_check (gfc_expr *e)
599 : {
600 16183608 : arith rc;
601 16183608 : arith rc2;
602 :
603 16183608 : switch (e->ts.type)
604 : {
605 15754824 : case BT_INTEGER:
606 15754824 : rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
607 15754824 : 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 303816 : case BT_REAL:
614 303816 : rc = gfc_check_real_range (e->value.real, e->ts.kind);
615 303816 : if (rc == ARITH_UNDERFLOW)
616 19 : mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
617 303816 : if (rc == ARITH_OVERFLOW)
618 16 : mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
619 303816 : if (rc == ARITH_NAN)
620 19 : mpfr_set_nan (e->value.real);
621 : break;
622 :
623 7250 : case BT_COMPLEX:
624 7250 : rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
625 7250 : if (rc == ARITH_UNDERFLOW)
626 0 : mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
627 7250 : if (rc == ARITH_OVERFLOW)
628 2 : mpfr_set_inf (mpc_realref (e->value.complex),
629 2 : mpfr_sgn (mpc_realref (e->value.complex)));
630 7250 : if (rc == ARITH_NAN)
631 4 : mpfr_set_nan (mpc_realref (e->value.complex));
632 :
633 7250 : rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
634 7250 : if (rc == ARITH_UNDERFLOW)
635 0 : mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
636 7250 : if (rc == ARITH_OVERFLOW)
637 2 : mpfr_set_inf (mpc_imagref (e->value.complex),
638 2 : mpfr_sgn (mpc_imagref (e->value.complex)));
639 7250 : if (rc == ARITH_NAN)
640 4 : mpfr_set_nan (mpc_imagref (e->value.complex));
641 :
642 7250 : if (rc == ARITH_OK)
643 7244 : rc = rc2;
644 : break;
645 :
646 0 : default:
647 0 : gfc_internal_error ("gfc_range_check(): Bad type");
648 : }
649 :
650 16183608 : 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 11343710 : check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
659 : {
660 11343710 : arith val = rc;
661 :
662 11343710 : if (val == ARITH_UNDERFLOW)
663 : {
664 19 : if (warn_underflow)
665 13 : gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
666 : val = ARITH_OK;
667 : }
668 :
669 11343691 : if (val == ARITH_ASYMMETRIC)
670 : {
671 86 : gfc_warning (0, gfc_arith_error (val), &x->where);
672 86 : val = ARITH_OK;
673 : }
674 :
675 11343710 : if (is_hard_arith_error (val))
676 1 : gfc_free_expr (r);
677 : else
678 11343709 : *rp = r;
679 :
680 11343710 : 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 132055 : gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
699 : {
700 132055 : gfc_expr *result;
701 132055 : arith rc;
702 :
703 132055 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
704 :
705 132055 : switch (op1->ts.type)
706 : {
707 100809 : case BT_INTEGER:
708 100809 : mpz_neg (result->value.integer, op1->value.integer);
709 100809 : 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 31213 : case BT_REAL:
721 31213 : mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
722 31213 : 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 132054 : rc = gfc_range_check (result);
733 132054 : 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 132054 : return check_result (rc, op1, result, resultp);
743 : }
744 :
745 :
746 : static arith
747 10356984 : gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
748 : {
749 10356984 : gfc_expr *result;
750 10356984 : arith rc;
751 :
752 10356984 : if (op1->ts.type != op2->ts.type)
753 : return ARITH_INVALID_TYPE;
754 :
755 10356983 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
756 :
757 10356983 : switch (op1->ts.type)
758 : {
759 10353841 : case BT_INTEGER:
760 10353841 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
761 10353841 : 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 10356983 : rc = gfc_range_check (result);
783 :
784 10356983 : return check_result (rc, op1, result, resultp);
785 : }
786 :
787 :
788 : static arith
789 512528 : gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
790 : {
791 512528 : gfc_expr *result;
792 512528 : arith rc;
793 :
794 512528 : if (op1->ts.type != op2->ts.type)
795 : return ARITH_INVALID_TYPE;
796 :
797 512527 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
798 :
799 512527 : switch (op1->ts.type)
800 : {
801 511439 : case BT_INTEGER:
802 511439 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
803 511439 : 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 512527 : rc = gfc_range_check (result);
825 :
826 512527 : return check_result (rc, op1, result, resultp);
827 : }
828 :
829 :
830 : static arith
831 312531 : gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
832 : {
833 312531 : gfc_expr *result;
834 312531 : arith rc;
835 :
836 312531 : if (op1->ts.type != op2->ts.type)
837 : return ARITH_INVALID_TYPE;
838 :
839 312529 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
840 :
841 312529 : switch (op1->ts.type)
842 : {
843 300095 : case BT_INTEGER:
844 300095 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
845 300095 : 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 11022 : case BT_REAL:
853 11022 : mpfr_mul (result->value.real, op1->value.real, op2->value.real,
854 : GFC_RND_MODE);
855 11022 : 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 312529 : rc = gfc_range_check (result);
868 :
869 312529 : return check_result (rc, op1, result, resultp);
870 : }
871 :
872 :
873 : static arith
874 7832 : gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
875 : {
876 7832 : gfc_expr *result;
877 7832 : arith rc;
878 :
879 7832 : if (op1->ts.type != op2->ts.type)
880 : return ARITH_INVALID_TYPE;
881 :
882 7830 : rc = ARITH_OK;
883 :
884 7830 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
885 :
886 7830 : switch (op1->ts.type)
887 : {
888 3638 : case BT_INTEGER:
889 3638 : case BT_UNSIGNED:
890 3638 : if (mpz_sgn (op2->value.integer) == 0)
891 : {
892 : rc = ARITH_DIV0;
893 : break;
894 : }
895 :
896 3617 : 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 3568 : mpz_tdiv_q (result->value.integer, op1->value.integer,
916 3568 : 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 7809 : if (rc == ARITH_OK)
960 7800 : rc = gfc_range_check (result);
961 :
962 7830 : return check_result (rc, op1, result, resultp);
963 : }
964 :
965 : /* Raise a number to a power. */
966 :
967 : static arith
968 21791 : arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
969 : {
970 21791 : int power_sign;
971 21791 : gfc_expr *result;
972 21791 : arith rc;
973 :
974 21791 : 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 21787 : if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
981 21787 : || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
982 : return ARITH_NOT_REDUCED;
983 :
984 21787 : rc = ARITH_OK;
985 21787 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
986 :
987 21787 : switch (op2->ts.type)
988 : {
989 6345 : case BT_INTEGER:
990 6345 : power_sign = mpz_sgn (op2->value.integer);
991 :
992 6069 : 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 199 : switch (op1->ts.type)
998 : {
999 85 : case BT_INTEGER:
1000 85 : mpz_set_ui (result->value.integer, 1);
1001 85 : break;
1002 :
1003 60 : case BT_REAL:
1004 60 : mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
1005 60 : break;
1006 :
1007 54 : case BT_COMPLEX:
1008 54 : mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
1009 54 : break;
1010 :
1011 0 : default:
1012 0 : gfc_internal_error ("arith_power(): Bad base");
1013 : }
1014 : }
1015 : else
1016 : {
1017 6146 : switch (op1->ts.type)
1018 : {
1019 5544 : case BT_INTEGER:
1020 5544 : {
1021 : /* First, we simplify the cases of op1 == 1, 0 or -1. */
1022 5544 : if (mpz_cmp_si (op1->value.integer, 1) == 0)
1023 : {
1024 : /* 1**op2 == 1 */
1025 870 : mpz_set_si (result->value.integer, 1);
1026 : }
1027 4674 : 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 4668 : else if (mpz_cmp_si (op1->value.integer, -1) == 0)
1037 : {
1038 : /* (-1)**op2 == (-1)**(mod(op2,2)) */
1039 84 : unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
1040 84 : if (odd)
1041 42 : mpz_set_si (result->value.integer, -1);
1042 : else
1043 42 : mpz_set_si (result->value.integer, 1);
1044 : }
1045 : /* Then, we take care of op2 < 0. */
1046 4584 : else if (mpz_cmp_si (op2->value.integer, 0) < 0)
1047 : {
1048 : /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1049 29 : mpz_set_si (result->value.integer, 0);
1050 29 : 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 4555 : int k, power;
1061 :
1062 4555 : k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
1063 4555 : power = gfc_integer_kinds[k].bit_size;
1064 4555 : if (mpz_cmp_si (op2->value.integer, power) < 0)
1065 : {
1066 4536 : gfc_extract_int (op2, &power);
1067 4536 : mpz_pow_ui (result->value.integer, op1->value.integer,
1068 : power);
1069 4536 : rc = gfc_range_check (result);
1070 4536 : 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 465 : case BT_REAL:
1089 465 : mpfr_pow_z (result->value.real, op1->value.real,
1090 465 : op2->value.integer, GFC_RND_MODE);
1091 465 : break;
1092 :
1093 137 : case BT_COMPLEX:
1094 137 : mpc_pow_z (result->value.complex, op1->value.complex,
1095 137 : op2->value.integer, GFC_MPC_RND_MODE);
1096 137 : 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 21752 : if (rc == ARITH_OK)
1165 21762 : rc = gfc_range_check (result);
1166 :
1167 21786 : 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 42680 : gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1244 : {
1245 42680 : int rc;
1246 :
1247 42680 : switch (op1->ts.type)
1248 : {
1249 32706 : case BT_INTEGER:
1250 32706 : case BT_UNSIGNED:
1251 32706 : rc = mpz_cmp (op1->value.integer, op2->value.integer);
1252 32706 : 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 42680 : 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 3438 : gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1358 : {
1359 3438 : gfc_expr *result;
1360 :
1361 3438 : if (op1->ts.type != op2->ts.type)
1362 : return ARITH_INVALID_TYPE;
1363 :
1364 3436 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1365 : &op1->where);
1366 6872 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1367 3436 : ? compare_complex (op1, op2)
1368 3436 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1369 :
1370 3436 : *resultp = result;
1371 3436 : return ARITH_OK;
1372 : }
1373 :
1374 :
1375 : static arith
1376 32518 : gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1377 : {
1378 32518 : gfc_expr *result;
1379 :
1380 32518 : if (op1->ts.type != op2->ts.type)
1381 : return ARITH_INVALID_TYPE;
1382 :
1383 32516 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1384 : &op1->where);
1385 65032 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1386 32712 : ? !compare_complex (op1, op2)
1387 32320 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1388 :
1389 32516 : *resultp = result;
1390 32516 : return ARITH_OK;
1391 : }
1392 :
1393 :
1394 : static arith
1395 3048 : gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1396 : {
1397 3048 : gfc_expr *result;
1398 :
1399 3048 : if (op1->ts.type != op2->ts.type)
1400 : return ARITH_INVALID_TYPE;
1401 :
1402 3046 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1403 : &op1->where);
1404 3046 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1405 3046 : *resultp = result;
1406 :
1407 3046 : return ARITH_OK;
1408 : }
1409 :
1410 :
1411 : static arith
1412 267 : gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1413 : {
1414 267 : gfc_expr *result;
1415 :
1416 267 : if (op1->ts.type != op2->ts.type)
1417 : return ARITH_INVALID_TYPE;
1418 :
1419 265 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1420 : &op1->where);
1421 265 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1422 265 : *resultp = result;
1423 :
1424 265 : 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 133198 : reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1464 : gfc_expr **result)
1465 : {
1466 133198 : gfc_constructor_base head;
1467 133198 : gfc_constructor *c;
1468 133198 : gfc_expr *r;
1469 133198 : arith rc;
1470 :
1471 133198 : if (op->expr_type == EXPR_CONSTANT)
1472 132946 : return eval (op, result);
1473 :
1474 252 : if (op->expr_type != EXPR_ARRAY)
1475 : return ARITH_NOT_REDUCED;
1476 :
1477 245 : rc = ARITH_OK;
1478 245 : head = gfc_constructor_copy (op->value.constructor);
1479 897 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1480 : {
1481 661 : 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 661 : if (is_hard_arith_error (rc_tmp))
1486 : {
1487 : rc = rc_tmp;
1488 : break;
1489 : }
1490 652 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1491 4 : rc = rc_tmp;
1492 :
1493 652 : gfc_replace_expr (c->expr, r);
1494 : }
1495 :
1496 245 : if (is_hard_arith_error (rc))
1497 9 : gfc_constructor_free (head);
1498 : else
1499 : {
1500 236 : gfc_constructor *c = gfc_constructor_first (head);
1501 236 : 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 206 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1509 : &op->where);
1510 : }
1511 236 : r->shape = gfc_copy_shape (op->shape, op->rank);
1512 236 : r->rank = op->rank;
1513 236 : r->corank = op->corank;
1514 236 : r->value.constructor = head;
1515 236 : *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 881 : reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1592 : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1593 : {
1594 881 : gfc_constructor_base head;
1595 881 : gfc_constructor *c;
1596 881 : gfc_expr *r;
1597 881 : arith rc = ARITH_OK;
1598 :
1599 881 : head = gfc_constructor_copy (op2->value.constructor);
1600 4428 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1601 : {
1602 3579 : arith rc_tmp;
1603 :
1604 3579 : gfc_simplify_expr (c->expr, 0);
1605 :
1606 3579 : if (c->expr->expr_type == EXPR_CONSTANT)
1607 3425 : 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 3569 : if (is_hard_arith_error (rc_tmp))
1616 : {
1617 : rc = rc_tmp;
1618 : break;
1619 : }
1620 3547 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1621 3 : rc = rc_tmp;
1622 :
1623 3547 : gfc_replace_expr (c->expr, r);
1624 : }
1625 :
1626 881 : if (is_hard_arith_error (rc))
1627 32 : gfc_constructor_free (head);
1628 : else
1629 : {
1630 849 : gfc_constructor *c = gfc_constructor_first (head);
1631 849 : if (c)
1632 : {
1633 759 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1634 : &op2->where);
1635 759 : r->shape = gfc_copy_shape (op2->shape, op2->rank);
1636 759 : 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 849 : r->rank = op2->rank;
1649 849 : r->corank = op2->corank;
1650 849 : r->value.constructor = head;
1651 849 : *result = r;
1652 : }
1653 :
1654 881 : 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 1596 : reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1665 : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1666 : {
1667 1596 : gfc_constructor_base head;
1668 1596 : gfc_constructor *c, *d;
1669 1596 : gfc_expr *r;
1670 1596 : arith rc = ARITH_OK;
1671 :
1672 1596 : if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1673 : return ARITH_INCOMMENSURATE;
1674 :
1675 1596 : head = gfc_constructor_copy (op1->value.constructor);
1676 3192 : for (c = gfc_constructor_first (head),
1677 1596 : d = gfc_constructor_first (op2->value.constructor);
1678 6159 : c && d;
1679 4563 : c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1680 : {
1681 4568 : 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 4568 : if (is_hard_arith_error (rc_tmp))
1686 : {
1687 : rc = rc_tmp;
1688 : break;
1689 : }
1690 4563 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1691 8 : rc = rc_tmp;
1692 :
1693 4563 : gfc_replace_expr (c->expr, r);
1694 : }
1695 :
1696 1596 : if (rc == ARITH_OK && (c || d))
1697 : rc = ARITH_INCOMMENSURATE;
1698 :
1699 1596 : if (is_hard_arith_error (rc))
1700 5 : gfc_constructor_free (head);
1701 : else
1702 : {
1703 1591 : gfc_constructor *c = gfc_constructor_first (head);
1704 1591 : 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 1459 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1714 : &op1->where);
1715 1459 : if (c->expr->ts.type == BT_CHARACTER)
1716 6 : r->ts.u.cl = c->expr->ts.u.cl;
1717 : }
1718 1591 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1719 1591 : r->rank = op1->rank;
1720 1591 : r->corank = op1->corank;
1721 1591 : r->value.constructor = head;
1722 1591 : *result = r;
1723 : }
1724 :
1725 : return rc;
1726 : }
1727 :
1728 :
1729 : static arith
1730 11259377 : reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1731 : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1732 : {
1733 11259377 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1734 11255605 : return eval (op1, op2, result);
1735 :
1736 3772 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1737 737 : return reduce_binary_ca (eval, op1, op2, result);
1738 :
1739 3035 : if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1740 1435 : return reduce_binary_ac (eval, op1, op2, result);
1741 :
1742 1600 : if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1743 : return ARITH_NOT_REDUCED;
1744 :
1745 1596 : 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 12910089 : eval_intrinsic (gfc_intrinsic_op op,
1768 : eval_f eval, gfc_expr *op1, gfc_expr *op2)
1769 : {
1770 12910089 : gfc_expr temp, *result;
1771 12910089 : int unary;
1772 12910089 : arith rc;
1773 :
1774 12910089 : if (!op1)
1775 : return NULL;
1776 :
1777 12910085 : gfc_clear_ts (&temp.ts);
1778 :
1779 12910085 : switch (op)
1780 : {
1781 : /* Logical unary */
1782 78037 : case INTRINSIC_NOT:
1783 78037 : if (op1->ts.type != BT_LOGICAL)
1784 70148 : goto runtime;
1785 :
1786 7889 : temp.ts.type = BT_LOGICAL;
1787 7889 : temp.ts.kind = gfc_default_logical_kind;
1788 7889 : unary = 1;
1789 7889 : break;
1790 :
1791 : /* Logical binary operators */
1792 251400 : case INTRINSIC_OR:
1793 251400 : case INTRINSIC_AND:
1794 251400 : case INTRINSIC_NEQV:
1795 251400 : case INTRINSIC_EQV:
1796 251400 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1797 62781 : goto runtime;
1798 :
1799 188619 : temp.ts.type = BT_LOGICAL;
1800 188619 : temp.ts.kind = gfc_default_logical_kind;
1801 188619 : unary = 0;
1802 188619 : break;
1803 :
1804 : /* Numeric unary */
1805 152947 : case INTRINSIC_UPLUS:
1806 152947 : case INTRINSIC_UMINUS:
1807 152947 : if (!gfc_numeric_ts (&op1->ts))
1808 6828 : goto runtime;
1809 :
1810 146119 : temp.ts = op1->ts;
1811 146119 : unary = 1;
1812 146119 : 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 65840 : case INTRINSIC_GE:
1821 65840 : case INTRINSIC_GE_OS:
1822 65840 : case INTRINSIC_LT:
1823 65840 : case INTRINSIC_LT_OS:
1824 65840 : case INTRINSIC_LE:
1825 65840 : case INTRINSIC_LE_OS:
1826 65840 : case INTRINSIC_GT:
1827 65840 : case INTRINSIC_GT_OS:
1828 65840 : 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 968931 : case INTRINSIC_EQ:
1837 968931 : case INTRINSIC_EQ_OS:
1838 968931 : case INTRINSIC_NE:
1839 968931 : case INTRINSIC_NE_OS:
1840 968931 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1841 : {
1842 102776 : unary = 0;
1843 102776 : temp.ts.type = BT_LOGICAL;
1844 102776 : temp.ts.kind = gfc_default_logical_kind;
1845 :
1846 : /* If kind mismatch, exit and we'll error out later. */
1847 102776 : if (op1->ts.kind != op2->ts.kind)
1848 40 : goto runtime;
1849 :
1850 : break;
1851 : }
1852 :
1853 940811 : gcc_fallthrough ();
1854 : /* Numeric binary */
1855 940811 : case INTRINSIC_POWER:
1856 940811 : 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 12316895 : gcc_fallthrough ();
1864 :
1865 12316895 : case INTRINSIC_PLUS:
1866 12316895 : case INTRINSIC_MINUS:
1867 12316895 : case INTRINSIC_TIMES:
1868 12316895 : case INTRINSIC_DIVIDE:
1869 12316895 : if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1870 488083 : goto runtime;
1871 :
1872 11828812 : 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 11828808 : 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 11828588 : temp.expr_type = EXPR_OP;
1885 11828588 : gfc_clear_ts (&temp.ts);
1886 11828588 : temp.value.op.op = op;
1887 :
1888 11828588 : temp.value.op.op1 = op1;
1889 11828588 : temp.value.op.op2 = op2;
1890 :
1891 11830748 : gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1892 :
1893 11828588 : if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1894 11828588 : || op == INTRINSIC_GE || op == INTRINSIC_GT
1895 11502408 : || op == INTRINSIC_LE || op == INTRINSIC_LT
1896 11491821 : || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1897 11480392 : || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1898 11394186 : || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1899 : {
1900 444178 : temp.ts.type = BT_LOGICAL;
1901 444178 : temp.ts.kind = gfc_default_logical_kind;
1902 : }
1903 :
1904 : unary = 0;
1905 : break;
1906 :
1907 : /* Character binary */
1908 7946 : case INTRINSIC_CONCAT:
1909 7946 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1910 6370 : || op1->ts.kind != op2->ts.kind)
1911 1585 : goto runtime;
1912 :
1913 6361 : temp.ts.type = BT_CHARACTER;
1914 6361 : temp.ts.kind = op1->ts.kind;
1915 6361 : unary = 0;
1916 6361 : 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 12280312 : if (op1->expr_type != EXPR_CONSTANT
1926 12280312 : && (op1->expr_type != EXPR_ARRAY
1927 3133 : || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1928 849448 : goto runtime;
1929 :
1930 11430864 : if (op2 != NULL
1931 11298327 : && op2->expr_type != EXPR_CONSTANT
1932 11476581 : && (op2->expr_type != EXPR_ARRAY
1933 2199 : || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1934 43518 : 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 11387346 : if (op1->expr_type == EXPR_ARRAY && op1->ts.type != BT_UNKNOWN)
1941 3106 : gfc_check_constructor_type (op1);
1942 11387346 : if (op2 != NULL && op2->expr_type == EXPR_ARRAY && op2->ts.type != BT_UNKNOWN)
1943 2199 : 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 11387346 : 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 11387346 : if (unary)
1960 132537 : rc = reduce_unary (eval.f2, op1, &result);
1961 : else
1962 11254809 : rc = reduce_binary (eval.f3, op1, op2, &result);
1963 :
1964 11387346 : if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1965 57 : goto runtime;
1966 :
1967 : /* Something went wrong. */
1968 11387289 : if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1969 : return NULL;
1970 :
1971 11387288 : 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 11387120 : done:
1984 :
1985 11387233 : gfc_free_expr (op1);
1986 11387233 : gfc_free_expr (op2);
1987 11387233 : return result;
1988 :
1989 1522796 : runtime:
1990 : /* Create a run-time expression. */
1991 1522796 : result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1992 1522796 : result->ts = temp.ts;
1993 1522796 : return result;
1994 : }
1995 :
1996 :
1997 : /* Modify type of expression for zero size array. */
1998 :
1999 : static gfc_expr *
2000 69 : eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
2001 : {
2002 69 : if (op == NULL)
2003 0 : gfc_internal_error ("eval_type_intrinsic0(): op NULL");
2004 :
2005 69 : switch (iop)
2006 : {
2007 68 : case INTRINSIC_GE:
2008 68 : case INTRINSIC_GE_OS:
2009 68 : case INTRINSIC_LT:
2010 68 : case INTRINSIC_LT_OS:
2011 68 : case INTRINSIC_LE:
2012 68 : case INTRINSIC_LE_OS:
2013 68 : case INTRINSIC_GT:
2014 68 : case INTRINSIC_GT_OS:
2015 68 : case INTRINSIC_EQ:
2016 68 : case INTRINSIC_EQ_OS:
2017 68 : case INTRINSIC_NE:
2018 68 : case INTRINSIC_NE_OS:
2019 68 : op->ts.type = BT_LOGICAL;
2020 68 : op->ts.kind = gfc_default_logical_kind;
2021 68 : break;
2022 :
2023 : default:
2024 : break;
2025 : }
2026 :
2027 69 : return op;
2028 : }
2029 :
2030 :
2031 : /* Return nonzero if the expression is a zero size array. */
2032 :
2033 : static bool
2034 25589264 : gfc_zero_size_array (gfc_expr *e)
2035 : {
2036 25589260 : 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 12679174 : reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
2049 : {
2050 12684100 : if (gfc_zero_size_array (op1))
2051 : {
2052 68 : gfc_free_expr (op2);
2053 68 : return op1;
2054 : }
2055 :
2056 12753500 : 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 230984 : eval_intrinsic_f2 (gfc_intrinsic_op op,
2068 : arith (*eval) (gfc_expr *, gfc_expr **),
2069 : gfc_expr *op1, gfc_expr *op2)
2070 : {
2071 230984 : gfc_expr *result;
2072 230984 : eval_f f;
2073 :
2074 230984 : if (op2 == NULL)
2075 : {
2076 231232 : 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 230984 : f.f2 = eval;
2087 230984 : return eval_intrinsic (op, f, op1, op2);
2088 : }
2089 :
2090 :
2091 : static gfc_expr *
2092 12679183 : 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 12679183 : gfc_expr *result;
2097 12679183 : eval_f f;
2098 :
2099 12679183 : if (!op1 && !op2)
2100 : return NULL;
2101 :
2102 12679174 : result = reduce_binary0 (op1, op2);
2103 12679174 : if (result != NULL)
2104 69 : return eval_type_intrinsic0(op, result);
2105 :
2106 12679105 : f.f3 = eval;
2107 12679105 : return eval_intrinsic (op, f, op1, op2);
2108 : }
2109 :
2110 :
2111 : gfc_expr *
2112 5258498 : gfc_parentheses (gfc_expr *op)
2113 : {
2114 5258498 : 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 152540 : gfc_uminus (gfc_expr *op)
2130 : {
2131 152540 : return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
2132 : }
2133 :
2134 :
2135 : gfc_expr *
2136 10412091 : gfc_add (gfc_expr *op1, gfc_expr *op2)
2137 : {
2138 10412091 : return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
2139 : }
2140 :
2141 :
2142 : gfc_expr *
2143 576675 : gfc_subtract (gfc_expr *op1, gfc_expr *op2)
2144 : {
2145 576675 : return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
2146 : }
2147 :
2148 :
2149 : gfc_expr *
2150 368385 : gfc_multiply (gfc_expr *op1, gfc_expr *op2)
2151 : {
2152 368385 : return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
2153 : }
2154 :
2155 :
2156 : gfc_expr *
2157 18995 : gfc_divide (gfc_expr *op1, gfc_expr *op2)
2158 : {
2159 18995 : return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
2160 : }
2161 :
2162 :
2163 : gfc_expr *
2164 74656 : gfc_power (gfc_expr *op1, gfc_expr *op2)
2165 : {
2166 74656 : return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
2167 : }
2168 :
2169 :
2170 : gfc_expr *
2171 7946 : gfc_concat (gfc_expr *op1, gfc_expr *op2)
2172 : {
2173 7946 : return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
2174 : }
2175 :
2176 :
2177 : gfc_expr *
2178 18583 : gfc_and (gfc_expr *op1, gfc_expr *op2)
2179 : {
2180 18583 : return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
2181 : }
2182 :
2183 :
2184 : gfc_expr *
2185 207209 : gfc_or (gfc_expr *op1, gfc_expr *op2)
2186 : {
2187 207209 : return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
2188 : }
2189 :
2190 :
2191 : gfc_expr *
2192 78037 : gfc_not (gfc_expr *op1)
2193 : {
2194 78037 : 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 23610 : gfc_neqv (gfc_expr *op1, gfc_expr *op2)
2207 : {
2208 23610 : return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
2209 : }
2210 :
2211 :
2212 : gfc_expr *
2213 34778 : gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2214 : {
2215 34778 : return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
2216 : }
2217 :
2218 :
2219 : gfc_expr *
2220 868365 : gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2221 : {
2222 868365 : return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
2223 : }
2224 :
2225 :
2226 : gfc_expr *
2227 42041 : gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2228 : {
2229 42041 : return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
2230 : }
2231 :
2232 :
2233 : gfc_expr *
2234 4765 : gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2235 : {
2236 4765 : return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2237 : }
2238 :
2239 :
2240 : gfc_expr *
2241 11279 : gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2242 : {
2243 11279 : return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2244 : }
2245 :
2246 :
2247 : gfc_expr *
2248 7807 : gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2249 : {
2250 7807 : 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 69824 : gfc_int2int (gfc_expr *src, int kind)
2347 : {
2348 69824 : gfc_expr *result;
2349 69824 : arith rc;
2350 :
2351 69824 : if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
2352 : return NULL;
2353 :
2354 69824 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2355 :
2356 69824 : mpz_set (result->value.integer, src->value.integer);
2357 :
2358 69824 : 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 69819 : 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 99474 : gfc_int2real (gfc_expr *src, int kind)
2395 : {
2396 99474 : gfc_expr *result;
2397 99474 : arith rc;
2398 :
2399 99474 : if (src->ts.type != BT_INTEGER)
2400 : return NULL;
2401 :
2402 99473 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2403 :
2404 99473 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2405 :
2406 99473 : 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 99473 : if (warn_conversion
2414 99473 : && 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 8052 : gfc_real2real (gfc_expr *src, int kind)
2663 : {
2664 8052 : gfc_expr *result;
2665 8052 : arith rc;
2666 8052 : bool did_warn = false;
2667 :
2668 8052 : if (src->ts.type != BT_REAL)
2669 : return NULL;
2670 :
2671 8048 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2672 :
2673 8048 : mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2674 :
2675 8048 : rc = gfc_check_real_range (result->value.real, kind);
2676 :
2677 8048 : 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 8048 : 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 8047 : 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 8047 : 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 1360 : gfc_real2complex (gfc_expr *src, int kind)
2725 : {
2726 1360 : gfc_expr *result;
2727 1360 : arith rc;
2728 1360 : bool did_warn = false;
2729 :
2730 1360 : if (src->ts.type != BT_REAL)
2731 : return NULL;
2732 :
2733 1355 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2734 :
2735 1355 : mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2736 :
2737 1355 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2738 :
2739 1355 : 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 1355 : 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 1355 : 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 1355 : 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 : }
|
