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