?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
libcpp, c, middle-end: Optimize initializers using #embed in C
[official-gcc.git] / gcc / fortran / arith.cc
bloba214b8bc1b3720839e45b574f46337b6ba2f0615
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 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 default:
1147 gfc_internal_error ("arith_power(): unknown type");
1148 }
1149
1150 if (rc == ARITH_OK)
1151 rc = gfc_range_check (result);
1152
1153 return check_result (rc, op1, result, resultp);
1154 }
1155
1156
1157 /* Concatenate two string constants. */
1158
1159 static arith
1160 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1161 {
1162 gfc_expr *result;
1163 size_t len;
1164
1165 /* By cleverly playing around with constructors, it is possible
1166 to get mismatching types here. */
1167 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1168 || op1->ts.kind != op2->ts.kind)
1169 return ARITH_WRONGCONCAT;
1170
1171 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1172 &op1->where);
1173
1174 len = op1->value.character.length + op2->value.character.length;
1175
1176 result->value.character.string = gfc_get_wide_string (len + 1);
1177 result->value.character.length = len;
1178
1179 memcpy (result->value.character.string, op1->value.character.string,
1180 op1->value.character.length * sizeof (gfc_char_t));
1181
1182 memcpy (&result->value.character.string[op1->value.character.length],
1183 op2->value.character.string,
1184 op2->value.character.length * sizeof (gfc_char_t));
1185
1186 result->value.character.string[len] = '\0';
1187
1188 *resultp = result;
1189
1190 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 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1198 {
1199 int rc;
1200 switch (op)
1201 {
1202 case INTRINSIC_EQ:
1203 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1204 break;
1205 case INTRINSIC_GT:
1206 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1207 break;
1208 case INTRINSIC_GE:
1209 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1210 break;
1211 case INTRINSIC_LT:
1212 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1213 break;
1214 case INTRINSIC_LE:
1215 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1216 break;
1217 default:
1218 gfc_internal_error ("compare_real(): Bad operator");
1219 }
1220
1221 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 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1230 {
1231 int rc;
1232
1233 switch (op1->ts.type)
1234 {
1235 case BT_INTEGER:
1236 case BT_UNSIGNED:
1237 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1238 break;
1239
1240 case BT_REAL:
1241 rc = compare_real (op1, op2, op);
1242 break;
1243
1244 case BT_CHARACTER:
1245 rc = gfc_compare_string (op1, op2);
1246 break;
1247
1248 case BT_LOGICAL:
1249 rc = ((!op1->value.logical && op2->value.logical)
1250 || (op1->value.logical && !op2->value.logical));
1251 break;
1252
1253 case BT_COMPLEX:
1254 gcc_assert (op == INTRINSIC_EQ);
1255 rc = mpc_cmp (op1->value.complex, op2->value.complex);
1256 break;
1257
1258 default:
1259 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1260 }
1261
1262 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 compare_complex (gfc_expr *op1, gfc_expr *op2)
1271 {
1272 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 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1282 {
1283 size_t len, alen, blen, i;
1284 gfc_char_t ac, bc;
1285
1286 alen = a->value.character.length;
1287 blen = b->value.character.length;
1288
1289 len = MAX(alen, blen);
1290
1291 for (i = 0; i < len; i++)
1292 {
1293 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1294 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1295
1296 if (ac < bc)
1297 return -1;
1298 if (ac > bc)
1299 return 1;
1300 }
1301
1302 /* Strings are equal */
1303 return 0;
1304 }
1305
1306
1307 int
1308 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1309 {
1310 size_t len, alen, blen, i;
1311 gfc_char_t ac, bc;
1312
1313 alen = a->value.character.length;
1314 blen = strlen (b);
1315
1316 len = MAX(alen, blen);
1317
1318 for (i = 0; i < len; i++)
1319 {
1320 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1321 bc = ((i < blen) ? b[i] : ' ');
1322
1323 if (!case_sensitive)
1324 {
1325 ac = TOLOWER (ac);
1326 bc = TOLOWER (bc);
1327 }
1328
1329 if (ac < bc)
1330 return -1;
1331 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 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1344 {
1345 gfc_expr *result;
1346
1347 if (op1->ts.type != op2->ts.type)
1348 return ARITH_INVALID_TYPE;
1349
1350 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1351 &op1->where);
1352 result->value.logical = (op1->ts.type == BT_COMPLEX)
1353 ? compare_complex (op1, op2)
1354 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1355
1356 *resultp = result;
1357 return ARITH_OK;
1358 }
1359
1360
1361 static arith
1362 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1363 {
1364 gfc_expr *result;
1365
1366 if (op1->ts.type != op2->ts.type)
1367 return ARITH_INVALID_TYPE;
1368
1369 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1370 &op1->where);
1371 result->value.logical = (op1->ts.type == BT_COMPLEX)
1372 ? !compare_complex (op1, op2)
1373 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1374
1375 *resultp = result;
1376 return ARITH_OK;
1377 }
1378
1379
1380 static arith
1381 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1382 {
1383 gfc_expr *result;
1384
1385 if (op1->ts.type != op2->ts.type)
1386 return ARITH_INVALID_TYPE;
1387
1388 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1389 &op1->where);
1390 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1391 *resultp = result;
1392
1393 return ARITH_OK;
1394 }
1395
1396
1397 static arith
1398 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1399 {
1400 gfc_expr *result;
1401
1402 if (op1->ts.type != op2->ts.type)
1403 return ARITH_INVALID_TYPE;
1404
1405 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1406 &op1->where);
1407 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1408 *resultp = result;
1409
1410 return ARITH_OK;
1411 }
1412
1413
1414 static arith
1415 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1416 {
1417 gfc_expr *result;
1418
1419 if (op1->ts.type != op2->ts.type)
1420 return ARITH_INVALID_TYPE;
1421
1422 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1423 &op1->where);
1424 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1425 *resultp = result;
1426
1427 return ARITH_OK;
1428 }
1429
1430
1431 static arith
1432 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1433 {
1434 gfc_expr *result;
1435
1436 if (op1->ts.type != op2->ts.type)
1437 return ARITH_INVALID_TYPE;
1438
1439 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1440 &op1->where);
1441 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1442 *resultp = result;
1443
1444 return ARITH_OK;
1445 }
1446
1447
1448 static arith
1449 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1450 gfc_expr **result)
1451 {
1452 gfc_constructor_base head;
1453 gfc_constructor *c;
1454 gfc_expr *r;
1455 arith rc;
1456
1457 if (op->expr_type == EXPR_CONSTANT)
1458 return eval (op, result);
1459
1460 if (op->expr_type != EXPR_ARRAY)
1461 return ARITH_NOT_REDUCED;
1462
1463 rc = ARITH_OK;
1464 head = gfc_constructor_copy (op->value.constructor);
1465 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1466 {
1467 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 if (is_hard_arith_error (rc_tmp))
1472 {
1473 rc = rc_tmp;
1474 break;
1475 }
1476 else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1477 rc = rc_tmp;
1478
1479 gfc_replace_expr (c->expr, r);
1480 }
1481
1482 if (is_hard_arith_error (rc))
1483 gfc_constructor_free (head);
1484 else
1485 {
1486 gfc_constructor *c = gfc_constructor_first (head);
1487 if (c == NULL)
1488 {
1489 /* Handle zero-sized arrays. */
1490 r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
1491 }
1492 else
1493 {
1494 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1495 &op->where);
1496 }
1497 r->shape = gfc_copy_shape (op->shape, op->rank);
1498 r->rank = op->rank;
1499 r->corank = op->corank;
1500 r->value.constructor = head;
1501 *result = r;
1502 }
1503
1504 return rc;
1505 }
1506
1507
1508 static arith
1509 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1510 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1511 {
1512 gfc_constructor_base head;
1513 gfc_constructor *c;
1514 gfc_expr *r;
1515 arith rc = ARITH_OK;
1516
1517 head = gfc_constructor_copy (op1->value.constructor);
1518 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1519 {
1520 arith rc_tmp;
1521
1522 gfc_simplify_expr (c->expr, 0);
1523
1524 if (c->expr->expr_type == EXPR_CONSTANT)
1525 rc_tmp = eval (c->expr, op2, &r);
1526 else if (c->expr->expr_type != EXPR_ARRAY)
1527 rc_tmp = ARITH_NOT_REDUCED;
1528 else
1529 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 if (is_hard_arith_error (rc_tmp))
1534 {
1535 rc = rc_tmp;
1536 break;
1537 }
1538 else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1539 rc = rc_tmp;
1540
1541 gfc_replace_expr (c->expr, r);
1542 }
1543
1544 if (is_hard_arith_error (rc))
1545 gfc_constructor_free (head);
1546 else
1547 {
1548 gfc_constructor *c = gfc_constructor_first (head);
1549 if (c)
1550 {
1551 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1552 &op1->where);
1553 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1554 }
1555 else
1556 {
1557 gcc_assert (op1->ts.type != BT_UNKNOWN);
1558 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
1559 &op1->where);
1560 r->shape = gfc_get_shape (op1->rank);
1561 }
1562 r->rank = op1->rank;
1563 r->corank = op1->corank;
1564 r->value.constructor = head;
1565 *result = r;
1566 }
1567
1568 return rc;
1569 }
1570
1571
1572 static arith
1573 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1574 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1575 {
1576 gfc_constructor_base head;
1577 gfc_constructor *c;
1578 gfc_expr *r;
1579 arith rc = ARITH_OK;
1580
1581 head = gfc_constructor_copy (op2->value.constructor);
1582 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1583 {
1584 arith rc_tmp;
1585
1586 gfc_simplify_expr (c->expr, 0);
1587
1588 if (c->expr->expr_type == EXPR_CONSTANT)
1589 rc_tmp = eval (op1, c->expr, &r);
1590 else if (c->expr->expr_type != EXPR_ARRAY)
1591 rc_tmp = ARITH_NOT_REDUCED;
1592 else
1593 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 if (is_hard_arith_error (rc_tmp))
1598 {
1599 rc = rc_tmp;
1600 break;
1601 }
1602 else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1603 rc = rc_tmp;
1604
1605 gfc_replace_expr (c->expr, r);
1606 }
1607
1608 if (is_hard_arith_error (rc))
1609 gfc_constructor_free (head);
1610 else
1611 {
1612 gfc_constructor *c = gfc_constructor_first (head);
1613 if (c)
1614 {
1615 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1616 &op2->where);
1617 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1618 }
1619 else
1620 {
1621 gcc_assert (op2->ts.type != BT_UNKNOWN);
1622 r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
1623 &op2->where);
1624 r->shape = gfc_get_shape (op2->rank);
1625 }
1626 r->rank = op2->rank;
1627 r->corank = op2->corank;
1628 r->value.constructor = head;
1629 *result = r;
1630 }
1631
1632 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 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1643 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1644 {
1645 gfc_constructor_base head;
1646 gfc_constructor *c, *d;
1647 gfc_expr *r;
1648 arith rc = ARITH_OK;
1649
1650 if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1651 return ARITH_INCOMMENSURATE;
1652
1653 head = gfc_constructor_copy (op1->value.constructor);
1654 for (c = gfc_constructor_first (head),
1655 d = gfc_constructor_first (op2->value.constructor);
1656 c && d;
1657 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1658 {
1659 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 if (is_hard_arith_error (rc_tmp))
1664 {
1665 rc = rc_tmp;
1666 break;
1667 }
1668 else if (rc_tmp != ARITH_OK && rc == ARITH_OK)
1669 rc = rc_tmp;
1670
1671 gfc_replace_expr (c->expr, r);
1672 }
1673
1674 if (rc == ARITH_OK && (c || d))
1675 rc = ARITH_INCOMMENSURATE;
1676
1677 if (is_hard_arith_error (rc))
1678 gfc_constructor_free (head);
1679 else
1680 {
1681 gfc_constructor *c = gfc_constructor_first (head);
1682 if (c == NULL)
1683 {
1684 /* Handle zero-sized arrays. */
1685 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
1686 }
1687 else
1688 {
1689 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1690 &op1->where);
1691 }
1692 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1693 r->rank = op1->rank;
1694 r->corank = op1->corank;
1695 r->value.constructor = head;
1696 *result = r;
1697 }
1698
1699 return rc;
1700 }
1701
1702
1703 static arith
1704 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1705 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1706 {
1707 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1708 return eval (op1, op2, result);
1709
1710 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1711 return reduce_binary_ca (eval, op1, op2, result);
1712
1713 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1714 return reduce_binary_ac (eval, op1, op2, result);
1715
1716 if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1717 return ARITH_NOT_REDUCED;
1718
1719 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 eval_intrinsic (gfc_intrinsic_op op,
1742 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1743 {
1744 gfc_expr temp, *result;
1745 int unary;
1746 arith rc;
1747
1748 if (!op1)
1749 return NULL;
1750
1751 gfc_clear_ts (&temp.ts);
1752
1753 switch (op)
1754 {
1755 /* Logical unary */
1756 case INTRINSIC_NOT:
1757 if (op1->ts.type != BT_LOGICAL)
1758 goto runtime;
1759
1760 temp.ts.type = BT_LOGICAL;
1761 temp.ts.kind = gfc_default_logical_kind;
1762 unary = 1;
1763 break;
1764
1765 /* Logical binary operators */
1766 case INTRINSIC_OR:
1767 case INTRINSIC_AND:
1768 case INTRINSIC_NEQV:
1769 case INTRINSIC_EQV:
1770 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1771 goto runtime;
1772
1773 temp.ts.type = BT_LOGICAL;
1774 temp.ts.kind = gfc_default_logical_kind;
1775 unary = 0;
1776 break;
1777
1778 /* Numeric unary */
1779 case INTRINSIC_UPLUS:
1780 case INTRINSIC_UMINUS:
1781 if (!gfc_numeric_ts (&op1->ts))
1782 goto runtime;
1783
1784 temp.ts = op1->ts;
1785 unary = 1;
1786 break;
1787
1788 case INTRINSIC_PARENTHESES:
1789 temp.ts = op1->ts;
1790 unary = 1;
1791 break;
1792
1793 /* Additional restrictions for ordering relations. */
1794 case INTRINSIC_GE:
1795 case INTRINSIC_GE_OS:
1796 case INTRINSIC_LT:
1797 case INTRINSIC_LT_OS:
1798 case INTRINSIC_LE:
1799 case INTRINSIC_LE_OS:
1800 case INTRINSIC_GT:
1801 case INTRINSIC_GT_OS:
1802 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1803 {
1804 temp.ts.type = BT_LOGICAL;
1805 temp.ts.kind = gfc_default_logical_kind;
1806 goto runtime;
1807 }
1808
1809 /* Fall through */
1810 case INTRINSIC_EQ:
1811 case INTRINSIC_EQ_OS:
1812 case INTRINSIC_NE:
1813 case INTRINSIC_NE_OS:
1814 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1815 {
1816 unary = 0;
1817 temp.ts.type = BT_LOGICAL;
1818 temp.ts.kind = gfc_default_logical_kind;
1819
1820 /* If kind mismatch, exit and we'll error out later. */
1821 if (op1->ts.kind != op2->ts.kind)
1822 goto runtime;
1823
1824 break;
1825 }
1826
1827 gcc_fallthrough ();
1828 /* Numeric binary */
1829 case INTRINSIC_POWER:
1830 if (flag_unsigned && op == INTRINSIC_POWER)
1831 {
1832 if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED)
1833 goto runtime;
1834 }
1835
1836 gcc_fallthrough ();
1837
1838 case INTRINSIC_PLUS:
1839 case INTRINSIC_MINUS:
1840 case INTRINSIC_TIMES:
1841 case INTRINSIC_DIVIDE:
1842 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1843 goto runtime;
1844
1845 if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
1846 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 if (!gfc_op_rank_conformable (op1, op2))
1852 goto runtime;
1853
1854 /* Insert any necessary type conversions to make the operands
1855 compatible. */
1856
1857 temp.expr_type = EXPR_OP;
1858 gfc_clear_ts (&temp.ts);
1859 temp.value.op.op = op;
1860
1861 temp.value.op.op1 = op1;
1862 temp.value.op.op2 = op2;
1863
1864 gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1865
1866 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1867 || op == INTRINSIC_GE || op == INTRINSIC_GT
1868 || op == INTRINSIC_LE || op == INTRINSIC_LT
1869 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1870 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1871 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1872 {
1873 temp.ts.type = BT_LOGICAL;
1874 temp.ts.kind = gfc_default_logical_kind;
1875 }
1876
1877 unary = 0;
1878 break;
1879
1880 /* Character binary */
1881 case INTRINSIC_CONCAT:
1882 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1883 || op1->ts.kind != op2->ts.kind)
1884 goto runtime;
1885
1886 temp.ts.type = BT_CHARACTER;
1887 temp.ts.kind = op1->ts.kind;
1888 unary = 0;
1889 break;
1890
1891 case INTRINSIC_USER:
1892 goto runtime;
1893
1894 default:
1895 gfc_internal_error ("eval_intrinsic(): Bad operator");
1896 }
1897
1898 if (op1->expr_type != EXPR_CONSTANT
1899 && (op1->expr_type != EXPR_ARRAY
1900 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1901 goto runtime;
1902
1903 if (op2 != NULL
1904 && op2->expr_type != EXPR_CONSTANT
1905 && (op2->expr_type != EXPR_ARRAY
1906 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1907 goto runtime;
1908
1909 if (unary)
1910 rc = reduce_unary (eval.f2, op1, &result);
1911 else
1912 rc = reduce_binary (eval.f3, op1, op2, &result);
1913
1914 if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1915 goto runtime;
1916
1917 /* Something went wrong. */
1918 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1919 return NULL;
1920
1921 if (rc != ARITH_OK)
1922 {
1923 gfc_error (gfc_arith_error (rc), &op1->where);
1924 if (rc == ARITH_OVERFLOW)
1925 goto done;
1926
1927 if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1928 gfc_seen_div0 = true;
1929
1930 return NULL;
1931 }
1932
1933 done:
1934
1935 gfc_free_expr (op1);
1936 gfc_free_expr (op2);
1937 return result;
1938
1939 runtime:
1940 /* Create a run-time expression. */
1941 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1942 result->ts = temp.ts;
1943
1944 return result;
1945 }
1946
1947
1948 /* Modify type of expression for zero size array. */
1949
1950 static gfc_expr *
1951 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1952 {
1953 if (op == NULL)
1954 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1955
1956 switch (iop)
1957 {
1958 case INTRINSIC_GE:
1959 case INTRINSIC_GE_OS:
1960 case INTRINSIC_LT:
1961 case INTRINSIC_LT_OS:
1962 case INTRINSIC_LE:
1963 case INTRINSIC_LE_OS:
1964 case INTRINSIC_GT:
1965 case INTRINSIC_GT_OS:
1966 case INTRINSIC_EQ:
1967 case INTRINSIC_EQ_OS:
1968 case INTRINSIC_NE:
1969 case INTRINSIC_NE_OS:
1970 op->ts.type = BT_LOGICAL;
1971 op->ts.kind = gfc_default_logical_kind;
1972 break;
1973
1974 default:
1975 break;
1976 }
1977
1978 return op;
1979 }
1980
1981
1982 /* Return nonzero if the expression is a zero size array. */
1983
1984 static bool
1985 gfc_zero_size_array (gfc_expr *e)
1986 {
1987 if (e == NULL || e->expr_type != EXPR_ARRAY)
1988 return false;
1989
1990 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 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
2000 {
2001 if (gfc_zero_size_array (op1))
2002 {
2003 gfc_free_expr (op2);
2004 return op1;
2005 }
2006
2007 if (gfc_zero_size_array (op2))
2008 {
2009 gfc_free_expr (op1);
2010 return op2;
2011 }
2012
2013 return NULL;
2014 }
2015
2016
2017 static gfc_expr *
2018 eval_intrinsic_f2 (gfc_intrinsic_op op,
2019 arith (*eval) (gfc_expr *, gfc_expr **),
2020 gfc_expr *op1, gfc_expr *op2)
2021 {
2022 gfc_expr *result;
2023 eval_f f;
2024
2025 if (op2 == NULL)
2026 {
2027 if (gfc_zero_size_array (op1))
2028 return eval_type_intrinsic0 (op, op1);
2029 }
2030 else
2031 {
2032 result = reduce_binary0 (op1, op2);
2033 if (result != NULL)
2034 return eval_type_intrinsic0 (op, result);
2035 }
2036
2037 f.f2 = eval;
2038 return eval_intrinsic (op, f, op1, op2);
2039 }
2040
2041
2042 static gfc_expr *
2043 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 gfc_expr *result;
2048 eval_f f;
2049
2050 if (!op1 && !op2)
2051 return NULL;
2052
2053 result = reduce_binary0 (op1, op2);
2054 if (result != NULL)
2055 return eval_type_intrinsic0(op, result);
2056
2057 f.f3 = eval;
2058 return eval_intrinsic (op, f, op1, op2);
2059 }
2060
2061
2062 gfc_expr *
2063 gfc_parentheses (gfc_expr *op)
2064 {
2065 if (gfc_is_constant_expr (op))
2066 return op;
2067
2068 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
2069 op, NULL);
2070 }
2071
2072 gfc_expr *
2073 gfc_uplus (gfc_expr *op)
2074 {
2075 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
2076 }
2077
2078
2079 gfc_expr *
2080 gfc_uminus (gfc_expr *op)
2081 {
2082 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
2083 }
2084
2085
2086 gfc_expr *
2087 gfc_add (gfc_expr *op1, gfc_expr *op2)
2088 {
2089 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
2090 }
2091
2092
2093 gfc_expr *
2094 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
2095 {
2096 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
2097 }
2098
2099
2100 gfc_expr *
2101 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
2102 {
2103 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
2104 }
2105
2106
2107 gfc_expr *
2108 gfc_divide (gfc_expr *op1, gfc_expr *op2)
2109 {
2110 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
2111 }
2112
2113
2114 gfc_expr *
2115 gfc_power (gfc_expr *op1, gfc_expr *op2)
2116 {
2117 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
2118 }
2119
2120
2121 gfc_expr *
2122 gfc_concat (gfc_expr *op1, gfc_expr *op2)
2123 {
2124 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
2125 }
2126
2127
2128 gfc_expr *
2129 gfc_and (gfc_expr *op1, gfc_expr *op2)
2130 {
2131 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
2132 }
2133
2134
2135 gfc_expr *
2136 gfc_or (gfc_expr *op1, gfc_expr *op2)
2137 {
2138 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
2139 }
2140
2141
2142 gfc_expr *
2143 gfc_not (gfc_expr *op1)
2144 {
2145 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
2146 }
2147
2148
2149 gfc_expr *
2150 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
2151 {
2152 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
2153 }
2154
2155
2156 gfc_expr *
2157 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
2158 {
2159 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
2160 }
2161
2162
2163 gfc_expr *
2164 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2165 {
2166 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
2167 }
2168
2169
2170 gfc_expr *
2171 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2172 {
2173 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
2174 }
2175
2176
2177 gfc_expr *
2178 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2179 {
2180 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
2181 }
2182
2183
2184 gfc_expr *
2185 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2186 {
2187 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2188 }
2189
2190
2191 gfc_expr *
2192 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2193 {
2194 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2195 }
2196
2197
2198 gfc_expr *
2199 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2200 {
2201 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 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2212 {
2213 switch (rc)
2214 {
2215 case ARITH_OK:
2216 gfc_error ("Arithmetic OK converting %s to %s at %L",
2217 gfc_typename (from), gfc_typename (to), where);
2218 break;
2219 case ARITH_OVERFLOW:
2220 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 break;
2224 case ARITH_UNDERFLOW:
2225 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 break;
2229 case ARITH_NAN:
2230 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 break;
2234 case ARITH_DIV0:
2235 gfc_error ("Division by zero converting %s to %s at %L",
2236 gfc_typename (from), gfc_typename (to), where);
2237 break;
2238 case ARITH_INCOMMENSURATE:
2239 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2240 gfc_typename (from), gfc_typename (to), where);
2241 break;
2242 case ARITH_ASYMMETRIC:
2243 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 break;
2247 default:
2248 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 }
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 wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2260 {
2261 mpfr_t rv, diff;
2262 bool ret;
2263
2264 gfc_set_model_kind (to_kind);
2265 mpfr_init (rv);
2266 gfc_set_model_kind (from_kind);
2267 mpfr_init (diff);
2268
2269 mpfr_set (rv, r, GFC_RND_MODE);
2270 mpfr_sub (diff, rv, r, GFC_RND_MODE);
2271
2272 ret = ! mpfr_zero_p (diff);
2273 mpfr_clear (rv);
2274 mpfr_clear (diff);
2275 return ret;
2276 }
2277
2278 /* Return true if conversion from an integer to a real loses precision. */
2279
2280 static bool
2281 wprecision_int_real (mpz_t n, mpfr_t r)
2282 {
2283 bool ret;
2284 mpz_t i;
2285 mpz_init (i);
2286 mpfr_get_z (i, r, GFC_RND_MODE);
2287 mpz_sub (i, i, n);
2288 ret = mpz_cmp_si (i, 0) != 0;
2289 mpz_clear (i);
2290 return ret;
2291 }
2292
2293 /* Convert integers to integers; we can reuse this for also converting
2294 unsigneds. */
2295
2296 gfc_expr *
2297 gfc_int2int (gfc_expr *src, int kind)
2298 {
2299 gfc_expr *result;
2300 arith rc;
2301
2302 if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
2303 return NULL;
2304
2305 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2306
2307 mpz_set (result->value.integer, src->value.integer);
2308
2309 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2310 {
2311 if (rc == ARITH_ASYMMETRIC)
2312 {
2313 gfc_warning (0, gfc_arith_error (rc), &src->where);
2314 }
2315 else
2316 {
2317 arith_error (rc, &src->ts, &result->ts, &src->where);
2318 gfc_free_expr (result);
2319 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 if (flag_range_check == 0)
2326 {
2327 int k;
2328
2329 k = gfc_validate_kind (BT_INTEGER, kind, false);
2330 gfc_convert_mpz_to_signed (result->value.integer,
2331 gfc_integer_kinds[k].bit_size);
2332
2333 if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2334 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 gfc_int2real (gfc_expr *src, int kind)
2346 {
2347 gfc_expr *result;
2348 arith rc;
2349
2350 if (src->ts.type != BT_INTEGER)
2351 return NULL;
2352
2353 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2354
2355 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2356
2357 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2358 {
2359 arith_error (rc, &src->ts, &result->ts, &src->where);
2360 gfc_free_expr (result);
2361 return NULL;
2362 }
2363
2364 if (warn_conversion
2365 && wprecision_int_real (src->value.integer, result->value.real))
2366 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 gfc_int2complex (gfc_expr *src, int kind)
2380 {
2381 gfc_expr *result;
2382 arith rc;
2383
2384 if (src->ts.type != BT_INTEGER)
2385 return NULL;
2386
2387 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2388
2389 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2390
2391 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2392 != ARITH_OK)
2393 {
2394 arith_error (rc, &src->ts, &result->ts, &src->where);
2395 gfc_free_expr (result);
2396 return NULL;
2397 }
2398
2399 if (warn_conversion
2400 && wprecision_int_real (src->value.integer,
2401 mpc_realref (result->value.complex)))
2402 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 gfc_uint2uint (gfc_expr *src, int kind)
2415 {
2416 gfc_expr *result;
2417 arith rc;
2418
2419 if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
2420 return NULL;
2421
2422 result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2423 mpz_set (result->value.integer, src->value.integer);
2424
2425 rc = gfc_range_check (result);
2426 if (rc != ARITH_OK)
2427 gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2428
2429 gfc_reduce_unsigned (result);
2430 return result;
2431 }
2432
2433 gfc_expr *
2434 gfc_int2uint (gfc_expr *src, int kind)
2435 {
2436 return gfc_uint2uint (src, kind);
2437 }
2438
2439 gfc_expr *
2440 gfc_uint2int (gfc_expr *src, int kind)
2441 {
2442 return gfc_int2int (src, kind);
2443 }
2444
2445 /* Convert UNSIGNED to reals. */
2446
2447 gfc_expr *
2448 gfc_uint2real (gfc_expr *src, int kind)
2449 {
2450 gfc_expr *result;
2451 arith rc;
2452
2453 if (src->ts.type != BT_UNSIGNED)
2454 return NULL;
2455
2456 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2457
2458 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2459
2460 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2461 {
2462 /* This should be rare, just in case. */
2463 arith_error (rc, &src->ts, &result->ts, &src->where);
2464 gfc_free_expr (result);
2465 return NULL;
2466 }
2467
2468 if (warn_conversion
2469 && wprecision_int_real (src->value.integer, result->value.real))
2470 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 gfc_uint2complex (gfc_expr *src, int kind)
2483 {
2484 gfc_expr *result;
2485 arith rc;
2486
2487 if (src->ts.type != BT_UNSIGNED)
2488 return NULL;
2489
2490 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2491
2492 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2493
2494 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 arith_error (rc, &src->ts, &result->ts, &src->where);
2499 gfc_free_expr (result);
2500 return NULL;
2501 }
2502
2503 if (warn_conversion
2504 && wprecision_int_real (src->value.integer,
2505 mpc_realref (result->value.complex)))
2506 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 gfc_real2int (gfc_expr *src, int kind)
2519 {
2520 gfc_expr *result;
2521 arith rc;
2522 bool did_warn = false;
2523
2524 if (src->ts.type != BT_REAL)
2525 return NULL;
2526
2527 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2528
2529 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2530
2531 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2532 {
2533 arith_error (rc, &src->ts, &result->ts, &src->where);
2534 gfc_free_expr (result);
2535 return NULL;
2536 }
2537
2538 /* If there was a fractional part, warn about this. */
2539
2540 if (warn_conversion)
2541 {
2542 mpfr_t f;
2543 mpfr_init (f);
2544 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2545 if (mpfr_cmp_si (f, 0) != 0)
2546 {
2547 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 did_warn = true;
2551 }
2552 mpfr_clear (f);
2553 }
2554 if (!did_warn && warn_conversion_extra)
2555 {
2556 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 gfc_real2uint (gfc_expr *src, int kind)
2568 {
2569 gfc_expr *result;
2570 arith rc;
2571 bool did_warn = false;
2572
2573 if (src->ts.type != BT_REAL)
2574 return NULL;
2575
2576 result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2577
2578 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2579 if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2580 gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2581
2582 gfc_reduce_unsigned (result);
2583
2584 /* If there was a fractional part, warn about this. */
2585
2586 if (warn_conversion)
2587 {
2588 mpfr_t f;
2589 mpfr_init (f);
2590 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2591 if (mpfr_cmp_si (f, 0) != 0)
2592 {
2593 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 did_warn = true;
2597 }
2598 mpfr_clear (f);
2599 }
2600 if (!did_warn && warn_conversion_extra)
2601 {
2602 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 gfc_real2real (gfc_expr *src, int kind)
2614 {
2615 gfc_expr *result;
2616 arith rc;
2617 bool did_warn = false;
2618
2619 if (src->ts.type != BT_REAL)
2620 return NULL;
2621
2622 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2623
2624 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2625
2626 rc = gfc_check_real_range (result->value.real, kind);
2627
2628 if (rc == ARITH_UNDERFLOW)
2629 {
2630 if (warn_underflow)
2631 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2632 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2633 }
2634 else if (rc != ARITH_OK)
2635 {
2636 arith_error (rc, &src->ts, &result->ts, &src->where);
2637 gfc_free_expr (result);
2638 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 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2646 {
2647 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 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2653 {
2654 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 did_warn = true;
2660 }
2661 }
2662
2663 if (!did_warn && warn_conversion_extra)
2664 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 gfc_real2complex (gfc_expr *src, int kind)
2676 {
2677 gfc_expr *result;
2678 arith rc;
2679 bool did_warn = false;
2680
2681 if (src->ts.type != BT_REAL)
2682 return NULL;
2683
2684 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2685
2686 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2687
2688 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2689
2690 if (rc == ARITH_UNDERFLOW)
2691 {
2692 if (warn_underflow)
2693 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2694 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2695 }
2696 else if (rc != ARITH_OK)
2697 {
2698 arith_error (rc, &src->ts, &result->ts, &src->where);
2699 gfc_free_expr (result);
2700 return NULL;
2701 }
2702
2703 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2704 {
2705 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2706
2707 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2708 {
2709 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 did_warn = true;
2715 }
2716 }
2717
2718 if (!did_warn && warn_conversion_extra)
2719 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 gfc_complex2int (gfc_expr *src, int kind)
2731 {
2732 gfc_expr *result;
2733 arith rc;
2734 bool did_warn = false;
2735
2736 if (src->ts.type != BT_COMPLEX)
2737 return NULL;
2738
2739 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2740
2741 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2742 &src->where);
2743
2744 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2745 {
2746 arith_error (rc, &src->ts, &result->ts, &src->where);
2747 gfc_free_expr (result);
2748 return NULL;
2749 }
2750
2751 if (warn_conversion || warn_conversion_extra)
2752 {
2753 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2754
2755 /* See if we discarded an imaginary part. */
2756 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2757 {
2758 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 did_warn = true;
2763 }
2764
2765 else {
2766 mpfr_t f;
2767
2768 mpfr_init (f);
2769 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2770 if (mpfr_cmp_si (f, 0) != 0)
2771 {
2772 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 did_warn = true;
2776 }
2777 mpfr_clear (f);
2778 }
2779
2780 if (!did_warn && warn_conversion_extra)
2781 {
2782 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 gfc_complex2uint (gfc_expr *src, int kind)
2795 {
2796 gfc_expr *result;
2797 arith rc;
2798 bool did_warn = false;
2799
2800 if (src->ts.type != BT_COMPLEX)
2801 return NULL;
2802
2803 result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
2804
2805 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2806 &src->where);
2807
2808 if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
2809 gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
2810
2811 gfc_reduce_unsigned (result);
2812
2813 if (warn_conversion || warn_conversion_extra)
2814 {
2815 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2816
2817 /* See if we discarded an imaginary part. */
2818 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2819 {
2820 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 did_warn = true;
2825 }
2826
2827 else
2828 {
2829 mpfr_t f;
2830
2831 mpfr_init (f);
2832 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2833 if (mpfr_cmp_si (f, 0) != 0)
2834 {
2835 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 did_warn = true;
2839 }
2840 mpfr_clear (f);
2841 }
2842
2843 if (!did_warn && warn_conversion_extra)
2844 {
2845 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 gfc_complex2real (gfc_expr *src, int kind)
2859 {
2860 gfc_expr *result;
2861 arith rc;
2862 bool did_warn = false;
2863
2864 if (src->ts.type != BT_COMPLEX)
2865 return NULL;
2866
2867 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2868
2869 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2870
2871 rc = gfc_check_real_range (result->value.real, kind);
2872
2873 if (rc == ARITH_UNDERFLOW)
2874 {
2875 if (warn_underflow)
2876 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2877 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2878 }
2879 if (rc != ARITH_OK)
2880 {
2881 arith_error (rc, &src->ts, &result->ts, &src->where);
2882 gfc_free_expr (result);
2883 return NULL;
2884 }
2885
2886 if (warn_conversion || warn_conversion_extra)
2887 {
2888 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2889
2890 /* See if we discarded an imaginary part. */
2891 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2892 {
2893 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 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 if (kind > src->ts.kind
2904 && wprecision_real_real (mpc_realref (src->value.complex),
2905 src->ts.kind, kind))
2906 {
2907 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 did_warn = true;
2913 }
2914 }
2915
2916 if (!did_warn && warn_conversion_extra)
2917 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 gfc_complex2complex (gfc_expr *src, int kind)
2929 {
2930 gfc_expr *result;
2931 arith rc;
2932 bool did_warn = false;
2933
2934 if (src->ts.type != BT_COMPLEX)
2935 return NULL;
2936
2937 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2938
2939 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2940
2941 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2942
2943 if (rc == ARITH_UNDERFLOW)
2944 {
2945 if (warn_underflow)
2946 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2947 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2948 }
2949 else if (rc != ARITH_OK)
2950 {
2951 arith_error (rc, &src->ts, &result->ts, &src->where);
2952 gfc_free_expr (result);
2953 return NULL;
2954 }
2955
2956 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2957
2958 if (rc == ARITH_UNDERFLOW)
2959 {
2960 if (warn_underflow)
2961 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2962 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2963 }
2964 else if (rc != ARITH_OK)
2965 {
2966 arith_error (rc, &src->ts, &result->ts, &src->where);
2967 gfc_free_expr (result);
2968 return NULL;
2969 }
2970
2971 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2972 && (wprecision_real_real (mpc_realref (src->value.complex),
2973 src->ts.kind, kind)
2974 || wprecision_real_real (mpc_imagref (src->value.complex),
2975 src->ts.kind, kind)))
2976 {
2977 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2978
2979 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 did_warn = true;
2984 }
2985
2986 if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2987 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 gfc_log2log (gfc_expr *src, int kind)
2999 {
3000 gfc_expr *result;
3001
3002 if (src->ts.type != BT_LOGICAL)
3003 return NULL;
3004
3005 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3006 result->value.logical = src->value.logical;
3007
3008 return result;
3009 }
3010
3011
3012 /* Convert logical to integer. */
3013
3014 gfc_expr *
3015 gfc_log2int (gfc_expr *src, int kind)
3016 {
3017 gfc_expr *result;
3018
3019 if (src->ts.type != BT_LOGICAL)
3020 return NULL;
3021
3022 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3023 mpz_set_si (result->value.integer, src->value.logical);
3024
3025 return result;
3026 }
3027
3028 /* Convert logical to unsigned. */
3029
3030 gfc_expr *
3031 gfc_log2uint (gfc_expr *src, int kind)
3032 {
3033 gfc_expr *result;
3034
3035 if (src->ts.type != BT_LOGICAL)
3036 return NULL;
3037
3038 result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
3039 mpz_set_si (result->value.integer, src->value.logical);
3040
3041 return result;
3042 }
3043
3044
3045 /* Convert integer to logical. */
3046
3047 gfc_expr *
3048 gfc_int2log (gfc_expr *src, int kind)
3049 {
3050 gfc_expr *result;
3051
3052 if (src->ts.type != BT_INTEGER)
3053 return NULL;
3054
3055 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3056 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3057
3058 return result;
3059 }
3060
3061 /* Convert unsigned to logical. */
3062
3063 gfc_expr *
3064 gfc_uint2log (gfc_expr *src, int kind)
3065 {
3066 gfc_expr *result;
3067
3068 if (src->ts.type != BT_UNSIGNED)
3069 return NULL;
3070
3071 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3072 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
3073
3074 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 gfc_character2character (gfc_expr *src, int kind)
3082 {
3083 gfc_expr *result;
3084 result = gfc_copy_expr (src);
3085 result->ts.kind = kind;
3086
3087 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 hollerith2representation (gfc_expr *result, gfc_expr *src)
3096 {
3097 size_t src_len, result_len;
3098
3099 src_len = src->representation.length - src->ts.u.pad;
3100 gfc_target_expr_size (result, &result_len);
3101
3102 if (src_len > result_len)
3103 {
3104 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 result->representation.string = XCNEWVEC (char, result_len + 1);
3110 memcpy (result->representation.string, src->representation.string,
3111 MIN (result_len, src_len));
3112
3113 if (src_len < result_len)
3114 memset (&result->representation.string[src_len], ' ', result_len - src_len);
3115
3116 result->representation.string[result_len] = '\0'; /* For debugger */
3117 result->representation.length = result_len;
3118 }
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 character2representation (gfc_expr *result, gfc_expr *src)
3127 {
3128 size_t src_len, result_len, i;
3129 src_len = src->value.character.length;
3130 gfc_target_expr_size (result, &result_len);
3131
3132 if (src_len > result_len)
3133 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 result->representation.string = XCNEWVEC (char, result_len + 1);
3138
3139 for (i = 0; i < MIN (result_len, src_len); i++)
3140 result->representation.string[i] = (char) src->value.character.string[i];
3141
3142 if (src_len < result_len)
3143 memset (&result->representation.string[src_len], ' ',
3144 result_len - src_len);
3145
3146 result->representation.string[result_len] = '\0'; /* For debugger. */
3147 result->representation.length = result_len;
3148 }
3149
3150 /* Convert Hollerith to integer. The constant will be padded or truncated. */
3151
3152 gfc_expr *
3153 gfc_hollerith2int (gfc_expr *src, int kind)
3154 {
3155 gfc_expr *result;
3156 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3157
3158 hollerith2representation (result, src);
3159 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3160 result->representation.length, result->value.integer);
3161
3162 return result;
3163 }
3164
3165 /* Convert character to integer. The constant will be padded or truncated. */
3166
3167 gfc_expr *
3168 gfc_character2int (gfc_expr *src, int kind)
3169 {
3170 gfc_expr *result;
3171 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
3172
3173 character2representation (result, src);
3174 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
3175 result->representation.length, result->value.integer);
3176 return result;
3177 }
3178
3179 /* Convert Hollerith to real. The constant will be padded or truncated. */
3180
3181 gfc_expr *
3182 gfc_hollerith2real (gfc_expr *src, int kind)
3183 {
3184 gfc_expr *result;
3185 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3186
3187 hollerith2representation (result, src);
3188 if (gfc_interpret_float (kind,
3189 (unsigned char *) result->representation.string,
3190 result->representation.length, result->value.real))
3191 return result;
3192 else
3193 return NULL;
3194 }
3195
3196 /* Convert character to real. The constant will be padded or truncated. */
3197
3198 gfc_expr *
3199 gfc_character2real (gfc_expr *src, int kind)
3200 {
3201 gfc_expr *result;
3202 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
3203
3204 character2representation (result, src);
3205 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
3206 result->representation.length, result->value.real);
3207
3208 return result;
3209 }
3210
3211
3212 /* Convert Hollerith to complex. The constant will be padded or truncated. */
3213
3214 gfc_expr *
3215 gfc_hollerith2complex (gfc_expr *src, int kind)
3216 {
3217 gfc_expr *result;
3218 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3219
3220 hollerith2representation (result, src);
3221 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3222 result->representation.length, result->value.complex);
3223
3224 return result;
3225 }
3226
3227 /* Convert character to complex. The constant will be padded or truncated. */
3228
3229 gfc_expr *
3230 gfc_character2complex (gfc_expr *src, int kind)
3231 {
3232 gfc_expr *result;
3233 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
3234
3235 character2representation (result, src);
3236 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
3237 result->representation.length, result->value.complex);
3238
3239 return result;
3240 }
3241
3242
3243 /* Convert Hollerith to character. */
3244
3245 gfc_expr *
3246 gfc_hollerith2character (gfc_expr *src, int kind)
3247 {
3248 gfc_expr *result;
3249
3250 result = gfc_copy_expr (src);
3251 result->ts.type = BT_CHARACTER;
3252 result->ts.kind = kind;
3253 result->ts.u.pad = 0;
3254
3255 result->value.character.length = result->representation.length;
3256 result->value.character.string
3257 = gfc_char_to_widechar (result->representation.string);
3258
3259 return result;
3260 }
3261
3262
3263 /* Convert Hollerith to logical. The constant will be padded or truncated. */
3264
3265 gfc_expr *
3266 gfc_hollerith2logical (gfc_expr *src, int kind)
3267 {
3268 gfc_expr *result;
3269 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3270
3271 hollerith2representation (result, src);
3272 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3273 result->representation.length, &result->value.logical);
3274
3275 return result;
3276 }
3277
3278 /* Convert character to logical. The constant will be padded or truncated. */
3279
3280 gfc_expr *
3281 gfc_character2logical (gfc_expr *src, int kind)
3282 {
3283 gfc_expr *result;
3284 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
3285
3286 character2representation (result, src);
3287 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
3288 result->representation.length, &result->value.logical);
3289
3290 return result;
3291 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org