?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
compiler: don't generate stubs for ambiguous direct interface methods
[official-gcc.git] / gcc / fortran / arith.cc
blobd57059a375fead7f7597460d31e9421deac8541f
1 /* Compiler arithmetic
2 Copyright (C) 2000-2022 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
62 /* Set the model number precision by the requested KIND. */
63
64 void
65 gfc_set_model_kind (int kind)
66 {
67 int index = gfc_validate_kind (BT_REAL, kind, false);
68 int base2prec;
69
70 base2prec = gfc_real_kinds[index].digits;
71 if (gfc_real_kinds[index].radix != 2)
72 base2prec *= gfc_real_kinds[index].radix / 2;
73 mpfr_set_default_prec (base2prec);
74 }
75
76
77 /* Set the model number precision from mpfr_t x. */
78
79 void
80 gfc_set_model (mpfr_t x)
81 {
82 mpfr_set_default_prec (mpfr_get_prec (x));
83 }
84
85
86 /* Given an arithmetic error code, return a pointer to a string that
87 explains the error. */
88
89 static const char *
90 gfc_arith_error (arith code)
91 {
92 const char *p;
93
94 switch (code)
95 {
96 case ARITH_OK:
97 p = G_("Arithmetic OK at %L");
98 break;
99 case ARITH_OVERFLOW:
100 p = G_("Arithmetic overflow at %L");
101 break;
102 case ARITH_UNDERFLOW:
103 p = G_("Arithmetic underflow at %L");
104 break;
105 case ARITH_NAN:
106 p = G_("Arithmetic NaN at %L");
107 break;
108 case ARITH_DIV0:
109 p = G_("Division by zero at %L");
110 break;
111 case ARITH_INCOMMENSURATE:
112 p = G_("Array operands are incommensurate at %L");
113 break;
114 case ARITH_ASYMMETRIC:
115 p = G_("Integer outside symmetric range implied by Standard Fortran"
116 " at %L");
117 break;
118 case ARITH_WRONGCONCAT:
119 p = G_("Illegal type in character concatenation at %L");
120 break;
121
122 default:
123 gfc_internal_error ("gfc_arith_error(): Bad error code");
124 }
125
126 return p;
127 }
128
129
130 /* Get things ready to do math. */
131
132 void
133 gfc_arith_init_1 (void)
134 {
135 gfc_integer_info *int_info;
136 gfc_real_info *real_info;
137 mpfr_t a, b;
138 int i;
139
140 mpfr_set_default_prec (128);
141 mpfr_init (a);
142
143 /* Convert the minimum and maximum values for each kind into their
144 GNU MP representation. */
145 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
146 {
147 /* Huge */
148 mpz_init (int_info->huge);
149 mpz_set_ui (int_info->huge, int_info->radix);
150 mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
151 mpz_sub_ui (int_info->huge, int_info->huge, 1);
152
153 /* These are the numbers that are actually representable by the
154 target. For bases other than two, this needs to be changed. */
155 if (int_info->radix != 2)
156 gfc_internal_error ("Fix min_int calculation");
157
158 /* See PRs 13490 and 17912, related to integer ranges.
159 The pedantic_min_int exists for range checking when a program
160 is compiled with -pedantic, and reflects the belief that
161 Standard Fortran requires integers to be symmetrical, i.e.
162 every negative integer must have a representable positive
163 absolute value, and vice versa. */
164
165 mpz_init (int_info->pedantic_min_int);
166 mpz_neg (int_info->pedantic_min_int, int_info->huge);
167
168 mpz_init (int_info->min_int);
169 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
170
171 /* Range */
172 mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
173 mpfr_log10 (a, a, GFC_RND_MODE);
174 mpfr_trunc (a, a);
175 int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
176 }
177
178 mpfr_clear (a);
179
180 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
181 {
182 gfc_set_model_kind (real_info->kind);
183
184 mpfr_init (a);
185 mpfr_init (b);
186
187 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
188 /* 1 - b**(-p) */
189 mpfr_init (real_info->huge);
190 mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
191 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
192 mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
193 mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
194
195 /* b**(emax-1) */
196 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
197 mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
198
199 /* (1 - b**(-p)) * b**(emax-1) */
200 mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
201
202 /* (1 - b**(-p)) * b**(emax-1) * b */
203 mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
204 GFC_RND_MODE);
205
206 /* tiny(x) = b**(emin-1) */
207 mpfr_init (real_info->tiny);
208 mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
209 mpfr_pow_si (real_info->tiny, real_info->tiny,
210 real_info->min_exponent - 1, GFC_RND_MODE);
211
212 /* subnormal (x) = b**(emin - digit) */
213 mpfr_init (real_info->subnormal);
214 mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
215 mpfr_pow_si (real_info->subnormal, real_info->subnormal,
216 real_info->min_exponent - real_info->digits, GFC_RND_MODE);
217
218 /* epsilon(x) = b**(1-p) */
219 mpfr_init (real_info->epsilon);
220 mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
221 mpfr_pow_si (real_info->epsilon, real_info->epsilon,
222 1 - real_info->digits, GFC_RND_MODE);
223
224 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
225 mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
226 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
227 mpfr_neg (b, b, GFC_RND_MODE);
228
229 /* a = min(a, b) */
230 mpfr_min (a, a, b, GFC_RND_MODE);
231 mpfr_trunc (a, a);
232 real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
233
234 /* precision(x) = int((p - 1) * log10(b)) + k */
235 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
236 mpfr_log10 (a, a, GFC_RND_MODE);
237 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
238 mpfr_trunc (a, a);
239 real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
240
241 /* If the radix is an integral power of 10, add one to the precision. */
242 for (i = 10; i <= real_info->radix; i *= 10)
243 if (i == real_info->radix)
244 real_info->precision++;
245
246 mpfr_clears (a, b, NULL);
247 }
248 }
249
250
251 /* Clean up, get rid of numeric constants. */
252
253 void
254 gfc_arith_done_1 (void)
255 {
256 gfc_integer_info *ip;
257 gfc_real_info *rp;
258
259 for (ip = gfc_integer_kinds; ip->kind; ip++)
260 {
261 mpz_clear (ip->min_int);
262 mpz_clear (ip->pedantic_min_int);
263 mpz_clear (ip->huge);
264 }
265
266 for (rp = gfc_real_kinds; rp->kind; rp++)
267 mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
268
269 mpfr_free_cache ();
270 }
271
272
273 /* Given a wide character value and a character kind, determine whether
274 the character is representable for that kind. */
275 bool
276 gfc_check_character_range (gfc_char_t c, int kind)
277 {
278 /* As wide characters are stored as 32-bit values, they're all
279 representable in UCS=4. */
280 if (kind == 4)
281 return true;
282
283 if (kind == 1)
284 return c <= 255 ? true : false;
285
286 gcc_unreachable ();
287 }
288
289
290 /* Given an integer and a kind, make sure that the integer lies within
291 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
292 ARITH_OVERFLOW. */
293
294 arith
295 gfc_check_integer_range (mpz_t p, int kind)
296 {
297 arith result;
298 int i;
299
300 i = gfc_validate_kind (BT_INTEGER, kind, false);
301 result = ARITH_OK;
302
303 if (pedantic)
304 {
305 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
306 result = ARITH_ASYMMETRIC;
307 }
308
309
310 if (flag_range_check == 0)
311 return result;
312
313 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
314 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
315 result = ARITH_OVERFLOW;
316
317 return result;
318 }
319
320
321 /* Given a real and a kind, make sure that the real lies within the
322 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
323 ARITH_UNDERFLOW. */
324
325 static arith
326 gfc_check_real_range (mpfr_t p, int kind)
327 {
328 arith retval;
329 mpfr_t q;
330 int i;
331
332 i = gfc_validate_kind (BT_REAL, kind, false);
333
334 gfc_set_model (p);
335 mpfr_init (q);
336 mpfr_abs (q, p, GFC_RND_MODE);
337
338 retval = ARITH_OK;
339
340 if (mpfr_inf_p (p))
341 {
342 if (flag_range_check != 0)
343 retval = ARITH_OVERFLOW;
344 }
345 else if (mpfr_nan_p (p))
346 {
347 if (flag_range_check != 0)
348 retval = ARITH_NAN;
349 }
350 else if (mpfr_sgn (q) == 0)
351 {
352 mpfr_clear (q);
353 return retval;
354 }
355 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
356 {
357 if (flag_range_check == 0)
358 mpfr_set_inf (p, mpfr_sgn (p));
359 else
360 retval = ARITH_OVERFLOW;
361 }
362 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
363 {
364 if (flag_range_check == 0)
365 {
366 if (mpfr_sgn (p) < 0)
367 {
368 mpfr_set_ui (p, 0, GFC_RND_MODE);
369 mpfr_set_si (q, -1, GFC_RND_MODE);
370 mpfr_copysign (p, p, q, GFC_RND_MODE);
371 }
372 else
373 mpfr_set_ui (p, 0, GFC_RND_MODE);
374 }
375 else
376 retval = ARITH_UNDERFLOW;
377 }
378 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
379 {
380 mpfr_exp_t emin, emax;
381 int en;
382
383 /* Save current values of emin and emax. */
384 emin = mpfr_get_emin ();
385 emax = mpfr_get_emax ();
386
387 /* Set emin and emax for the current model number. */
388 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
389 mpfr_set_emin ((mpfr_exp_t) en);
390 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
391 mpfr_check_range (q, 0, GFC_RND_MODE);
392 mpfr_subnormalize (q, 0, GFC_RND_MODE);
393
394 /* Reset emin and emax. */
395 mpfr_set_emin (emin);
396 mpfr_set_emax (emax);
397
398 /* Copy sign if needed. */
399 if (mpfr_sgn (p) < 0)
400 mpfr_neg (p, q, MPFR_RNDN);
401 else
402 mpfr_set (p, q, MPFR_RNDN);
403 }
404
405 mpfr_clear (q);
406
407 return retval;
408 }
409
410
411 /* Low-level arithmetic functions. All of these subroutines assume
412 that all operands are of the same type and return an operand of the
413 same type. The other thing about these subroutines is that they
414 can fail in various ways -- overflow, underflow, division by zero,
415 zero raised to the zero, etc. */
416
417 static arith
418 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
419 {
420 gfc_expr *result;
421
422 result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
423 result->value.logical = !op1->value.logical;
424 *resultp = result;
425
426 return ARITH_OK;
427 }
428
429
430 static arith
431 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
432 {
433 gfc_expr *result;
434
435 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
436 &op1->where);
437 result->value.logical = op1->value.logical && op2->value.logical;
438 *resultp = result;
439
440 return ARITH_OK;
441 }
442
443
444 static arith
445 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
446 {
447 gfc_expr *result;
448
449 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
450 &op1->where);
451 result->value.logical = op1->value.logical || op2->value.logical;
452 *resultp = result;
453
454 return ARITH_OK;
455 }
456
457
458 static arith
459 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
460 {
461 gfc_expr *result;
462
463 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
464 &op1->where);
465 result->value.logical = op1->value.logical == op2->value.logical;
466 *resultp = result;
467
468 return ARITH_OK;
469 }
470
471
472 static arith
473 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
474 {
475 gfc_expr *result;
476
477 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
478 &op1->where);
479 result->value.logical = op1->value.logical != op2->value.logical;
480 *resultp = result;
481
482 return ARITH_OK;
483 }
484
485
486 /* Make sure a constant numeric expression is within the range for
487 its type and kind. Note that there's also a gfc_check_range(),
488 but that one deals with the intrinsic RANGE function. */
489
490 arith
491 gfc_range_check (gfc_expr *e)
492 {
493 arith rc;
494 arith rc2;
495
496 switch (e->ts.type)
497 {
498 case BT_INTEGER:
499 rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
500 break;
501
502 case BT_REAL:
503 rc = gfc_check_real_range (e->value.real, e->ts.kind);
504 if (rc == ARITH_UNDERFLOW)
505 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
506 if (rc == ARITH_OVERFLOW)
507 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
508 if (rc == ARITH_NAN)
509 mpfr_set_nan (e->value.real);
510 break;
511
512 case BT_COMPLEX:
513 rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
514 if (rc == ARITH_UNDERFLOW)
515 mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
516 if (rc == ARITH_OVERFLOW)
517 mpfr_set_inf (mpc_realref (e->value.complex),
518 mpfr_sgn (mpc_realref (e->value.complex)));
519 if (rc == ARITH_NAN)
520 mpfr_set_nan (mpc_realref (e->value.complex));
521
522 rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
523 if (rc == ARITH_UNDERFLOW)
524 mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
525 if (rc == ARITH_OVERFLOW)
526 mpfr_set_inf (mpc_imagref (e->value.complex),
527 mpfr_sgn (mpc_imagref (e->value.complex)));
528 if (rc == ARITH_NAN)
529 mpfr_set_nan (mpc_imagref (e->value.complex));
530
531 if (rc == ARITH_OK)
532 rc = rc2;
533 break;
534
535 default:
536 gfc_internal_error ("gfc_range_check(): Bad type");
537 }
538
539 return rc;
540 }
541
542
543 /* Several of the following routines use the same set of statements to
544 check the validity of the result. Encapsulate the checking here. */
545
546 static arith
547 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
548 {
549 arith val = rc;
550
551 if (val == ARITH_UNDERFLOW)
552 {
553 if (warn_underflow)
554 gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
555 val = ARITH_OK;
556 }
557
558 if (val == ARITH_ASYMMETRIC)
559 {
560 gfc_warning (0, gfc_arith_error (val), &x->where);
561 val = ARITH_OK;
562 }
563
564 if (val == ARITH_OK || val == ARITH_OVERFLOW)
565 *rp = r;
566 else
567 gfc_free_expr (r);
568
569 return val;
570 }
571
572
573 /* It may seem silly to have a subroutine that actually computes the
574 unary plus of a constant, but it prevents us from making exceptions
575 in the code elsewhere. Used for unary plus and parenthesized
576 expressions. */
577
578 static arith
579 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
580 {
581 *resultp = gfc_copy_expr (op1);
582 return ARITH_OK;
583 }
584
585
586 static arith
587 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
588 {
589 gfc_expr *result;
590 arith rc;
591
592 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
593
594 switch (op1->ts.type)
595 {
596 case BT_INTEGER:
597 mpz_neg (result->value.integer, op1->value.integer);
598 break;
599
600 case BT_REAL:
601 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
602 break;
603
604 case BT_COMPLEX:
605 mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
606 break;
607
608 default:
609 gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
610 }
611
612 rc = gfc_range_check (result);
613
614 return check_result (rc, op1, result, resultp);
615 }
616
617
618 static arith
619 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
620 {
621 gfc_expr *result;
622 arith rc;
623
624 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
625
626 switch (op1->ts.type)
627 {
628 case BT_INTEGER:
629 mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
630 break;
631
632 case BT_REAL:
633 mpfr_add (result->value.real, op1->value.real, op2->value.real,
634 GFC_RND_MODE);
635 break;
636
637 case BT_COMPLEX:
638 mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
639 GFC_MPC_RND_MODE);
640 break;
641
642 default:
643 gfc_internal_error ("gfc_arith_plus(): Bad basic type");
644 }
645
646 rc = gfc_range_check (result);
647
648 return check_result (rc, op1, result, resultp);
649 }
650
651
652 static arith
653 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
654 {
655 gfc_expr *result;
656 arith rc;
657
658 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
659
660 switch (op1->ts.type)
661 {
662 case BT_INTEGER:
663 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
664 break;
665
666 case BT_REAL:
667 mpfr_sub (result->value.real, op1->value.real, op2->value.real,
668 GFC_RND_MODE);
669 break;
670
671 case BT_COMPLEX:
672 mpc_sub (result->value.complex, op1->value.complex,
673 op2->value.complex, GFC_MPC_RND_MODE);
674 break;
675
676 default:
677 gfc_internal_error ("gfc_arith_minus(): Bad basic type");
678 }
679
680 rc = gfc_range_check (result);
681
682 return check_result (rc, op1, result, resultp);
683 }
684
685
686 static arith
687 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
688 {
689 gfc_expr *result;
690 arith rc;
691
692 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
693
694 switch (op1->ts.type)
695 {
696 case BT_INTEGER:
697 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
698 break;
699
700 case BT_REAL:
701 mpfr_mul (result->value.real, op1->value.real, op2->value.real,
702 GFC_RND_MODE);
703 break;
704
705 case BT_COMPLEX:
706 gfc_set_model (mpc_realref (op1->value.complex));
707 mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
708 GFC_MPC_RND_MODE);
709 break;
710
711 default:
712 gfc_internal_error ("gfc_arith_times(): Bad basic type");
713 }
714
715 rc = gfc_range_check (result);
716
717 return check_result (rc, op1, result, resultp);
718 }
719
720
721 static arith
722 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
723 {
724 gfc_expr *result;
725 arith rc;
726
727 rc = ARITH_OK;
728
729 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
730
731 switch (op1->ts.type)
732 {
733 case BT_INTEGER:
734 if (mpz_sgn (op2->value.integer) == 0)
735 {
736 rc = ARITH_DIV0;
737 break;
738 }
739
740 if (warn_integer_division)
741 {
742 mpz_t r;
743 mpz_init (r);
744 mpz_tdiv_qr (result->value.integer, r, op1->value.integer,
745 op2->value.integer);
746
747 if (mpz_cmp_si (r, 0) != 0)
748 {
749 char *p;
750 p = mpz_get_str (NULL, 10, result->value.integer);
751 gfc_warning_now (OPT_Winteger_division, "Integer division "
752 "truncated to constant %qs at %L", p,
753 &op1->where);
754 free (p);
755 }
756 mpz_clear (r);
757 }
758 else
759 mpz_tdiv_q (result->value.integer, op1->value.integer,
760 op2->value.integer);
761
762 break;
763
764 case BT_REAL:
765 if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1)
766 {
767 rc = ARITH_DIV0;
768 break;
769 }
770
771 mpfr_div (result->value.real, op1->value.real, op2->value.real,
772 GFC_RND_MODE);
773 break;
774
775 case BT_COMPLEX:
776 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
777 && flag_range_check == 1)
778 {
779 rc = ARITH_DIV0;
780 break;
781 }
782
783 gfc_set_model (mpc_realref (op1->value.complex));
784 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
785 {
786 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
787 PR 40318. */
788 mpfr_set_nan (mpc_realref (result->value.complex));
789 mpfr_set_nan (mpc_imagref (result->value.complex));
790 }
791 else
792 mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
793 GFC_MPC_RND_MODE);
794 break;
795
796 default:
797 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
798 }
799
800 if (rc == ARITH_OK)
801 rc = gfc_range_check (result);
802
803 return check_result (rc, op1, result, resultp);
804 }
805
806 /* Raise a number to a power. */
807
808 static arith
809 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
810 {
811 int power_sign;
812 gfc_expr *result;
813 arith rc;
814
815 rc = ARITH_OK;
816 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
817
818 switch (op2->ts.type)
819 {
820 case BT_INTEGER:
821 power_sign = mpz_sgn (op2->value.integer);
822
823 if (power_sign == 0)
824 {
825 /* Handle something to the zeroth power. Since we're dealing
826 with integral exponents, there is no ambiguity in the
827 limiting procedure used to determine the value of 0**0. */
828 switch (op1->ts.type)
829 {
830 case BT_INTEGER:
831 mpz_set_ui (result->value.integer, 1);
832 break;
833
834 case BT_REAL:
835 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
836 break;
837
838 case BT_COMPLEX:
839 mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
840 break;
841
842 default:
843 gfc_internal_error ("arith_power(): Bad base");
844 }
845 }
846 else
847 {
848 switch (op1->ts.type)
849 {
850 case BT_INTEGER:
851 {
852 /* First, we simplify the cases of op1 == 1, 0 or -1. */
853 if (mpz_cmp_si (op1->value.integer, 1) == 0)
854 {
855 /* 1**op2 == 1 */
856 mpz_set_si (result->value.integer, 1);
857 }
858 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
859 {
860 /* 0**op2 == 0, if op2 > 0
861 0**op2 overflow, if op2 < 0 ; in that case, we
862 set the result to 0 and return ARITH_DIV0. */
863 mpz_set_si (result->value.integer, 0);
864 if (mpz_cmp_si (op2->value.integer, 0) < 0)
865 rc = ARITH_DIV0;
866 }
867 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
868 {
869 /* (-1)**op2 == (-1)**(mod(op2,2)) */
870 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
871 if (odd)
872 mpz_set_si (result->value.integer, -1);
873 else
874 mpz_set_si (result->value.integer, 1);
875 }
876 /* Then, we take care of op2 < 0. */
877 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
878 {
879 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
880 mpz_set_si (result->value.integer, 0);
881 if (warn_integer_division)
882 gfc_warning_now (OPT_Winteger_division, "Negative "
883 "exponent of integer has zero "
884 "result at %L", &result->where);
885 }
886 else
887 {
888 /* We have abs(op1) > 1 and op2 > 1.
889 If op2 > bit_size(op1), we'll have an out-of-range
890 result. */
891 int k, power;
892
893 k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
894 power = gfc_integer_kinds[k].bit_size;
895 if (mpz_cmp_si (op2->value.integer, power) < 0)
896 {
897 gfc_extract_int (op2, &power);
898 mpz_pow_ui (result->value.integer, op1->value.integer,
899 power);
900 rc = gfc_range_check (result);
901 if (rc == ARITH_OVERFLOW)
902 gfc_error_now ("Result of exponentiation at %L "
903 "exceeds the range of %s", &op1->where,
904 gfc_typename (&(op1->ts)));
905 }
906 else
907 {
908 /* Provide a nonsense value to propagate up. */
909 mpz_set (result->value.integer,
910 gfc_integer_kinds[k].huge);
911 mpz_add_ui (result->value.integer,
912 result->value.integer, 1);
913 rc = ARITH_OVERFLOW;
914 }
915 }
916 }
917 break;
918
919 case BT_REAL:
920 mpfr_pow_z (result->value.real, op1->value.real,
921 op2->value.integer, GFC_RND_MODE);
922 break;
923
924 case BT_COMPLEX:
925 mpc_pow_z (result->value.complex, op1->value.complex,
926 op2->value.integer, GFC_MPC_RND_MODE);
927 break;
928
929 default:
930 break;
931 }
932 }
933 break;
934
935 case BT_REAL:
936
937 if (gfc_init_expr_flag)
938 {
939 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
940 "exponent in an initialization "
941 "expression at %L", &op2->where))
942 {
943 gfc_free_expr (result);
944 return ARITH_PROHIBIT;
945 }
946 }
947
948 if (mpfr_cmp_si (op1->value.real, 0) < 0)
949 {
950 gfc_error ("Raising a negative REAL at %L to "
951 "a REAL power is prohibited", &op1->where);
952 gfc_free_expr (result);
953 return ARITH_PROHIBIT;
954 }
955
956 mpfr_pow (result->value.real, op1->value.real, op2->value.real,
957 GFC_RND_MODE);
958 break;
959
960 case BT_COMPLEX:
961 {
962 if (gfc_init_expr_flag)
963 {
964 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
965 "exponent in an initialization "
966 "expression at %L", &op2->where))
967 {
968 gfc_free_expr (result);
969 return ARITH_PROHIBIT;
970 }
971 }
972
973 mpc_pow (result->value.complex, op1->value.complex,
974 op2->value.complex, GFC_MPC_RND_MODE);
975 }
976 break;
977 default:
978 gfc_internal_error ("arith_power(): unknown type");
979 }
980
981 if (rc == ARITH_OK)
982 rc = gfc_range_check (result);
983
984 return check_result (rc, op1, result, resultp);
985 }
986
987
988 /* Concatenate two string constants. */
989
990 static arith
991 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
992 {
993 gfc_expr *result;
994 size_t len;
995
996 /* By cleverly playing around with constructors, it is possible
997 to get mismaching types here. */
998 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
999 || op1->ts.kind != op2->ts.kind)
1000 return ARITH_WRONGCONCAT;
1001
1002 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1003 &op1->where);
1004
1005 len = op1->value.character.length + op2->value.character.length;
1006
1007 result->value.character.string = gfc_get_wide_string (len + 1);
1008 result->value.character.length = len;
1009
1010 memcpy (result->value.character.string, op1->value.character.string,
1011 op1->value.character.length * sizeof (gfc_char_t));
1012
1013 memcpy (&result->value.character.string[op1->value.character.length],
1014 op2->value.character.string,
1015 op2->value.character.length * sizeof (gfc_char_t));
1016
1017 result->value.character.string[len] = '\0';
1018
1019 *resultp = result;
1020
1021 return ARITH_OK;
1022 }
1023
1024 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1025 This function mimics mpfr_cmp but takes NaN into account. */
1026
1027 static int
1028 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1029 {
1030 int rc;
1031 switch (op)
1032 {
1033 case INTRINSIC_EQ:
1034 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1035 break;
1036 case INTRINSIC_GT:
1037 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1038 break;
1039 case INTRINSIC_GE:
1040 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1041 break;
1042 case INTRINSIC_LT:
1043 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1044 break;
1045 case INTRINSIC_LE:
1046 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1047 break;
1048 default:
1049 gfc_internal_error ("compare_real(): Bad operator");
1050 }
1051
1052 return rc;
1053 }
1054
1055 /* Comparison operators. Assumes that the two expression nodes
1056 contain two constants of the same type. The op argument is
1057 needed to handle NaN correctly. */
1058
1059 int
1060 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1061 {
1062 int rc;
1063
1064 switch (op1->ts.type)
1065 {
1066 case BT_INTEGER:
1067 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1068 break;
1069
1070 case BT_REAL:
1071 rc = compare_real (op1, op2, op);
1072 break;
1073
1074 case BT_CHARACTER:
1075 rc = gfc_compare_string (op1, op2);
1076 break;
1077
1078 case BT_LOGICAL:
1079 rc = ((!op1->value.logical && op2->value.logical)
1080 || (op1->value.logical && !op2->value.logical));
1081 break;
1082
1083 default:
1084 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1085 }
1086
1087 return rc;
1088 }
1089
1090
1091 /* Compare a pair of complex numbers. Naturally, this is only for
1092 equality and inequality. */
1093
1094 static int
1095 compare_complex (gfc_expr *op1, gfc_expr *op2)
1096 {
1097 return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1098 }
1099
1100
1101 /* Given two constant strings and the inverse collating sequence, compare the
1102 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1103 We use the processor's default collating sequence. */
1104
1105 int
1106 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1107 {
1108 size_t len, alen, blen, i;
1109 gfc_char_t ac, bc;
1110
1111 alen = a->value.character.length;
1112 blen = b->value.character.length;
1113
1114 len = MAX(alen, blen);
1115
1116 for (i = 0; i < len; i++)
1117 {
1118 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1119 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1120
1121 if (ac < bc)
1122 return -1;
1123 if (ac > bc)
1124 return 1;
1125 }
1126
1127 /* Strings are equal */
1128 return 0;
1129 }
1130
1131
1132 int
1133 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1134 {
1135 size_t len, alen, blen, i;
1136 gfc_char_t ac, bc;
1137
1138 alen = a->value.character.length;
1139 blen = strlen (b);
1140
1141 len = MAX(alen, blen);
1142
1143 for (i = 0; i < len; i++)
1144 {
1145 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1146 bc = ((i < blen) ? b[i] : ' ');
1147
1148 if (!case_sensitive)
1149 {
1150 ac = TOLOWER (ac);
1151 bc = TOLOWER (bc);
1152 }
1153
1154 if (ac < bc)
1155 return -1;
1156 if (ac > bc)
1157 return 1;
1158 }
1159
1160 /* Strings are equal */
1161 return 0;
1162 }
1163
1164
1165 /* Specific comparison subroutines. */
1166
1167 static arith
1168 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1169 {
1170 gfc_expr *result;
1171
1172 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1173 &op1->where);
1174 result->value.logical = (op1->ts.type == BT_COMPLEX)
1175 ? compare_complex (op1, op2)
1176 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1177
1178 *resultp = result;
1179 return ARITH_OK;
1180 }
1181
1182
1183 static arith
1184 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1185 {
1186 gfc_expr *result;
1187
1188 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1189 &op1->where);
1190 result->value.logical = (op1->ts.type == BT_COMPLEX)
1191 ? !compare_complex (op1, op2)
1192 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1193
1194 *resultp = result;
1195 return ARITH_OK;
1196 }
1197
1198
1199 static arith
1200 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1201 {
1202 gfc_expr *result;
1203
1204 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1205 &op1->where);
1206 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1207 *resultp = result;
1208
1209 return ARITH_OK;
1210 }
1211
1212
1213 static arith
1214 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1215 {
1216 gfc_expr *result;
1217
1218 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1219 &op1->where);
1220 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1221 *resultp = result;
1222
1223 return ARITH_OK;
1224 }
1225
1226
1227 static arith
1228 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1229 {
1230 gfc_expr *result;
1231
1232 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1233 &op1->where);
1234 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1235 *resultp = result;
1236
1237 return ARITH_OK;
1238 }
1239
1240
1241 static arith
1242 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1243 {
1244 gfc_expr *result;
1245
1246 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1247 &op1->where);
1248 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1249 *resultp = result;
1250
1251 return ARITH_OK;
1252 }
1253
1254
1255 static arith
1256 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1257 gfc_expr **result)
1258 {
1259 gfc_constructor_base head;
1260 gfc_constructor *c;
1261 gfc_expr *r;
1262 arith rc;
1263
1264 if (op->expr_type == EXPR_CONSTANT)
1265 return eval (op, result);
1266
1267 rc = ARITH_OK;
1268 head = gfc_constructor_copy (op->value.constructor);
1269 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1270 {
1271 rc = reduce_unary (eval, c->expr, &r);
1272
1273 if (rc != ARITH_OK)
1274 break;
1275
1276 gfc_replace_expr (c->expr, r);
1277 }
1278
1279 if (rc != ARITH_OK)
1280 gfc_constructor_free (head);
1281 else
1282 {
1283 gfc_constructor *c = gfc_constructor_first (head);
1284 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1285 &op->where);
1286 r->shape = gfc_copy_shape (op->shape, op->rank);
1287 r->rank = op->rank;
1288 r->value.constructor = head;
1289 *result = r;
1290 }
1291
1292 return rc;
1293 }
1294
1295
1296 static arith
1297 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1298 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1299 {
1300 gfc_constructor_base head;
1301 gfc_constructor *c;
1302 gfc_expr *r;
1303 arith rc = ARITH_OK;
1304
1305 head = gfc_constructor_copy (op1->value.constructor);
1306 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1307 {
1308 gfc_simplify_expr (c->expr, 0);
1309
1310 if (c->expr->expr_type == EXPR_CONSTANT)
1311 rc = eval (c->expr, op2, &r);
1312 else
1313 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1314
1315 if (rc != ARITH_OK)
1316 break;
1317
1318 gfc_replace_expr (c->expr, r);
1319 }
1320
1321 if (rc != ARITH_OK)
1322 gfc_constructor_free (head);
1323 else
1324 {
1325 gfc_constructor *c = gfc_constructor_first (head);
1326 if (c)
1327 {
1328 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1329 &op1->where);
1330 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1331 }
1332 else
1333 {
1334 gcc_assert (op1->ts.type != BT_UNKNOWN);
1335 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
1336 &op1->where);
1337 r->shape = gfc_get_shape (op1->rank);
1338 }
1339 r->rank = op1->rank;
1340 r->value.constructor = head;
1341 *result = r;
1342 }
1343
1344 return rc;
1345 }
1346
1347
1348 static arith
1349 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1350 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1351 {
1352 gfc_constructor_base head;
1353 gfc_constructor *c;
1354 gfc_expr *r;
1355 arith rc = ARITH_OK;
1356
1357 head = gfc_constructor_copy (op2->value.constructor);
1358 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1359 {
1360 gfc_simplify_expr (c->expr, 0);
1361
1362 if (c->expr->expr_type == EXPR_CONSTANT)
1363 rc = eval (op1, c->expr, &r);
1364 else
1365 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1366
1367 if (rc != ARITH_OK)
1368 break;
1369
1370 gfc_replace_expr (c->expr, r);
1371 }
1372
1373 if (rc != ARITH_OK)
1374 gfc_constructor_free (head);
1375 else
1376 {
1377 gfc_constructor *c = gfc_constructor_first (head);
1378 if (c)
1379 {
1380 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1381 &op2->where);
1382 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1383 }
1384 else
1385 {
1386 gcc_assert (op2->ts.type != BT_UNKNOWN);
1387 r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
1388 &op2->where);
1389 r->shape = gfc_get_shape (op2->rank);
1390 }
1391 r->rank = op2->rank;
1392 r->value.constructor = head;
1393 *result = r;
1394 }
1395
1396 return rc;
1397 }
1398
1399
1400 /* We need a forward declaration of reduce_binary. */
1401 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1402 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1403
1404
1405 static arith
1406 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1407 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1408 {
1409 gfc_constructor_base head;
1410 gfc_constructor *c, *d;
1411 gfc_expr *r;
1412 arith rc = ARITH_OK;
1413
1414 if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1415 return ARITH_INCOMMENSURATE;
1416
1417 head = gfc_constructor_copy (op1->value.constructor);
1418 for (c = gfc_constructor_first (head),
1419 d = gfc_constructor_first (op2->value.constructor);
1420 c && d;
1421 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1422 {
1423 rc = reduce_binary (eval, c->expr, d->expr, &r);
1424 if (rc != ARITH_OK)
1425 break;
1426
1427 gfc_replace_expr (c->expr, r);
1428 }
1429
1430 if (c || d)
1431 rc = ARITH_INCOMMENSURATE;
1432
1433 if (rc != ARITH_OK)
1434 gfc_constructor_free (head);
1435 else
1436 {
1437 gfc_constructor *c = gfc_constructor_first (head);
1438 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1439 &op1->where);
1440 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1441 r->rank = op1->rank;
1442 r->value.constructor = head;
1443 *result = r;
1444 }
1445
1446 return rc;
1447 }
1448
1449
1450 static arith
1451 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1452 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1453 {
1454 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1455 return eval (op1, op2, result);
1456
1457 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1458 return reduce_binary_ca (eval, op1, op2, result);
1459
1460 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1461 return reduce_binary_ac (eval, op1, op2, result);
1462
1463 return reduce_binary_aa (eval, op1, op2, result);
1464 }
1465
1466
1467 typedef union
1468 {
1469 arith (*f2)(gfc_expr *, gfc_expr **);
1470 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1471 }
1472 eval_f;
1473
1474 /* High level arithmetic subroutines. These subroutines go into
1475 eval_intrinsic(), which can do one of several things to its
1476 operands. If the operands are incompatible with the intrinsic
1477 operation, we return a node pointing to the operands and hope that
1478 an operator interface is found during resolution.
1479
1480 If the operands are compatible and are constants, then we try doing
1481 the arithmetic. We also handle the cases where either or both
1482 operands are array constructors. */
1483
1484 static gfc_expr *
1485 eval_intrinsic (gfc_intrinsic_op op,
1486 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1487 {
1488 gfc_expr temp, *result;
1489 int unary;
1490 arith rc;
1491
1492 if (!op1)
1493 return NULL;
1494
1495 gfc_clear_ts (&temp.ts);
1496
1497 switch (op)
1498 {
1499 /* Logical unary */
1500 case INTRINSIC_NOT:
1501 if (op1->ts.type != BT_LOGICAL)
1502 goto runtime;
1503
1504 temp.ts.type = BT_LOGICAL;
1505 temp.ts.kind = gfc_default_logical_kind;
1506 unary = 1;
1507 break;
1508
1509 /* Logical binary operators */
1510 case INTRINSIC_OR:
1511 case INTRINSIC_AND:
1512 case INTRINSIC_NEQV:
1513 case INTRINSIC_EQV:
1514 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1515 goto runtime;
1516
1517 temp.ts.type = BT_LOGICAL;
1518 temp.ts.kind = gfc_default_logical_kind;
1519 unary = 0;
1520 break;
1521
1522 /* Numeric unary */
1523 case INTRINSIC_UPLUS:
1524 case INTRINSIC_UMINUS:
1525 if (!gfc_numeric_ts (&op1->ts))
1526 goto runtime;
1527
1528 temp.ts = op1->ts;
1529 unary = 1;
1530 break;
1531
1532 case INTRINSIC_PARENTHESES:
1533 temp.ts = op1->ts;
1534 unary = 1;
1535 break;
1536
1537 /* Additional restrictions for ordering relations. */
1538 case INTRINSIC_GE:
1539 case INTRINSIC_GE_OS:
1540 case INTRINSIC_LT:
1541 case INTRINSIC_LT_OS:
1542 case INTRINSIC_LE:
1543 case INTRINSIC_LE_OS:
1544 case INTRINSIC_GT:
1545 case INTRINSIC_GT_OS:
1546 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1547 {
1548 temp.ts.type = BT_LOGICAL;
1549 temp.ts.kind = gfc_default_logical_kind;
1550 goto runtime;
1551 }
1552
1553 /* Fall through */
1554 case INTRINSIC_EQ:
1555 case INTRINSIC_EQ_OS:
1556 case INTRINSIC_NE:
1557 case INTRINSIC_NE_OS:
1558 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1559 {
1560 unary = 0;
1561 temp.ts.type = BT_LOGICAL;
1562 temp.ts.kind = gfc_default_logical_kind;
1563
1564 /* If kind mismatch, exit and we'll error out later. */
1565 if (op1->ts.kind != op2->ts.kind)
1566 goto runtime;
1567
1568 break;
1569 }
1570
1571 gcc_fallthrough ();
1572 /* Numeric binary */
1573 case INTRINSIC_PLUS:
1574 case INTRINSIC_MINUS:
1575 case INTRINSIC_TIMES:
1576 case INTRINSIC_DIVIDE:
1577 case INTRINSIC_POWER:
1578 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1579 goto runtime;
1580
1581 /* Insert any necessary type conversions to make the operands
1582 compatible. */
1583
1584 temp.expr_type = EXPR_OP;
1585 gfc_clear_ts (&temp.ts);
1586 temp.value.op.op = op;
1587
1588 temp.value.op.op1 = op1;
1589 temp.value.op.op2 = op2;
1590
1591 gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1592
1593 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1594 || op == INTRINSIC_GE || op == INTRINSIC_GT
1595 || op == INTRINSIC_LE || op == INTRINSIC_LT
1596 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1597 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1598 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1599 {
1600 temp.ts.type = BT_LOGICAL;
1601 temp.ts.kind = gfc_default_logical_kind;
1602 }
1603
1604 unary = 0;
1605 break;
1606
1607 /* Character binary */
1608 case INTRINSIC_CONCAT:
1609 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1610 || op1->ts.kind != op2->ts.kind)
1611 goto runtime;
1612
1613 temp.ts.type = BT_CHARACTER;
1614 temp.ts.kind = op1->ts.kind;
1615 unary = 0;
1616 break;
1617
1618 case INTRINSIC_USER:
1619 goto runtime;
1620
1621 default:
1622 gfc_internal_error ("eval_intrinsic(): Bad operator");
1623 }
1624
1625 if (op1->expr_type != EXPR_CONSTANT
1626 && (op1->expr_type != EXPR_ARRAY
1627 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1628 goto runtime;
1629
1630 if (op2 != NULL
1631 && op2->expr_type != EXPR_CONSTANT
1632 && (op2->expr_type != EXPR_ARRAY
1633 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1634 goto runtime;
1635
1636 if (unary)
1637 rc = reduce_unary (eval.f2, op1, &result);
1638 else
1639 rc = reduce_binary (eval.f3, op1, op2, &result);
1640
1641
1642 /* Something went wrong. */
1643 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1644 return NULL;
1645
1646 if (rc != ARITH_OK)
1647 {
1648 gfc_error (gfc_arith_error (rc), &op1->where);
1649 if (rc == ARITH_OVERFLOW)
1650 goto done;
1651
1652 if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1653 gfc_seen_div0 = true;
1654
1655 return NULL;
1656 }
1657
1658 done:
1659
1660 gfc_free_expr (op1);
1661 gfc_free_expr (op2);
1662 return result;
1663
1664 runtime:
1665 /* Create a run-time expression. */
1666 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1667 result->ts = temp.ts;
1668
1669 return result;
1670 }
1671
1672
1673 /* Modify type of expression for zero size array. */
1674
1675 static gfc_expr *
1676 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1677 {
1678 if (op == NULL)
1679 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1680
1681 switch (iop)
1682 {
1683 case INTRINSIC_GE:
1684 case INTRINSIC_GE_OS:
1685 case INTRINSIC_LT:
1686 case INTRINSIC_LT_OS:
1687 case INTRINSIC_LE:
1688 case INTRINSIC_LE_OS:
1689 case INTRINSIC_GT:
1690 case INTRINSIC_GT_OS:
1691 case INTRINSIC_EQ:
1692 case INTRINSIC_EQ_OS:
1693 case INTRINSIC_NE:
1694 case INTRINSIC_NE_OS:
1695 op->ts.type = BT_LOGICAL;
1696 op->ts.kind = gfc_default_logical_kind;
1697 break;
1698
1699 default:
1700 break;
1701 }
1702
1703 return op;
1704 }
1705
1706
1707 /* Return nonzero if the expression is a zero size array. */
1708
1709 static bool
1710 gfc_zero_size_array (gfc_expr *e)
1711 {
1712 if (e == NULL || e->expr_type != EXPR_ARRAY)
1713 return false;
1714
1715 return e->value.constructor == NULL;
1716 }
1717
1718
1719 /* Reduce a binary expression where at least one of the operands
1720 involves a zero-length array. Returns NULL if neither of the
1721 operands is a zero-length array. */
1722
1723 static gfc_expr *
1724 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1725 {
1726 if (gfc_zero_size_array (op1))
1727 {
1728 gfc_free_expr (op2);
1729 return op1;
1730 }
1731
1732 if (gfc_zero_size_array (op2))
1733 {
1734 gfc_free_expr (op1);
1735 return op2;
1736 }
1737
1738 return NULL;
1739 }
1740
1741
1742 static gfc_expr *
1743 eval_intrinsic_f2 (gfc_intrinsic_op op,
1744 arith (*eval) (gfc_expr *, gfc_expr **),
1745 gfc_expr *op1, gfc_expr *op2)
1746 {
1747 gfc_expr *result;
1748 eval_f f;
1749
1750 if (op2 == NULL)
1751 {
1752 if (gfc_zero_size_array (op1))
1753 return eval_type_intrinsic0 (op, op1);
1754 }
1755 else
1756 {
1757 result = reduce_binary0 (op1, op2);
1758 if (result != NULL)
1759 return eval_type_intrinsic0 (op, result);
1760 }
1761
1762 f.f2 = eval;
1763 return eval_intrinsic (op, f, op1, op2);
1764 }
1765
1766
1767 static gfc_expr *
1768 eval_intrinsic_f3 (gfc_intrinsic_op op,
1769 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1770 gfc_expr *op1, gfc_expr *op2)
1771 {
1772 gfc_expr *result;
1773 eval_f f;
1774
1775 if (!op1 && !op2)
1776 return NULL;
1777
1778 result = reduce_binary0 (op1, op2);
1779 if (result != NULL)
1780 return eval_type_intrinsic0(op, result);
1781
1782 f.f3 = eval;
1783 return eval_intrinsic (op, f, op1, op2);
1784 }
1785
1786
1787 gfc_expr *
1788 gfc_parentheses (gfc_expr *op)
1789 {
1790 if (gfc_is_constant_expr (op))
1791 return op;
1792
1793 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1794 op, NULL);
1795 }
1796
1797 gfc_expr *
1798 gfc_uplus (gfc_expr *op)
1799 {
1800 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1801 }
1802
1803
1804 gfc_expr *
1805 gfc_uminus (gfc_expr *op)
1806 {
1807 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1808 }
1809
1810
1811 gfc_expr *
1812 gfc_add (gfc_expr *op1, gfc_expr *op2)
1813 {
1814 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1815 }
1816
1817
1818 gfc_expr *
1819 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1820 {
1821 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1822 }
1823
1824
1825 gfc_expr *
1826 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1827 {
1828 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1829 }
1830
1831
1832 gfc_expr *
1833 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1834 {
1835 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1836 }
1837
1838
1839 gfc_expr *
1840 gfc_power (gfc_expr *op1, gfc_expr *op2)
1841 {
1842 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1843 }
1844
1845
1846 gfc_expr *
1847 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1848 {
1849 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1850 }
1851
1852
1853 gfc_expr *
1854 gfc_and (gfc_expr *op1, gfc_expr *op2)
1855 {
1856 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1857 }
1858
1859
1860 gfc_expr *
1861 gfc_or (gfc_expr *op1, gfc_expr *op2)
1862 {
1863 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1864 }
1865
1866
1867 gfc_expr *
1868 gfc_not (gfc_expr *op1)
1869 {
1870 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1871 }
1872
1873
1874 gfc_expr *
1875 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1876 {
1877 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1878 }
1879
1880
1881 gfc_expr *
1882 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1883 {
1884 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1885 }
1886
1887
1888 gfc_expr *
1889 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1890 {
1891 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1892 }
1893
1894
1895 gfc_expr *
1896 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1897 {
1898 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1899 }
1900
1901
1902 gfc_expr *
1903 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1904 {
1905 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1906 }
1907
1908
1909 gfc_expr *
1910 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1911 {
1912 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1913 }
1914
1915
1916 gfc_expr *
1917 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1918 {
1919 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1920 }
1921
1922
1923 gfc_expr *
1924 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1925 {
1926 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1927 }
1928
1929
1930 /******* Simplification of intrinsic functions with constant arguments *****/
1931
1932
1933 /* Deal with an arithmetic error. */
1934
1935 static void
1936 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1937 {
1938 switch (rc)
1939 {
1940 case ARITH_OK:
1941 gfc_error ("Arithmetic OK converting %s to %s at %L",
1942 gfc_typename (from), gfc_typename (to), where);
1943 break;
1944 case ARITH_OVERFLOW:
1945 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1946 "can be disabled with the option %<-fno-range-check%>",
1947 gfc_typename (from), gfc_typename (to), where);
1948 break;
1949 case ARITH_UNDERFLOW:
1950 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1951 "can be disabled with the option %<-fno-range-check%>",
1952 gfc_typename (from), gfc_typename (to), where);
1953 break;
1954 case ARITH_NAN:
1955 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1956 "can be disabled with the option %<-fno-range-check%>",
1957 gfc_typename (from), gfc_typename (to), where);
1958 break;
1959 case ARITH_DIV0:
1960 gfc_error ("Division by zero converting %s to %s at %L",
1961 gfc_typename (from), gfc_typename (to), where);
1962 break;
1963 case ARITH_INCOMMENSURATE:
1964 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1965 gfc_typename (from), gfc_typename (to), where);
1966 break;
1967 case ARITH_ASYMMETRIC:
1968 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1969 " converting %s to %s at %L",
1970 gfc_typename (from), gfc_typename (to), where);
1971 break;
1972 default:
1973 gfc_internal_error ("gfc_arith_error(): Bad error code");
1974 }
1975
1976 /* TODO: Do something about the error, i.e., throw exception, return
1977 NaN, etc. */
1978 }
1979
1980 /* Returns true if significant bits were lost when converting real
1981 constant r from from_kind to to_kind. */
1982
1983 static bool
1984 wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
1985 {
1986 mpfr_t rv, diff;
1987 bool ret;
1988
1989 gfc_set_model_kind (to_kind);
1990 mpfr_init (rv);
1991 gfc_set_model_kind (from_kind);
1992 mpfr_init (diff);
1993
1994 mpfr_set (rv, r, GFC_RND_MODE);
1995 mpfr_sub (diff, rv, r, GFC_RND_MODE);
1996
1997 ret = ! mpfr_zero_p (diff);
1998 mpfr_clear (rv);
1999 mpfr_clear (diff);
2000 return ret;
2001 }
2002
2003 /* Return true if conversion from an integer to a real loses precision. */
2004
2005 static bool
2006 wprecision_int_real (mpz_t n, mpfr_t r)
2007 {
2008 bool ret;
2009 mpz_t i;
2010 mpz_init (i);
2011 mpfr_get_z (i, r, GFC_RND_MODE);
2012 mpz_sub (i, i, n);
2013 ret = mpz_cmp_si (i, 0) != 0;
2014 mpz_clear (i);
2015 return ret;
2016 }
2017
2018 /* Convert integers to integers. */
2019
2020 gfc_expr *
2021 gfc_int2int (gfc_expr *src, int kind)
2022 {
2023 gfc_expr *result;
2024 arith rc;
2025
2026 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2027
2028 mpz_set (result->value.integer, src->value.integer);
2029
2030 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2031 {
2032 if (rc == ARITH_ASYMMETRIC)
2033 {
2034 gfc_warning (0, gfc_arith_error (rc), &src->where);
2035 }
2036 else
2037 {
2038 arith_error (rc, &src->ts, &result->ts, &src->where);
2039 gfc_free_expr (result);
2040 return NULL;
2041 }
2042 }
2043
2044 /* If we do not trap numeric overflow, we need to convert the number to
2045 signed, throwing away high-order bits if necessary. */
2046 if (flag_range_check == 0)
2047 {
2048 int k;
2049
2050 k = gfc_validate_kind (BT_INTEGER, kind, false);
2051 gfc_convert_mpz_to_signed (result->value.integer,
2052 gfc_integer_kinds[k].bit_size);
2053
2054 if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2055 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2056 gfc_typename (&src->ts), gfc_typename (&result->ts),
2057 &src->where);
2058 }
2059 return result;
2060 }
2061
2062
2063 /* Convert integers to reals. */
2064
2065 gfc_expr *
2066 gfc_int2real (gfc_expr *src, int kind)
2067 {
2068 gfc_expr *result;
2069 arith rc;
2070
2071 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2072
2073 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2074
2075 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2076 {
2077 arith_error (rc, &src->ts, &result->ts, &src->where);
2078 gfc_free_expr (result);
2079 return NULL;
2080 }
2081
2082 if (warn_conversion
2083 && wprecision_int_real (src->value.integer, result->value.real))
2084 gfc_warning (OPT_Wconversion, "Change of value in conversion "
2085 "from %qs to %qs at %L",
2086 gfc_typename (&src->ts),
2087 gfc_typename (&result->ts),
2088 &src->where);
2089
2090 return result;
2091 }
2092
2093
2094 /* Convert default integer to default complex. */
2095
2096 gfc_expr *
2097 gfc_int2complex (gfc_expr *src, int kind)
2098 {
2099 gfc_expr *result;
2100 arith rc;
2101
2102 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2103
2104 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2105
2106 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2107 != ARITH_OK)
2108 {
2109 arith_error (rc, &src->ts, &result->ts, &src->where);
2110 gfc_free_expr (result);
2111 return NULL;
2112 }
2113
2114 if (warn_conversion
2115 && wprecision_int_real (src->value.integer,
2116 mpc_realref (result->value.complex)))
2117 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2118 "from %qs to %qs at %L",
2119 gfc_typename (&src->ts),
2120 gfc_typename (&result->ts),
2121 &src->where);
2122
2123 return result;
2124 }
2125
2126
2127 /* Convert default real to default integer. */
2128
2129 gfc_expr *
2130 gfc_real2int (gfc_expr *src, int kind)
2131 {
2132 gfc_expr *result;
2133 arith rc;
2134 bool did_warn = false;
2135
2136 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2137
2138 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2139
2140 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2141 {
2142 arith_error (rc, &src->ts, &result->ts, &src->where);
2143 gfc_free_expr (result);
2144 return NULL;
2145 }
2146
2147 /* If there was a fractional part, warn about this. */
2148
2149 if (warn_conversion)
2150 {
2151 mpfr_t f;
2152 mpfr_init (f);
2153 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2154 if (mpfr_cmp_si (f, 0) != 0)
2155 {
2156 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2157 "from %qs to %qs at %L", gfc_typename (&src->ts),
2158 gfc_typename (&result->ts), &src->where);
2159 did_warn = true;
2160 }
2161 }
2162 if (!did_warn && warn_conversion_extra)
2163 {
2164 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2165 "at %L", gfc_typename (&src->ts),
2166 gfc_typename (&result->ts), &src->where);
2167 }
2168
2169 return result;
2170 }
2171
2172
2173 /* Convert real to real. */
2174
2175 gfc_expr *
2176 gfc_real2real (gfc_expr *src, int kind)
2177 {
2178 gfc_expr *result;
2179 arith rc;
2180 bool did_warn = false;
2181
2182 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2183
2184 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2185
2186 rc = gfc_check_real_range (result->value.real, kind);
2187
2188 if (rc == ARITH_UNDERFLOW)
2189 {
2190 if (warn_underflow)
2191 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2192 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2193 }
2194 else if (rc != ARITH_OK)
2195 {
2196 arith_error (rc, &src->ts, &result->ts, &src->where);
2197 gfc_free_expr (result);
2198 return NULL;
2199 }
2200
2201 /* As a special bonus, don't warn about REAL values which are not changed by
2202 the conversion if -Wconversion is specified and -Wconversion-extra is
2203 not. */
2204
2205 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2206 {
2207 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2208
2209 /* Calculate the difference between the constant and the rounded
2210 value and check it against zero. */
2211
2212 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2213 {
2214 gfc_warning_now (w, "Change of value in conversion from "
2215 "%qs to %qs at %L",
2216 gfc_typename (&src->ts), gfc_typename (&result->ts),
2217 &src->where);
2218 /* Make sure the conversion warning is not emitted again. */
2219 did_warn = true;
2220 }
2221 }
2222
2223 if (!did_warn && warn_conversion_extra)
2224 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2225 "at %L", gfc_typename(&src->ts),
2226 gfc_typename(&result->ts), &src->where);
2227
2228 return result;
2229 }
2230
2231
2232 /* Convert real to complex. */
2233
2234 gfc_expr *
2235 gfc_real2complex (gfc_expr *src, int kind)
2236 {
2237 gfc_expr *result;
2238 arith rc;
2239 bool did_warn = false;
2240
2241 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2242
2243 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2244
2245 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2246
2247 if (rc == ARITH_UNDERFLOW)
2248 {
2249 if (warn_underflow)
2250 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2251 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2252 }
2253 else if (rc != ARITH_OK)
2254 {
2255 arith_error (rc, &src->ts, &result->ts, &src->where);
2256 gfc_free_expr (result);
2257 return NULL;
2258 }
2259
2260 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2261 {
2262 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2263
2264 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2265 {
2266 gfc_warning_now (w, "Change of value in conversion from "
2267 "%qs to %qs at %L",
2268 gfc_typename (&src->ts), gfc_typename (&result->ts),
2269 &src->where);
2270 /* Make sure the conversion warning is not emitted again. */
2271 did_warn = true;
2272 }
2273 }
2274
2275 if (!did_warn && warn_conversion_extra)
2276 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2277 "at %L", gfc_typename(&src->ts),
2278 gfc_typename(&result->ts), &src->where);
2279
2280 return result;
2281 }
2282
2283
2284 /* Convert complex to integer. */
2285
2286 gfc_expr *
2287 gfc_complex2int (gfc_expr *src, int kind)
2288 {
2289 gfc_expr *result;
2290 arith rc;
2291 bool did_warn = false;
2292
2293 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2294
2295 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2296 &src->where);
2297
2298 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2299 {
2300 arith_error (rc, &src->ts, &result->ts, &src->where);
2301 gfc_free_expr (result);
2302 return NULL;
2303 }
2304
2305 if (warn_conversion || warn_conversion_extra)
2306 {
2307 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2308
2309 /* See if we discarded an imaginary part. */
2310 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2311 {
2312 gfc_warning_now (w, "Non-zero imaginary part discarded "
2313 "in conversion from %qs to %qs at %L",
2314 gfc_typename(&src->ts), gfc_typename (&result->ts),
2315 &src->where);
2316 did_warn = true;
2317 }
2318
2319 else {
2320 mpfr_t f;
2321
2322 mpfr_init (f);
2323 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2324 if (mpfr_cmp_si (f, 0) != 0)
2325 {
2326 gfc_warning_now (w, "Change of value in conversion from "
2327 "%qs to %qs at %L", gfc_typename (&src->ts),
2328 gfc_typename (&result->ts), &src->where);
2329 did_warn = true;
2330 }
2331 mpfr_clear (f);
2332 }
2333
2334 if (!did_warn && warn_conversion_extra)
2335 {
2336 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2337 "at %L", gfc_typename (&src->ts),
2338 gfc_typename (&result->ts), &src->where);
2339 }
2340 }
2341
2342 return result;
2343 }
2344
2345
2346 /* Convert complex to real. */
2347
2348 gfc_expr *
2349 gfc_complex2real (gfc_expr *src, int kind)
2350 {
2351 gfc_expr *result;
2352 arith rc;
2353 bool did_warn = false;
2354
2355 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2356
2357 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2358
2359 rc = gfc_check_real_range (result->value.real, kind);
2360
2361 if (rc == ARITH_UNDERFLOW)
2362 {
2363 if (warn_underflow)
2364 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2365 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2366 }
2367 if (rc != ARITH_OK)
2368 {
2369 arith_error (rc, &src->ts, &result->ts, &src->where);
2370 gfc_free_expr (result);
2371 return NULL;
2372 }
2373
2374 if (warn_conversion || warn_conversion_extra)
2375 {
2376 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2377
2378 /* See if we discarded an imaginary part. */
2379 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2380 {
2381 gfc_warning (w, "Non-zero imaginary part discarded "
2382 "in conversion from %qs to %qs at %L",
2383 gfc_typename(&src->ts), gfc_typename (&result->ts),
2384 &src->where);
2385 did_warn = true;
2386 }
2387
2388 /* Calculate the difference between the real constant and the rounded
2389 value and check it against zero. */
2390
2391 if (kind > src->ts.kind
2392 && wprecision_real_real (mpc_realref (src->value.complex),
2393 src->ts.kind, kind))
2394 {
2395 gfc_warning_now (w, "Change of value in conversion from "
2396 "%qs to %qs at %L",
2397 gfc_typename (&src->ts), gfc_typename (&result->ts),
2398 &src->where);
2399 /* Make sure the conversion warning is not emitted again. */
2400 did_warn = true;
2401 }
2402 }
2403
2404 if (!did_warn && warn_conversion_extra)
2405 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2406 gfc_typename(&src->ts), gfc_typename (&result->ts),
2407 &src->where);
2408
2409 return result;
2410 }
2411
2412
2413 /* Convert complex to complex. */
2414
2415 gfc_expr *
2416 gfc_complex2complex (gfc_expr *src, int kind)
2417 {
2418 gfc_expr *result;
2419 arith rc;
2420 bool did_warn = false;
2421
2422 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2423
2424 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2425
2426 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2427
2428 if (rc == ARITH_UNDERFLOW)
2429 {
2430 if (warn_underflow)
2431 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2432 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2433 }
2434 else if (rc != ARITH_OK)
2435 {
2436 arith_error (rc, &src->ts, &result->ts, &src->where);
2437 gfc_free_expr (result);
2438 return NULL;
2439 }
2440
2441 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2442
2443 if (rc == ARITH_UNDERFLOW)
2444 {
2445 if (warn_underflow)
2446 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2447 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2448 }
2449 else if (rc != ARITH_OK)
2450 {
2451 arith_error (rc, &src->ts, &result->ts, &src->where);
2452 gfc_free_expr (result);
2453 return NULL;
2454 }
2455
2456 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2457 && (wprecision_real_real (mpc_realref (src->value.complex),
2458 src->ts.kind, kind)
2459 || wprecision_real_real (mpc_imagref (src->value.complex),
2460 src->ts.kind, kind)))
2461 {
2462 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2463
2464 gfc_warning_now (w, "Change of value in conversion from "
2465 "%qs to %qs at %L",
2466 gfc_typename (&src->ts), gfc_typename (&result->ts),
2467 &src->where);
2468 did_warn = true;
2469 }
2470
2471 if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2472 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2473 "at %L", gfc_typename(&src->ts),
2474 gfc_typename (&result->ts), &src->where);
2475
2476 return result;
2477 }
2478
2479
2480 /* Logical kind conversion. */
2481
2482 gfc_expr *
2483 gfc_log2log (gfc_expr *src, int kind)
2484 {
2485 gfc_expr *result;
2486
2487 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2488 result->value.logical = src->value.logical;
2489
2490 return result;
2491 }
2492
2493
2494 /* Convert logical to integer. */
2495
2496 gfc_expr *
2497 gfc_log2int (gfc_expr *src, int kind)
2498 {
2499 gfc_expr *result;
2500
2501 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2502 mpz_set_si (result->value.integer, src->value.logical);
2503
2504 return result;
2505 }
2506
2507
2508 /* Convert integer to logical. */
2509
2510 gfc_expr *
2511 gfc_int2log (gfc_expr *src, int kind)
2512 {
2513 gfc_expr *result;
2514
2515 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2516 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2517
2518 return result;
2519 }
2520
2521 /* Convert character to character. We only use wide strings internally,
2522 so we only set the kind. */
2523
2524 gfc_expr *
2525 gfc_character2character (gfc_expr *src, int kind)
2526 {
2527 gfc_expr *result;
2528 result = gfc_copy_expr (src);
2529 result->ts.kind = kind;
2530
2531 return result;
2532 }
2533
2534 /* Helper function to set the representation in a Hollerith conversion.
2535 This assumes that the ts.type and ts.kind of the result have already
2536 been set. */
2537
2538 static void
2539 hollerith2representation (gfc_expr *result, gfc_expr *src)
2540 {
2541 size_t src_len, result_len;
2542
2543 src_len = src->representation.length - src->ts.u.pad;
2544 gfc_target_expr_size (result, &result_len);
2545
2546 if (src_len > result_len)
2547 {
2548 gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
2549 "is truncated in conversion to %qs", &src->where,
2550 gfc_typename(&result->ts));
2551 }
2552
2553 result->representation.string = XCNEWVEC (char, result_len + 1);
2554 memcpy (result->representation.string, src->representation.string,
2555 MIN (result_len, src_len));
2556
2557 if (src_len < result_len)
2558 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2559
2560 result->representation.string[result_len] = '\0'; /* For debugger */
2561 result->representation.length = result_len;
2562 }
2563
2564
2565 /* Helper function to set the representation in a character conversion.
2566 This assumes that the ts.type and ts.kind of the result have already
2567 been set. */
2568
2569 static void
2570 character2representation (gfc_expr *result, gfc_expr *src)
2571 {
2572 size_t src_len, result_len, i;
2573 src_len = src->value.character.length;
2574 gfc_target_expr_size (result, &result_len);
2575
2576 if (src_len > result_len)
2577 gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
2578 "truncated in conversion to %s", &src->where,
2579 gfc_typename(&result->ts));
2580
2581 result->representation.string = XCNEWVEC (char, result_len + 1);
2582
2583 for (i = 0; i < MIN (result_len, src_len); i++)
2584 result->representation.string[i] = (char) src->value.character.string[i];
2585
2586 if (src_len < result_len)
2587 memset (&result->representation.string[src_len], ' ',
2588 result_len - src_len);
2589
2590 result->representation.string[result_len] = '\0'; /* For debugger. */
2591 result->representation.length = result_len;
2592 }
2593
2594 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2595
2596 gfc_expr *
2597 gfc_hollerith2int (gfc_expr *src, int kind)
2598 {
2599 gfc_expr *result;
2600 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2601
2602 hollerith2representation (result, src);
2603 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2604 result->representation.length, result->value.integer);
2605
2606 return result;
2607 }
2608
2609 /* Convert character to integer. The constant will be padded or truncated. */
2610
2611 gfc_expr *
2612 gfc_character2int (gfc_expr *src, int kind)
2613 {
2614 gfc_expr *result;
2615 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2616
2617 character2representation (result, src);
2618 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2619 result->representation.length, result->value.integer);
2620 return result;
2621 }
2622
2623 /* Convert Hollerith to real. The constant will be padded or truncated. */
2624
2625 gfc_expr *
2626 gfc_hollerith2real (gfc_expr *src, int kind)
2627 {
2628 gfc_expr *result;
2629 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2630
2631 hollerith2representation (result, src);
2632 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2633 result->representation.length, result->value.real);
2634
2635 return result;
2636 }
2637
2638 /* Convert character to real. The constant will be padded or truncated. */
2639
2640 gfc_expr *
2641 gfc_character2real (gfc_expr *src, int kind)
2642 {
2643 gfc_expr *result;
2644 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2645
2646 character2representation (result, src);
2647 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2648 result->representation.length, result->value.real);
2649
2650 return result;
2651 }
2652
2653
2654 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2655
2656 gfc_expr *
2657 gfc_hollerith2complex (gfc_expr *src, int kind)
2658 {
2659 gfc_expr *result;
2660 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2661
2662 hollerith2representation (result, src);
2663 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2664 result->representation.length, result->value.complex);
2665
2666 return result;
2667 }
2668
2669 /* Convert character to complex. The constant will be padded or truncated. */
2670
2671 gfc_expr *
2672 gfc_character2complex (gfc_expr *src, int kind)
2673 {
2674 gfc_expr *result;
2675 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2676
2677 character2representation (result, src);
2678 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2679 result->representation.length, result->value.complex);
2680
2681 return result;
2682 }
2683
2684
2685 /* Convert Hollerith to character. */
2686
2687 gfc_expr *
2688 gfc_hollerith2character (gfc_expr *src, int kind)
2689 {
2690 gfc_expr *result;
2691
2692 result = gfc_copy_expr (src);
2693 result->ts.type = BT_CHARACTER;
2694 result->ts.kind = kind;
2695 result->ts.u.pad = 0;
2696
2697 result->value.character.length = result->representation.length;
2698 result->value.character.string
2699 = gfc_char_to_widechar (result->representation.string);
2700
2701 return result;
2702 }
2703
2704
2705 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2706
2707 gfc_expr *
2708 gfc_hollerith2logical (gfc_expr *src, int kind)
2709 {
2710 gfc_expr *result;
2711 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2712
2713 hollerith2representation (result, src);
2714 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2715 result->representation.length, &result->value.logical);
2716
2717 return result;
2718 }
2719
2720 /* Convert character to logical. The constant will be padded or truncated. */
2721
2722 gfc_expr *
2723 gfc_character2logical (gfc_expr *src, int kind)
2724 {
2725 gfc_expr *result;
2726 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2727
2728 character2representation (result, src);
2729 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2730 result->representation.length, &result->value.logical);
2731
2732 return result;
2733 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org