Branch data Line data Source code
1 : : /* Compiler arithmetic
2 : : Copyright (C) 2000-2024 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 : 1077 : gfc_reduce_unsigned (gfc_expr *e)
65 : : {
66 : 1077 : int k;
67 : 1077 : gcc_checking_assert (e->expr_type == EXPR_CONSTANT
68 : : && e->ts.type == BT_UNSIGNED);
69 : 1077 : k = gfc_validate_kind (BT_UNSIGNED, e->ts.kind, false);
70 : 1077 : mpz_and (e->value.integer, e->value.integer, gfc_unsigned_kinds[k].huge);
71 : 1077 : }
72 : : /* Set the model number precision by the requested KIND. */
73 : :
74 : : void
75 : 868712 : gfc_set_model_kind (int kind)
76 : : {
77 : 868712 : int index = gfc_validate_kind (BT_REAL, kind, false);
78 : 868712 : int base2prec;
79 : :
80 : 868712 : base2prec = gfc_real_kinds[index].digits;
81 : 868712 : if (gfc_real_kinds[index].radix != 2)
82 : 0 : base2prec *= gfc_real_kinds[index].radix / 2;
83 : 868712 : mpfr_set_default_prec (base2prec);
84 : 868712 : }
85 : :
86 : :
87 : : /* Set the model number precision from mpfr_t x. */
88 : :
89 : : void
90 : 438197 : gfc_set_model (mpfr_t x)
91 : : {
92 : 438197 : mpfr_set_default_prec (mpfr_get_prec (x));
93 : 438197 : }
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 : 11339648 : 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 : 30461 : gfc_arith_init_1 (void)
176 : : {
177 : 30461 : gfc_integer_info *int_info;
178 : 30461 : gfc_unsigned_info *uint_info;
179 : 30461 : gfc_real_info *real_info;
180 : 30461 : mpfr_t a, b;
181 : 30461 : int i;
182 : :
183 : 30461 : mpfr_set_default_prec (128);
184 : 30461 : mpfr_init (a);
185 : :
186 : : /* Convert the minimum and maximum values for each kind into their
187 : : GNU MP representation. */
188 : 212820 : for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
189 : : {
190 : : /* Huge */
191 : 151898 : mpz_init (int_info->huge);
192 : 151898 : mpz_set_ui (int_info->huge, int_info->radix);
193 : 151898 : mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
194 : 151898 : 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 : 151898 : 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 : 151898 : mpz_init (int_info->pedantic_min_int);
209 : 151898 : mpz_neg (int_info->pedantic_min_int, int_info->huge);
210 : :
211 : 151898 : mpz_init (int_info->min_int);
212 : 151898 : mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
213 : :
214 : : /* Range */
215 : 151898 : mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
216 : 151898 : mpfr_log10 (a, a, GFC_RND_MODE);
217 : 151898 : mpfr_trunc (a, a);
218 : 151898 : int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
219 : : }
220 : :
221 : : /* Similar, for UNSIGNED. */
222 : 30461 : if (flag_unsigned)
223 : : {
224 : 1200 : for (uint_info = gfc_unsigned_kinds; uint_info->kind != 0; uint_info++)
225 : : {
226 : : /* UNSIGNED is radix 2. */
227 : 1000 : gcc_assert (uint_info->radix == 2);
228 : : /* Huge. */
229 : 1000 : mpz_init (uint_info->huge);
230 : 1000 : mpz_set_ui (uint_info->huge, 2);
231 : 1000 : mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits);
232 : 1000 : mpz_sub_ui (uint_info->huge, uint_info->huge, 1);
233 : :
234 : : /* int_min - the smallest number we can reasonably convert from. */
235 : :
236 : 1000 : mpz_init (uint_info->int_min);
237 : 1000 : mpz_set_ui (uint_info->int_min, 2);
238 : 1000 : mpz_pow_ui (uint_info->int_min, uint_info->int_min,
239 : 1000 : uint_info->digits - 1);
240 : 1000 : mpz_neg (uint_info->int_min, uint_info->int_min);
241 : :
242 : : /* Range. */
243 : 1000 : mpfr_set_z (a, uint_info->huge, GFC_RND_MODE);
244 : 1000 : mpfr_log10 (a, a, GFC_RND_MODE);
245 : 1000 : mpfr_trunc (a,a);
246 : 1000 : uint_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
247 : : }
248 : :
249 : : }
250 : :
251 : 30461 : mpfr_clear (a);
252 : :
253 : 182766 : for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
254 : : {
255 : 121844 : gfc_set_model_kind (real_info->kind);
256 : :
257 : 121844 : mpfr_init (a);
258 : 121844 : mpfr_init (b);
259 : :
260 : : /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
261 : : /* 1 - b**(-p) */
262 : 121844 : mpfr_init (real_info->huge);
263 : 121844 : mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
264 : 121844 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
265 : 121844 : mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
266 : 121844 : mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
267 : :
268 : : /* b**(emax-1) */
269 : 121844 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
270 : 121844 : mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
271 : :
272 : : /* (1 - b**(-p)) * b**(emax-1) */
273 : 121844 : mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
274 : :
275 : : /* (1 - b**(-p)) * b**(emax-1) * b */
276 : 121844 : mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
277 : : GFC_RND_MODE);
278 : :
279 : : /* tiny(x) = b**(emin-1) */
280 : 121844 : mpfr_init (real_info->tiny);
281 : 121844 : mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
282 : 121844 : mpfr_pow_si (real_info->tiny, real_info->tiny,
283 : 121844 : real_info->min_exponent - 1, GFC_RND_MODE);
284 : :
285 : : /* subnormal (x) = b**(emin - digit) */
286 : 121844 : mpfr_init (real_info->subnormal);
287 : 121844 : mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
288 : 121844 : mpfr_pow_si (real_info->subnormal, real_info->subnormal,
289 : 121844 : real_info->min_exponent - real_info->digits, GFC_RND_MODE);
290 : :
291 : : /* epsilon(x) = b**(1-p) */
292 : 121844 : mpfr_init (real_info->epsilon);
293 : 121844 : mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
294 : 121844 : mpfr_pow_si (real_info->epsilon, real_info->epsilon,
295 : 121844 : 1 - real_info->digits, GFC_RND_MODE);
296 : :
297 : : /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
298 : 121844 : mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
299 : 121844 : mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
300 : 121844 : mpfr_neg (b, b, GFC_RND_MODE);
301 : :
302 : : /* a = min(a, b) */
303 : 121844 : mpfr_min (a, a, b, GFC_RND_MODE);
304 : 121844 : mpfr_trunc (a, a);
305 : 121844 : real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
306 : :
307 : : /* precision(x) = int((p - 1) * log10(b)) + k */
308 : 121844 : mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
309 : 121844 : mpfr_log10 (a, a, GFC_RND_MODE);
310 : 121844 : mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
311 : 121844 : mpfr_trunc (a, a);
312 : 121844 : 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 : 121844 : for (i = 10; i <= real_info->radix; i *= 10)
316 : 0 : if (i == real_info->radix)
317 : 0 : real_info->precision++;
318 : :
319 : 121844 : mpfr_clears (a, b, NULL);
320 : : }
321 : 30461 : }
322 : :
323 : :
324 : : /* Clean up, get rid of numeric constants. */
325 : :
326 : : void
327 : 30444 : gfc_arith_done_1 (void)
328 : : {
329 : 30444 : gfc_integer_info *ip;
330 : 30444 : gfc_real_info *rp;
331 : :
332 : 182257 : for (ip = gfc_integer_kinds; ip->kind; ip++)
333 : : {
334 : 151813 : mpz_clear (ip->min_int);
335 : 151813 : mpz_clear (ip->pedantic_min_int);
336 : 151813 : mpz_clear (ip->huge);
337 : : }
338 : :
339 : 152220 : for (rp = gfc_real_kinds; rp->kind; rp++)
340 : 121776 : mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
341 : :
342 : 30444 : mpfr_free_cache ();
343 : 30444 : }
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 : 1725118 : 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 : 1725118 : if (kind == 4)
354 : : return true;
355 : :
356 : 1551937 : if (kind == 1)
357 : 1551937 : 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 : 15498928 : gfc_check_integer_range (mpz_t p, int kind)
369 : : {
370 : 15498928 : arith result;
371 : 15498928 : int i;
372 : :
373 : 15498928 : i = gfc_validate_kind (BT_INTEGER, kind, false);
374 : 15498928 : result = ARITH_OK;
375 : :
376 : 15498928 : if (pedantic)
377 : : {
378 : 13368217 : if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
379 : 15498928 : result = ARITH_ASYMMETRIC;
380 : : }
381 : :
382 : :
383 : 15498928 : if (flag_range_check == 0)
384 : : return result;
385 : :
386 : 15469502 : if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
387 : 15469502 : || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
388 : 15498928 : result = ARITH_OVERFLOW;
389 : :
390 : : return result;
391 : : }
392 : :
393 : : /* Same as above. */
394 : : arith
395 : 10946 : gfc_check_unsigned_range (mpz_t p, int kind)
396 : : {
397 : 10946 : int i;
398 : :
399 : 10946 : i = gfc_validate_kind (BT_UNSIGNED, kind, false);
400 : :
401 : 10946 : if (pedantic && mpz_cmp_si (p, 0) < 0)
402 : : return ARITH_UNSIGNED_NEGATIVE;
403 : :
404 : 10946 : if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0)
405 : : return ARITH_UNSIGNED_TRUNCATED;
406 : :
407 : 10945 : 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 : 436719 : gfc_check_real_range (mpfr_t p, int kind)
419 : : {
420 : 436719 : arith retval;
421 : 436719 : mpfr_t q;
422 : 436719 : int i;
423 : :
424 : 436719 : i = gfc_validate_kind (BT_REAL, kind, false);
425 : :
426 : 436719 : gfc_set_model (p);
427 : 436719 : mpfr_init (q);
428 : 436719 : mpfr_abs (q, p, GFC_RND_MODE);
429 : :
430 : 436719 : retval = ARITH_OK;
431 : :
432 : 436719 : if (mpfr_inf_p (p))
433 : : {
434 : 1142 : if (flag_range_check != 0)
435 : 21 : retval = ARITH_OVERFLOW;
436 : : }
437 : 435577 : else if (mpfr_nan_p (p))
438 : : {
439 : 236 : if (flag_range_check != 0)
440 : 370518 : retval = ARITH_NAN;
441 : : }
442 : 435341 : else if (mpfr_sgn (q) == 0)
443 : : {
444 : 66201 : mpfr_clear (q);
445 : 66201 : return retval;
446 : : }
447 : 369140 : 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 : 369097 : 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 : 369075 : else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
471 : : {
472 : 156 : mpfr_exp_t emin, emax;
473 : 156 : int en;
474 : :
475 : : /* Save current values of emin and emax. */
476 : 156 : emin = mpfr_get_emin ();
477 : 156 : emax = mpfr_get_emax ();
478 : :
479 : : /* Set emin and emax for the current model number. */
480 : 156 : en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
481 : 156 : mpfr_set_emin ((mpfr_exp_t) en);
482 : 156 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
483 : 156 : mpfr_check_range (q, 0, GFC_RND_MODE);
484 : 156 : mpfr_subnormalize (q, 0, GFC_RND_MODE);
485 : :
486 : : /* Reset emin and emax. */
487 : 156 : mpfr_set_emin (emin);
488 : 156 : mpfr_set_emax (emax);
489 : :
490 : : /* Copy sign if needed. */
491 : 156 : if (mpfr_sgn (p) < 0)
492 : 24 : mpfr_neg (p, q, MPFR_RNDN);
493 : : else
494 : 132 : mpfr_set (p, q, MPFR_RNDN);
495 : : }
496 : :
497 : 370518 : mpfr_clear (q);
498 : :
499 : 370518 : 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 : 519 : gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
511 : : {
512 : 519 : gfc_expr *result;
513 : :
514 : 519 : if (op1->ts.type != BT_LOGICAL)
515 : : return ARITH_INVALID_TYPE;
516 : :
517 : 519 : result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
518 : 519 : result->value.logical = !op1->value.logical;
519 : 519 : *resultp = result;
520 : :
521 : 519 : 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 : 7243 : gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
544 : : {
545 : 7243 : gfc_expr *result;
546 : :
547 : 7243 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
548 : : return ARITH_INVALID_TYPE;
549 : :
550 : 7242 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
551 : : &op1->where);
552 : 7242 : result->value.logical = op1->value.logical || op2->value.logical;
553 : 7242 : *resultp = result;
554 : :
555 : 7242 : 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 : 1347 : gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
578 : : {
579 : 1347 : gfc_expr *result;
580 : :
581 : 1347 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
582 : : return ARITH_INVALID_TYPE;
583 : :
584 : 1346 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
585 : : &op1->where);
586 : 1346 : result->value.logical = op1->value.logical != op2->value.logical;
587 : 1346 : *resultp = result;
588 : :
589 : 1346 : 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 : 15745529 : gfc_range_check (gfc_expr *e)
599 : : {
600 : 15745529 : arith rc;
601 : 15745529 : arith rc2;
602 : :
603 : 15745529 : switch (e->ts.type)
604 : : {
605 : 15431029 : case BT_INTEGER:
606 : 15431029 : rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
607 : 15431029 : break;
608 : :
609 : 10934 : case BT_UNSIGNED:
610 : 10934 : rc = gfc_check_unsigned_range (e->value.integer, e->ts.kind);
611 : 10934 : break;
612 : :
613 : 296464 : case BT_REAL:
614 : 296464 : rc = gfc_check_real_range (e->value.real, e->ts.kind);
615 : 296464 : if (rc == ARITH_UNDERFLOW)
616 : 9 : mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
617 : 296464 : if (rc == ARITH_OVERFLOW)
618 : 16 : mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
619 : 296464 : if (rc == ARITH_NAN)
620 : 17 : mpfr_set_nan (e->value.real);
621 : : break;
622 : :
623 : 7102 : case BT_COMPLEX:
624 : 7102 : rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
625 : 7102 : if (rc == ARITH_UNDERFLOW)
626 : 0 : mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
627 : 7102 : if (rc == ARITH_OVERFLOW)
628 : 2 : mpfr_set_inf (mpc_realref (e->value.complex),
629 : 2 : mpfr_sgn (mpc_realref (e->value.complex)));
630 : 7102 : if (rc == ARITH_NAN)
631 : 4 : mpfr_set_nan (mpc_realref (e->value.complex));
632 : :
633 : 7102 : rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
634 : 7102 : if (rc == ARITH_UNDERFLOW)
635 : 0 : mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
636 : 7102 : if (rc == ARITH_OVERFLOW)
637 : 2 : mpfr_set_inf (mpc_imagref (e->value.complex),
638 : 2 : mpfr_sgn (mpc_imagref (e->value.complex)));
639 : 7102 : if (rc == ARITH_NAN)
640 : 4 : mpfr_set_nan (mpc_imagref (e->value.complex));
641 : :
642 : 7102 : if (rc == ARITH_OK)
643 : 7096 : rc = rc2;
644 : : break;
645 : :
646 : 0 : default:
647 : 0 : gfc_internal_error ("gfc_range_check(): Bad type");
648 : : }
649 : :
650 : 15745529 : 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 : 11320354 : check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
659 : : {
660 : 11320354 : arith val = rc;
661 : :
662 : 11320354 : 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 : 11320345 : if (val == ARITH_ASYMMETRIC)
670 : : {
671 : 86 : gfc_warning (0, gfc_arith_error (val), &x->where);
672 : 86 : val = ARITH_OK;
673 : : }
674 : :
675 : 11320354 : if (is_hard_arith_error (val))
676 : 1 : gfc_free_expr (r);
677 : : else
678 : 11320353 : *rp = r;
679 : :
680 : 11320354 : 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 : 129343 : gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
699 : : {
700 : 129343 : gfc_expr *result;
701 : 129343 : arith rc;
702 : :
703 : 129343 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
704 : :
705 : 129343 : switch (op1->ts.type)
706 : : {
707 : 98293 : case BT_INTEGER:
708 : 98293 : mpz_neg (result->value.integer, op1->value.integer);
709 : 98293 : 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 : 31017 : case BT_REAL:
721 : 31017 : mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
722 : 31017 : 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 : 129342 : rc = gfc_range_check (result);
733 : 129342 : 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 : 129342 : return check_result (rc, op1, result, resultp);
743 : : }
744 : :
745 : :
746 : : static arith
747 : 10356387 : gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
748 : : {
749 : 10356387 : gfc_expr *result;
750 : 10356387 : arith rc;
751 : :
752 : 10356387 : if (op1->ts.type != op2->ts.type)
753 : : return ARITH_INVALID_TYPE;
754 : :
755 : 10356386 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
756 : :
757 : 10356386 : switch (op1->ts.type)
758 : : {
759 : 10353245 : case BT_INTEGER:
760 : 10353245 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
761 : 10353245 : break;
762 : :
763 : 223 : case BT_UNSIGNED:
764 : 223 : mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
765 : 223 : gfc_reduce_unsigned (result);
766 : 223 : 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 : 10356386 : rc = gfc_range_check (result);
783 : :
784 : 10356386 : return check_result (rc, op1, result, resultp);
785 : : }
786 : :
787 : :
788 : : static arith
789 : 511260 : gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
790 : : {
791 : 511260 : gfc_expr *result;
792 : 511260 : arith rc;
793 : :
794 : 511260 : if (op1->ts.type != op2->ts.type)
795 : : return ARITH_INVALID_TYPE;
796 : :
797 : 511259 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
798 : :
799 : 511259 : switch (op1->ts.type)
800 : : {
801 : 510164 : case BT_INTEGER:
802 : 510164 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
803 : 510164 : break;
804 : :
805 : 66 : case BT_UNSIGNED:
806 : 66 : mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
807 : 66 : gfc_reduce_unsigned (result);
808 : 66 : break;
809 : :
810 : 929 : case BT_REAL:
811 : 929 : mpfr_sub (result->value.real, op1->value.real, op2->value.real,
812 : : GFC_RND_MODE);
813 : 929 : 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 : 511259 : rc = gfc_range_check (result);
825 : :
826 : 511259 : return check_result (rc, op1, result, resultp);
827 : : }
828 : :
829 : :
830 : : static arith
831 : 309707 : gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
832 : : {
833 : 309707 : gfc_expr *result;
834 : 309707 : arith rc;
835 : :
836 : 309707 : if (op1->ts.type != op2->ts.type)
837 : : return ARITH_INVALID_TYPE;
838 : :
839 : 309705 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
840 : :
841 : 309705 : switch (op1->ts.type)
842 : : {
843 : 297341 : case BT_INTEGER:
844 : 297341 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
845 : 297341 : break;
846 : :
847 : 192 : case BT_UNSIGNED:
848 : 192 : mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
849 : 192 : gfc_reduce_unsigned (result);
850 : 192 : break;
851 : :
852 : 10969 : case BT_REAL:
853 : 10969 : mpfr_mul (result->value.real, op1->value.real, op2->value.real,
854 : : GFC_RND_MODE);
855 : 10969 : 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 : 309705 : rc = gfc_range_check (result);
868 : :
869 : 309705 : return check_result (rc, op1, result, resultp);
870 : : }
871 : :
872 : :
873 : : static arith
874 : 7607 : gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
875 : : {
876 : 7607 : gfc_expr *result;
877 : 7607 : arith rc;
878 : :
879 : 7607 : if (op1->ts.type != op2->ts.type)
880 : : return ARITH_INVALID_TYPE;
881 : :
882 : 7605 : rc = ARITH_OK;
883 : :
884 : 7605 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
885 : :
886 : 7605 : 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 : 3929 : case BT_REAL:
921 : : /* Set "Division by zero" only for regular numerator. */
922 : 3929 : if (flag_range_check == 1
923 : 3361 : && mpfr_zero_p (op2->value.real)
924 : 20 : && mpfr_regular_p (op1->value.real))
925 : 3929 : rc = ARITH_DIV0;
926 : :
927 : 3929 : mpfr_div (result->value.real, op1->value.real, op2->value.real,
928 : : GFC_RND_MODE);
929 : 3929 : 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 : 7586 : if (rc == ARITH_OK)
960 : 7577 : rc = gfc_range_check (result);
961 : :
962 : 7605 : return check_result (rc, op1, result, resultp);
963 : : }
964 : :
965 : : /* Raise a number to a power. */
966 : :
967 : : static arith
968 : 6068 : arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
969 : : {
970 : 6068 : int power_sign;
971 : 6068 : gfc_expr *result;
972 : 6068 : arith rc;
973 : :
974 : 6068 : 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 : 6064 : if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
981 : 6059 : || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
982 : : return ARITH_NOT_REDUCED;
983 : :
984 : 6057 : rc = ARITH_OK;
985 : 6057 : result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
986 : :
987 : 6057 : switch (op2->ts.type)
988 : : {
989 : 5731 : case BT_INTEGER:
990 : 5731 : power_sign = mpz_sgn (op2->value.integer);
991 : :
992 : 5655 : 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 : 5647 : switch (op1->ts.type)
1018 : : {
1019 : 5334 : case BT_INTEGER:
1020 : 5334 : {
1021 : : /* First, we simplify the cases of op1 == 1, 0 or -1. */
1022 : 5334 : 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 : 4530 : 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 : 4524 : 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 : 4500 : 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 : 4491 : int k, power;
1061 : :
1062 : 4491 : k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
1063 : 4491 : power = gfc_integer_kinds[k].bit_size;
1064 : 4491 : if (mpz_cmp_si (op2->value.integer, power) < 0)
1065 : : {
1066 : 4472 : gfc_extract_int (op2, &power);
1067 : 4472 : mpz_pow_ui (result->value.integer, op1->value.integer,
1068 : : power);
1069 : 4472 : rc = gfc_range_check (result);
1070 : 4472 : 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 : 278 : case BT_REAL:
1105 : :
1106 : 278 : 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 : 277 : 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 : 277 : mpfr_pow (result->value.real, op1->value.real, op2->value.real,
1126 : : GFC_RND_MODE);
1127 : 277 : 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 : 0 : default:
1147 : 0 : gfc_internal_error ("arith_power(): unknown type");
1148 : : }
1149 : :
1150 : 6042 : if (rc == ARITH_OK)
1151 : 6032 : rc = gfc_range_check (result);
1152 : :
1153 : 6056 : return check_result (rc, op1, result, resultp);
1154 : : }
1155 : :
1156 : :
1157 : : /* Concatenate two string constants. */
1158 : :
1159 : : static arith
1160 : 4194 : gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1161 : : {
1162 : 4194 : gfc_expr *result;
1163 : 4194 : size_t len;
1164 : :
1165 : : /* By cleverly playing around with constructors, it is possible
1166 : : to get mismatching types here. */
1167 : 4194 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1168 : 4193 : || op1->ts.kind != op2->ts.kind)
1169 : : return ARITH_WRONGCONCAT;
1170 : :
1171 : 4193 : result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1172 : : &op1->where);
1173 : :
1174 : 4193 : len = op1->value.character.length + op2->value.character.length;
1175 : :
1176 : 4193 : result->value.character.string = gfc_get_wide_string (len + 1);
1177 : 4193 : result->value.character.length = len;
1178 : :
1179 : 4193 : memcpy (result->value.character.string, op1->value.character.string,
1180 : 4193 : op1->value.character.length * sizeof (gfc_char_t));
1181 : :
1182 : 4193 : memcpy (&result->value.character.string[op1->value.character.length],
1183 : 4193 : op2->value.character.string,
1184 : 4193 : op2->value.character.length * sizeof (gfc_char_t));
1185 : :
1186 : 4193 : result->value.character.string[len] = '\0';
1187 : :
1188 : 4193 : *resultp = result;
1189 : :
1190 : 4193 : return ARITH_OK;
1191 : : }
1192 : :
1193 : : /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1194 : : This function mimics mpfr_cmp but takes NaN into account. */
1195 : :
1196 : : static int
1197 : 3163 : compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1198 : : {
1199 : 3163 : int rc;
1200 : 3163 : switch (op)
1201 : : {
1202 : 1673 : case INTRINSIC_EQ:
1203 : 1673 : rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1204 : 1673 : break;
1205 : 872 : case INTRINSIC_GT:
1206 : 872 : rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1207 : : break;
1208 : 72 : case INTRINSIC_GE:
1209 : 72 : rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1210 : : break;
1211 : 60 : case INTRINSIC_LT:
1212 : 60 : rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1213 : : break;
1214 : 486 : case INTRINSIC_LE:
1215 : 486 : rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1216 : : break;
1217 : 0 : default:
1218 : 0 : gfc_internal_error ("compare_real(): Bad operator");
1219 : : }
1220 : :
1221 : 3163 : return rc;
1222 : : }
1223 : :
1224 : : /* Comparison operators. Assumes that the two expression nodes
1225 : : contain two constants of the same type. The op argument is
1226 : : needed to handle NaN correctly. */
1227 : :
1228 : : int
1229 : 42423 : gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1230 : : {
1231 : 42423 : int rc;
1232 : :
1233 : 42423 : switch (op1->ts.type)
1234 : : {
1235 : 32421 : case BT_INTEGER:
1236 : 32421 : case BT_UNSIGNED:
1237 : 32421 : rc = mpz_cmp (op1->value.integer, op2->value.integer);
1238 : 32421 : break;
1239 : :
1240 : 3163 : case BT_REAL:
1241 : 3163 : rc = compare_real (op1, op2, op);
1242 : 3163 : break;
1243 : :
1244 : 6791 : case BT_CHARACTER:
1245 : 6791 : rc = gfc_compare_string (op1, op2);
1246 : 6791 : break;
1247 : :
1248 : 38 : case BT_LOGICAL:
1249 : 0 : rc = ((!op1->value.logical && op2->value.logical)
1250 : 38 : || (op1->value.logical && !op2->value.logical));
1251 : 38 : break;
1252 : :
1253 : 10 : case BT_COMPLEX:
1254 : 10 : gcc_assert (op == INTRINSIC_EQ);
1255 : 10 : rc = mpc_cmp (op1->value.complex, op2->value.complex);
1256 : 10 : break;
1257 : :
1258 : 0 : default:
1259 : 0 : gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1260 : : }
1261 : :
1262 : 42423 : return rc;
1263 : : }
1264 : :
1265 : :
1266 : : /* Compare a pair of complex numbers. Naturally, this is only for
1267 : : equality and inequality. */
1268 : :
1269 : : static int
1270 : 196 : compare_complex (gfc_expr *op1, gfc_expr *op2)
1271 : : {
1272 : 196 : return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1273 : : }
1274 : :
1275 : :
1276 : : /* Given two constant strings and the inverse collating sequence, compare the
1277 : : strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1278 : : We use the processor's default collating sequence. */
1279 : :
1280 : : int
1281 : 7414 : gfc_compare_string (gfc_expr *a, gfc_expr *b)
1282 : : {
1283 : 7414 : size_t len, alen, blen, i;
1284 : 7414 : gfc_char_t ac, bc;
1285 : :
1286 : 7414 : alen = a->value.character.length;
1287 : 7414 : blen = b->value.character.length;
1288 : :
1289 : 7414 : len = MAX(alen, blen);
1290 : :
1291 : 18338 : for (i = 0; i < len; i++)
1292 : : {
1293 : 13587 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1294 : 13587 : bc = ((i < blen) ? b->value.character.string[i] : ' ');
1295 : :
1296 : 13587 : if (ac < bc)
1297 : : return -1;
1298 : 12617 : if (ac > bc)
1299 : : return 1;
1300 : : }
1301 : :
1302 : : /* Strings are equal */
1303 : : return 0;
1304 : : }
1305 : :
1306 : :
1307 : : int
1308 : 381 : gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1309 : : {
1310 : 381 : size_t len, alen, blen, i;
1311 : 381 : gfc_char_t ac, bc;
1312 : :
1313 : 381 : alen = a->value.character.length;
1314 : 381 : blen = strlen (b);
1315 : :
1316 : 381 : len = MAX(alen, blen);
1317 : :
1318 : 1383 : for (i = 0; i < len; i++)
1319 : : {
1320 : 1255 : ac = ((i < alen) ? a->value.character.string[i] : ' ');
1321 : 1255 : bc = ((i < blen) ? b[i] : ' ');
1322 : :
1323 : 1255 : if (!case_sensitive)
1324 : : {
1325 : 1255 : ac = TOLOWER (ac);
1326 : 1255 : bc = TOLOWER (bc);
1327 : : }
1328 : :
1329 : 1255 : if (ac < bc)
1330 : : return -1;
1331 : 1176 : if (ac > bc)
1332 : : return 1;
1333 : : }
1334 : :
1335 : : /* Strings are equal */
1336 : : return 0;
1337 : : }
1338 : :
1339 : :
1340 : : /* Specific comparison subroutines. */
1341 : :
1342 : : static arith
1343 : 3272 : gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1344 : : {
1345 : 3272 : gfc_expr *result;
1346 : :
1347 : 3272 : if (op1->ts.type != op2->ts.type)
1348 : : return ARITH_INVALID_TYPE;
1349 : :
1350 : 3270 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1351 : : &op1->where);
1352 : 6540 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1353 : 3270 : ? compare_complex (op1, op2)
1354 : 3270 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1355 : :
1356 : 3270 : *resultp = result;
1357 : 3270 : return ARITH_OK;
1358 : : }
1359 : :
1360 : :
1361 : : static arith
1362 : 32333 : gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1363 : : {
1364 : 32333 : gfc_expr *result;
1365 : :
1366 : 32333 : if (op1->ts.type != op2->ts.type)
1367 : : return ARITH_INVALID_TYPE;
1368 : :
1369 : 32331 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1370 : : &op1->where);
1371 : 64662 : result->value.logical = (op1->ts.type == BT_COMPLEX)
1372 : 32527 : ? !compare_complex (op1, op2)
1373 : 32135 : : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1374 : :
1375 : 32331 : *resultp = result;
1376 : 32331 : return ARITH_OK;
1377 : : }
1378 : :
1379 : :
1380 : : static arith
1381 : 3049 : gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1382 : : {
1383 : 3049 : gfc_expr *result;
1384 : :
1385 : 3049 : if (op1->ts.type != op2->ts.type)
1386 : : return ARITH_INVALID_TYPE;
1387 : :
1388 : 3047 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1389 : : &op1->where);
1390 : 3047 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1391 : 3047 : *resultp = result;
1392 : :
1393 : 3047 : return ARITH_OK;
1394 : : }
1395 : :
1396 : :
1397 : : static arith
1398 : 262 : gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1399 : : {
1400 : 262 : gfc_expr *result;
1401 : :
1402 : 262 : if (op1->ts.type != op2->ts.type)
1403 : : return ARITH_INVALID_TYPE;
1404 : :
1405 : 260 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1406 : : &op1->where);
1407 : 260 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1408 : 260 : *resultp = result;
1409 : :
1410 : 260 : return ARITH_OK;
1411 : : }
1412 : :
1413 : :
1414 : : static arith
1415 : 453 : gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1416 : : {
1417 : 453 : gfc_expr *result;
1418 : :
1419 : 453 : if (op1->ts.type != op2->ts.type)
1420 : : return ARITH_INVALID_TYPE;
1421 : :
1422 : 451 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1423 : : &op1->where);
1424 : 451 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1425 : 451 : *resultp = result;
1426 : :
1427 : 451 : return ARITH_OK;
1428 : : }
1429 : :
1430 : :
1431 : : static arith
1432 : 666 : gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1433 : : {
1434 : 666 : gfc_expr *result;
1435 : :
1436 : 666 : if (op1->ts.type != op2->ts.type)
1437 : : return ARITH_INVALID_TYPE;
1438 : :
1439 : 664 : result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1440 : : &op1->where);
1441 : 664 : result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1442 : 664 : *resultp = result;
1443 : :
1444 : 664 : return ARITH_OK;
1445 : : }
1446 : :
1447 : :
1448 : : static arith
1449 : 130372 : reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1450 : : gfc_expr **result)
1451 : : {
1452 : 130372 : gfc_constructor_base head;
1453 : 130372 : gfc_constructor *c;
1454 : 130372 : gfc_expr *r;
1455 : 130372 : arith rc;
1456 : :
1457 : 130372 : if (op->expr_type == EXPR_CONSTANT)
1458 : 130213 : return eval (op, result);
1459 : :
1460 : 159 : if (op->expr_type != EXPR_ARRAY)
1461 : : return ARITH_NOT_REDUCED;
1462 : :
1463 : 148 : rc = ARITH_OK;
1464 : 148 : head = gfc_constructor_copy (op->value.constructor);
1465 : 440 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1466 : : {
1467 : 309 : arith rc_tmp = reduce_unary (eval, c->expr, &r);
1468 : :
1469 : : /* Remember first recoverable ("soft") error encountered during
1470 : : reduction and continue, but terminate on serious errors. */
1471 : 309 : if (is_hard_arith_error (rc_tmp))
1472 : : {
1473 : : rc = rc_tmp;
1474 : : break;
1475 : : }
1476 : 292 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1477 : 4 : rc = rc_tmp;
1478 : :
1479 : 292 : gfc_replace_expr (c->expr, r);
1480 : : }
1481 : :
1482 : 148 : if (is_hard_arith_error (rc))
1483 : 17 : gfc_constructor_free (head);
1484 : : else
1485 : : {
1486 : 131 : gfc_constructor *c = gfc_constructor_first (head);
1487 : 131 : if (c == NULL)
1488 : : {
1489 : : /* Handle zero-sized arrays. */
1490 : 30 : r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
1491 : : }
1492 : : else
1493 : : {
1494 : 101 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1495 : : &op->where);
1496 : : }
1497 : 131 : r->shape = gfc_copy_shape (op->shape, op->rank);
1498 : 131 : r->rank = op->rank;
1499 : 131 : r->corank = op->corank;
1500 : 131 : r->value.constructor = head;
1501 : 131 : *result = r;
1502 : : }
1503 : :
1504 : : return rc;
1505 : : }
1506 : :
1507 : :
1508 : : static arith
1509 : 1414 : reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1510 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1511 : : {
1512 : 1414 : gfc_constructor_base head;
1513 : 1414 : gfc_constructor *c;
1514 : 1414 : gfc_expr *r;
1515 : 1414 : arith rc = ARITH_OK;
1516 : :
1517 : 1414 : head = gfc_constructor_copy (op1->value.constructor);
1518 : 9650 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1519 : : {
1520 : 8292 : arith rc_tmp;
1521 : :
1522 : 8292 : gfc_simplify_expr (c->expr, 0);
1523 : :
1524 : 8292 : if (c->expr->expr_type == EXPR_CONSTANT)
1525 : 8255 : rc_tmp = eval (c->expr, op2, &r);
1526 : 37 : else if (c->expr->expr_type != EXPR_ARRAY)
1527 : : rc_tmp = ARITH_NOT_REDUCED;
1528 : : else
1529 : 27 : rc_tmp = reduce_binary_ac (eval, c->expr, op2, &r);
1530 : :
1531 : : /* Remember first recoverable ("soft") error encountered during
1532 : : reduction and continue, but terminate on serious errors. */
1533 : 8282 : if (is_hard_arith_error (rc_tmp))
1534 : : {
1535 : : rc = rc_tmp;
1536 : : break;
1537 : : }
1538 : 8236 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1539 : 5 : rc = rc_tmp;
1540 : :
1541 : 8236 : gfc_replace_expr (c->expr, r);
1542 : : }
1543 : :
1544 : 1414 : if (is_hard_arith_error (rc))
1545 : 56 : gfc_constructor_free (head);
1546 : : else
1547 : : {
1548 : 1358 : gfc_constructor *c = gfc_constructor_first (head);
1549 : 1358 : if (c)
1550 : : {
1551 : 1358 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1552 : : &op1->where);
1553 : 1358 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1554 : : }
1555 : : else
1556 : : {
1557 : 0 : gcc_assert (op1->ts.type != BT_UNKNOWN);
1558 : 0 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
1559 : : &op1->where);
1560 : 0 : r->shape = gfc_get_shape (op1->rank);
1561 : : }
1562 : 1358 : r->rank = op1->rank;
1563 : 1358 : r->corank = op1->corank;
1564 : 1358 : r->value.constructor = head;
1565 : 1358 : *result = r;
1566 : : }
1567 : :
1568 : 1414 : return rc;
1569 : : }
1570 : :
1571 : :
1572 : : static arith
1573 : 645 : reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1574 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1575 : : {
1576 : 645 : gfc_constructor_base head;
1577 : 645 : gfc_constructor *c;
1578 : 645 : gfc_expr *r;
1579 : 645 : arith rc = ARITH_OK;
1580 : :
1581 : 645 : head = gfc_constructor_copy (op2->value.constructor);
1582 : 3367 : for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1583 : : {
1584 : 2754 : arith rc_tmp;
1585 : :
1586 : 2754 : gfc_simplify_expr (c->expr, 0);
1587 : :
1588 : 2754 : if (c->expr->expr_type == EXPR_CONSTANT)
1589 : 2624 : rc_tmp = eval (op1, c->expr, &r);
1590 : 130 : else if (c->expr->expr_type != EXPR_ARRAY)
1591 : : rc_tmp = ARITH_NOT_REDUCED;
1592 : : else
1593 : 120 : rc_tmp = reduce_binary_ca (eval, op1, c->expr, &r);
1594 : :
1595 : : /* Remember first recoverable ("soft") error encountered during
1596 : : reduction and continue, but terminate on serious errors. */
1597 : 2744 : if (is_hard_arith_error (rc_tmp))
1598 : : {
1599 : : rc = rc_tmp;
1600 : : break;
1601 : : }
1602 : 2722 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1603 : 3 : rc = rc_tmp;
1604 : :
1605 : 2722 : gfc_replace_expr (c->expr, r);
1606 : : }
1607 : :
1608 : 645 : if (is_hard_arith_error (rc))
1609 : 32 : gfc_constructor_free (head);
1610 : : else
1611 : : {
1612 : 613 : gfc_constructor *c = gfc_constructor_first (head);
1613 : 613 : if (c)
1614 : : {
1615 : 523 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1616 : : &op2->where);
1617 : 523 : r->shape = gfc_copy_shape (op2->shape, op2->rank);
1618 : : }
1619 : : else
1620 : : {
1621 : 90 : gcc_assert (op2->ts.type != BT_UNKNOWN);
1622 : 90 : r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
1623 : : &op2->where);
1624 : 90 : r->shape = gfc_get_shape (op2->rank);
1625 : : }
1626 : 613 : r->rank = op2->rank;
1627 : 613 : r->corank = op2->corank;
1628 : 613 : r->value.constructor = head;
1629 : 613 : *result = r;
1630 : : }
1631 : :
1632 : 645 : return rc;
1633 : : }
1634 : :
1635 : :
1636 : : /* We need a forward declaration of reduce_binary. */
1637 : : static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1638 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1639 : :
1640 : :
1641 : : static arith
1642 : 1510 : reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1643 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1644 : : {
1645 : 1510 : gfc_constructor_base head;
1646 : 1510 : gfc_constructor *c, *d;
1647 : 1510 : gfc_expr *r;
1648 : 1510 : arith rc = ARITH_OK;
1649 : :
1650 : 1510 : if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1651 : : return ARITH_INCOMMENSURATE;
1652 : :
1653 : 1510 : head = gfc_constructor_copy (op1->value.constructor);
1654 : 3020 : for (c = gfc_constructor_first (head),
1655 : 1510 : d = gfc_constructor_first (op2->value.constructor);
1656 : 5743 : c && d;
1657 : 4233 : c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1658 : : {
1659 : 4242 : arith rc_tmp = reduce_binary (eval, c->expr, d->expr, &r);
1660 : :
1661 : : /* Remember first recoverable ("soft") error encountered during
1662 : : reduction and continue, but terminate on serious errors. */
1663 : 4242 : if (is_hard_arith_error (rc_tmp))
1664 : : {
1665 : : rc = rc_tmp;
1666 : : break;
1667 : : }
1668 : 4233 : else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1669 : 8 : rc = rc_tmp;
1670 : :
1671 : 4233 : gfc_replace_expr (c->expr, r);
1672 : : }
1673 : :
1674 : 1510 : if (rc == ARITH_OK && (c || d))
1675 : : rc = ARITH_INCOMMENSURATE;
1676 : :
1677 : 1510 : if (is_hard_arith_error (rc))
1678 : 9 : gfc_constructor_free (head);
1679 : : else
1680 : : {
1681 : 1501 : gfc_constructor *c = gfc_constructor_first (head);
1682 : 1501 : if (c == NULL)
1683 : : {
1684 : : /* Handle zero-sized arrays. */
1685 : 132 : r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
1686 : : }
1687 : : else
1688 : : {
1689 : 1369 : r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1690 : : &op1->where);
1691 : : }
1692 : 1501 : r->shape = gfc_copy_shape (op1->shape, op1->rank);
1693 : 1501 : r->rank = op1->rank;
1694 : 1501 : r->corank = op1->corank;
1695 : 1501 : r->value.constructor = head;
1696 : 1501 : *result = r;
1697 : : }
1698 : :
1699 : : return rc;
1700 : : }
1701 : :
1702 : :
1703 : : static arith
1704 : 11237746 : reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1705 : : gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1706 : : {
1707 : 11237746 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1708 : 11234316 : return eval (op1, op2, result);
1709 : :
1710 : 3430 : if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1711 : 525 : return reduce_binary_ca (eval, op1, op2, result);
1712 : :
1713 : 2905 : if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1714 : 1387 : return reduce_binary_ac (eval, op1, op2, result);
1715 : :
1716 : 1518 : if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1717 : : return ARITH_NOT_REDUCED;
1718 : :
1719 : 1510 : return reduce_binary_aa (eval, op1, op2, result);
1720 : : }
1721 : :
1722 : :
1723 : : typedef union
1724 : : {
1725 : : arith (*f2)(gfc_expr *, gfc_expr **);
1726 : : arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1727 : : }
1728 : : eval_f;
1729 : :
1730 : : /* High level arithmetic subroutines. These subroutines go into
1731 : : eval_intrinsic(), which can do one of several things to its
1732 : : operands. If the operands are incompatible with the intrinsic
1733 : : operation, we return a node pointing to the operands and hope that
1734 : : an operator interface is found during resolution.
1735 : :
1736 : : If the operands are compatible and are constants, then we try doing
1737 : : the arithmetic. We also handle the cases where either or both
1738 : : operands are array constructors. */
1739 : :
1740 : : static gfc_expr *
1741 : 12484398 : eval_intrinsic (gfc_intrinsic_op op,
1742 : : eval_f eval, gfc_expr *op1, gfc_expr *op2)
1743 : : {
1744 : 12484398 : gfc_expr temp, *result;
1745 : 12484398 : int unary;
1746 : 12484398 : arith rc;
1747 : :
1748 : 12484398 : if (!op1)
1749 : : return NULL;
1750 : :
1751 : 12484394 : gfc_clear_ts (&temp.ts);
1752 : :
1753 : 12484394 : switch (op)
1754 : : {
1755 : : /* Logical unary */
1756 : 73613 : case INTRINSIC_NOT:
1757 : 73613 : if (op1->ts.type != BT_LOGICAL)
1758 : 65980 : goto runtime;
1759 : :
1760 : 7633 : temp.ts.type = BT_LOGICAL;
1761 : 7633 : temp.ts.kind = gfc_default_logical_kind;
1762 : 7633 : unary = 1;
1763 : 7633 : break;
1764 : :
1765 : : /* Logical binary operators */
1766 : 124792 : case INTRINSIC_OR:
1767 : 124792 : case INTRINSIC_AND:
1768 : 124792 : case INTRINSIC_NEQV:
1769 : 124792 : case INTRINSIC_EQV:
1770 : 124792 : if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1771 : 58850 : goto runtime;
1772 : :
1773 : 65942 : temp.ts.type = BT_LOGICAL;
1774 : 65942 : temp.ts.kind = gfc_default_logical_kind;
1775 : 65942 : unary = 0;
1776 : 65942 : break;
1777 : :
1778 : : /* Numeric unary */
1779 : 149964 : case INTRINSIC_UPLUS:
1780 : 149964 : case INTRINSIC_UMINUS:
1781 : 149964 : if (!gfc_numeric_ts (&op1->ts))
1782 : 6397 : goto runtime;
1783 : :
1784 : 143567 : temp.ts = op1->ts;
1785 : 143567 : unary = 1;
1786 : 143567 : break;
1787 : :
1788 : 0 : case INTRINSIC_PARENTHESES:
1789 : 0 : temp.ts = op1->ts;
1790 : 0 : unary = 1;
1791 : 0 : break;
1792 : :
1793 : : /* Additional restrictions for ordering relations. */
1794 : 65636 : case INTRINSIC_GE:
1795 : 65636 : case INTRINSIC_GE_OS:
1796 : 65636 : case INTRINSIC_LT:
1797 : 65636 : case INTRINSIC_LT_OS:
1798 : 65636 : case INTRINSIC_LE:
1799 : 65636 : case INTRINSIC_LE_OS:
1800 : 65636 : case INTRINSIC_GT:
1801 : 65636 : case INTRINSIC_GT_OS:
1802 : 65636 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1803 : : {
1804 : 36 : temp.ts.type = BT_LOGICAL;
1805 : 36 : temp.ts.kind = gfc_default_logical_kind;
1806 : 36 : goto runtime;
1807 : : }
1808 : :
1809 : : /* Fall through */
1810 : 749840 : case INTRINSIC_EQ:
1811 : 749840 : case INTRINSIC_EQ_OS:
1812 : 749840 : case INTRINSIC_NE:
1813 : 749840 : case INTRINSIC_NE_OS:
1814 : 749840 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1815 : : {
1816 : 98954 : unary = 0;
1817 : 98954 : temp.ts.type = BT_LOGICAL;
1818 : 98954 : temp.ts.kind = gfc_default_logical_kind;
1819 : :
1820 : : /* If kind mismatch, exit and we'll error out later. */
1821 : 98954 : if (op1->ts.kind != op2->ts.kind)
1822 : 40 : goto runtime;
1823 : :
1824 : : break;
1825 : : }
1826 : :
1827 : 663345 : gcc_fallthrough ();
1828 : : /* Numeric binary */
1829 : 663345 : case INTRINSIC_POWER:
1830 : 663345 : if (flag_unsigned && op == INTRINSIC_POWER)
1831 : : {
1832 : 74 : if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED)
1833 : 2 : goto runtime;
1834 : : }
1835 : :
1836 : 12029280 : gcc_fallthrough ();
1837 : :
1838 : 12029280 : case INTRINSIC_PLUS:
1839 : 12029280 : case INTRINSIC_MINUS:
1840 : 12029280 : case INTRINSIC_TIMES:
1841 : 12029280 : case INTRINSIC_DIVIDE:
1842 : 12029280 : if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1843 : 460432 : goto runtime;
1844 : :
1845 : 11568848 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
1846 : 3 : goto runtime;
1847 : :
1848 : : /* Do not perform conversions if operands are not conformable as
1849 : : required for the binary intrinsic operators (F2018:10.1.5).
1850 : : Defer to a possibly overloading user-defined operator. */
1851 : 11568845 : if (!gfc_op_rank_conformable (op1, op2))
1852 : 220 : goto runtime;
1853 : :
1854 : : /* Insert any necessary type conversions to make the operands
1855 : : compatible. */
1856 : :
1857 : 11568625 : temp.expr_type = EXPR_OP;
1858 : 11568625 : gfc_clear_ts (&temp.ts);
1859 : 11568625 : temp.value.op.op = op;
1860 : :
1861 : 11568625 : temp.value.op.op1 = op1;
1862 : 11568625 : temp.value.op.op2 = op2;
1863 : :
1864 : 11570427 : gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1865 : :
1866 : 11568625 : if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1867 : 11568625 : || op == INTRINSIC_GE || op == INTRINSIC_GT
1868 : 11432575 : || op == INTRINSIC_LE || op == INTRINSIC_LT
1869 : 11421940 : || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1870 : 11410398 : || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1871 : 11323543 : || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1872 : : {
1873 : 254841 : temp.ts.type = BT_LOGICAL;
1874 : 254841 : temp.ts.kind = gfc_default_logical_kind;
1875 : : }
1876 : :
1877 : : unary = 0;
1878 : : break;
1879 : :
1880 : : /* Character binary */
1881 : 7753 : case INTRINSIC_CONCAT:
1882 : 7753 : if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1883 : 6234 : || op1->ts.kind != op2->ts.kind)
1884 : 1528 : goto runtime;
1885 : :
1886 : 6225 : temp.ts.type = BT_CHARACTER;
1887 : 6225 : temp.ts.kind = op1->ts.kind;
1888 : 6225 : unary = 0;
1889 : 6225 : break;
1890 : :
1891 : 0 : case INTRINSIC_USER:
1892 : 0 : goto runtime;
1893 : :
1894 : 0 : default:
1895 : 0 : gfc_internal_error ("eval_intrinsic(): Bad operator");
1896 : : }
1897 : :
1898 : 11890906 : if (op1->expr_type != EXPR_CONSTANT
1899 : 11890906 : && (op1->expr_type != EXPR_ARRAY
1900 : 2902 : || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1901 : 499685 : goto runtime;
1902 : :
1903 : 11391221 : if (op2 != NULL
1904 : 11261158 : && op2->expr_type != EXPR_CONSTANT
1905 : 11420776 : && (op2->expr_type != EXPR_ARRAY
1906 : 1901 : || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1907 : 27654 : goto runtime;
1908 : :
1909 : 11363567 : if (unary)
1910 : 130063 : rc = reduce_unary (eval.f2, op1, &result);
1911 : : else
1912 : 11233504 : rc = reduce_binary (eval.f3, op1, op2, &result);
1913 : :
1914 : 11363567 : if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1915 : 72 : goto runtime;
1916 : :
1917 : : /* Something went wrong. */
1918 : 11363495 : if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1919 : : return NULL;
1920 : :
1921 : 11363494 : if (rc != ARITH_OK)
1922 : : {
1923 : 164 : gfc_error (gfc_arith_error (rc), &op1->where);
1924 : 164 : if (rc == ARITH_OVERFLOW)
1925 : 113 : goto done;
1926 : :
1927 : 51 : if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1928 : 22 : gfc_seen_div0 = true;
1929 : :
1930 : 51 : return NULL;
1931 : : }
1932 : :
1933 : 11363330 : done:
1934 : :
1935 : 11363443 : gfc_free_expr (op1);
1936 : 11363443 : gfc_free_expr (op2);
1937 : 11363443 : return result;
1938 : :
1939 : 1120899 : runtime:
1940 : : /* Create a run-time expression. */
1941 : 1120899 : result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1942 : 1120899 : result->ts = temp.ts;
1943 : :
1944 : 1120899 : return result;
1945 : : }
1946 : :
1947 : :
1948 : : /* Modify type of expression for zero size array. */
1949 : :
1950 : : static gfc_expr *
1951 : 65 : eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1952 : : {
1953 : 65 : if (op == NULL)
1954 : 0 : gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1955 : :
1956 : 65 : switch (iop)
1957 : : {
1958 : 64 : case INTRINSIC_GE:
1959 : 64 : case INTRINSIC_GE_OS:
1960 : 64 : case INTRINSIC_LT:
1961 : 64 : case INTRINSIC_LT_OS:
1962 : 64 : case INTRINSIC_LE:
1963 : 64 : case INTRINSIC_LE_OS:
1964 : 64 : case INTRINSIC_GT:
1965 : 64 : case INTRINSIC_GT_OS:
1966 : 64 : case INTRINSIC_EQ:
1967 : 64 : case INTRINSIC_EQ_OS:
1968 : 64 : case INTRINSIC_NE:
1969 : 64 : case INTRINSIC_NE_OS:
1970 : 64 : op->ts.type = BT_LOGICAL;
1971 : 64 : op->ts.kind = gfc_default_logical_kind;
1972 : 64 : break;
1973 : :
1974 : : default:
1975 : : break;
1976 : : }
1977 : :
1978 : 65 : return op;
1979 : : }
1980 : :
1981 : :
1982 : : /* Return nonzero if the expression is a zero size array. */
1983 : :
1984 : : static bool
1985 : 24745285 : gfc_zero_size_array (gfc_expr *e)
1986 : : {
1987 : 24745281 : if (e == NULL || e->expr_type != EXPR_ARRAY)
1988 : : return false;
1989 : :
1990 : 0 : return e->value.constructor == NULL;
1991 : : }
1992 : :
1993 : :
1994 : : /* Reduce a binary expression where at least one of the operands
1995 : : involves a zero-length array. Returns NULL if neither of the
1996 : : operands is a zero-length array. */
1997 : :
1998 : : static gfc_expr *
1999 : 12260886 : reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
2000 : : {
2001 : 12265639 : if (gfc_zero_size_array (op1))
2002 : : {
2003 : 64 : gfc_free_expr (op2);
2004 : 64 : return op1;
2005 : : }
2006 : :
2007 : 12331603 : if (gfc_zero_size_array (op2))
2008 : : {
2009 : 1 : gfc_free_expr (op1);
2010 : 1 : return op2;
2011 : : }
2012 : :
2013 : : return NULL;
2014 : : }
2015 : :
2016 : :
2017 : : static gfc_expr *
2018 : 223577 : eval_intrinsic_f2 (gfc_intrinsic_op op,
2019 : : arith (*eval) (gfc_expr *, gfc_expr **),
2020 : : gfc_expr *op1, gfc_expr *op2)
2021 : : {
2022 : 223577 : gfc_expr *result;
2023 : 223577 : eval_f f;
2024 : :
2025 : 223577 : if (op2 == NULL)
2026 : : {
2027 : 223701 : if (gfc_zero_size_array (op1))
2028 : 0 : return eval_type_intrinsic0 (op, op1);
2029 : : }
2030 : : else
2031 : : {
2032 : 0 : result = reduce_binary0 (op1, op2);
2033 : 0 : if (result != NULL)
2034 : 0 : return eval_type_intrinsic0 (op, result);
2035 : : }
2036 : :
2037 : 223577 : f.f2 = eval;
2038 : 223577 : return eval_intrinsic (op, f, op1, op2);
2039 : : }
2040 : :
2041 : :
2042 : : static gfc_expr *
2043 : 12260891 : eval_intrinsic_f3 (gfc_intrinsic_op op,
2044 : : arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
2045 : : gfc_expr *op1, gfc_expr *op2)
2046 : : {
2047 : 12260891 : gfc_expr *result;
2048 : 12260891 : eval_f f;
2049 : :
2050 : 12260891 : if (!op1 && !op2)
2051 : : return NULL;
2052 : :
2053 : 12260886 : result = reduce_binary0 (op1, op2);
2054 : 12260886 : if (result != NULL)
2055 : 65 : return eval_type_intrinsic0(op, result);
2056 : :
2057 : 12260821 : f.f3 = eval;
2058 : 12260821 : return eval_intrinsic (op, f, op1, op2);
2059 : : }
2060 : :
2061 : :
2062 : : gfc_expr *
2063 : 5256662 : gfc_parentheses (gfc_expr *op)
2064 : : {
2065 : 5256662 : if (gfc_is_constant_expr (op))
2066 : : return op;
2067 : :
2068 : 0 : return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
2069 : 0 : op, NULL);
2070 : : }
2071 : :
2072 : : gfc_expr *
2073 : 398 : gfc_uplus (gfc_expr *op)
2074 : : {
2075 : 398 : return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
2076 : : }
2077 : :
2078 : :
2079 : : gfc_expr *
2080 : 149566 : gfc_uminus (gfc_expr *op)
2081 : : {
2082 : 149566 : return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
2083 : : }
2084 : :
2085 : :
2086 : : gfc_expr *
2087 : 10409294 : gfc_add (gfc_expr *op1, gfc_expr *op2)
2088 : : {
2089 : 10409294 : return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
2090 : : }
2091 : :
2092 : :
2093 : : gfc_expr *
2094 : 574595 : gfc_subtract (gfc_expr *op1, gfc_expr *op2)
2095 : : {
2096 : 574595 : return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
2097 : : }
2098 : :
2099 : :
2100 : : gfc_expr *
2101 : 363611 : gfc_multiply (gfc_expr *op1, gfc_expr *op2)
2102 : : {
2103 : 363611 : return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
2104 : : }
2105 : :
2106 : :
2107 : : gfc_expr *
2108 : 18447 : gfc_divide (gfc_expr *op1, gfc_expr *op2)
2109 : : {
2110 : 18447 : return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
2111 : : }
2112 : :
2113 : :
2114 : : gfc_expr *
2115 : 12459 : gfc_power (gfc_expr *op1, gfc_expr *op2)
2116 : : {
2117 : 12459 : return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
2118 : : }
2119 : :
2120 : :
2121 : : gfc_expr *
2122 : 7753 : gfc_concat (gfc_expr *op1, gfc_expr *op2)
2123 : : {
2124 : 7753 : return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
2125 : : }
2126 : :
2127 : :
2128 : : gfc_expr *
2129 : 18131 : gfc_and (gfc_expr *op1, gfc_expr *op2)
2130 : : {
2131 : 18131 : return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
2132 : : }
2133 : :
2134 : :
2135 : : gfc_expr *
2136 : 82111 : gfc_or (gfc_expr *op1, gfc_expr *op2)
2137 : : {
2138 : 82111 : return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
2139 : : }
2140 : :
2141 : :
2142 : : gfc_expr *
2143 : 73613 : gfc_not (gfc_expr *op1)
2144 : : {
2145 : 73613 : return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
2146 : : }
2147 : :
2148 : :
2149 : : gfc_expr *
2150 : 1990 : gfc_eqv (gfc_expr *op1, gfc_expr *op2)
2151 : : {
2152 : 1990 : return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
2153 : : }
2154 : :
2155 : :
2156 : : gfc_expr *
2157 : 22560 : gfc_neqv (gfc_expr *op1, gfc_expr *op2)
2158 : : {
2159 : 22560 : return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
2160 : : }
2161 : :
2162 : :
2163 : : gfc_expr *
2164 : 33781 : gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2165 : : {
2166 : 33781 : return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
2167 : : }
2168 : :
2169 : :
2170 : : gfc_expr *
2171 : 650471 : gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2172 : : {
2173 : 650471 : return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
2174 : : }
2175 : :
2176 : :
2177 : : gfc_expr *
2178 : 41387 : gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2179 : : {
2180 : 41387 : return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
2181 : : }
2182 : :
2183 : :
2184 : : gfc_expr *
2185 : 4962 : gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2186 : : {
2187 : 4962 : return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2188 : : }
2189 : :
2190 : :
2191 : : gfc_expr *
2192 : 11386 : gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2193 : : {
2194 : 11386 : return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2195 : : }
2196 : :
2197 : :
2198 : : gfc_expr *
2199 : 7953 : gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2200 : : {
2201 : 7953 : return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
2202 : : }
2203 : :
2204 : :
2205 : : /******* Simplification of intrinsic functions with constant arguments *****/
2206 : :
2207 : :
2208 : : /* Deal with an arithmetic error. */
2209 : :
2210 : : static void
2211 : 6 : arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2212 : : {
2213 : 6 : switch (rc)
2214 : : {
2215 : 0 : case ARITH_OK:
2216 : 0 : gfc_error ("Arithmetic OK converting %s to %s at %L",
2217 : : gfc_typename (from), gfc_typename (to), where);
2218 : 0 : break;
2219 : 6 : case ARITH_OVERFLOW:
2220 : 6 : gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2221 : : "can be disabled with the option %<-fno-range-check%>",
2222 : : gfc_typename (from), gfc_typename (to), where);
2223 : 6 : break;
2224 : 0 : case ARITH_UNDERFLOW:
2225 : 0 : gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
2226 : : "can be disabled with the option %<-fno-range-check%>",
2227 : : gfc_typename (from), gfc_typename (to), where);
2228 : 0 : break;
2229 : 0 : case ARITH_NAN:
2230 : 0 : gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
2231 : : "can be disabled with the option %<-fno-range-check%>",
2232 : : gfc_typename (from), gfc_typename (to), where);
2233 : 0 : break;
2234 : 0 : case ARITH_DIV0:
2235 : 0 : gfc_error ("Division by zero converting %s to %s at %L",
2236 : : gfc_typename (from), gfc_typename (to), where);
2237 : 0 : break;
2238 : 0 : case ARITH_INCOMMENSURATE:
2239 : 0 : gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2240 : : gfc_typename (from), gfc_typename (to), where);
2241 : 0 : break;
2242 : 0 : case ARITH_ASYMMETRIC:
2243 : 0 : gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2244 : : " converting %s to %s at %L",
2245 : : gfc_typename (from), gfc_typename (to), where);
2246 : 0 : break;
2247 : 0 : default:
2248 : 0 : gfc_internal_error ("gfc_arith_error(): Bad error code");
2249 : : }
2250 : :
2251 : : /* TODO: Do something about the error, i.e., throw exception, return
2252 : : NaN, etc. */
2253 : 6 : }
2254 : :
2255 : : /* Returns true if significant bits were lost when converting real
2256 : : constant r from from_kind to to_kind. */
2257 : :
2258 : : static bool
2259 : 19 : wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2260 : : {
2261 : 19 : mpfr_t rv, diff;
2262 : 19 : bool ret;
2263 : :
2264 : 19 : gfc_set_model_kind (to_kind);
2265 : 19 : mpfr_init (rv);
2266 : 19 : gfc_set_model_kind (from_kind);
2267 : 19 : mpfr_init (diff);
2268 : :
2269 : 19 : mpfr_set (rv, r, GFC_RND_MODE);
2270 : 19 : mpfr_sub (diff, rv, r, GFC_RND_MODE);
2271 : :
2272 : 19 : ret = ! mpfr_zero_p (diff);
2273 : 19 : mpfr_clear (rv);
2274 : 19 : mpfr_clear (diff);
2275 : 19 : return ret;
2276 : : }
2277 : :
2278 : : /* Return true if conversion from an integer to a real loses precision. */
2279 : :
2280 : : static bool
2281 : 82 : wprecision_int_real (mpz_t n, mpfr_t r)
2282 : : {
2283 : 82 : bool ret;
2284 : 82 : mpz_t i;
2285 : 82 : mpz_init (i);
2286 : 82 : mpfr_get_z (i, r, GFC_RND_MODE);
2287 : 82 : mpz_sub (i, i, n);
2288 : 82 : ret = mpz_cmp_si (i, 0) != 0;
2289 : 82 : mpz_clear (i);
2290 : 82 : return ret;
2291 : : }
2292 : :
2293 : : /* Convert integers to integers; we can reuse this for also converting
2294 : : unsigneds. */
2295 : :
2296 : : gfc_expr *
2297 : 65944 : gfc_int2int (gfc_expr *src, int kind)
2298 : : {
2299 : 65944 : gfc_expr *result;
2300 : 65944 : arith rc;
2301 : :
2302 : 65944 : if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
2303 : : return NULL;
2304 : :
2305 : 65944 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2306 : :
2307 : 65944 : mpz_set (result->value.integer, src->value.integer);
2308 : :
2309 : 65944 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2310 : : {
2311 : 5 : if (rc == ARITH_ASYMMETRIC)
2312 : : {
2313 : 0 : gfc_warning (0, gfc_arith_error (rc), &src->where);
2314 : : }
2315 : : else
2316 : : {
2317 : 5 : arith_error (rc, &src->ts, &result->ts, &src->where);
2318 : 5 : gfc_free_expr (result);
2319 : 5 : return NULL;
2320 : : }
2321 : : }
2322 : :
2323 : : /* If we do not trap numeric overflow, we need to convert the number to
2324 : : signed, throwing away high-order bits if necessary. */
2325 : 65939 : if (flag_range_check == 0)
2326 : : {
2327 : 142 : int k;
2328 : :
2329 : 142 : k = gfc_validate_kind (BT_INTEGER, kind, false);
2330 : 142 : gfc_convert_mpz_to_signed (result->value.integer,
2331 : : gfc_integer_kinds[k].bit_size);
2332 : :
2333 : 142 : if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2334 : 1 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2335 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2336 : : &src->where);
2337 : : }
2338 : : return result;
2339 : : }
2340 : :
2341 : :
2342 : : /* Convert integers to reals. */
2343 : :
2344 : : gfc_expr *
2345 : 114877 : gfc_int2real (gfc_expr *src, int kind)
2346 : : {
2347 : 114877 : gfc_expr *result;
2348 : 114877 : arith rc;
2349 : :
2350 : 114877 : if (src->ts.type != BT_INTEGER)
2351 : : return NULL;
2352 : :
2353 : 114876 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2354 : :
2355 : 114876 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2356 : :
2357 : 114876 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2358 : : {
2359 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2360 : 0 : gfc_free_expr (result);
2361 : 0 : return NULL;
2362 : : }
2363 : :
2364 : 114876 : if (warn_conversion
2365 : 114876 : && wprecision_int_real (src->value.integer, result->value.real))
2366 : 4 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2367 : : "from %qs to %qs at %L",
2368 : : gfc_typename (&src->ts),
2369 : : gfc_typename (&result->ts),
2370 : : &src->where);
2371 : :
2372 : : return result;
2373 : : }
2374 : :
2375 : :
2376 : : /* Convert default integer to default complex. */
2377 : :
2378 : : gfc_expr *
2379 : 832 : gfc_int2complex (gfc_expr *src, int kind)
2380 : : {
2381 : 832 : gfc_expr *result;
2382 : 832 : arith rc;
2383 : :
2384 : 832 : if (src->ts.type != BT_INTEGER)
2385 : : return NULL;
2386 : :
2387 : 829 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2388 : :
2389 : 829 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2390 : :
2391 : 829 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2392 : : != ARITH_OK)
2393 : : {
2394 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2395 : 0 : gfc_free_expr (result);
2396 : 0 : return NULL;
2397 : : }
2398 : :
2399 : 829 : if (warn_conversion
2400 : 829 : && wprecision_int_real (src->value.integer,
2401 : : mpc_realref (result->value.complex)))
2402 : 1 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2403 : : "from %qs to %qs at %L",
2404 : : gfc_typename (&src->ts),
2405 : : gfc_typename (&result->ts),
2406 : : &src->where);
2407 : :
2408 : : return result;
2409 : : }
2410 : :
2411 : : /* Convert unsigned to unsigned, or integer to unsigned. */
2412 : :
2413 : : gfc_expr *
2414 : 438 : gfc_uint2uint (gfc_expr *src, int kind)
2415 : : {
2416 : 438 : gfc_expr *result;
2417 : 438 : arith rc;
2418 : :
2419 : 438 : if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
2420 : : return NULL;
2421 : :
2422 : 438 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2423 : 438 : mpz_set (result->value.integer, src->value.integer);
2424 : :
2425 : 438 : rc = gfc_range_check (result);
2426 : 438 : if (rc != ARITH_OK)
2427 : 12 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2428 : :
2429 : 438 : gfc_reduce_unsigned (result);
2430 : 438 : return result;
2431 : : }
2432 : :
2433 : : gfc_expr *
2434 : 150 : gfc_int2uint (gfc_expr *src, int kind)
2435 : : {
2436 : 150 : return gfc_uint2uint (src, kind);
2437 : : }
2438 : :
2439 : : gfc_expr *
2440 : 325 : gfc_uint2int (gfc_expr *src, int kind)
2441 : : {
2442 : 325 : return gfc_int2int (src, kind);
2443 : : }
2444 : :
2445 : : /* Convert UNSIGNED to reals. */
2446 : :
2447 : : gfc_expr *
2448 : 48 : gfc_uint2real (gfc_expr *src, int kind)
2449 : : {
2450 : 48 : gfc_expr *result;
2451 : 48 : arith rc;
2452 : :
2453 : 48 : if (src->ts.type != BT_UNSIGNED)
2454 : : return NULL;
2455 : :
2456 : 48 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2457 : :
2458 : 48 : mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2459 : :
2460 : 48 : if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2461 : : {
2462 : : /* This should be rare, just in case. */
2463 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2464 : 0 : gfc_free_expr (result);
2465 : 0 : return NULL;
2466 : : }
2467 : :
2468 : 48 : if (warn_conversion
2469 : 48 : && wprecision_int_real (src->value.integer, result->value.real))
2470 : 0 : gfc_warning (OPT_Wconversion, "Change of value in conversion "
2471 : : "from %qs to %qs at %L",
2472 : : gfc_typename (&src->ts),
2473 : : gfc_typename (&result->ts),
2474 : : &src->where);
2475 : :
2476 : : return result;
2477 : : }
2478 : :
2479 : : /* Convert default integer to default complex. */
2480 : :
2481 : : gfc_expr *
2482 : 0 : gfc_uint2complex (gfc_expr *src, int kind)
2483 : : {
2484 : 0 : gfc_expr *result;
2485 : 0 : arith rc;
2486 : :
2487 : 0 : if (src->ts.type != BT_UNSIGNED)
2488 : : return NULL;
2489 : :
2490 : 0 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2491 : :
2492 : 0 : mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2493 : :
2494 : 0 : if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2495 : : != ARITH_OK)
2496 : : {
2497 : : /* This should be rare, just in case. */
2498 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2499 : 0 : gfc_free_expr (result);
2500 : 0 : return NULL;
2501 : : }
2502 : :
2503 : 0 : if (warn_conversion
2504 : 0 : && wprecision_int_real (src->value.integer,
2505 : : mpc_realref (result->value.complex)))
2506 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2507 : : "from %qs to %qs at %L",
2508 : : gfc_typename (&src->ts),
2509 : : gfc_typename (&result->ts),
2510 : : &src->where);
2511 : :
2512 : : return result;
2513 : : }
2514 : :
2515 : : /* Convert default real to default integer. */
2516 : :
2517 : : gfc_expr *
2518 : 278 : gfc_real2int (gfc_expr *src, int kind)
2519 : : {
2520 : 278 : gfc_expr *result;
2521 : 278 : arith rc;
2522 : 278 : bool did_warn = false;
2523 : :
2524 : 278 : if (src->ts.type != BT_REAL)
2525 : : return NULL;
2526 : :
2527 : 278 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2528 : :
2529 : 278 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2530 : :
2531 : 278 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2532 : : {
2533 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2534 : 0 : gfc_free_expr (result);
2535 : 0 : return NULL;
2536 : : }
2537 : :
2538 : : /* If there was a fractional part, warn about this. */
2539 : :
2540 : 278 : if (warn_conversion)
2541 : : {
2542 : 4 : mpfr_t f;
2543 : 4 : mpfr_init (f);
2544 : 4 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2545 : 4 : if (mpfr_cmp_si (f, 0) != 0)
2546 : : {
2547 : 2 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2548 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2549 : : gfc_typename (&result->ts), &src->where);
2550 : 2 : did_warn = true;
2551 : : }
2552 : 4 : mpfr_clear (f);
2553 : : }
2554 : 278 : if (!did_warn && warn_conversion_extra)
2555 : : {
2556 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2557 : : "at %L", gfc_typename (&src->ts),
2558 : : gfc_typename (&result->ts), &src->where);
2559 : : }
2560 : :
2561 : : return result;
2562 : : }
2563 : :
2564 : : /* Convert real to unsigned. */
2565 : :
2566 : : gfc_expr *
2567 : 6 : gfc_real2uint (gfc_expr *src, int kind)
2568 : : {
2569 : 6 : gfc_expr *result;
2570 : 6 : arith rc;
2571 : 6 : bool did_warn = false;
2572 : :
2573 : 6 : if (src->ts.type != BT_REAL)
2574 : : return NULL;
2575 : :
2576 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2577 : :
2578 : 6 : gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2579 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2580 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2581 : :
2582 : 6 : gfc_reduce_unsigned (result);
2583 : :
2584 : : /* If there was a fractional part, warn about this. */
2585 : :
2586 : 6 : if (warn_conversion)
2587 : : {
2588 : 0 : mpfr_t f;
2589 : 0 : mpfr_init (f);
2590 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2591 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2592 : : {
2593 : 0 : gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2594 : : "from %qs to %qs at %L", gfc_typename (&src->ts),
2595 : : gfc_typename (&result->ts), &src->where);
2596 : 0 : did_warn = true;
2597 : : }
2598 : 0 : mpfr_clear (f);
2599 : : }
2600 : 6 : if (!did_warn && warn_conversion_extra)
2601 : : {
2602 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2603 : : "at %L", gfc_typename (&src->ts),
2604 : : gfc_typename (&result->ts), &src->where);
2605 : : }
2606 : :
2607 : : return result;
2608 : : }
2609 : :
2610 : : /* Convert real to real. */
2611 : :
2612 : : gfc_expr *
2613 : 7376 : gfc_real2real (gfc_expr *src, int kind)
2614 : : {
2615 : 7376 : gfc_expr *result;
2616 : 7376 : arith rc;
2617 : 7376 : bool did_warn = false;
2618 : :
2619 : 7376 : if (src->ts.type != BT_REAL)
2620 : : return NULL;
2621 : :
2622 : 7372 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2623 : :
2624 : 7372 : mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2625 : :
2626 : 7372 : rc = gfc_check_real_range (result->value.real, kind);
2627 : :
2628 : 7372 : if (rc == ARITH_UNDERFLOW)
2629 : : {
2630 : 0 : if (warn_underflow)
2631 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2632 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2633 : : }
2634 : 7372 : else if (rc != ARITH_OK)
2635 : : {
2636 : 1 : arith_error (rc, &src->ts, &result->ts, &src->where);
2637 : 1 : gfc_free_expr (result);
2638 : 1 : return NULL;
2639 : : }
2640 : :
2641 : : /* As a special bonus, don't warn about REAL values which are not changed by
2642 : : the conversion if -Wconversion is specified and -Wconversion-extra is
2643 : : not. */
2644 : :
2645 : 7371 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2646 : : {
2647 : 11 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2648 : :
2649 : : /* Calculate the difference between the constant and the rounded
2650 : : value and check it against zero. */
2651 : :
2652 : 11 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2653 : : {
2654 : 2 : gfc_warning_now (w, "Change of value in conversion from "
2655 : : "%qs to %qs at %L",
2656 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2657 : : &src->where);
2658 : : /* Make sure the conversion warning is not emitted again. */
2659 : 2 : did_warn = true;
2660 : : }
2661 : : }
2662 : :
2663 : 7371 : if (!did_warn && warn_conversion_extra)
2664 : 8 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2665 : : "at %L", gfc_typename(&src->ts),
2666 : : gfc_typename(&result->ts), &src->where);
2667 : :
2668 : : return result;
2669 : : }
2670 : :
2671 : :
2672 : : /* Convert real to complex. */
2673 : :
2674 : : gfc_expr *
2675 : 1372 : gfc_real2complex (gfc_expr *src, int kind)
2676 : : {
2677 : 1372 : gfc_expr *result;
2678 : 1372 : arith rc;
2679 : 1372 : bool did_warn = false;
2680 : :
2681 : 1372 : if (src->ts.type != BT_REAL)
2682 : : return NULL;
2683 : :
2684 : 1367 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2685 : :
2686 : 1367 : mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2687 : :
2688 : 1367 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2689 : :
2690 : 1367 : if (rc == ARITH_UNDERFLOW)
2691 : : {
2692 : 0 : if (warn_underflow)
2693 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2694 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2695 : : }
2696 : 1367 : else if (rc != ARITH_OK)
2697 : : {
2698 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2699 : 0 : gfc_free_expr (result);
2700 : 0 : return NULL;
2701 : : }
2702 : :
2703 : 1367 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2704 : : {
2705 : 2 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2706 : :
2707 : 2 : if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2708 : : {
2709 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2710 : : "%qs to %qs at %L",
2711 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2712 : : &src->where);
2713 : : /* Make sure the conversion warning is not emitted again. */
2714 : 1 : did_warn = true;
2715 : : }
2716 : : }
2717 : :
2718 : 1367 : if (!did_warn && warn_conversion_extra)
2719 : 2 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2720 : : "at %L", gfc_typename(&src->ts),
2721 : : gfc_typename(&result->ts), &src->where);
2722 : :
2723 : : return result;
2724 : : }
2725 : :
2726 : :
2727 : : /* Convert complex to integer. */
2728 : :
2729 : : gfc_expr *
2730 : 80 : gfc_complex2int (gfc_expr *src, int kind)
2731 : : {
2732 : 80 : gfc_expr *result;
2733 : 80 : arith rc;
2734 : 80 : bool did_warn = false;
2735 : :
2736 : 80 : if (src->ts.type != BT_COMPLEX)
2737 : : return NULL;
2738 : :
2739 : 80 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2740 : :
2741 : 80 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2742 : : &src->where);
2743 : :
2744 : 80 : if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2745 : : {
2746 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2747 : 0 : gfc_free_expr (result);
2748 : 0 : return NULL;
2749 : : }
2750 : :
2751 : 80 : if (warn_conversion || warn_conversion_extra)
2752 : : {
2753 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2754 : :
2755 : : /* See if we discarded an imaginary part. */
2756 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2757 : : {
2758 : 2 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2759 : : "in conversion from %qs to %qs at %L",
2760 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2761 : : &src->where);
2762 : 2 : did_warn = true;
2763 : : }
2764 : :
2765 : : else {
2766 : 2 : mpfr_t f;
2767 : :
2768 : 2 : mpfr_init (f);
2769 : 2 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2770 : 2 : if (mpfr_cmp_si (f, 0) != 0)
2771 : : {
2772 : 1 : gfc_warning_now (w, "Change of value in conversion from "
2773 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2774 : : gfc_typename (&result->ts), &src->where);
2775 : 1 : did_warn = true;
2776 : : }
2777 : 2 : mpfr_clear (f);
2778 : : }
2779 : :
2780 : 4 : if (!did_warn && warn_conversion_extra)
2781 : : {
2782 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2783 : : "at %L", gfc_typename (&src->ts),
2784 : : gfc_typename (&result->ts), &src->where);
2785 : : }
2786 : : }
2787 : :
2788 : : return result;
2789 : : }
2790 : :
2791 : : /* Convert complex to integer. */
2792 : :
2793 : : gfc_expr *
2794 : 6 : gfc_complex2uint (gfc_expr *src, int kind)
2795 : : {
2796 : 6 : gfc_expr *result;
2797 : 6 : arith rc;
2798 : 6 : bool did_warn = false;
2799 : :
2800 : 6 : if (src->ts.type != BT_COMPLEX)
2801 : : return NULL;
2802 : :
2803 : 6 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2804 : :
2805 : 6 : gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2806 : : &src->where);
2807 : :
2808 : 6 : if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2809 : 0 : gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2810 : :
2811 : 6 : gfc_reduce_unsigned (result);
2812 : :
2813 : 6 : if (warn_conversion || warn_conversion_extra)
2814 : : {
2815 : 0 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2816 : :
2817 : : /* See if we discarded an imaginary part. */
2818 : 0 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2819 : : {
2820 : 0 : gfc_warning_now (w, "Non-zero imaginary part discarded "
2821 : : "in conversion from %qs to %qs at %L",
2822 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2823 : : &src->where);
2824 : 0 : did_warn = true;
2825 : : }
2826 : :
2827 : : else
2828 : : {
2829 : 0 : mpfr_t f;
2830 : :
2831 : 0 : mpfr_init (f);
2832 : 0 : mpfr_frac (f, src->value.real, GFC_RND_MODE);
2833 : 0 : if (mpfr_cmp_si (f, 0) != 0)
2834 : : {
2835 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2836 : : "%qs to %qs at %L", gfc_typename (&src->ts),
2837 : : gfc_typename (&result->ts), &src->where);
2838 : 0 : did_warn = true;
2839 : : }
2840 : 0 : mpfr_clear (f);
2841 : : }
2842 : :
2843 : 0 : if (!did_warn && warn_conversion_extra)
2844 : : {
2845 : 0 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2846 : : "at %L", gfc_typename (&src->ts),
2847 : : gfc_typename (&result->ts), &src->where);
2848 : : }
2849 : : }
2850 : :
2851 : : return result;
2852 : : }
2853 : :
2854 : :
2855 : : /* Convert complex to real. */
2856 : :
2857 : : gfc_expr *
2858 : 209 : gfc_complex2real (gfc_expr *src, int kind)
2859 : : {
2860 : 209 : gfc_expr *result;
2861 : 209 : arith rc;
2862 : 209 : bool did_warn = false;
2863 : :
2864 : 209 : if (src->ts.type != BT_COMPLEX)
2865 : : return NULL;
2866 : :
2867 : 209 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2868 : :
2869 : 209 : mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2870 : :
2871 : 209 : rc = gfc_check_real_range (result->value.real, kind);
2872 : :
2873 : 209 : if (rc == ARITH_UNDERFLOW)
2874 : : {
2875 : 0 : if (warn_underflow)
2876 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2877 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2878 : : }
2879 : 209 : if (rc != ARITH_OK)
2880 : : {
2881 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2882 : 0 : gfc_free_expr (result);
2883 : 0 : return NULL;
2884 : : }
2885 : :
2886 : 209 : if (warn_conversion || warn_conversion_extra)
2887 : : {
2888 : 4 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2889 : :
2890 : : /* See if we discarded an imaginary part. */
2891 : 4 : if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2892 : : {
2893 : 4 : gfc_warning (w, "Non-zero imaginary part discarded "
2894 : : "in conversion from %qs to %qs at %L",
2895 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2896 : : &src->where);
2897 : 4 : did_warn = true;
2898 : : }
2899 : :
2900 : : /* Calculate the difference between the real constant and the rounded
2901 : : value and check it against zero. */
2902 : :
2903 : 4 : if (kind > src->ts.kind
2904 : 4 : && wprecision_real_real (mpc_realref (src->value.complex),
2905 : : src->ts.kind, kind))
2906 : : {
2907 : 0 : gfc_warning_now (w, "Change of value in conversion from "
2908 : : "%qs to %qs at %L",
2909 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2910 : : &src->where);
2911 : : /* Make sure the conversion warning is not emitted again. */
2912 : 0 : did_warn = true;
2913 : : }
2914 : : }
2915 : :
2916 : 209 : if (!did_warn && warn_conversion_extra)
2917 : 0 : gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2918 : : gfc_typename(&src->ts), gfc_typename (&result->ts),
2919 : : &src->where);
2920 : :
2921 : : return result;
2922 : : }
2923 : :
2924 : :
2925 : : /* Convert complex to complex. */
2926 : :
2927 : : gfc_expr *
2928 : 679 : gfc_complex2complex (gfc_expr *src, int kind)
2929 : : {
2930 : 679 : gfc_expr *result;
2931 : 679 : arith rc;
2932 : 679 : bool did_warn = false;
2933 : :
2934 : 679 : if (src->ts.type != BT_COMPLEX)
2935 : : return NULL;
2936 : :
2937 : 675 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2938 : :
2939 : 675 : mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2940 : :
2941 : 675 : rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2942 : :
2943 : 675 : if (rc == ARITH_UNDERFLOW)
2944 : : {
2945 : 0 : if (warn_underflow)
2946 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2947 : 0 : mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2948 : : }
2949 : 675 : else if (rc != ARITH_OK)
2950 : : {
2951 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2952 : 0 : gfc_free_expr (result);
2953 : 0 : return NULL;
2954 : : }
2955 : :
2956 : 675 : rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2957 : :
2958 : 675 : if (rc == ARITH_UNDERFLOW)
2959 : : {
2960 : 0 : if (warn_underflow)
2961 : 0 : gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2962 : 0 : mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2963 : : }
2964 : 675 : else if (rc != ARITH_OK)
2965 : : {
2966 : 0 : arith_error (rc, &src->ts, &result->ts, &src->where);
2967 : 0 : gfc_free_expr (result);
2968 : 0 : return NULL;
2969 : : }
2970 : :
2971 : 675 : if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2972 : 678 : && (wprecision_real_real (mpc_realref (src->value.complex),
2973 : : src->ts.kind, kind)
2974 : 3 : || wprecision_real_real (mpc_imagref (src->value.complex),
2975 : : src->ts.kind, kind)))
2976 : : {
2977 : 3 : int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2978 : :
2979 : 3 : gfc_warning_now (w, "Change of value in conversion from "
2980 : : "%qs to %qs at %L",
2981 : : gfc_typename (&src->ts), gfc_typename (&result->ts),
2982 : : &src->where);
2983 : 3 : did_warn = true;
2984 : : }
2985 : :
2986 : 675 : if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2987 : 1 : gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2988 : : "at %L", gfc_typename(&src->ts),
2989 : : gfc_typename (&result->ts), &src->where);
2990 : :
2991 : : return result;
2992 : : }
2993 : :
2994 : :
2995 : : /* Logical kind conversion. */
2996 : :
2997 : : gfc_expr *
2998 : 680 : gfc_log2log (gfc_expr *src, int kind)
2999 : : {
3000 : 680 : gfc_expr *result;
3001 : :
3002 : 680 : if (src->ts.type != BT_LOGICAL)
3003 : : return NULL;
3004 : :
3005 : 680 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3006 : 680 : result->value.logical = src->value.logical;
3007 : :
3008 : 680 : return result;
3009 : : }
3010 : :
3011 : :
3012 : : /* Convert logical to integer. */
3013 : :
3014 : : gfc_expr *
3015 : 14 : gfc_log2int (gfc_expr *src, int kind)
3016 : : {
3017 : 14 : gfc_expr *result;
3018 : :
3019 : 14 : if (src->ts.type != BT_LOGICAL)
3020 : : return NULL;
3021 : :
3022 : 14 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3023 : 14 : mpz_set_si (result->value.integer, src->value.logical);
3024 : :
3025 : 14 : return result;
3026 : : }
3027 : :
3028 : : /* Convert logical to unsigned. */
3029 : :
3030 : : gfc_expr *
3031 : 0 : gfc_log2uint (gfc_expr *src, int kind)
3032 : : {
3033 : 0 : gfc_expr *result;
3034 : :
3035 : 0 : if (src->ts.type != BT_LOGICAL)
3036 : : return NULL;
3037 : :
3038 : 0 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
3039 : 0 : mpz_set_si (result->value.integer, src->value.logical);
3040 : :
3041 : 0 : return result;
3042 : : }
3043 : :
3044 : :
3045 : : /* Convert integer to logical. */
3046 : :
3047 : : gfc_expr *
3048 : 0 : gfc_int2log (gfc_expr *src, int kind)
3049 : : {
3050 : 0 : gfc_expr *result;
3051 : :
3052 : 0 : if (src->ts.type != BT_INTEGER)
3053 : : return NULL;
3054 : :
3055 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3056 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3057 : :
3058 : 0 : return result;
3059 : : }
3060 : :
3061 : : /* Convert unsigned to logical. */
3062 : :
3063 : : gfc_expr *
3064 : 0 : gfc_uint2log (gfc_expr *src, int kind)
3065 : : {
3066 : 0 : gfc_expr *result;
3067 : :
3068 : 0 : if (src->ts.type != BT_UNSIGNED)
3069 : : return NULL;
3070 : :
3071 : 0 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3072 : 0 : result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3073 : :
3074 : 0 : return result;
3075 : : }
3076 : :
3077 : : /* Convert character to character. We only use wide strings internally,
3078 : : so we only set the kind. */
3079 : :
3080 : : gfc_expr *
3081 : 0 : gfc_character2character (gfc_expr *src, int kind)
3082 : : {
3083 : 0 : gfc_expr *result;
3084 : 0 : result = gfc_copy_expr (src);
3085 : 0 : result->ts.kind = kind;
3086 : :
3087 : 0 : return result;
3088 : : }
3089 : :
3090 : : /* Helper function to set the representation in a Hollerith conversion.
3091 : : This assumes that the ts.type and ts.kind of the result have already
3092 : : been set. */
3093 : :
3094 : : static void
3095 : 1187 : hollerith2representation (gfc_expr *result, gfc_expr *src)
3096 : : {
3097 : 1187 : size_t src_len, result_len;
3098 : :
3099 : 1187 : src_len = src->representation.length - src->ts.u.pad;
3100 : 1187 : gfc_target_expr_size (result, &result_len);
3101 : :
3102 : 1187 : if (src_len > result_len)
3103 : : {
3104 : 248 : gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
3105 : : "is truncated in conversion to %qs", &src->where,
3106 : : gfc_typename(&result->ts));
3107 : : }
3108 : :
3109 : 1187 : result->representation.string = XCNEWVEC (char, result_len + 1);
3110 : 1187 : memcpy (result->representation.string, src->representation.string,
3111 : 1187 : MIN (result_len, src_len));
3112 : :
3113 : 1187 : if (src_len < result_len)
3114 : 294 : memset (&result->representation.string[src_len], ' ', result_len - src_len);
3115 : :
3116 : 1187 : result->representation.string[result_len] = '\0'; /* For debugger */
3117 : 1187 : result->representation.length = result_len;
3118 : 1187 : }
3119 : :
3120 : :
3121 : : /* Helper function to set the representation in a character conversion.
3122 : : This assumes that the ts.type and ts.kind of the result have already
3123 : : been set. */
3124 : :
3125 : : static void
3126 : 747 : character2representation (gfc_expr *result, gfc_expr *src)
3127 : : {
3128 : 747 : size_t src_len, result_len, i;
3129 : 747 : src_len = src->value.character.length;
3130 : 747 : gfc_target_expr_size (result, &result_len);
3131 : :
3132 : 747 : if (src_len > result_len)
3133 : 240 : gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
3134 : : "truncated in conversion to %s", &src->where,
3135 : : gfc_typename(&result->ts));
3136 : :
3137 : 747 : result->representation.string = XCNEWVEC (char, result_len + 1);
3138 : :
3139 : 3991 : for (i = 0; i < MIN (result_len, src_len); i++)
3140 : 3244 : result->representation.string[i] = (char) src->value.character.string[i];
3141 : :
3142 : 747 : if (src_len < result_len)
3143 : 246 : memset (&result->representation.string[src_len], ' ',
3144 : : result_len - src_len);
3145 : :
3146 : 747 : result->representation.string[result_len] = '\0'; /* For debugger. */
3147 : 747 : result->representation.length = result_len;
3148 : 747 : }
3149 : :
3150 : : /* Convert Hollerith to integer. The constant will be padded or truncated. */
3151 : :
3152 : : gfc_expr *
3153 : 377 : gfc_hollerith2int (gfc_expr *src, int kind)
3154 : : {
3155 : 377 : gfc_expr *result;
3156 : 377 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3157 : :
3158 : 377 : hollerith2representation (result, src);
3159 : 377 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3160 : 377 : result->representation.length, result->value.integer);
3161 : :
3162 : 377 : return result;
3163 : : }
3164 : :
3165 : : /* Convert character to integer. The constant will be padded or truncated. */
3166 : :
3167 : : gfc_expr *
3168 : 187 : gfc_character2int (gfc_expr *src, int kind)
3169 : : {
3170 : 187 : gfc_expr *result;
3171 : 187 : result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3172 : :
3173 : 187 : character2representation (result, src);
3174 : 187 : gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3175 : 187 : result->representation.length, result->value.integer);
3176 : 187 : return result;
3177 : : }
3178 : :
3179 : : /* Convert Hollerith to real. The constant will be padded or truncated. */
3180 : :
3181 : : gfc_expr *
3182 : 327 : gfc_hollerith2real (gfc_expr *src, int kind)
3183 : : {
3184 : 327 : gfc_expr *result;
3185 : 327 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3186 : :
3187 : 327 : hollerith2representation (result, src);
3188 : 327 : if (gfc_interpret_float (kind,
3189 : 327 : (unsigned char *) result->representation.string,
3190 : 327 : result->representation.length, result->value.real))
3191 : : return result;
3192 : : else
3193 : 0 : return NULL;
3194 : : }
3195 : :
3196 : : /* Convert character to real. The constant will be padded or truncated. */
3197 : :
3198 : : gfc_expr *
3199 : 187 : gfc_character2real (gfc_expr *src, int kind)
3200 : : {
3201 : 187 : gfc_expr *result;
3202 : 187 : result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3203 : :
3204 : 187 : character2representation (result, src);
3205 : 187 : gfc_interpret_float (kind, (unsigned char *) result->representation.string,
3206 : 187 : result->representation.length, result->value.real);
3207 : :
3208 : 187 : return result;
3209 : : }
3210 : :
3211 : :
3212 : : /* Convert Hollerith to complex. The constant will be padded or truncated. */
3213 : :
3214 : : gfc_expr *
3215 : 288 : gfc_hollerith2complex (gfc_expr *src, int kind)
3216 : : {
3217 : 288 : gfc_expr *result;
3218 : 288 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3219 : :
3220 : 288 : hollerith2representation (result, src);
3221 : 288 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3222 : 288 : result->representation.length, result->value.complex);
3223 : :
3224 : 288 : return result;
3225 : : }
3226 : :
3227 : : /* Convert character to complex. The constant will be padded or truncated. */
3228 : :
3229 : : gfc_expr *
3230 : 187 : gfc_character2complex (gfc_expr *src, int kind)
3231 : : {
3232 : 187 : gfc_expr *result;
3233 : 187 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3234 : :
3235 : 187 : character2representation (result, src);
3236 : 187 : gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3237 : 187 : result->representation.length, result->value.complex);
3238 : :
3239 : 187 : return result;
3240 : : }
3241 : :
3242 : :
3243 : : /* Convert Hollerith to character. */
3244 : :
3245 : : gfc_expr *
3246 : 174 : gfc_hollerith2character (gfc_expr *src, int kind)
3247 : : {
3248 : 174 : gfc_expr *result;
3249 : :
3250 : 174 : result = gfc_copy_expr (src);
3251 : 174 : result->ts.type = BT_CHARACTER;
3252 : 174 : result->ts.kind = kind;
3253 : 174 : result->ts.u.pad = 0;
3254 : :
3255 : 174 : result->value.character.length = result->representation.length;
3256 : 174 : result->value.character.string
3257 : 174 : = gfc_char_to_widechar (result->representation.string);
3258 : :
3259 : 174 : return result;
3260 : : }
3261 : :
3262 : :
3263 : : /* Convert Hollerith to logical. The constant will be padded or truncated. */
3264 : :
3265 : : gfc_expr *
3266 : 195 : gfc_hollerith2logical (gfc_expr *src, int kind)
3267 : : {
3268 : 195 : gfc_expr *result;
3269 : 195 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3270 : :
3271 : 195 : hollerith2representation (result, src);
3272 : 195 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3273 : 195 : result->representation.length, &result->value.logical);
3274 : :
3275 : 195 : return result;
3276 : : }
3277 : :
3278 : : /* Convert character to logical. The constant will be padded or truncated. */
3279 : :
3280 : : gfc_expr *
3281 : 186 : gfc_character2logical (gfc_expr *src, int kind)
3282 : : {
3283 : 186 : gfc_expr *result;
3284 : 186 : result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3285 : :
3286 : 186 : character2representation (result, src);
3287 : 186 : gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3288 : 186 : result->representation.length, &result->value.logical);
3289 : :
3290 : 186 : return result;
3291 : : }
|
