Branch data Line data Source code
1 : : /* Compiler arithmetic
2 : : Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : /* Since target arithmetic must be done on the host, there has to
22 : : be some way of evaluating arithmetic expressions as the host
23 : : would evaluate them. We use the GNU MP library and the MPFR
24 : : library to do arithmetic, and this file provides the interface. */
25 : :
26 : : #include "config.h"
27 : : #include "system.h"
28 : : #include "coretypes.h"
29 : : #include "options.h"
30 : : #include "gfortran.h"
31 : : #include "arith.h"
32 : : #include "target-memory.h"
33 : : #include "constructor.h"
34 : :
35 : : bool gfc_seen_div0;
36 : :
37 : : /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
38 : : It's easily implemented with a few calls though. */
39 : :
40 : : void
41 : 744 : gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
42 : : {
43 : 744 : mpfr_exp_t e;
44 : :
45 : 744 : 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 : 743 : e = mpfr_get_z_exp (z, x);
54 : :
55 : 743 : if (e > 0)
56 : 24 : mpz_mul_2exp (z, z, e);
57 : : else
58 : 719 : 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 : 863600 : gfc_set_model_kind (int kind)
76 : : {
77 : 863600 : int index = gfc_validate_kind (BT_REAL, kind, false);
78 : 863600 : int base2prec;
79 : :
80 : 863600 : base2prec = gfc_real_kinds[index].digits;
81 : 863600 : if (gfc_real_kinds[index].radix != 2)
82 : 0 : base2prec *= gfc_real_kinds[index].radix / 2;
83 : 863600 : mpfr_set_default_prec (base2prec);
84 : 863600 : }
85 : :
86 : :
87 : : /* Set the model number precision from mpfr_t x. */
88 : :
89 : : void
90 : 438111 : gfc_set_model (mpfr_t x)
91 : : {
92 : 438111 : mpfr_set_default_prec (mpfr_get_prec (x));
93 : 438111 : }
94 : :
95 : :
96 : : /* Given an arithmetic error code, return a pointer to a string that
97 : : explains the error. */
98 : :
99 : : const char *
100 : 268 : gfc_arith_error (arith code)
101 : : {
102 : 268 : const char *p;
103 : :
104 : 268 : switch (code)
105 : : {
106 : : case ARITH_OK:
107 : : p = G_("Arithmetic OK at %L");
108 : : break;
109 : 113 : case ARITH_OVERFLOW:
110 : 113 : p = G_("Arithmetic overflow at %L");
111 : 113 : break;
112 : 3 : case ARITH_UNDERFLOW:
113 : 3 : p = G_("Arithmetic underflow at %L");
114 : 3 : break;
115 : 18 : case ARITH_NAN:
116 : 18 : p = G_("Arithmetic NaN at %L");
117 : 18 : break;
118 : 31 : case ARITH_DIV0:
119 : 31 : p = G_("Division by zero at %L");
120 : 31 : 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 : 268 : 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 : 11357218 : 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 : 115 : default:
167 : 0 : return true;
168 : : }
169 : : }
170 : :
171 : :
172 : : /* Get things ready to do math. */
173 : :
174 : : void
175 : 30444 : gfc_arith_init_1 (void)
176 : : {
177 : 30444 : gfc_integer_info *int_info;
178 : 30444 : gfc_unsigned_info *uint_info;
179 : 30444 : gfc_real_info *real_info;
180 : 30444 : mpfr_t a, b;
181 : 30444 : int i;
182 : :
183 : 30444 : mpfr_set_default_prec (128);
184 : 30444 : mpfr_init (a);
185 : :
186 : : /* Convert the minimum and maximum values for each kind into their
187 : : GNU MP representation. */
188 : 212701 : for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
189 : : {
190 : : /* Huge */
191 : 151813 : mpz_init (int_info->huge);
192 : 151813 : mpz_set_ui (int_info->huge, int_info->radix);
193 : 151813 : mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
194 : 151813 : 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 : 151813 : 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 : 151813 : mpz_init (int_info->pedantic_min_int);
209 : 151813 : mpz_neg (int_info->pedantic_min_int, int_info->huge);
210 : :
211 : 151813 : mpz_init (int_info->min_int);
212 : 151813 : mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
213 : :
214 : : /* Range */
215 : 151813 : mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
216 : 151813 : mpfr_log10 (a, a, GFC_RND_MODE);
217 : 151813 : mpfr_trunc (a, a);
218 : 151813 : int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
219 : : }
220 : :
221 : : /* Similar, for UNSIGNED. */
222 : 30444 : if (flag_unsigned)
223 : : {
224 : 1392 : for (uint_info = gfc_unsigned_kinds; uint_info->kind != 0; uint_info++)
225 : : {
226 : : /* UNSIGNED is radix 2. */
227 : 1160 : gcc_assert (uint_info->radix == 2);
228 : : /* Huge. */
229 : 1160 : mpz_init (uint_info->huge);
230 : 1160 : mpz_set_ui (uint_info->huge, 2);
231 : 1160 : mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits);
232 : 1160 : mpz_sub_ui (uint_info->huge, uint_info->huge, 1);
233 : :
234 : : /* int_min - the smallest number we can reasonably convert from. */
235 : :
236 : 1160 : mpz_init (uint_info->int_min);
237 : 1160 : mpz_set_ui (uint_info->int_min, 2);
238 : 1160 : mpz_pow_ui (uint_info->int_min, uint_info->int_min,
239 : 1160 : uint_info->digits - 1);
240 : 1160 : mpz_neg (uint_info->int_min, uint_info->int_min);
241 : :
242 : : /* Range. */
243 : 1160 : mpfr_set_z (a, uint_info->huge, GFC_RND_MODE);
244 : 1160 : mpfr_log10 (a, a, GFC_RND_MODE);
245 : 1160 : mpfr_trunc (a,a);
246 : 1160 : uint_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
247 : : }
248 : :
249 : : }
250 : :
251 : 30444 : mpfr_clear (a);
252 : :
253 : 182664 : for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
254 : : {
255 : 121776 : gfc_set_model_kind (real_info->kind);
256 : :
257 : 121776 : mpfr_init (a);
258 : 121776 : mpfr_init (b);
259 : :
260 : : /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
261 : : /* 1 - b**(-p) */
262 : 121776 : mpfr_init (real_info->huge);
263 : 121776 : mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
264 : 121776 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
265 : 121776 : mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
266 : 121776 : mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
267 : :
268 : : /* b**(emax-1) */
269 : 121776 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
270 : 121776 : mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
271 : :
272 : : /* (1 - b**(-p)) * b**(emax-1) */
273 : 121776 : mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
274 : :
275 : : /* (1 - b**(-p)) * b**(emax-1) * b */
276 : 121776 : mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
277 : : GFC_RND_MODE);
278 : :
279 : : /* tiny(x) = b**(emin-1) */
280 : 121776 : mpfr_init (real_info->tiny);
281 : 121776 : mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
282 : 121776 : mpfr_pow_si (real_info->tiny, real_info->tiny,
283 : 121776 : real_info->min_exponent - 1, GFC_RND_MODE);
284 : :
285 : : /* subnormal (x) = b**(emin - digit) */
286 : 121776 : mpfr_init (real_info->subnormal);
287 : 121776 : mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
288 : 121776 : mpfr_pow_si (real_info->subnormal, real_info->subnormal,
289 : 121776 : real_info->min_exponent - real_info->digits, GFC_RND_MODE);
290 : :
291 : : /* epsilon(x) = b**(1-p) */
292 : 121776 : mpfr_init (real_info->epsilon);
293 : 121776 : mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
294 : 121776 : mpfr_pow_si (real_info->epsilon, real_info->epsilon,
295 : 121776 : 1 - real_info->digits, GFC_RND_MODE);
296 : :
297 : : /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
298 : 121776 : mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
299 : 121776 : mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
300 : 121776 : mpfr_neg (b, b, GFC_RND_MODE);
301 : :
302 : : /* a = min(a, b) */
303 : 121776 : mpfr_min (a, a, b, GFC_RND_MODE);
304 : 121776 : mpfr_trunc (a, a);
305 : 121776 : real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
306 : :
307 : : /* precision(x) = int((p - 1) * log10(b)) + k */
308 : 121776 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
309 : 121776 : mpfr_log10 (a, a, GFC_RND_MODE);
310 : 121776 : mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
311 : 121776 : mpfr_trunc (a, a);
312 : 121776 : 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 : 121776 : for (i = 10; i <= real_info->radix; i *= 10)
316 : 0 : if (i == real_info->radix)
317 : 0 : real_info->precision++;
318 : :
319 : 121776 : mpfr_clears (a, b, NULL);
320 : : }
321 : 30444 : }
322 : :
323 : :
324 : : /* Clean up, get rid of numeric constants. */
325 : :
326 : : void
327 : 30427 : gfc_arith_done_1 (void)
328 : : {
329 : 30427 : gfc_integer_info *ip;
330 : 30427 : gfc_real_info *rp;
331 : :
332 : 182155 : for (ip = gfc_integer_kinds; ip->kind; ip++)
333 : : {
334 : 151728 : mpz_clear (ip->min_int);
335 : 151728 : mpz_clear (ip->pedantic_min_int);
336 : 151728 : mpz_clear (ip->huge);
337 : : }
338 : :
339 : 152135 : for (rp = gfc_real_kinds; rp->kind; rp++)
340 : 121708 : mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
341 : :
342 : 30427 : mpfr_free_cache ();
343 : 30427 : }
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 : 1722645 : 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 : 1722645 : if (kind == 4)
354 : : return true;
355 : :
356 : 1548462 : if (kind == 1)
357 : 1548462 : 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 : 15617313 : gfc_check_integer_range (mpz_t p, int kind)
369 : : {
370 : 15617313 : arith result;
371 : 15617313 : int i;
372 : :
373 : 15617313 : i = gfc_validate_kind (BT_INTEGER, kind, false);
374 : 15617313 : result = ARITH_OK;
375 : :
376 : 15617313 : if (pedantic)
377 : : {
378 : 13398344 : if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
379 : 15617313 : result = ARITH_ASYMMETRIC;
380 : : }
381 : :
382 : :
383 : 15617313 : if (flag_range_check == 0)
384 : : return result;
385 : :
386 : 15588267 : if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
387 : 15588267 : || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
388 : 15617313 : result = ARITH_OVERFLOW;
389 : :
390 : : return result;
391 : : }
392 : :
393 : : /* Same as above. */
394 : : arith
395 : 117650 : gfc_check_unsigned_range (mpz_t p, int kind)
396 : : {
397 : 117650 : int i;
398 : :
399 : 117650 : i = gfc_validate_kind (BT_UNSIGNED, kind, false);
400 : :
401 : 117650 : if (pedantic && mpz_cmp_si (p, 0) < 0)
402 : : return ARITH_UNSIGNED_NEGATIVE;
403 : :
404 : 117650 : if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0)
405 : : return ARITH_UNSIGNED_TRUNCATED;
406 : :
407 : 117649 : 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 : 436633 : gfc_check_real_range (mpfr_t p, int kind)
419 : : {
420 : 436633 : arith retval;
421 : 436633 : mpfr_t q;
422 : 436633 : int i;
423 : :
424 : 436633 : i = gfc_validate_kind (BT_REAL, kind, false);
425 : :
426 : 436633 : gfc_set_model (p);
427 : 436633 : mpfr_init (q);
428 : 436633 : mpfr_abs (q, p, GFC_RND_MODE);
429 : :
430 : 436633 : retval = ARITH_OK;
431 : :
432 : 436633 : if (mpfr_inf_p (p))
433 : : {
434 : 1142 : if (flag_range_check != 0)
435 : 21 : retval = ARITH_OVERFLOW;
436 : : }
437 : 435491 : else if (mpfr_nan_p (p))
438 : : {
439 : 236 : if (flag_range_check != 0)
440 : 370523 : retval = ARITH_NAN;
441 : : }
442 : 435255 : else if (mpfr_sgn (q) == 0)
443 : : {
444 : 66110 : mpfr_clear (q);
445 : 66110 : return retval;
446 : : }
447 : 369145 : else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
448 : : {
449 : 43 : if (flag_range_check == 0)
450 : 39 : mpfr_set_inf (p, mpfr_sgn (p));
451 : : else
452 : : retval = ARITH_OVERFLOW;
453 : : }
454 : 369102 : else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
455 : : {
456 : 22 : if (flag_range_check == 0)
457 : : {
458 : 13 : if (mpfr_sgn (p) < 0)
459 : : {
460 : 6 : mpfr_set_ui (p, 0, GFC_RND_MODE);
461 : 6 : mpfr_set_si (q, -1, GFC_RND_MODE);
462 : 6 : mpfr_copysign (p, p, q, GFC_RND_MODE);
463 : : }
464 : : else
465 : 7 : mpfr_set_ui (p, 0, GFC_RND_MODE);
466 : : }
467 : : else
468 : : retval = ARITH_UNDERFLOW;
469 : : }
470 : 369080 : 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 : 370523 : mpfr_clear (q);
498 : :
499 : 370523 : 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 : 525 : gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
511 : : {
512 : 525 : gfc_expr *result;
513 : :
514 : 525 : if (op1->ts.type != BT_LOGICAL)
515 : : return ARITH_INVALID_TYPE;
516 : :
517 : 525 : result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
518 : 525 : result->value.logical = !op1->value.logical;
519 : 525 : *resultp = result;
520 : :
521 : 525 : return ARITH_OK;
522 : : }
523 : :
524 : :
525 : : static arith
526 : 1334 : gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
527 : : {
528 : 1334 : gfc_expr *result;
529 : :
530 : 1334 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
531 : : return ARITH_INVALID_TYPE;
532 : :
533 : 1333 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
534 : : &op1->where);
535 : 1333 : result->value.logical = op1->value.logical && op2->value.logical;
536 : 1333 : *resultp = result;
537 : :
538 : 1333 : return ARITH_OK;
539 : : }
540 : :
541 : :
542 : : static arith
543 : 7269 : gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
544 : : {
545 : 7269 : gfc_expr *result;
546 : :
547 : 7269 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
548 : : return ARITH_INVALID_TYPE;
549 : :
550 : 7268 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
551 : : &op1->where);
552 : 7268 : result->value.logical = op1->value.logical || op2->value.logical;
553 : 7268 : *resultp = result;
554 : :
555 : 7268 : 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 : 15969481 : gfc_range_check (gfc_expr *e)
599 : : {
600 : 15969481 : arith rc;
601 : 15969481 : arith rc2;
602 : :
603 : 15969481 : switch (e->ts.type)
604 : : {
605 : 15549826 : case BT_INTEGER:
606 : 15549826 : rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
607 : 15549826 : break;
608 : :
609 : 117638 : case BT_UNSIGNED:
610 : 117638 : rc = gfc_check_unsigned_range (e->value.integer, e->ts.kind);
611 : 117638 : break;
612 : :
613 : 294925 : case BT_REAL:
614 : 294925 : rc = gfc_check_real_range (e->value.real, e->ts.kind);
615 : 294925 : if (rc == ARITH_UNDERFLOW)
616 : 9 : mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
617 : 294925 : if (rc == ARITH_OVERFLOW)
618 : 16 : mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
619 : 294925 : if (rc == ARITH_NAN)
620 : 17 : mpfr_set_nan (e->value.real);
621 : : break;
622 : :
623 : 7092 : case BT_COMPLEX:
624 : 7092 : rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
625 : 7092 : if (rc == ARITH_UNDERFLOW)
626 : 0 : mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
627 : 7092 : if (rc == ARITH_OVERFLOW)
628 : 2 : mpfr_set_inf (mpc_realref (e->value.complex),
629 : 2 : mpfr_sgn (mpc_realref (e->value.complex)));
630 : 7092 : if (rc == ARITH_NAN)
631 : 4 : mpfr_set_nan (mpc_realref (e->value.complex));
632 : :
633 : 7092 : rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
634 : 7092 : if (rc == ARITH_UNDERFLOW)
635 : 0 : mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
636 : 7092 : if (rc == ARITH_OVERFLOW)
637 : 2 : mpfr_set_inf (mpc_imagref (e->value.complex),
638 : 2 : mpfr_sgn (mpc_imagref (e->value.complex)));
639 : 7092 : if (rc == ARITH_NAN)
640 : 4 : mpfr_set_nan (mpc_imagref (e->value.complex));
641 : :
642 : 7092 : if (rc == ARITH_OK)
643 : 7086 : rc = rc2;
644 : : break;
645 : :
646 : 0 : default:
647 : 0 : gfc_internal_error ("gfc_range_check(): Bad type");
648 : : }
649 : :
650 : 15969481 : 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 : 11337036 : check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
659 : : {
660 : 11337036 : arith val = rc;
661 : :
662 : 11337036 : if (val == ARITH_UNDERFLOW)
663 : : {
664 : 9 : if (warn_underflow)
665 : 3 : gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
666 : : val = ARITH_OK;
667 : : }
668 : :
669 : 11337027 : if (val == ARITH_ASYMMETRIC)
670 : : {
671 : 86 : gfc_warning (0, gfc_arith_error (val), &x->where);
672 : 86 : val = ARITH_OK;
673 : : }
674 : :
675 : 11337036 : if (is_hard_arith_error (val))
676 : 1 : gfc_free_expr (r);
677 : : else
678 : 11337035 : *rp = r;
679 : :
680 : 11337036 : 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 : 129656 : gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
699 : : {
700 : 129656 : gfc_expr *result;
701 : 129656 : arith rc;
702 : :
703 : 129656 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
704 : :
705 : 129656 : switch (op1->ts.type)
706 : : {
707 : 98803 : case BT_INTEGER:
708 : 98803 : mpz_neg (result->value.integer, op1->value.integer);
709 : 98803 : 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 : 30820 : case BT_REAL:
721 : 30820 : mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
722 : 30820 : 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 : 129655 : rc = gfc_range_check (result);
733 : 129655 : 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 : 129655 : return check_result (rc, op1, result, resultp);
743 : : }
744 : :
745 : :
746 : : static arith
747 : 10356278 : gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
748 : : {
749 : 10356278 : gfc_expr *result;
750 : 10356278 : arith rc;
751 : :
752 : 10356278 : if (op1->ts.type != op2->ts.type)
753 : : return ARITH_INVALID_TYPE;
754 : :
755 : 10356277 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
756 : :
757 : 10356277 : switch (op1->ts.type)
758 : : {
759 : 10353135 : case BT_INTEGER:
760 : 10353135 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
761 : 10353135 : 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 : 10356277 : rc = gfc_range_check (result);
783 : :
784 : 10356277 : return check_result (rc, op1, result, resultp);
785 : : }
786 : :
787 : :
788 : : static arith
789 : 511351 : gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
790 : : {
791 : 511351 : gfc_expr *result;
792 : 511351 : arith rc;
793 : :
794 : 511351 : if (op1->ts.type != op2->ts.type)
795 : : return ARITH_INVALID_TYPE;
796 : :
797 : 511350 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
798 : :
799 : 511350 : switch (op1->ts.type)
800 : : {
801 : 510262 : case BT_INTEGER:
802 : 510262 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
803 : 510262 : 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 : 511350 : rc = gfc_range_check (result);
825 : :
826 : 511350 : return check_result (rc, op1, result, resultp);
827 : : }
828 : :
829 : :
830 : : static arith
831 : 310997 : gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
832 : : {
833 : 310997 : gfc_expr *result;
834 : 310997 : arith rc;
835 : :
836 : 310997 : if (op1->ts.type != op2->ts.type)
837 : : return ARITH_INVALID_TYPE;
838 : :
839 : 310995 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
840 : :
841 : 310995 : switch (op1->ts.type)
842 : : {
843 : 298773 : case BT_INTEGER:
844 : 298773 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
845 : 298773 : 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 : 10810 : case BT_REAL:
853 : 10810 : mpfr_mul (result->value.real, op1->value.real, op2->value.real,
854 : : GFC_RND_MODE);
855 : 10810 : 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 : 310995 : rc = gfc_range_check (result);
868 : :
869 : 310995 : return check_result (rc, op1, result, resultp);
870 : : }
871 : :
872 : :
873 : : static arith
874 : 7587 : gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
875 : : {
876 : 7587 : gfc_expr *result;
877 : 7587 : arith rc;
878 : :
879 : 7587 : if (op1->ts.type != op2->ts.type)
880 : : return ARITH_INVALID_TYPE;
881 : :
882 : 7585 : rc = ARITH_OK;
883 : :
884 : 7585 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
885 : :
886 : 7585 : switch (op1->ts.type)
887 : : {
888 : 3635 : case BT_INTEGER:
889 : 3635 : case BT_UNSIGNED:
890 : 3635 : if (mpz_sgn (op2->value.integer) == 0)
891 : : {
892 : : rc = ARITH_DIV0;
893 : : break;
894 : : }
895 : :
896 : 3616 : if (warn_integer_division)
897 : : {
898 : 49 : mpz_t r;
899 : 49 : mpz_init (r);
900 : 49 : mpz_tdiv_qr (result->value.integer, r, op1->value.integer,
901 : 49 : op2->value.integer);
902 : :
903 : 49 : if (mpz_cmp_si (r, 0) != 0)
904 : : {
905 : 6 : char *p;
906 : 6 : p = mpz_get_str (NULL, 10, result->value.integer);
907 : 6 : gfc_warning (OPT_Winteger_division, "Integer division "
908 : : "truncated to constant %qs at %L", p,
909 : : &op1->where);
910 : 6 : free (p);
911 : : }
912 : 49 : mpz_clear (r);
913 : : }
914 : : else
915 : 3567 : mpz_tdiv_q (result->value.integer, op1->value.integer,
916 : 3567 : op2->value.integer);
917 : :
918 : : break;
919 : :
920 : 3909 : case BT_REAL:
921 : : /* Set "Division by zero" only for regular numerator. */
922 : 3909 : if (flag_range_check == 1
923 : 3341 : && mpfr_zero_p (op2->value.real)
924 : 20 : && mpfr_regular_p (op1->value.real))
925 : 3909 : rc = ARITH_DIV0;
926 : :
927 : 3909 : mpfr_div (result->value.real, op1->value.real, op2->value.real,
928 : : GFC_RND_MODE);
929 : 3909 : 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 : 7566 : if (rc == ARITH_OK)
960 : 7557 : rc = gfc_range_check (result);
961 : :
962 : 7585 : return check_result (rc, op1, result, resultp);
963 : : }
964 : :
965 : : /* Raise a number to a power. */
966 : :
967 : : static arith
968 : 21185 : arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
969 : : {
970 : 21185 : int power_sign;
971 : 21185 : gfc_expr *result;
972 : 21185 : arith rc;
973 : :
974 : 21185 : 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 : 21181 : if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
981 : 21176 : || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
982 : : return ARITH_NOT_REDUCED;
983 : :
984 : 21174 : rc = ARITH_OK;
985 : 21174 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
986 : :
987 : 21174 : switch (op2->ts.type)
988 : : {
989 : 5732 : case BT_INTEGER:
990 : 5732 : power_sign = mpz_sgn (op2->value.integer);
991 : :
992 : 5656 : if (power_sign == 0)
993 : : {
994 : : /* Handle something to the zeroth power. Since we're dealing
995 : : with integral exponents, there is no ambiguity in the
996 : : limiting procedure used to determine the value of 0**0. */
997 : 84 : switch (op1->ts.type)
998 : : {
999 : 35 : case BT_INTEGER:
1000 : 35 : mpz_set_ui (result->value.integer, 1);
1001 : 35 : break;
1002 : :
1003 : 10 : case BT_REAL:
1004 : 10 : mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
1005 : 10 : break;
1006 : :
1007 : 39 : case BT_COMPLEX:
1008 : 39 : mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
1009 : 39 : break;
1010 : :
1011 : 0 : default:
1012 : 0 : gfc_internal_error ("arith_power(): Bad base");
1013 : : }
1014 : : }
1015 : : else
1016 : : {
1017 : 5648 : switch (op1->ts.type)
1018 : : {
1019 : 5335 : case BT_INTEGER:
1020 : 5335 : {
1021 : : /* First, we simplify the cases of op1 == 1, 0 or -1. */
1022 : 5335 : if (mpz_cmp_si (op1->value.integer, 1) == 0)
1023 : : {
1024 : : /* 1**op2 == 1 */
1025 : 804 : mpz_set_si (result->value.integer, 1);
1026 : : }
1027 : 4531 : 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 : 4525 : else if (mpz_cmp_si (op1->value.integer, -1) == 0)
1037 : : {
1038 : : /* (-1)**op2 == (-1)**(mod(op2,2)) */
1039 : 24 : unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
1040 : 24 : if (odd)
1041 : 12 : mpz_set_si (result->value.integer, -1);
1042 : : else
1043 : 12 : mpz_set_si (result->value.integer, 1);
1044 : : }
1045 : : /* Then, we take care of op2 < 0. */
1046 : 4501 : else if (mpz_cmp_si (op2->value.integer, 0) < 0)
1047 : : {
1048 : : /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
1049 : 9 : mpz_set_si (result->value.integer, 0);
1050 : 9 : if (warn_integer_division)
1051 : 1 : gfc_warning_now (OPT_Winteger_division, "Negative "
1052 : : "exponent of integer has zero "
1053 : : "result at %L", &result->where);
1054 : : }
1055 : : else
1056 : : {
1057 : : /* We have abs(op1) > 1 and op2 > 1.
1058 : : If op2 > bit_size(op1), we'll have an out-of-range
1059 : : result. */
1060 : 4492 : int k, power;
1061 : :
1062 : 4492 : k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
1063 : 4492 : power = gfc_integer_kinds[k].bit_size;
1064 : 4492 : if (mpz_cmp_si (op2->value.integer, power) < 0)
1065 : : {
1066 : 4473 : gfc_extract_int (op2, &power);
1067 : 4473 : mpz_pow_ui (result->value.integer, op1->value.integer,
1068 : : power);
1069 : 4473 : rc = gfc_range_check (result);
1070 : 4473 : 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 : 273 : case BT_REAL:
1089 : 273 : mpfr_pow_z (result->value.real, op1->value.real,
1090 : 273 : op2->value.integer, GFC_RND_MODE);
1091 : 273 : break;
1092 : :
1093 : 40 : case BT_COMPLEX:
1094 : 40 : mpc_pow_z (result->value.complex, op1->value.complex,
1095 : 40 : op2->value.integer, GFC_MPC_RND_MODE);
1096 : 40 : 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 : 21159 : if (rc == ARITH_OK)
1165 : 21149 : rc = gfc_range_check (result);
1166 : :
1167 : 21173 : return check_result (rc, op1, result, resultp);
1168 : : }
1169 : :
1170 : :
1171 : : /* Concatenate two string constants. */
1172 : :
1173 : : static arith
1174 : 4411 : gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1175 : : {
1176 : 4411 : gfc_expr *result;
1177 : 4411 : size_t len;
1178 : :
1179 : : /* By cleverly playing around with constructors, it is possible
1180 : : to get mismatching types here. */
1181 : 4411 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1182 : 4410 : || op1->ts.kind != op2->ts.kind)
1183 : : return ARITH_WRONGCONCAT;
1184 : :
1185 : 4410 : result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1186 : : &op1->where);
1187 : :
1188 : 4410 : len = op1->value.character.length + op2->value.character.length;
1189 : :
1190 : 4410 : result->value.character.string = gfc_get_wide_string (len + 1);
1191 : 4410 : result->value.character.length = len;
1192 : :
1193 : 4410 : memcpy (result->value.character.string, op1->value.character.string,
1194 : 4410 : op1->value.character.length * sizeof (gfc_char_t));
1195 : :
1196 : 4410 : memcpy (&result->value.character.string[op1->value.character.length],
1197 : 4410 : op2->value.character.string,
1198 : 4410 : op2->value.character.length * sizeof (gfc_char_t));
1199 : :
1200 : 4410 : result->value.character.string[len] = '\0';
1201 : :
1202 : 4410 : *resultp = result;
1203 : :
1204 : 4410 : 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 : 3073 : compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1212 : : {
1213 : 3073 : int rc;
1214 : 3073 : switch (op)
1215 : : {
1216 : 1633 : case INTRINSIC_EQ:
1217 : 1633 : rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1218 : 1633 : 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 : 72 : 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 : 436 : 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 : 3073 : 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 : 42058 : gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1244 : : {
1245 : 42058 : int rc;
1246 : :
1247 : 42058 : switch (op1->ts.type)
1248 : : {
1249 : 32311 : case BT_INTEGER:
1250 : 32311 : case BT_UNSIGNED:
1251 : 32311 : rc = mpz_cmp (op1->value.integer, op2->value.integer);
1252 : 32311 : break;
1253 : :
1254 : 3073 : case BT_REAL:
1255 : 3073 : rc = compare_real (op1, op2, op);
1256 : 3073 : break;
1257 : :
1258 : 6626 : case BT_CHARACTER:
1259 : 6626 : rc = gfc_compare_string (op1, op2);
1260 : 6626 : 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 : 42058 : 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 : 7154 : gfc_compare_string (gfc_expr *a, gfc_expr *b)
1296 : : {
1297 : 7154 : size_t len, alen, blen, i;
1298 : 7154 : gfc_char_t ac, bc;
1299 : :
1300 : 7154 : alen = a->value.character.length;
1301 : 7154 : blen = b->value.character.length;
1302 : :
1303 : 7154 : len = MAX(alen, blen);
1304 : :
1305 : 17003 : for (i = 0; i < len; i++)
1306 : : {
1307 : 12422 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1308 : 12422 : bc = ((i < blen) ? b->value.character.string[i] : ' ');
1309 : :
1310 : 12422 : if (ac < bc)
1311 : : return -1;
1312 : 11492 : if (ac > bc)
1313 : : return 1;
1314 : : }
1315 : :
1316 : : /* Strings are equal */
1317 : : return 0;
1318 : : }
1319 : :
1320 : :
1321 : : int
1322 : 399 : gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1323 : : {
1324 : 399 : size_t len, alen, blen, i;
1325 : 399 : gfc_char_t ac, bc;
1326 : :
1327 : 399 : alen = a->value.character.length;
1328 : 399 : blen = strlen (b);
1329 : :
1330 : 399 : len = MAX(alen, blen);
1331 : :
1332 : 1455 : for (i = 0; i < len; i++)
1333 : : {
1334 : 1321 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1335 : 1321 : bc = ((i < blen) ? b[i] : ' ');
1336 : :
1337 : 1321 : if (!case_sensitive)
1338 : : {
1339 : 1321 : ac = TOLOWER (ac);
1340 : 1321 : bc = TOLOWER (bc);
1341 : : }
1342 : :
1343 : 1321 : if (ac < bc)
1344 : : return -1;
1345 : 1242 : 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 : 3262 : gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1358 : : {
1359 : 3262 : gfc_expr *result;
1360 : :
1361 : 3262 : if (op1->ts.type != op2->ts.type)
1362 : : return ARITH_INVALID_TYPE;
1363 : :
1364 : 3260 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1365 : : &op1->where);
1366 : 6520 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1367 : 3260 : ? compare_complex (op1, op2)
1368 : 3260 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1369 : :
1370 : 3260 : *resultp = result;
1371 : 3260 : return ARITH_OK;
1372 : : }
1373 : :
1374 : :
1375 : : static arith
1376 : 32118 : gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1377 : : {
1378 : 32118 : gfc_expr *result;
1379 : :
1380 : 32118 : if (op1->ts.type != op2->ts.type)
1381 : : return ARITH_INVALID_TYPE;
1382 : :
1383 : 32116 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1384 : : &op1->where);
1385 : 64232 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1386 : 32312 : ? !compare_complex (op1, op2)
1387 : 31920 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1388 : :
1389 : 32116 : *resultp = result;
1390 : 32116 : return ARITH_OK;
1391 : : }
1392 : :
1393 : :
1394 : : static arith
1395 : 3044 : gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1396 : : {
1397 : 3044 : gfc_expr *result;
1398 : :
1399 : 3044 : if (op1->ts.type != op2->ts.type)
1400 : : return ARITH_INVALID_TYPE;
1401 : :
1402 : 3042 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1403 : : &op1->where);
1404 : 3042 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1405 : 3042 : *resultp = result;
1406 : :
1407 : 3042 : return ARITH_OK;
1408 : : }
1409 : :
1410 : :
1411 : : static arith
1412 : 262 : gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1413 : : {
1414 : 262 : gfc_expr *result;
1415 : :
1416 : 262 : if (op1->ts.type != op2->ts.type)
1417 : : return ARITH_INVALID_TYPE;
1418 : :
1419 : 260 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1420 : : &op1->where);
1421 : 260 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1422 : 260 : *resultp = result;
1423 : :
1424 : 260 : return ARITH_OK;
1425 : : }
1426 : :
1427 : :
1428 : : static arith
1429 : 453 : gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1430 : : {
1431 : 453 : gfc_expr *result;
1432 : :
1433 : 453 : if (op1->ts.type != op2->ts.type)
1434 : : return ARITH_INVALID_TYPE;
1435 : :
1436 : 451 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1437 : : &op1->where);
1438 : 451 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1439 : 451 : *resultp = result;
1440 : :
1441 : 451 : 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 : 130768 : reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1464 : : gfc_expr **result)
1465 : : {
1466 : 130768 : gfc_constructor_base head;
1467 : 130768 : gfc_constructor *c;
1468 : 130768 : gfc_expr *r;
1469 : 130768 : arith rc;
1470 : :
1471 : 130768 : if (op->expr_type == EXPR_CONSTANT)
1472 : 130532 : return eval (op, result);
1473 : :
1474 : 236 : if (op->expr_type != EXPR_ARRAY)
1475 : : return ARITH_NOT_REDUCED;
1476 : :
1477 : 225 : rc = ARITH_OK;
1478 : 225 : head = gfc_constructor_copy (op->value.constructor);
1479 : 825 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1480 : : {
1481 : 617 : 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 : 617 : if (is_hard_arith_error (rc_tmp))
1486 : : {
1487 : : rc = rc_tmp;
1488 : : break;
1489 : : }
1490 : 600 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1491 : 4 : rc = rc_tmp;
1492 : :
1493 : 600 : gfc_replace_expr (c->expr, r);
1494 : : }
1495 : :
1496 : 225 : if (is_hard_arith_error (rc))
1497 : 17 : gfc_constructor_free (head);
1498 : : else
1499 : : {
1500 : 208 : gfc_constructor *c = gfc_constructor_first (head);
1501 : 208 : 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 : 178 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1509 : : &op->where);
1510 : : }
1511 : 208 : r->shape = gfc_copy_shape (op->shape, op->rank);
1512 : 208 : r->rank = op->rank;
1513 : 208 : r->corank = op->corank;
1514 : 208 : r->value.constructor = head;
1515 : 208 : *result = r;
1516 : : }
1517 : :
1518 : : return rc;
1519 : : }
1520 : :
1521 : :
1522 : : static arith
1523 : 1409 : reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1524 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1525 : : {
1526 : 1409 : gfc_constructor_base head;
1527 : 1409 : gfc_constructor *c;
1528 : 1409 : gfc_expr *r;
1529 : 1409 : arith rc = ARITH_OK;
1530 : :
1531 : 1409 : head = gfc_constructor_copy (op1->value.constructor);
1532 : 9625 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1533 : : {
1534 : 8272 : arith rc_tmp;
1535 : :
1536 : 8272 : gfc_simplify_expr (c->expr, 0);
1537 : :
1538 : 8272 : if (c->expr->expr_type == EXPR_CONSTANT)
1539 : 8235 : rc_tmp = eval (c->expr, op2, &r);
1540 : 37 : else if (c->expr->expr_type != EXPR_ARRAY)
1541 : : rc_tmp = ARITH_NOT_REDUCED;
1542 : : else
1543 : 27 : 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 : 8262 : if (is_hard_arith_error (rc_tmp))
1548 : : {
1549 : : rc = rc_tmp;
1550 : : break;
1551 : : }
1552 : 8216 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1553 : 5 : rc = rc_tmp;
1554 : :
1555 : 8216 : gfc_replace_expr (c->expr, r);
1556 : : }
1557 : :
1558 : 1409 : if (is_hard_arith_error (rc))
1559 : 56 : gfc_constructor_free (head);
1560 : : else
1561 : : {
1562 : 1353 : gfc_constructor *c = gfc_constructor_first (head);
1563 : 1353 : if (c)
1564 : : {
1565 : 1353 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1566 : : &op1->where);
1567 : 1353 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1568 : : }
1569 : : else
1570 : : {
1571 : 0 : gcc_assert (op1->ts.type != BT_UNKNOWN);
1572 : 0 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
1573 : : &op1->where);
1574 : 0 : r->shape = gfc_get_shape (op1->rank);
1575 : : }
1576 : 1353 : r->rank = op1->rank;
1577 : 1353 : r->corank = op1->corank;
1578 : 1353 : r->value.constructor = head;
1579 : 1353 : *result = r;
1580 : : }
1581 : :
1582 : 1409 : return rc;
1583 : : }
1584 : :
1585 : :
1586 : : static arith
1587 : 754 : reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1588 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1589 : : {
1590 : 754 : gfc_constructor_base head;
1591 : 754 : gfc_constructor *c;
1592 : 754 : gfc_expr *r;
1593 : 754 : arith rc = ARITH_OK;
1594 : :
1595 : 754 : head = gfc_constructor_copy (op2->value.constructor);
1596 : 3900 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1597 : : {
1598 : 3178 : arith rc_tmp;
1599 : :
1600 : 3178 : gfc_simplify_expr (c->expr, 0);
1601 : :
1602 : 3178 : if (c->expr->expr_type == EXPR_CONSTANT)
1603 : 3048 : rc_tmp = eval (op1, c->expr, &r);
1604 : 130 : else if (c->expr->expr_type != EXPR_ARRAY)
1605 : : rc_tmp = ARITH_NOT_REDUCED;
1606 : : else
1607 : 120 : rc_tmp = reduce_binary_ca (eval, op1, c->expr, &r);
1608 : :
1609 : : /* Remember first recoverable ("soft") error encountered during
1610 : : reduction and continue, but terminate on serious errors. */
1611 : 3168 : if (is_hard_arith_error (rc_tmp))
1612 : : {
1613 : : rc = rc_tmp;
1614 : : break;
1615 : : }
1616 : 3146 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1617 : 3 : rc = rc_tmp;
1618 : :
1619 : 3146 : gfc_replace_expr (c->expr, r);
1620 : : }
1621 : :
1622 : 754 : if (is_hard_arith_error (rc))
1623 : 32 : gfc_constructor_free (head);
1624 : : else
1625 : : {
1626 : 722 : gfc_constructor *c = gfc_constructor_first (head);
1627 : 722 : if (c)
1628 : : {
1629 : 632 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1630 : : &op2->where);
1631 : 632 : r->shape = gfc_copy_shape (op2->shape, op2->rank);
1632 : : }
1633 : : else
1634 : : {
1635 : 90 : gcc_assert (op2->ts.type != BT_UNKNOWN);
1636 : 90 : r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
1637 : : &op2->where);
1638 : 90 : r->shape = gfc_get_shape (op2->rank);
1639 : : }
1640 : 722 : r->rank = op2->rank;
1641 : 722 : r->corank = op2->corank;
1642 : 722 : r->value.constructor = head;
1643 : 722 : *result = r;
1644 : : }
1645 : :
1646 : 754 : return rc;
1647 : : }
1648 : :
1649 : :
1650 : : /* We need a forward declaration of reduce_binary. */
1651 : : static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1652 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1653 : :
1654 : :
1655 : : static arith
1656 : 1499 : reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1657 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1658 : : {
1659 : 1499 : gfc_constructor_base head;
1660 : 1499 : gfc_constructor *c, *d;
1661 : 1499 : gfc_expr *r;
1662 : 1499 : arith rc = ARITH_OK;
1663 : :
1664 : 1499 : if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1665 : : return ARITH_INCOMMENSURATE;
1666 : :
1667 : 1499 : head = gfc_constructor_copy (op1->value.constructor);
1668 : 2998 : for (c = gfc_constructor_first (head),
1669 : 1499 : d = gfc_constructor_first (op2->value.constructor);
1670 : 5738 : c && d;
1671 : 4239 : c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1672 : : {
1673 : 4248 : arith rc_tmp = reduce_binary (eval, c->expr, d->expr, &r);
1674 : :
1675 : : /* Remember first recoverable ("soft") error encountered during
1676 : : reduction and continue, but terminate on serious errors. */
1677 : 4248 : if (is_hard_arith_error (rc_tmp))
1678 : : {
1679 : : rc = rc_tmp;
1680 : : break;
1681 : : }
1682 : 4239 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1683 : 8 : rc = rc_tmp;
1684 : :
1685 : 4239 : gfc_replace_expr (c->expr, r);
1686 : : }
1687 : :
1688 : 1499 : if (rc == ARITH_OK && (c || d))
1689 : : rc = ARITH_INCOMMENSURATE;
1690 : :
1691 : 1499 : if (is_hard_arith_error (rc))
1692 : 9 : gfc_constructor_free (head);
1693 : : else
1694 : : {
1695 : 1490 : gfc_constructor *c = gfc_constructor_first (head);
1696 : 1490 : if (c == NULL)
1697 : : {
1698 : : /* Handle zero-sized arrays. */
1699 : 132 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
1700 : : }
1701 : : else
1702 : : {
1703 : 1358 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1704 : : &op1->where);
1705 : : }
1706 : 1490 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1707 : 1490 : r->rank = op1->rank;
1708 : 1490 : r->corank = op1->corank;
1709 : 1490 : r->value.constructor = head;
1710 : 1490 : *result = r;
1711 : : }
1712 : :
1713 : : return rc;
1714 : : }
1715 : :
1716 : :
1717 : : static arith
1718 : 11253863 : reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1719 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1720 : : {
1721 : 11253863 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1722 : 11250340 : return eval (op1, op2, result);
1723 : :
1724 : 3523 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1725 : 634 : return reduce_binary_ca (eval, op1, op2, result);
1726 : :
1727 : 2889 : if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1728 : 1382 : return reduce_binary_ac (eval, op1, op2, result);
1729 : :
1730 : 1507 : if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1731 : : return ARITH_NOT_REDUCED;
1732 : :
1733 : 1499 : return reduce_binary_aa (eval, op1, op2, result);
1734 : : }
1735 : :
1736 : :
1737 : : typedef union
1738 : : {
1739 : : arith (*f2)(gfc_expr *, gfc_expr **);
1740 : : arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1741 : : }
1742 : : eval_f;
1743 : :
1744 : : /* High level arithmetic subroutines. These subroutines go into
1745 : : eval_intrinsic(), which can do one of several things to its
1746 : : operands. If the operands are incompatible with the intrinsic
1747 : : operation, we return a node pointing to the operands and hope that
1748 : : an operator interface is found during resolution.
1749 : :
1750 : : If the operands are compatible and are constants, then we try doing
1751 : : the arithmetic. We also handle the cases where either or both
1752 : : operands are array constructors. */
1753 : :
1754 : : static gfc_expr *
1755 : 12856014 : eval_intrinsic (gfc_intrinsic_op op,
1756 : : eval_f eval, gfc_expr *op1, gfc_expr *op2)
1757 : : {
1758 : 12856014 : gfc_expr temp, *result;
1759 : 12856014 : int unary;
1760 : 12856014 : arith rc;
1761 : :
1762 : 12856014 : if (!op1)
1763 : : return NULL;
1764 : :
1765 : 12856010 : gfc_clear_ts (&temp.ts);
1766 : :
1767 : 12856010 : switch (op)
1768 : : {
1769 : : /* Logical unary */
1770 : 76765 : case INTRINSIC_NOT:
1771 : 76765 : if (op1->ts.type != BT_LOGICAL)
1772 : 68970 : goto runtime;
1773 : :
1774 : 7795 : temp.ts.type = BT_LOGICAL;
1775 : 7795 : temp.ts.kind = gfc_default_logical_kind;
1776 : 7795 : unary = 1;
1777 : 7795 : break;
1778 : :
1779 : : /* Logical binary operators */
1780 : 249133 : case INTRINSIC_OR:
1781 : 249133 : case INTRINSIC_AND:
1782 : 249133 : case INTRINSIC_NEQV:
1783 : 249133 : case INTRINSIC_EQV:
1784 : 249133 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1785 : 62479 : goto runtime;
1786 : :
1787 : 186654 : temp.ts.type = BT_LOGICAL;
1788 : 186654 : temp.ts.kind = gfc_default_logical_kind;
1789 : 186654 : unary = 0;
1790 : 186654 : break;
1791 : :
1792 : : /* Numeric unary */
1793 : 150355 : case INTRINSIC_UPLUS:
1794 : 150355 : case INTRINSIC_UMINUS:
1795 : 150355 : if (!gfc_numeric_ts (&op1->ts))
1796 : 6653 : goto runtime;
1797 : :
1798 : 143702 : temp.ts = op1->ts;
1799 : 143702 : unary = 1;
1800 : 143702 : break;
1801 : :
1802 : 0 : case INTRINSIC_PARENTHESES:
1803 : 0 : temp.ts = op1->ts;
1804 : 0 : unary = 1;
1805 : 0 : break;
1806 : :
1807 : : /* Additional restrictions for ordering relations. */
1808 : 64480 : case INTRINSIC_GE:
1809 : 64480 : case INTRINSIC_GE_OS:
1810 : 64480 : case INTRINSIC_LT:
1811 : 64480 : case INTRINSIC_LT_OS:
1812 : 64480 : case INTRINSIC_LE:
1813 : 64480 : case INTRINSIC_LE_OS:
1814 : 64480 : case INTRINSIC_GT:
1815 : 64480 : case INTRINSIC_GT_OS:
1816 : 64480 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1817 : : {
1818 : 36 : temp.ts.type = BT_LOGICAL;
1819 : 36 : temp.ts.kind = gfc_default_logical_kind;
1820 : 36 : goto runtime;
1821 : : }
1822 : :
1823 : : /* Fall through */
1824 : 931531 : case INTRINSIC_EQ:
1825 : 931531 : case INTRINSIC_EQ_OS:
1826 : 931531 : case INTRINSIC_NE:
1827 : 931531 : case INTRINSIC_NE_OS:
1828 : 931531 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1829 : : {
1830 : 97665 : unary = 0;
1831 : 97665 : temp.ts.type = BT_LOGICAL;
1832 : 97665 : temp.ts.kind = gfc_default_logical_kind;
1833 : :
1834 : : /* If kind mismatch, exit and we'll error out later. */
1835 : 97665 : if (op1->ts.kind != op2->ts.kind)
1836 : 40 : goto runtime;
1837 : :
1838 : : break;
1839 : : }
1840 : :
1841 : 906756 : gcc_fallthrough ();
1842 : : /* Numeric binary */
1843 : 906756 : case INTRINSIC_POWER:
1844 : 906756 : if (pedantic && (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED))
1845 : : {
1846 : 0 : gfc_error ("Unsigned exponentiation not permitted with -pedantic "
1847 : : "at %L", &op1->where);
1848 : 0 : goto runtime;
1849 : : }
1850 : :
1851 : 12274703 : gcc_fallthrough ();
1852 : :
1853 : 12274703 : case INTRINSIC_PLUS:
1854 : 12274703 : case INTRINSIC_MINUS:
1855 : 12274703 : case INTRINSIC_TIMES:
1856 : 12274703 : case INTRINSIC_DIVIDE:
1857 : 12274703 : if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1858 : 460856 : goto runtime;
1859 : :
1860 : 11813847 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
1861 : 4 : goto runtime;
1862 : :
1863 : : /* Do not perform conversions if operands are not conformable as
1864 : : required for the binary intrinsic operators (F2018:10.1.5).
1865 : : Defer to a possibly overloading user-defined operator. */
1866 : 11813843 : if (!gfc_op_rank_conformable (op1, op2))
1867 : 220 : goto runtime;
1868 : :
1869 : : /* Insert any necessary type conversions to make the operands
1870 : : compatible. */
1871 : :
1872 : 11813623 : temp.expr_type = EXPR_OP;
1873 : 11813623 : gfc_clear_ts (&temp.ts);
1874 : 11813623 : temp.value.op.op = op;
1875 : :
1876 : 11813623 : temp.value.op.op1 = op1;
1877 : 11813623 : temp.value.op.op2 = op2;
1878 : :
1879 : 11815497 : gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1880 : :
1881 : 11813623 : if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1882 : 11813623 : || op == INTRINSIC_GE || op == INTRINSIC_GT
1883 : 11493805 : || op == INTRINSIC_LE || op == INTRINSIC_LT
1884 : 11483283 : || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1885 : 11471898 : || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1886 : 11385812 : || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1887 : : {
1888 : 437563 : temp.ts.type = BT_LOGICAL;
1889 : 437563 : temp.ts.kind = gfc_default_logical_kind;
1890 : : }
1891 : :
1892 : : unary = 0;
1893 : : break;
1894 : :
1895 : : /* Character binary */
1896 : 7353 : case INTRINSIC_CONCAT:
1897 : 7353 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1898 : 5826 : || op1->ts.kind != op2->ts.kind)
1899 : 1536 : goto runtime;
1900 : :
1901 : 5817 : temp.ts.type = BT_CHARACTER;
1902 : 5817 : temp.ts.kind = op1->ts.kind;
1903 : 5817 : unary = 0;
1904 : 5817 : break;
1905 : :
1906 : 0 : case INTRINSIC_USER:
1907 : 0 : goto runtime;
1908 : :
1909 : 0 : default:
1910 : 0 : gfc_internal_error ("eval_intrinsic(): Bad operator");
1911 : : }
1912 : :
1913 : 12255216 : if (op1->expr_type != EXPR_CONSTANT
1914 : 12255216 : && (op1->expr_type != EXPR_ARRAY
1915 : 2963 : || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1916 : 832727 : goto runtime;
1917 : :
1918 : 11422489 : if (op2 != NULL
1919 : 11292338 : && op2->expr_type != EXPR_CONSTANT
1920 : 11467211 : && (op2->expr_type != EXPR_ARRAY
1921 : 1999 : || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1922 : 42723 : goto runtime;
1923 : :
1924 : 11379766 : if (unary)
1925 : 130151 : rc = reduce_unary (eval.f2, op1, &result);
1926 : : else
1927 : 11249615 : rc = reduce_binary (eval.f3, op1, op2, &result);
1928 : :
1929 : 11379766 : if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1930 : 72 : goto runtime;
1931 : :
1932 : : /* Something went wrong. */
1933 : 11379694 : if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1934 : : return NULL;
1935 : :
1936 : 11379693 : if (rc != ARITH_OK)
1937 : : {
1938 : 164 : gfc_error (gfc_arith_error (rc), &op1->where);
1939 : 164 : if (rc == ARITH_OVERFLOW)
1940 : 113 : goto done;
1941 : :
1942 : 51 : if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1943 : 22 : gfc_seen_div0 = true;
1944 : :
1945 : 51 : return NULL;
1946 : : }
1947 : :
1948 : 11379529 : done:
1949 : :
1950 : 11379642 : gfc_free_expr (op1);
1951 : 11379642 : gfc_free_expr (op2);
1952 : 11379642 : return result;
1953 : :
1954 : 1476316 : runtime:
1955 : : /* Create a run-time expression. */
1956 : 1476316 : result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1957 : 1476316 : result->ts = temp.ts;
1958 : 1476316 : return result;
1959 : : }
1960 : :
1961 : :
1962 : : /* Modify type of expression for zero size array. */
1963 : :
1964 : : static gfc_expr *
1965 : 65 : eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1966 : : {
1967 : 65 : if (op == NULL)
1968 : 0 : gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1969 : :
1970 : 65 : switch (iop)
1971 : : {
1972 : 64 : case INTRINSIC_GE:
1973 : 64 : case INTRINSIC_GE_OS:
1974 : 64 : case INTRINSIC_LT:
1975 : 64 : case INTRINSIC_LT_OS:
1976 : 64 : case INTRINSIC_LE:
1977 : 64 : case INTRINSIC_LE_OS:
1978 : 64 : case INTRINSIC_GT:
1979 : 64 : case INTRINSIC_GT_OS:
1980 : 64 : case INTRINSIC_EQ:
1981 : 64 : case INTRINSIC_EQ_OS:
1982 : 64 : case INTRINSIC_NE:
1983 : 64 : case INTRINSIC_NE_OS:
1984 : 64 : op->ts.type = BT_LOGICAL;
1985 : 64 : op->ts.kind = gfc_default_logical_kind;
1986 : 64 : break;
1987 : :
1988 : : default:
1989 : : break;
1990 : : }
1991 : :
1992 : 65 : return op;
1993 : : }
1994 : :
1995 : :
1996 : : /* Return nonzero if the expression is a zero size array. */
1997 : :
1998 : : static bool
1999 : 25484974 : gfc_zero_size_array (gfc_expr *e)
2000 : : {
2001 : 25484970 : if (e == NULL || e->expr_type != EXPR_ARRAY)
2002 : : return false;
2003 : :
2004 : 0 : return e->value.constructor == NULL;
2005 : : }
2006 : :
2007 : :
2008 : : /* Reduce a binary expression where at least one of the operands
2009 : : involves a zero-length array. Returns NULL if neither of the
2010 : : operands is a zero-length array. */
2011 : :
2012 : : static gfc_expr *
2013 : 12628959 : reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
2014 : : {
2015 : 12633671 : if (gfc_zero_size_array (op1))
2016 : : {
2017 : 64 : gfc_free_expr (op2);
2018 : 64 : return op1;
2019 : : }
2020 : :
2021 : 12700523 : if (gfc_zero_size_array (op2))
2022 : : {
2023 : 1 : gfc_free_expr (op1);
2024 : 1 : return op2;
2025 : : }
2026 : :
2027 : : return NULL;
2028 : : }
2029 : :
2030 : :
2031 : : static gfc_expr *
2032 : 227120 : eval_intrinsic_f2 (gfc_intrinsic_op op,
2033 : : arith (*eval) (gfc_expr *, gfc_expr **),
2034 : : gfc_expr *op1, gfc_expr *op2)
2035 : : {
2036 : 227120 : gfc_expr *result;
2037 : 227120 : eval_f f;
2038 : :
2039 : 227120 : if (op2 == NULL)
2040 : : {
2041 : 227321 : if (gfc_zero_size_array (op1))
2042 : 0 : return eval_type_intrinsic0 (op, op1);
2043 : : }
2044 : : else
2045 : : {
2046 : 0 : result = reduce_binary0 (op1, op2);
2047 : 0 : if (result != NULL)
2048 : 0 : return eval_type_intrinsic0 (op, result);
2049 : : }
2050 : :
2051 : 227120 : f.f2 = eval;
2052 : 227120 : return eval_intrinsic (op, f, op1, op2);
2053 : : }
2054 : :
2055 : :
2056 : : static gfc_expr *
2057 : 12628964 : eval_intrinsic_f3 (gfc_intrinsic_op op,
2058 : : arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
2059 : : gfc_expr *op1, gfc_expr *op2)
2060 : : {
2061 : 12628964 : gfc_expr *result;
2062 : 12628964 : eval_f f;
2063 : :
2064 : 12628964 : if (!op1 && !op2)
2065 : : return NULL;
2066 : :
2067 : 12628959 : result = reduce_binary0 (op1, op2);
2068 : 12628959 : if (result != NULL)
2069 : 65 : return eval_type_intrinsic0(op, result);
2070 : :
2071 : 12628894 : f.f3 = eval;
2072 : 12628894 : return eval_intrinsic (op, f, op1, op2);
2073 : : }
2074 : :
2075 : :
2076 : : gfc_expr *
2077 : 5256626 : gfc_parentheses (gfc_expr *op)
2078 : : {
2079 : 5256626 : if (gfc_is_constant_expr (op))
2080 : : return op;
2081 : :
2082 : 0 : return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
2083 : 0 : op, NULL);
2084 : : }
2085 : :
2086 : : gfc_expr *
2087 : 398 : gfc_uplus (gfc_expr *op)
2088 : : {
2089 : 398 : return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
2090 : : }
2091 : :
2092 : :
2093 : : gfc_expr *
2094 : 149957 : gfc_uminus (gfc_expr *op)
2095 : : {
2096 : 149957 : return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
2097 : : }
2098 : :
2099 : :
2100 : : gfc_expr *
2101 : 10409854 : gfc_add (gfc_expr *op1, gfc_expr *op2)
2102 : : {
2103 : 10409854 : return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
2104 : : }
2105 : :
2106 : :
2107 : : gfc_expr *
2108 : 574241 : gfc_subtract (gfc_expr *op1, gfc_expr *op2)
2109 : : {
2110 : 574241 : return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
2111 : : }
2112 : :
2113 : :
2114 : : gfc_expr *
2115 : 365531 : gfc_multiply (gfc_expr *op1, gfc_expr *op2)
2116 : : {
2117 : 365531 : return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
2118 : : }
2119 : :
2120 : :
2121 : : gfc_expr *
2122 : 18331 : gfc_divide (gfc_expr *op1, gfc_expr *op2)
2123 : : {
2124 : 18331 : return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
2125 : : }
2126 : :
2127 : :
2128 : : gfc_expr *
2129 : 72890 : gfc_power (gfc_expr *op1, gfc_expr *op2)
2130 : : {
2131 : 72890 : return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
2132 : : }
2133 : :
2134 : :
2135 : : gfc_expr *
2136 : 7353 : gfc_concat (gfc_expr *op1, gfc_expr *op2)
2137 : : {
2138 : 7353 : return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
2139 : : }
2140 : :
2141 : :
2142 : : gfc_expr *
2143 : 18091 : gfc_and (gfc_expr *op1, gfc_expr *op2)
2144 : : {
2145 : 18091 : return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
2146 : : }
2147 : :
2148 : :
2149 : : gfc_expr *
2150 : 205576 : gfc_or (gfc_expr *op1, gfc_expr *op2)
2151 : : {
2152 : 205576 : return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
2153 : : }
2154 : :
2155 : :
2156 : : gfc_expr *
2157 : 76765 : gfc_not (gfc_expr *op1)
2158 : : {
2159 : 76765 : return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
2160 : : }
2161 : :
2162 : :
2163 : : gfc_expr *
2164 : 1992 : gfc_eqv (gfc_expr *op1, gfc_expr *op2)
2165 : : {
2166 : 1992 : return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
2167 : : }
2168 : :
2169 : :
2170 : : gfc_expr *
2171 : 23474 : gfc_neqv (gfc_expr *op1, gfc_expr *op2)
2172 : : {
2173 : 23474 : return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
2174 : : }
2175 : :
2176 : :
2177 : : gfc_expr *
2178 : 33491 : gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2179 : : {
2180 : 33491 : return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
2181 : : }
2182 : :
2183 : :
2184 : : gfc_expr *
2185 : 833608 : gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2186 : : {
2187 : 833608 : return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
2188 : : }
2189 : :
2190 : :
2191 : : gfc_expr *
2192 : 40894 : gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2193 : : {
2194 : 40894 : return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
2195 : : }
2196 : :
2197 : :
2198 : : gfc_expr *
2199 : 4728 : gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2200 : : {
2201 : 4728 : return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2202 : : }
2203 : :
2204 : :
2205 : : gfc_expr *
2206 : 11121 : gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2207 : : {
2208 : 11121 : return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2209 : : }
2210 : :
2211 : :
2212 : : gfc_expr *
2213 : 7789 : gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2214 : : {
2215 : 7789 : return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
2216 : : }
2217 : :
2218 : :
2219 : : /******* Simplification of intrinsic functions with constant arguments *****/
2220 : :
2221 : :
2222 : : /* Deal with an arithmetic error. */
2223 : :
2224 : : static void
2225 : 6 : arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2226 : : {
2227 : 6 : switch (rc)
2228 : : {
2229 : 0 : case ARITH_OK:
2230 : 0 : gfc_error ("Arithmetic OK converting %s to %s at %L",
2231 : : gfc_typename (from), gfc_typename (to), where);
2232 : 0 : break;
2233 : 6 : case ARITH_OVERFLOW:
2234 : 6 : gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2235 : : "can be disabled with the option %<-fno-range-check%>",
2236 : : gfc_typename (from), gfc_typename (to), where);
2237 : 6 : break;
2238 : 0 : case ARITH_UNDERFLOW:
2239 : 0 : gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
2240 : : "can be disabled with the option %<-fno-range-check%>",
2241 : : gfc_typename (from), gfc_typename (to), where);
2242 : 0 : break;
2243 : 0 : case ARITH_NAN:
2244 : 0 : gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
2245 : : "can be disabled with the option %<-fno-range-check%>",
2246 : : gfc_typename (from), gfc_typename (to), where);
2247 : 0 : break;
2248 : 0 : case ARITH_DIV0:
2249 : 0 : gfc_error ("Division by zero converting %s to %s at %L",
2250 : : gfc_typename (from), gfc_typename (to), where);
2251 : 0 : break;
2252 : 0 : case ARITH_INCOMMENSURATE:
2253 : 0 : gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2254 : : gfc_typename (from), gfc_typename (to), where);
2255 : 0 : break;
2256 : 0 : case ARITH_ASYMMETRIC:
2257 : 0 : gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2258 : : " converting %s to %s at %L",
2259 : : gfc_typename (from), gfc_typename (to), where);
2260 : 0 : break;
2261 : 0 : default:
2262 : 0 : gfc_internal_error ("gfc_arith_error(): Bad error code");
2263 : : }
2264 : :
2265 : : /* TODO: Do something about the error, i.e., throw exception, return
2266 : : NaN, etc. */
2267 : 6 : }
2268 : :
2269 : : /* Returns true if significant bits were lost when converting real
2270 : : constant r from from_kind to to_kind. */
2271 : :
2272 : : static bool
2273 : 19 : wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2274 : : {
2275 : 19 : mpfr_t rv, diff;
2276 : 19 : bool ret;
2277 : :
2278 : 19 : gfc_set_model_kind (to_kind);
2279 : 19 : mpfr_init (rv);
2280 : 19 : gfc_set_model_kind (from_kind);
2281 : 19 : mpfr_init (diff);
2282 : :
2283 : 19 : mpfr_set (rv, r, GFC_RND_MODE);
2284 : 19 : mpfr_sub (diff, rv, r, GFC_RND_MODE);
2285 : :
2286 : 19 : ret = ! mpfr_zero_p (diff);
2287 : 19 : mpfr_clear (rv);
2288 : 19 : mpfr_clear (diff);
2289 : 19 : return ret;
2290 : : }
2291 : :
2292 : : /* Return true if conversion from an integer to a real loses precision. */
2293 : :
2294 : : static bool
2295 : 82 : wprecision_int_real (mpz_t n, mpfr_t r)
2296 : : {
2297 : 82 : bool ret;
2298 : 82 : mpz_t i;
2299 : 82 : mpz_init (i);
2300 : 82 : mpfr_get_z (i, r, GFC_RND_MODE);
2301 : 82 : mpz_sub (i, i, n);
2302 : 82 : ret = mpz_cmp_si (i, 0) != 0;
2303 : 82 : mpz_clear (i);
2304 : 82 : return ret;
2305 : : }
2306 : :
2307 : : /* Convert integers to integers; we can reuse this for also converting
2308 : : unsigneds. */
2309 : :
2310 : : gfc_expr *
2311 : 65557 : gfc_int2int (gfc_expr *src, int kind)
2312 : : {
2313 : 65557 : gfc_expr *result;
2314 : 65557 : arith rc;
2315 : :
2316 : 65557 : if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
2317 : : return NULL;
2318 : :
2319 : 65557 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2320 : :
2321 : 65557 : mpz_set (result->value.integer, src->value.integer);
2322 : :
2323 : 65557 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2324 : : {
2325 : 5 : if (rc == ARITH_ASYMMETRIC)
2326 : : {
2327 : 0 : gfc_warning (0, gfc_arith_error (rc), &src->where);
2328 : : }
2329 : : else
2330 : : {
2331 : 5 : arith_error (rc, &src->ts, &result->ts, &src->where);
2332 : 5 : gfc_free_expr (result);
2333 : 5 : return NULL;
2334 : : }
2335 : : }
2336 : :
2337 : : /* If we do not trap numeric overflow, we need to convert the number to
2338 : : signed, throwing away high-order bits if necessary. */
2339 : 65552 : if (flag_range_check == 0)
2340 : : {
2341 : 132 : int k;
2342 : :
2343 : 132 : k = gfc_validate_kind (BT_INTEGER, kind, false);
2344 : 132 : gfc_convert_mpz_to_signed (result->value.integer,
2345 : : gfc_integer_kinds[k].bit_size);
2346 : :
2347 : 132 : if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2348 : 1 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2349 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2350 : : &src->where);
2351 : : }
2352 : : return result;
2353 : : }
2354 : :
2355 : :
2356 : : /* Convert integers to reals. */
2357 : :
2358 : : gfc_expr *
2359 : 116509 : gfc_int2real (gfc_expr *src, int kind)
2360 : : {
2361 : 116509 : gfc_expr *result;
2362 : 116509 : arith rc;
2363 : :
2364 : 116509 : if (src->ts.type != BT_INTEGER)
2365 : : return NULL;
2366 : :
2367 : 116508 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2368 : :
2369 : 116508 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2370 : :
2371 : 116508 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2372 : : {
2373 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2374 : 0 : gfc_free_expr (result);
2375 : 0 : return NULL;
2376 : : }
2377 : :
2378 : 116508 : if (warn_conversion
2379 : 116508 : && wprecision_int_real (src->value.integer, result->value.real))
2380 : 4 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2381 : : "from %qs to %qs at %L",
2382 : : gfc_typename (&src->ts),
2383 : : gfc_typename (&result->ts),
2384 : : &src->where);
2385 : :
2386 : : return result;
2387 : : }
2388 : :
2389 : :
2390 : : /* Convert default integer to default complex. */
2391 : :
2392 : : gfc_expr *
2393 : 834 : gfc_int2complex (gfc_expr *src, int kind)
2394 : : {
2395 : 834 : gfc_expr *result;
2396 : 834 : arith rc;
2397 : :
2398 : 834 : if (src->ts.type != BT_INTEGER)
2399 : : return NULL;
2400 : :
2401 : 831 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2402 : :
2403 : 831 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2404 : :
2405 : 831 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2406 : : != 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 : 831 : if (warn_conversion
2414 : 831 : && wprecision_int_real (src->value.integer,
2415 : : mpc_realref (result->value.complex)))
2416 : 1 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2417 : : "from %qs to %qs at %L",
2418 : : gfc_typename (&src->ts),
2419 : : gfc_typename (&result->ts),
2420 : : &src->where);
2421 : :
2422 : : return result;
2423 : : }
2424 : :
2425 : : /* Convert unsigned to unsigned, or integer to unsigned. */
2426 : :
2427 : : gfc_expr *
2428 : 441 : gfc_uint2uint (gfc_expr *src, int kind)
2429 : : {
2430 : 441 : gfc_expr *result;
2431 : 441 : arith rc;
2432 : :
2433 : 441 : if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
2434 : : return NULL;
2435 : :
2436 : 441 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2437 : 441 : mpz_set (result->value.integer, src->value.integer);
2438 : :
2439 : 441 : rc = gfc_range_check (result);
2440 : 441 : if (rc != ARITH_OK)
2441 : 12 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2442 : :
2443 : 441 : gfc_reduce_unsigned (result);
2444 : 441 : return result;
2445 : : }
2446 : :
2447 : : gfc_expr *
2448 : 152 : gfc_int2uint (gfc_expr *src, int kind)
2449 : : {
2450 : 152 : return gfc_uint2uint (src, kind);
2451 : : }
2452 : :
2453 : : gfc_expr *
2454 : 325 : gfc_uint2int (gfc_expr *src, int kind)
2455 : : {
2456 : 325 : return gfc_int2int (src, kind);
2457 : : }
2458 : :
2459 : : /* Convert UNSIGNED to reals. */
2460 : :
2461 : : gfc_expr *
2462 : 48 : gfc_uint2real (gfc_expr *src, int kind)
2463 : : {
2464 : 48 : gfc_expr *result;
2465 : 48 : arith rc;
2466 : :
2467 : 48 : if (src->ts.type != BT_UNSIGNED)
2468 : : return NULL;
2469 : :
2470 : 48 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2471 : :
2472 : 48 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2473 : :
2474 : 48 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2475 : : {
2476 : : /* This should be rare, just in case. */
2477 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2478 : 0 : gfc_free_expr (result);
2479 : 0 : return NULL;
2480 : : }
2481 : :
2482 : 48 : if (warn_conversion
2483 : 48 : && wprecision_int_real (src->value.integer, result->value.real))
2484 : 0 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2485 : : "from %qs to %qs at %L",
2486 : : gfc_typename (&src->ts),
2487 : : gfc_typename (&result->ts),
2488 : : &src->where);
2489 : :
2490 : : return result;
2491 : : }
2492 : :
2493 : : /* Convert default integer to default complex. */
2494 : :
2495 : : gfc_expr *
2496 : 0 : gfc_uint2complex (gfc_expr *src, int kind)
2497 : : {
2498 : 0 : gfc_expr *result;
2499 : 0 : arith rc;
2500 : :
2501 : 0 : if (src->ts.type != BT_UNSIGNED)
2502 : : return NULL;
2503 : :
2504 : 0 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2505 : :
2506 : 0 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2507 : :
2508 : 0 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2509 : : != 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 : 0 : if (warn_conversion
2518 : 0 : && wprecision_int_real (src->value.integer,
2519 : : mpc_realref (result->value.complex)))
2520 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2521 : : "from %qs to %qs at %L",
2522 : : gfc_typename (&src->ts),
2523 : : gfc_typename (&result->ts),
2524 : : &src->where);
2525 : :
2526 : : return result;
2527 : : }
2528 : :
2529 : : /* Convert default real to default integer. */
2530 : :
2531 : : gfc_expr *
2532 : 278 : gfc_real2int (gfc_expr *src, int kind)
2533 : : {
2534 : 278 : gfc_expr *result;
2535 : 278 : arith rc;
2536 : 278 : bool did_warn = false;
2537 : :
2538 : 278 : if (src->ts.type != BT_REAL)
2539 : : return NULL;
2540 : :
2541 : 278 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2542 : :
2543 : 278 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2544 : :
2545 : 278 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2546 : : {
2547 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2548 : 0 : gfc_free_expr (result);
2549 : 0 : return NULL;
2550 : : }
2551 : :
2552 : : /* If there was a fractional part, warn about this. */
2553 : :
2554 : 278 : if (warn_conversion)
2555 : : {
2556 : 4 : mpfr_t f;
2557 : 4 : mpfr_init (f);
2558 : 4 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2559 : 4 : if (mpfr_cmp_si (f, 0) != 0)
2560 : : {
2561 : 2 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2562 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2563 : : gfc_typename (&result->ts), &src->where);
2564 : 2 : did_warn = true;
2565 : : }
2566 : 4 : mpfr_clear (f);
2567 : : }
2568 : 278 : if (!did_warn && warn_conversion_extra)
2569 : : {
2570 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2571 : : "at %L", gfc_typename (&src->ts),
2572 : : gfc_typename (&result->ts), &src->where);
2573 : : }
2574 : :
2575 : : return result;
2576 : : }
2577 : :
2578 : : /* Convert real to unsigned. */
2579 : :
2580 : : gfc_expr *
2581 : 6 : gfc_real2uint (gfc_expr *src, int kind)
2582 : : {
2583 : 6 : gfc_expr *result;
2584 : 6 : arith rc;
2585 : 6 : bool did_warn = false;
2586 : :
2587 : 6 : if (src->ts.type != BT_REAL)
2588 : : return NULL;
2589 : :
2590 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2591 : :
2592 : 6 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2593 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2594 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2595 : :
2596 : 6 : gfc_reduce_unsigned (result);
2597 : :
2598 : : /* If there was a fractional part, warn about this. */
2599 : :
2600 : 6 : if (warn_conversion)
2601 : : {
2602 : 0 : mpfr_t f;
2603 : 0 : mpfr_init (f);
2604 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2605 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2606 : : {
2607 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2608 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2609 : : gfc_typename (&result->ts), &src->where);
2610 : 0 : did_warn = true;
2611 : : }
2612 : 0 : mpfr_clear (f);
2613 : : }
2614 : 6 : if (!did_warn && warn_conversion_extra)
2615 : : {
2616 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2617 : : "at %L", gfc_typename (&src->ts),
2618 : : gfc_typename (&result->ts), &src->where);
2619 : : }
2620 : :
2621 : : return result;
2622 : : }
2623 : :
2624 : : /* Convert real to real. */
2625 : :
2626 : : gfc_expr *
2627 : 7277 : gfc_real2real (gfc_expr *src, int kind)
2628 : : {
2629 : 7277 : gfc_expr *result;
2630 : 7277 : arith rc;
2631 : 7277 : bool did_warn = false;
2632 : :
2633 : 7277 : if (src->ts.type != BT_REAL)
2634 : : return NULL;
2635 : :
2636 : 7273 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2637 : :
2638 : 7273 : mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2639 : :
2640 : 7273 : rc = gfc_check_real_range (result->value.real, kind);
2641 : :
2642 : 7273 : if (rc == ARITH_UNDERFLOW)
2643 : : {
2644 : 0 : if (warn_underflow)
2645 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2646 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2647 : : }
2648 : 7273 : else if (rc != ARITH_OK)
2649 : : {
2650 : 1 : arith_error (rc, &src->ts, &result->ts, &src->where);
2651 : 1 : gfc_free_expr (result);
2652 : 1 : return NULL;
2653 : : }
2654 : :
2655 : : /* As a special bonus, don't warn about REAL values which are not changed by
2656 : : the conversion if -Wconversion is specified and -Wconversion-extra is
2657 : : not. */
2658 : :
2659 : 7272 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2660 : : {
2661 : 11 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2662 : :
2663 : : /* Calculate the difference between the constant and the rounded
2664 : : value and check it against zero. */
2665 : :
2666 : 11 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2667 : : {
2668 : 2 : gfc_warning_now (w, "Change of value in conversion from "
2669 : : "%qs to %qs at %L",
2670 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2671 : : &src->where);
2672 : : /* Make sure the conversion warning is not emitted again. */
2673 : 2 : did_warn = true;
2674 : : }
2675 : : }
2676 : :
2677 : 7272 : if (!did_warn && warn_conversion_extra)
2678 : 8 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2679 : : "at %L", gfc_typename(&src->ts),
2680 : : gfc_typename(&result->ts), &src->where);
2681 : :
2682 : : return result;
2683 : : }
2684 : :
2685 : :
2686 : : /* Convert real to complex. */
2687 : :
2688 : : gfc_expr *
2689 : 1330 : gfc_real2complex (gfc_expr *src, int kind)
2690 : : {
2691 : 1330 : gfc_expr *result;
2692 : 1330 : arith rc;
2693 : 1330 : bool did_warn = false;
2694 : :
2695 : 1330 : if (src->ts.type != BT_REAL)
2696 : : return NULL;
2697 : :
2698 : 1325 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2699 : :
2700 : 1325 : mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2701 : :
2702 : 1325 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2703 : :
2704 : 1325 : if (rc == ARITH_UNDERFLOW)
2705 : : {
2706 : 0 : if (warn_underflow)
2707 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2708 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2709 : : }
2710 : 1325 : else if (rc != ARITH_OK)
2711 : : {
2712 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2713 : 0 : gfc_free_expr (result);
2714 : 0 : return NULL;
2715 : : }
2716 : :
2717 : 1325 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2718 : : {
2719 : 2 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2720 : :
2721 : 2 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2722 : : {
2723 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2724 : : "%qs to %qs at %L",
2725 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2726 : : &src->where);
2727 : : /* Make sure the conversion warning is not emitted again. */
2728 : 1 : did_warn = true;
2729 : : }
2730 : : }
2731 : :
2732 : 1325 : if (!did_warn && warn_conversion_extra)
2733 : 2 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2734 : : "at %L", gfc_typename(&src->ts),
2735 : : gfc_typename(&result->ts), &src->where);
2736 : :
2737 : : return result;
2738 : : }
2739 : :
2740 : :
2741 : : /* Convert complex to integer. */
2742 : :
2743 : : gfc_expr *
2744 : 80 : gfc_complex2int (gfc_expr *src, int kind)
2745 : : {
2746 : 80 : gfc_expr *result;
2747 : 80 : arith rc;
2748 : 80 : bool did_warn = false;
2749 : :
2750 : 80 : if (src->ts.type != BT_COMPLEX)
2751 : : return NULL;
2752 : :
2753 : 80 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2754 : :
2755 : 80 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2756 : : &src->where);
2757 : :
2758 : 80 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2759 : : {
2760 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2761 : 0 : gfc_free_expr (result);
2762 : 0 : return NULL;
2763 : : }
2764 : :
2765 : 80 : if (warn_conversion || warn_conversion_extra)
2766 : : {
2767 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2768 : :
2769 : : /* See if we discarded an imaginary part. */
2770 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2771 : : {
2772 : 2 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2773 : : "in conversion from %qs to %qs at %L",
2774 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2775 : : &src->where);
2776 : 2 : did_warn = true;
2777 : : }
2778 : :
2779 : : else {
2780 : 2 : mpfr_t f;
2781 : :
2782 : 2 : mpfr_init (f);
2783 : 2 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2784 : 2 : if (mpfr_cmp_si (f, 0) != 0)
2785 : : {
2786 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2787 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2788 : : gfc_typename (&result->ts), &src->where);
2789 : 1 : did_warn = true;
2790 : : }
2791 : 2 : mpfr_clear (f);
2792 : : }
2793 : :
2794 : 4 : if (!did_warn && warn_conversion_extra)
2795 : : {
2796 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2797 : : "at %L", gfc_typename (&src->ts),
2798 : : gfc_typename (&result->ts), &src->where);
2799 : : }
2800 : : }
2801 : :
2802 : : return result;
2803 : : }
2804 : :
2805 : : /* Convert complex to integer. */
2806 : :
2807 : : gfc_expr *
2808 : 6 : gfc_complex2uint (gfc_expr *src, int kind)
2809 : : {
2810 : 6 : gfc_expr *result;
2811 : 6 : arith rc;
2812 : 6 : bool did_warn = false;
2813 : :
2814 : 6 : if (src->ts.type != BT_COMPLEX)
2815 : : return NULL;
2816 : :
2817 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2818 : :
2819 : 6 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2820 : : &src->where);
2821 : :
2822 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2823 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2824 : :
2825 : 6 : gfc_reduce_unsigned (result);
2826 : :
2827 : 6 : if (warn_conversion || warn_conversion_extra)
2828 : : {
2829 : 0 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2830 : :
2831 : : /* See if we discarded an imaginary part. */
2832 : 0 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2833 : : {
2834 : 0 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2835 : : "in conversion from %qs to %qs at %L",
2836 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2837 : : &src->where);
2838 : 0 : did_warn = true;
2839 : : }
2840 : :
2841 : : else
2842 : : {
2843 : 0 : mpfr_t f;
2844 : :
2845 : 0 : mpfr_init (f);
2846 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2847 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2848 : : {
2849 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2850 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2851 : : gfc_typename (&result->ts), &src->where);
2852 : 0 : did_warn = true;
2853 : : }
2854 : 0 : mpfr_clear (f);
2855 : : }
2856 : :
2857 : 0 : if (!did_warn && warn_conversion_extra)
2858 : : {
2859 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2860 : : "at %L", gfc_typename (&src->ts),
2861 : : gfc_typename (&result->ts), &src->where);
2862 : : }
2863 : : }
2864 : :
2865 : : return result;
2866 : : }
2867 : :
2868 : :
2869 : : /* Convert complex to real. */
2870 : :
2871 : : gfc_expr *
2872 : 209 : gfc_complex2real (gfc_expr *src, int kind)
2873 : : {
2874 : 209 : gfc_expr *result;
2875 : 209 : arith rc;
2876 : 209 : bool did_warn = false;
2877 : :
2878 : 209 : if (src->ts.type != BT_COMPLEX)
2879 : : return NULL;
2880 : :
2881 : 209 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2882 : :
2883 : 209 : mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2884 : :
2885 : 209 : rc = gfc_check_real_range (result->value.real, kind);
2886 : :
2887 : 209 : if (rc == ARITH_UNDERFLOW)
2888 : : {
2889 : 0 : if (warn_underflow)
2890 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2891 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2892 : : }
2893 : 209 : if (rc != ARITH_OK)
2894 : : {
2895 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2896 : 0 : gfc_free_expr (result);
2897 : 0 : return NULL;
2898 : : }
2899 : :
2900 : 209 : if (warn_conversion || warn_conversion_extra)
2901 : : {
2902 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2903 : :
2904 : : /* See if we discarded an imaginary part. */
2905 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2906 : : {
2907 : 4 : gfc_warning (w, "Non-zero imaginary part discarded "
2908 : : "in conversion from %qs to %qs at %L",
2909 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2910 : : &src->where);
2911 : 4 : did_warn = true;
2912 : : }
2913 : :
2914 : : /* Calculate the difference between the real constant and the rounded
2915 : : value and check it against zero. */
2916 : :
2917 : 4 : if (kind > src->ts.kind
2918 : 4 : && wprecision_real_real (mpc_realref (src->value.complex),
2919 : : src->ts.kind, kind))
2920 : : {
2921 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2922 : : "%qs to %qs at %L",
2923 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2924 : : &src->where);
2925 : : /* Make sure the conversion warning is not emitted again. */
2926 : 0 : did_warn = true;
2927 : : }
2928 : : }
2929 : :
2930 : 209 : if (!did_warn && warn_conversion_extra)
2931 : 0 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2932 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2933 : : &src->where);
2934 : :
2935 : : return result;
2936 : : }
2937 : :
2938 : :
2939 : : /* Convert complex to complex. */
2940 : :
2941 : : gfc_expr *
2942 : 669 : gfc_complex2complex (gfc_expr *src, int kind)
2943 : : {
2944 : 669 : gfc_expr *result;
2945 : 669 : arith rc;
2946 : 669 : bool did_warn = false;
2947 : :
2948 : 669 : if (src->ts.type != BT_COMPLEX)
2949 : : return NULL;
2950 : :
2951 : 665 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2952 : :
2953 : 665 : mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2954 : :
2955 : 665 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2956 : :
2957 : 665 : if (rc == ARITH_UNDERFLOW)
2958 : : {
2959 : 0 : if (warn_underflow)
2960 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2961 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2962 : : }
2963 : 665 : else if (rc != ARITH_OK)
2964 : : {
2965 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2966 : 0 : gfc_free_expr (result);
2967 : 0 : return NULL;
2968 : : }
2969 : :
2970 : 665 : rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2971 : :
2972 : 665 : if (rc == ARITH_UNDERFLOW)
2973 : : {
2974 : 0 : if (warn_underflow)
2975 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2976 : 0 : mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2977 : : }
2978 : 665 : else if (rc != ARITH_OK)
2979 : : {
2980 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2981 : 0 : gfc_free_expr (result);
2982 : 0 : return NULL;
2983 : : }
2984 : :
2985 : 665 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2986 : 668 : && (wprecision_real_real (mpc_realref (src->value.complex),
2987 : : src->ts.kind, kind)
2988 : 3 : || wprecision_real_real (mpc_imagref (src->value.complex),
2989 : : src->ts.kind, kind)))
2990 : : {
2991 : 3 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2992 : :
2993 : 3 : gfc_warning_now (w, "Change of value in conversion from "
2994 : : "%qs to %qs at %L",
2995 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2996 : : &src->where);
2997 : 3 : did_warn = true;
2998 : : }
2999 : :
3000 : 665 : if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
3001 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
3002 : : "at %L", gfc_typename(&src->ts),
3003 : : gfc_typename (&result->ts), &src->where);
3004 : :
3005 : : return result;
3006 : : }
3007 : :
3008 : :
3009 : : /* Logical kind conversion. */
3010 : :
3011 : : gfc_expr *
3012 : 680 : gfc_log2log (gfc_expr *src, int kind)
3013 : : {
3014 : 680 : gfc_expr *result;
3015 : :
3016 : 680 : if (src->ts.type != BT_LOGICAL)
3017 : : return NULL;
3018 : :
3019 : 680 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3020 : 680 : result->value.logical = src->value.logical;
3021 : :
3022 : 680 : return result;
3023 : : }
3024 : :
3025 : :
3026 : : /* Convert logical to integer. */
3027 : :
3028 : : gfc_expr *
3029 : 14 : gfc_log2int (gfc_expr *src, int kind)
3030 : : {
3031 : 14 : gfc_expr *result;
3032 : :
3033 : 14 : if (src->ts.type != BT_LOGICAL)
3034 : : return NULL;
3035 : :
3036 : 14 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3037 : 14 : mpz_set_si (result->value.integer, src->value.logical);
3038 : :
3039 : 14 : return result;
3040 : : }
3041 : :
3042 : : /* Convert logical to unsigned. */
3043 : :
3044 : : gfc_expr *
3045 : 0 : gfc_log2uint (gfc_expr *src, int kind)
3046 : : {
3047 : 0 : gfc_expr *result;
3048 : :
3049 : 0 : if (src->ts.type != BT_LOGICAL)
3050 : : return NULL;
3051 : :
3052 : 0 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
3053 : 0 : mpz_set_si (result->value.integer, src->value.logical);
3054 : :
3055 : 0 : return result;
3056 : : }
3057 : :
3058 : :
3059 : : /* Convert integer to logical. */
3060 : :
3061 : : gfc_expr *
3062 : 0 : gfc_int2log (gfc_expr *src, int kind)
3063 : : {
3064 : 0 : gfc_expr *result;
3065 : :
3066 : 0 : if (src->ts.type != BT_INTEGER)
3067 : : return NULL;
3068 : :
3069 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3070 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3071 : :
3072 : 0 : return result;
3073 : : }
3074 : :
3075 : : /* Convert unsigned to logical. */
3076 : :
3077 : : gfc_expr *
3078 : 0 : gfc_uint2log (gfc_expr *src, int kind)
3079 : : {
3080 : 0 : gfc_expr *result;
3081 : :
3082 : 0 : if (src->ts.type != BT_UNSIGNED)
3083 : : return NULL;
3084 : :
3085 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3086 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3087 : :
3088 : 0 : return result;
3089 : : }
3090 : :
3091 : : /* Convert character to character. We only use wide strings internally,
3092 : : so we only set the kind. */
3093 : :
3094 : : gfc_expr *
3095 : 0 : gfc_character2character (gfc_expr *src, int kind)
3096 : : {
3097 : 0 : gfc_expr *result;
3098 : 0 : result = gfc_copy_expr (src);
3099 : 0 : result->ts.kind = kind;
3100 : :
3101 : 0 : return result;
3102 : : }
3103 : :
3104 : : /* Helper function to set the representation in a Hollerith conversion.
3105 : : This assumes that the ts.type and ts.kind of the result have already
3106 : : been set. */
3107 : :
3108 : : static void
3109 : 1187 : hollerith2representation (gfc_expr *result, gfc_expr *src)
3110 : : {
3111 : 1187 : size_t src_len, result_len;
3112 : :
3113 : 1187 : src_len = src->representation.length - src->ts.u.pad;
3114 : 1187 : gfc_target_expr_size (result, &result_len);
3115 : :
3116 : 1187 : if (src_len > result_len)
3117 : : {
3118 : 248 : gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
3119 : : "is truncated in conversion to %qs", &src->where,
3120 : : gfc_typename(&result->ts));
3121 : : }
3122 : :
3123 : 1187 : result->representation.string = XCNEWVEC (char, result_len + 1);
3124 : 1187 : memcpy (result->representation.string, src->representation.string,
3125 : 1187 : MIN (result_len, src_len));
3126 : :
3127 : 1187 : if (src_len < result_len)
3128 : 294 : memset (&result->representation.string[src_len], ' ', result_len - src_len);
3129 : :
3130 : 1187 : result->representation.string[result_len] = '\0'; /* For debugger */
3131 : 1187 : result->representation.length = result_len;
3132 : 1187 : }
3133 : :
3134 : :
3135 : : /* Helper function to set the representation in a character conversion.
3136 : : This assumes that the ts.type and ts.kind of the result have already
3137 : : been set. */
3138 : :
3139 : : static void
3140 : 747 : character2representation (gfc_expr *result, gfc_expr *src)
3141 : : {
3142 : 747 : size_t src_len, result_len, i;
3143 : 747 : src_len = src->value.character.length;
3144 : 747 : gfc_target_expr_size (result, &result_len);
3145 : :
3146 : 747 : if (src_len > result_len)
3147 : 240 : gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
3148 : : "truncated in conversion to %s", &src->where,
3149 : : gfc_typename(&result->ts));
3150 : :
3151 : 747 : result->representation.string = XCNEWVEC (char, result_len + 1);
3152 : :
3153 : 3991 : for (i = 0; i < MIN (result_len, src_len); i++)
3154 : 3244 : result->representation.string[i] = (char) src->value.character.string[i];
3155 : :
3156 : 747 : if (src_len < result_len)
3157 : 246 : memset (&result->representation.string[src_len], ' ',
3158 : : result_len - src_len);
3159 : :
3160 : 747 : result->representation.string[result_len] = '\0'; /* For debugger. */
3161 : 747 : result->representation.length = result_len;
3162 : 747 : }
3163 : :
3164 : : /* Convert Hollerith to integer. The constant will be padded or truncated. */
3165 : :
3166 : : gfc_expr *
3167 : 377 : gfc_hollerith2int (gfc_expr *src, int kind)
3168 : : {
3169 : 377 : gfc_expr *result;
3170 : 377 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3171 : :
3172 : 377 : hollerith2representation (result, src);
3173 : 377 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3174 : 377 : result->representation.length, result->value.integer);
3175 : :
3176 : 377 : return result;
3177 : : }
3178 : :
3179 : : /* Convert character to integer. The constant will be padded or truncated. */
3180 : :
3181 : : gfc_expr *
3182 : 187 : gfc_character2int (gfc_expr *src, int kind)
3183 : : {
3184 : 187 : gfc_expr *result;
3185 : 187 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3186 : :
3187 : 187 : character2representation (result, src);
3188 : 187 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3189 : 187 : result->representation.length, result->value.integer);
3190 : 187 : return result;
3191 : : }
3192 : :
3193 : : /* Convert Hollerith to real. The constant will be padded or truncated. */
3194 : :
3195 : : gfc_expr *
3196 : 327 : gfc_hollerith2real (gfc_expr *src, int kind)
3197 : : {
3198 : 327 : gfc_expr *result;
3199 : 327 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3200 : :
3201 : 327 : hollerith2representation (result, src);
3202 : 327 : if (gfc_interpret_float (kind,
3203 : 327 : (unsigned char *) result->representation.string,
3204 : 327 : result->representation.length, result->value.real))
3205 : : return result;
3206 : : else
3207 : 0 : return NULL;
3208 : : }
3209 : :
3210 : : /* Convert character to real. The constant will be padded or truncated. */
3211 : :
3212 : : gfc_expr *
3213 : 187 : gfc_character2real (gfc_expr *src, int kind)
3214 : : {
3215 : 187 : gfc_expr *result;
3216 : 187 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3217 : :
3218 : 187 : character2representation (result, src);
3219 : 187 : gfc_interpret_float (kind, (unsigned char *) result->representation.string,
3220 : 187 : result->representation.length, result->value.real);
3221 : :
3222 : 187 : return result;
3223 : : }
3224 : :
3225 : :
3226 : : /* Convert Hollerith to complex. The constant will be padded or truncated. */
3227 : :
3228 : : gfc_expr *
3229 : 288 : gfc_hollerith2complex (gfc_expr *src, int kind)
3230 : : {
3231 : 288 : gfc_expr *result;
3232 : 288 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3233 : :
3234 : 288 : hollerith2representation (result, src);
3235 : 288 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3236 : 288 : result->representation.length, result->value.complex);
3237 : :
3238 : 288 : return result;
3239 : : }
3240 : :
3241 : : /* Convert character to complex. The constant will be padded or truncated. */
3242 : :
3243 : : gfc_expr *
3244 : 187 : gfc_character2complex (gfc_expr *src, int kind)
3245 : : {
3246 : 187 : gfc_expr *result;
3247 : 187 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3248 : :
3249 : 187 : character2representation (result, src);
3250 : 187 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3251 : 187 : result->representation.length, result->value.complex);
3252 : :
3253 : 187 : return result;
3254 : : }
3255 : :
3256 : :
3257 : : /* Convert Hollerith to character. */
3258 : :
3259 : : gfc_expr *
3260 : 164 : gfc_hollerith2character (gfc_expr *src, int kind)
3261 : : {
3262 : 164 : gfc_expr *result;
3263 : :
3264 : 164 : result = gfc_copy_expr (src);
3265 : 164 : result->ts.type = BT_CHARACTER;
3266 : 164 : result->ts.kind = kind;
3267 : 164 : result->ts.u.pad = 0;
3268 : :
3269 : 164 : result->value.character.length = result->representation.length;
3270 : 164 : result->value.character.string
3271 : 164 : = gfc_char_to_widechar (result->representation.string);
3272 : :
3273 : 164 : return result;
3274 : : }
3275 : :
3276 : :
3277 : : /* Convert Hollerith to logical. The constant will be padded or truncated. */
3278 : :
3279 : : gfc_expr *
3280 : 195 : gfc_hollerith2logical (gfc_expr *src, int kind)
3281 : : {
3282 : 195 : gfc_expr *result;
3283 : 195 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3284 : :
3285 : 195 : hollerith2representation (result, src);
3286 : 195 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3287 : 195 : result->representation.length, &result->value.logical);
3288 : :
3289 : 195 : return result;
3290 : : }
3291 : :
3292 : : /* Convert character to logical. The constant will be padded or truncated. */
3293 : :
3294 : : gfc_expr *
3295 : 186 : gfc_character2logical (gfc_expr *src, int kind)
3296 : : {
3297 : 186 : gfc_expr *result;
3298 : 186 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3299 : :
3300 : 186 : character2representation (result, src);
3301 : 186 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3302 : 186 : result->representation.length, &result->value.logical);
3303 : :
3304 : 186 : return result;
3305 : : }
|
