?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
libgo: update to Go 1.15.4 release
[official-gcc.git] / gcc / fortran / arith.c
blobc4c1041afdf1093c46ea082e7e96eda1537b2ecd
1 /* Compiler arithmetic
2 Copyright (C) 2000-2020 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 if (c->expr->expr_type == EXPR_CONSTANT)
1309 rc = eval (c->expr, op2, &r);
1310 else
1311 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1312
1313 if (rc != ARITH_OK)
1314 break;
1315
1316 gfc_replace_expr (c->expr, r);
1317 }
1318
1319 if (rc != ARITH_OK)
1320 gfc_constructor_free (head);
1321 else
1322 {
1323 gfc_constructor *c = gfc_constructor_first (head);
1324 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1325 &op1->where);
1326 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1327 r->rank = op1->rank;
1328 r->value.constructor = head;
1329 *result = r;
1330 }
1331
1332 return rc;
1333 }
1334
1335
1336 static arith
1337 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1338 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1339 {
1340 gfc_constructor_base head;
1341 gfc_constructor *c;
1342 gfc_expr *r;
1343 arith rc = ARITH_OK;
1344
1345 head = gfc_constructor_copy (op2->value.constructor);
1346 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1347 {
1348 if (c->expr->expr_type == EXPR_CONSTANT)
1349 rc = eval (op1, c->expr, &r);
1350 else
1351 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1352
1353 if (rc != ARITH_OK)
1354 break;
1355
1356 gfc_replace_expr (c->expr, r);
1357 }
1358
1359 if (rc != ARITH_OK)
1360 gfc_constructor_free (head);
1361 else
1362 {
1363 gfc_constructor *c = gfc_constructor_first (head);
1364 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1365 &op2->where);
1366 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1367 r->rank = op2->rank;
1368 r->value.constructor = head;
1369 *result = r;
1370 }
1371
1372 return rc;
1373 }
1374
1375
1376 /* We need a forward declaration of reduce_binary. */
1377 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1378 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1379
1380
1381 static arith
1382 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1383 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1384 {
1385 gfc_constructor_base head;
1386 gfc_constructor *c, *d;
1387 gfc_expr *r;
1388 arith rc = ARITH_OK;
1389
1390 if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1391 return ARITH_INCOMMENSURATE;
1392
1393 head = gfc_constructor_copy (op1->value.constructor);
1394 for (c = gfc_constructor_first (head),
1395 d = gfc_constructor_first (op2->value.constructor);
1396 c && d;
1397 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1398 {
1399 rc = reduce_binary (eval, c->expr, d->expr, &r);
1400 if (rc != ARITH_OK)
1401 break;
1402
1403 gfc_replace_expr (c->expr, r);
1404 }
1405
1406 if (c || d)
1407 rc = ARITH_INCOMMENSURATE;
1408
1409 if (rc != ARITH_OK)
1410 gfc_constructor_free (head);
1411 else
1412 {
1413 gfc_constructor *c = gfc_constructor_first (head);
1414 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1415 &op1->where);
1416 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1417 r->rank = op1->rank;
1418 r->value.constructor = head;
1419 *result = r;
1420 }
1421
1422 return rc;
1423 }
1424
1425
1426 static arith
1427 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1428 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1429 {
1430 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1431 return eval (op1, op2, result);
1432
1433 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1434 return reduce_binary_ca (eval, op1, op2, result);
1435
1436 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1437 return reduce_binary_ac (eval, op1, op2, result);
1438
1439 return reduce_binary_aa (eval, op1, op2, result);
1440 }
1441
1442
1443 typedef union
1444 {
1445 arith (*f2)(gfc_expr *, gfc_expr **);
1446 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1447 }
1448 eval_f;
1449
1450 /* High level arithmetic subroutines. These subroutines go into
1451 eval_intrinsic(), which can do one of several things to its
1452 operands. If the operands are incompatible with the intrinsic
1453 operation, we return a node pointing to the operands and hope that
1454 an operator interface is found during resolution.
1455
1456 If the operands are compatible and are constants, then we try doing
1457 the arithmetic. We also handle the cases where either or both
1458 operands are array constructors. */
1459
1460 static gfc_expr *
1461 eval_intrinsic (gfc_intrinsic_op op,
1462 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1463 {
1464 gfc_expr temp, *result;
1465 int unary;
1466 arith rc;
1467
1468 gfc_clear_ts (&temp.ts);
1469
1470 switch (op)
1471 {
1472 /* Logical unary */
1473 case INTRINSIC_NOT:
1474 if (op1->ts.type != BT_LOGICAL)
1475 goto runtime;
1476
1477 temp.ts.type = BT_LOGICAL;
1478 temp.ts.kind = gfc_default_logical_kind;
1479 unary = 1;
1480 break;
1481
1482 /* Logical binary operators */
1483 case INTRINSIC_OR:
1484 case INTRINSIC_AND:
1485 case INTRINSIC_NEQV:
1486 case INTRINSIC_EQV:
1487 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1488 goto runtime;
1489
1490 temp.ts.type = BT_LOGICAL;
1491 temp.ts.kind = gfc_default_logical_kind;
1492 unary = 0;
1493 break;
1494
1495 /* Numeric unary */
1496 case INTRINSIC_UPLUS:
1497 case INTRINSIC_UMINUS:
1498 if (!gfc_numeric_ts (&op1->ts))
1499 goto runtime;
1500
1501 temp.ts = op1->ts;
1502 unary = 1;
1503 break;
1504
1505 case INTRINSIC_PARENTHESES:
1506 temp.ts = op1->ts;
1507 unary = 1;
1508 break;
1509
1510 /* Additional restrictions for ordering relations. */
1511 case INTRINSIC_GE:
1512 case INTRINSIC_GE_OS:
1513 case INTRINSIC_LT:
1514 case INTRINSIC_LT_OS:
1515 case INTRINSIC_LE:
1516 case INTRINSIC_LE_OS:
1517 case INTRINSIC_GT:
1518 case INTRINSIC_GT_OS:
1519 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1520 {
1521 temp.ts.type = BT_LOGICAL;
1522 temp.ts.kind = gfc_default_logical_kind;
1523 goto runtime;
1524 }
1525
1526 /* Fall through */
1527 case INTRINSIC_EQ:
1528 case INTRINSIC_EQ_OS:
1529 case INTRINSIC_NE:
1530 case INTRINSIC_NE_OS:
1531 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1532 {
1533 unary = 0;
1534 temp.ts.type = BT_LOGICAL;
1535 temp.ts.kind = gfc_default_logical_kind;
1536
1537 /* If kind mismatch, exit and we'll error out later. */
1538 if (op1->ts.kind != op2->ts.kind)
1539 goto runtime;
1540
1541 break;
1542 }
1543
1544 gcc_fallthrough ();
1545 /* Numeric binary */
1546 case INTRINSIC_PLUS:
1547 case INTRINSIC_MINUS:
1548 case INTRINSIC_TIMES:
1549 case INTRINSIC_DIVIDE:
1550 case INTRINSIC_POWER:
1551 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1552 goto runtime;
1553
1554 /* Insert any necessary type conversions to make the operands
1555 compatible. */
1556
1557 temp.expr_type = EXPR_OP;
1558 gfc_clear_ts (&temp.ts);
1559 temp.value.op.op = op;
1560
1561 temp.value.op.op1 = op1;
1562 temp.value.op.op2 = op2;
1563
1564 gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1565
1566 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1567 || op == INTRINSIC_GE || op == INTRINSIC_GT
1568 || op == INTRINSIC_LE || op == INTRINSIC_LT
1569 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1570 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1571 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1572 {
1573 temp.ts.type = BT_LOGICAL;
1574 temp.ts.kind = gfc_default_logical_kind;
1575 }
1576
1577 unary = 0;
1578 break;
1579
1580 /* Character binary */
1581 case INTRINSIC_CONCAT:
1582 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1583 || op1->ts.kind != op2->ts.kind)
1584 goto runtime;
1585
1586 temp.ts.type = BT_CHARACTER;
1587 temp.ts.kind = op1->ts.kind;
1588 unary = 0;
1589 break;
1590
1591 case INTRINSIC_USER:
1592 goto runtime;
1593
1594 default:
1595 gfc_internal_error ("eval_intrinsic(): Bad operator");
1596 }
1597
1598 if (op1->expr_type != EXPR_CONSTANT
1599 && (op1->expr_type != EXPR_ARRAY
1600 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1601 goto runtime;
1602
1603 if (op2 != NULL
1604 && op2->expr_type != EXPR_CONSTANT
1605 && (op2->expr_type != EXPR_ARRAY
1606 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1607 goto runtime;
1608
1609 if (unary)
1610 rc = reduce_unary (eval.f2, op1, &result);
1611 else
1612 rc = reduce_binary (eval.f3, op1, op2, &result);
1613
1614
1615 /* Something went wrong. */
1616 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1617 return NULL;
1618
1619 if (rc != ARITH_OK)
1620 {
1621 gfc_error (gfc_arith_error (rc), &op1->where);
1622 if (rc == ARITH_OVERFLOW)
1623 goto done;
1624
1625 if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1626 gfc_seen_div0 = true;
1627
1628 return NULL;
1629 }
1630
1631 done:
1632
1633 gfc_free_expr (op1);
1634 gfc_free_expr (op2);
1635 return result;
1636
1637 runtime:
1638 /* Create a run-time expression. */
1639 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1640 result->ts = temp.ts;
1641
1642 return result;
1643 }
1644
1645
1646 /* Modify type of expression for zero size array. */
1647
1648 static gfc_expr *
1649 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1650 {
1651 if (op == NULL)
1652 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1653
1654 switch (iop)
1655 {
1656 case INTRINSIC_GE:
1657 case INTRINSIC_GE_OS:
1658 case INTRINSIC_LT:
1659 case INTRINSIC_LT_OS:
1660 case INTRINSIC_LE:
1661 case INTRINSIC_LE_OS:
1662 case INTRINSIC_GT:
1663 case INTRINSIC_GT_OS:
1664 case INTRINSIC_EQ:
1665 case INTRINSIC_EQ_OS:
1666 case INTRINSIC_NE:
1667 case INTRINSIC_NE_OS:
1668 op->ts.type = BT_LOGICAL;
1669 op->ts.kind = gfc_default_logical_kind;
1670 break;
1671
1672 default:
1673 break;
1674 }
1675
1676 return op;
1677 }
1678
1679
1680 /* Return nonzero if the expression is a zero size array. */
1681
1682 static int
1683 gfc_zero_size_array (gfc_expr *e)
1684 {
1685 if (e->expr_type != EXPR_ARRAY)
1686 return 0;
1687
1688 return e->value.constructor == NULL;
1689 }
1690
1691
1692 /* Reduce a binary expression where at least one of the operands
1693 involves a zero-length array. Returns NULL if neither of the
1694 operands is a zero-length array. */
1695
1696 static gfc_expr *
1697 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1698 {
1699 if (gfc_zero_size_array (op1))
1700 {
1701 gfc_free_expr (op2);
1702 return op1;
1703 }
1704
1705 if (gfc_zero_size_array (op2))
1706 {
1707 gfc_free_expr (op1);
1708 return op2;
1709 }
1710
1711 return NULL;
1712 }
1713
1714
1715 static gfc_expr *
1716 eval_intrinsic_f2 (gfc_intrinsic_op op,
1717 arith (*eval) (gfc_expr *, gfc_expr **),
1718 gfc_expr *op1, gfc_expr *op2)
1719 {
1720 gfc_expr *result;
1721 eval_f f;
1722
1723 if (op2 == NULL)
1724 {
1725 if (gfc_zero_size_array (op1))
1726 return eval_type_intrinsic0 (op, op1);
1727 }
1728 else
1729 {
1730 result = reduce_binary0 (op1, op2);
1731 if (result != NULL)
1732 return eval_type_intrinsic0 (op, result);
1733 }
1734
1735 f.f2 = eval;
1736 return eval_intrinsic (op, f, op1, op2);
1737 }
1738
1739
1740 static gfc_expr *
1741 eval_intrinsic_f3 (gfc_intrinsic_op op,
1742 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1743 gfc_expr *op1, gfc_expr *op2)
1744 {
1745 gfc_expr *result;
1746 eval_f f;
1747
1748 if (!op1 && !op2)
1749 return NULL;
1750
1751 result = reduce_binary0 (op1, op2);
1752 if (result != NULL)
1753 return eval_type_intrinsic0(op, result);
1754
1755 f.f3 = eval;
1756 return eval_intrinsic (op, f, op1, op2);
1757 }
1758
1759
1760 gfc_expr *
1761 gfc_parentheses (gfc_expr *op)
1762 {
1763 if (gfc_is_constant_expr (op))
1764 return op;
1765
1766 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1767 op, NULL);
1768 }
1769
1770 gfc_expr *
1771 gfc_uplus (gfc_expr *op)
1772 {
1773 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1774 }
1775
1776
1777 gfc_expr *
1778 gfc_uminus (gfc_expr *op)
1779 {
1780 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1781 }
1782
1783
1784 gfc_expr *
1785 gfc_add (gfc_expr *op1, gfc_expr *op2)
1786 {
1787 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1788 }
1789
1790
1791 gfc_expr *
1792 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1793 {
1794 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1795 }
1796
1797
1798 gfc_expr *
1799 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1800 {
1801 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1802 }
1803
1804
1805 gfc_expr *
1806 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1807 {
1808 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1809 }
1810
1811
1812 gfc_expr *
1813 gfc_power (gfc_expr *op1, gfc_expr *op2)
1814 {
1815 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1816 }
1817
1818
1819 gfc_expr *
1820 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1821 {
1822 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1823 }
1824
1825
1826 gfc_expr *
1827 gfc_and (gfc_expr *op1, gfc_expr *op2)
1828 {
1829 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1830 }
1831
1832
1833 gfc_expr *
1834 gfc_or (gfc_expr *op1, gfc_expr *op2)
1835 {
1836 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1837 }
1838
1839
1840 gfc_expr *
1841 gfc_not (gfc_expr *op1)
1842 {
1843 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1844 }
1845
1846
1847 gfc_expr *
1848 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1849 {
1850 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1851 }
1852
1853
1854 gfc_expr *
1855 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1856 {
1857 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1858 }
1859
1860
1861 gfc_expr *
1862 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1863 {
1864 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1865 }
1866
1867
1868 gfc_expr *
1869 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1870 {
1871 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1872 }
1873
1874
1875 gfc_expr *
1876 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1877 {
1878 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1879 }
1880
1881
1882 gfc_expr *
1883 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1884 {
1885 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1886 }
1887
1888
1889 gfc_expr *
1890 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1891 {
1892 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1893 }
1894
1895
1896 gfc_expr *
1897 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1898 {
1899 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1900 }
1901
1902
1903 /******* Simplification of intrinsic functions with constant arguments *****/
1904
1905
1906 /* Deal with an arithmetic error. */
1907
1908 static void
1909 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1910 {
1911 switch (rc)
1912 {
1913 case ARITH_OK:
1914 gfc_error ("Arithmetic OK converting %s to %s at %L",
1915 gfc_typename (from), gfc_typename (to), where);
1916 break;
1917 case ARITH_OVERFLOW:
1918 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1919 "can be disabled with the option %<-fno-range-check%>",
1920 gfc_typename (from), gfc_typename (to), where);
1921 break;
1922 case ARITH_UNDERFLOW:
1923 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1924 "can be disabled with the option %<-fno-range-check%>",
1925 gfc_typename (from), gfc_typename (to), where);
1926 break;
1927 case ARITH_NAN:
1928 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1929 "can be disabled with the option %<-fno-range-check%>",
1930 gfc_typename (from), gfc_typename (to), where);
1931 break;
1932 case ARITH_DIV0:
1933 gfc_error ("Division by zero converting %s to %s at %L",
1934 gfc_typename (from), gfc_typename (to), where);
1935 break;
1936 case ARITH_INCOMMENSURATE:
1937 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1938 gfc_typename (from), gfc_typename (to), where);
1939 break;
1940 case ARITH_ASYMMETRIC:
1941 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1942 " converting %s to %s at %L",
1943 gfc_typename (from), gfc_typename (to), where);
1944 break;
1945 default:
1946 gfc_internal_error ("gfc_arith_error(): Bad error code");
1947 }
1948
1949 /* TODO: Do something about the error, i.e., throw exception, return
1950 NaN, etc. */
1951 }
1952
1953 /* Returns true if significant bits were lost when converting real
1954 constant r from from_kind to to_kind. */
1955
1956 static bool
1957 wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
1958 {
1959 mpfr_t rv, diff;
1960 bool ret;
1961
1962 gfc_set_model_kind (to_kind);
1963 mpfr_init (rv);
1964 gfc_set_model_kind (from_kind);
1965 mpfr_init (diff);
1966
1967 mpfr_set (rv, r, GFC_RND_MODE);
1968 mpfr_sub (diff, rv, r, GFC_RND_MODE);
1969
1970 ret = ! mpfr_zero_p (diff);
1971 mpfr_clear (rv);
1972 mpfr_clear (diff);
1973 return ret;
1974 }
1975
1976 /* Return true if conversion from an integer to a real loses precision. */
1977
1978 static bool
1979 wprecision_int_real (mpz_t n, mpfr_t r)
1980 {
1981 bool ret;
1982 mpz_t i;
1983 mpz_init (i);
1984 mpfr_get_z (i, r, GFC_RND_MODE);
1985 mpz_sub (i, i, n);
1986 ret = mpz_cmp_si (i, 0) != 0;
1987 mpz_clear (i);
1988 return ret;
1989 }
1990
1991 /* Convert integers to integers. */
1992
1993 gfc_expr *
1994 gfc_int2int (gfc_expr *src, int kind)
1995 {
1996 gfc_expr *result;
1997 arith rc;
1998
1999 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2000
2001 mpz_set (result->value.integer, src->value.integer);
2002
2003 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2004 {
2005 if (rc == ARITH_ASYMMETRIC)
2006 {
2007 gfc_warning (0, gfc_arith_error (rc), &src->where);
2008 }
2009 else
2010 {
2011 arith_error (rc, &src->ts, &result->ts, &src->where);
2012 gfc_free_expr (result);
2013 return NULL;
2014 }
2015 }
2016
2017 /* If we do not trap numeric overflow, we need to convert the number to
2018 signed, throwing away high-order bits if necessary. */
2019 if (flag_range_check == 0)
2020 {
2021 int k;
2022
2023 k = gfc_validate_kind (BT_INTEGER, kind, false);
2024 gfc_convert_mpz_to_signed (result->value.integer,
2025 gfc_integer_kinds[k].bit_size);
2026
2027 if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2028 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2029 gfc_typename (&src->ts), gfc_typename (&result->ts),
2030 &src->where);
2031 }
2032 return result;
2033 }
2034
2035
2036 /* Convert integers to reals. */
2037
2038 gfc_expr *
2039 gfc_int2real (gfc_expr *src, int kind)
2040 {
2041 gfc_expr *result;
2042 arith rc;
2043
2044 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2045
2046 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2047
2048 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2049 {
2050 arith_error (rc, &src->ts, &result->ts, &src->where);
2051 gfc_free_expr (result);
2052 return NULL;
2053 }
2054
2055 if (warn_conversion
2056 && wprecision_int_real (src->value.integer, result->value.real))
2057 gfc_warning (OPT_Wconversion, "Change of value in conversion "
2058 "from %qs to %qs at %L",
2059 gfc_typename (&src->ts),
2060 gfc_typename (&result->ts),
2061 &src->where);
2062
2063 return result;
2064 }
2065
2066
2067 /* Convert default integer to default complex. */
2068
2069 gfc_expr *
2070 gfc_int2complex (gfc_expr *src, int kind)
2071 {
2072 gfc_expr *result;
2073 arith rc;
2074
2075 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2076
2077 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2078
2079 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2080 != ARITH_OK)
2081 {
2082 arith_error (rc, &src->ts, &result->ts, &src->where);
2083 gfc_free_expr (result);
2084 return NULL;
2085 }
2086
2087 if (warn_conversion
2088 && wprecision_int_real (src->value.integer,
2089 mpc_realref (result->value.complex)))
2090 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2091 "from %qs to %qs at %L",
2092 gfc_typename (&src->ts),
2093 gfc_typename (&result->ts),
2094 &src->where);
2095
2096 return result;
2097 }
2098
2099
2100 /* Convert default real to default integer. */
2101
2102 gfc_expr *
2103 gfc_real2int (gfc_expr *src, int kind)
2104 {
2105 gfc_expr *result;
2106 arith rc;
2107 bool did_warn = false;
2108
2109 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2110
2111 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2112
2113 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2114 {
2115 arith_error (rc, &src->ts, &result->ts, &src->where);
2116 gfc_free_expr (result);
2117 return NULL;
2118 }
2119
2120 /* If there was a fractional part, warn about this. */
2121
2122 if (warn_conversion)
2123 {
2124 mpfr_t f;
2125 mpfr_init (f);
2126 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2127 if (mpfr_cmp_si (f, 0) != 0)
2128 {
2129 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2130 "from %qs to %qs at %L", gfc_typename (&src->ts),
2131 gfc_typename (&result->ts), &src->where);
2132 did_warn = true;
2133 }
2134 }
2135 if (!did_warn && warn_conversion_extra)
2136 {
2137 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2138 "at %L", gfc_typename (&src->ts),
2139 gfc_typename (&result->ts), &src->where);
2140 }
2141
2142 return result;
2143 }
2144
2145
2146 /* Convert real to real. */
2147
2148 gfc_expr *
2149 gfc_real2real (gfc_expr *src, int kind)
2150 {
2151 gfc_expr *result;
2152 arith rc;
2153 bool did_warn = false;
2154
2155 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2156
2157 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2158
2159 rc = gfc_check_real_range (result->value.real, kind);
2160
2161 if (rc == ARITH_UNDERFLOW)
2162 {
2163 if (warn_underflow)
2164 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2165 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2166 }
2167 else if (rc != ARITH_OK)
2168 {
2169 arith_error (rc, &src->ts, &result->ts, &src->where);
2170 gfc_free_expr (result);
2171 return NULL;
2172 }
2173
2174 /* As a special bonus, don't warn about REAL values which are not changed by
2175 the conversion if -Wconversion is specified and -Wconversion-extra is
2176 not. */
2177
2178 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2179 {
2180 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2181
2182 /* Calculate the difference between the constant and the rounded
2183 value and check it against zero. */
2184
2185 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2186 {
2187 gfc_warning_now (w, "Change of value in conversion from "
2188 "%qs to %qs at %L",
2189 gfc_typename (&src->ts), gfc_typename (&result->ts),
2190 &src->where);
2191 /* Make sure the conversion warning is not emitted again. */
2192 did_warn = true;
2193 }
2194 }
2195
2196 if (!did_warn && warn_conversion_extra)
2197 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2198 "at %L", gfc_typename(&src->ts),
2199 gfc_typename(&result->ts), &src->where);
2200
2201 return result;
2202 }
2203
2204
2205 /* Convert real to complex. */
2206
2207 gfc_expr *
2208 gfc_real2complex (gfc_expr *src, int kind)
2209 {
2210 gfc_expr *result;
2211 arith rc;
2212 bool did_warn = false;
2213
2214 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2215
2216 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2217
2218 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2219
2220 if (rc == ARITH_UNDERFLOW)
2221 {
2222 if (warn_underflow)
2223 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2224 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2225 }
2226 else if (rc != ARITH_OK)
2227 {
2228 arith_error (rc, &src->ts, &result->ts, &src->where);
2229 gfc_free_expr (result);
2230 return NULL;
2231 }
2232
2233 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2234 {
2235 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2236
2237 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2238 {
2239 gfc_warning_now (w, "Change of value in conversion from "
2240 "%qs to %qs at %L",
2241 gfc_typename (&src->ts), gfc_typename (&result->ts),
2242 &src->where);
2243 /* Make sure the conversion warning is not emitted again. */
2244 did_warn = true;
2245 }
2246 }
2247
2248 if (!did_warn && warn_conversion_extra)
2249 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2250 "at %L", gfc_typename(&src->ts),
2251 gfc_typename(&result->ts), &src->where);
2252
2253 return result;
2254 }
2255
2256
2257 /* Convert complex to integer. */
2258
2259 gfc_expr *
2260 gfc_complex2int (gfc_expr *src, int kind)
2261 {
2262 gfc_expr *result;
2263 arith rc;
2264 bool did_warn = false;
2265
2266 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2267
2268 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2269 &src->where);
2270
2271 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2272 {
2273 arith_error (rc, &src->ts, &result->ts, &src->where);
2274 gfc_free_expr (result);
2275 return NULL;
2276 }
2277
2278 if (warn_conversion || warn_conversion_extra)
2279 {
2280 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2281
2282 /* See if we discarded an imaginary part. */
2283 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2284 {
2285 gfc_warning_now (w, "Non-zero imaginary part discarded "
2286 "in conversion from %qs to %qs at %L",
2287 gfc_typename(&src->ts), gfc_typename (&result->ts),
2288 &src->where);
2289 did_warn = true;
2290 }
2291
2292 else {
2293 mpfr_t f;
2294
2295 mpfr_init (f);
2296 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2297 if (mpfr_cmp_si (f, 0) != 0)
2298 {
2299 gfc_warning_now (w, "Change of value in conversion from "
2300 "%qs to %qs at %L", gfc_typename (&src->ts),
2301 gfc_typename (&result->ts), &src->where);
2302 did_warn = true;
2303 }
2304 mpfr_clear (f);
2305 }
2306
2307 if (!did_warn && warn_conversion_extra)
2308 {
2309 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2310 "at %L", gfc_typename (&src->ts),
2311 gfc_typename (&result->ts), &src->where);
2312 }
2313 }
2314
2315 return result;
2316 }
2317
2318
2319 /* Convert complex to real. */
2320
2321 gfc_expr *
2322 gfc_complex2real (gfc_expr *src, int kind)
2323 {
2324 gfc_expr *result;
2325 arith rc;
2326 bool did_warn = false;
2327
2328 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2329
2330 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2331
2332 rc = gfc_check_real_range (result->value.real, kind);
2333
2334 if (rc == ARITH_UNDERFLOW)
2335 {
2336 if (warn_underflow)
2337 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2338 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2339 }
2340 if (rc != ARITH_OK)
2341 {
2342 arith_error (rc, &src->ts, &result->ts, &src->where);
2343 gfc_free_expr (result);
2344 return NULL;
2345 }
2346
2347 if (warn_conversion || warn_conversion_extra)
2348 {
2349 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2350
2351 /* See if we discarded an imaginary part. */
2352 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2353 {
2354 gfc_warning (w, "Non-zero imaginary part discarded "
2355 "in conversion from %qs to %qs at %L",
2356 gfc_typename(&src->ts), gfc_typename (&result->ts),
2357 &src->where);
2358 did_warn = true;
2359 }
2360
2361 /* Calculate the difference between the real constant and the rounded
2362 value and check it against zero. */
2363
2364 if (kind > src->ts.kind
2365 && wprecision_real_real (mpc_realref (src->value.complex),
2366 src->ts.kind, kind))
2367 {
2368 gfc_warning_now (w, "Change of value in conversion from "
2369 "%qs to %qs at %L",
2370 gfc_typename (&src->ts), gfc_typename (&result->ts),
2371 &src->where);
2372 /* Make sure the conversion warning is not emitted again. */
2373 did_warn = true;
2374 }
2375 }
2376
2377 if (!did_warn && warn_conversion_extra)
2378 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2379 gfc_typename(&src->ts), gfc_typename (&result->ts),
2380 &src->where);
2381
2382 return result;
2383 }
2384
2385
2386 /* Convert complex to complex. */
2387
2388 gfc_expr *
2389 gfc_complex2complex (gfc_expr *src, int kind)
2390 {
2391 gfc_expr *result;
2392 arith rc;
2393 bool did_warn = false;
2394
2395 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2396
2397 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2398
2399 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2400
2401 if (rc == ARITH_UNDERFLOW)
2402 {
2403 if (warn_underflow)
2404 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2405 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2406 }
2407 else if (rc != ARITH_OK)
2408 {
2409 arith_error (rc, &src->ts, &result->ts, &src->where);
2410 gfc_free_expr (result);
2411 return NULL;
2412 }
2413
2414 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2415
2416 if (rc == ARITH_UNDERFLOW)
2417 {
2418 if (warn_underflow)
2419 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2420 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2421 }
2422 else if (rc != ARITH_OK)
2423 {
2424 arith_error (rc, &src->ts, &result->ts, &src->where);
2425 gfc_free_expr (result);
2426 return NULL;
2427 }
2428
2429 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2430 && (wprecision_real_real (mpc_realref (src->value.complex),
2431 src->ts.kind, kind)
2432 || wprecision_real_real (mpc_imagref (src->value.complex),
2433 src->ts.kind, kind)))
2434 {
2435 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2436
2437 gfc_warning_now (w, "Change of value in conversion from "
2438 "%qs to %qs at %L",
2439 gfc_typename (&src->ts), gfc_typename (&result->ts),
2440 &src->where);
2441 did_warn = true;
2442 }
2443
2444 if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2445 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2446 "at %L", gfc_typename(&src->ts),
2447 gfc_typename (&result->ts), &src->where);
2448
2449 return result;
2450 }
2451
2452
2453 /* Logical kind conversion. */
2454
2455 gfc_expr *
2456 gfc_log2log (gfc_expr *src, int kind)
2457 {
2458 gfc_expr *result;
2459
2460 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2461 result->value.logical = src->value.logical;
2462
2463 return result;
2464 }
2465
2466
2467 /* Convert logical to integer. */
2468
2469 gfc_expr *
2470 gfc_log2int (gfc_expr *src, int kind)
2471 {
2472 gfc_expr *result;
2473
2474 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2475 mpz_set_si (result->value.integer, src->value.logical);
2476
2477 return result;
2478 }
2479
2480
2481 /* Convert integer to logical. */
2482
2483 gfc_expr *
2484 gfc_int2log (gfc_expr *src, int kind)
2485 {
2486 gfc_expr *result;
2487
2488 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2489 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2490
2491 return result;
2492 }
2493
2494 /* Convert character to character. We only use wide strings internally,
2495 so we only set the kind. */
2496
2497 gfc_expr *
2498 gfc_character2character (gfc_expr *src, int kind)
2499 {
2500 gfc_expr *result;
2501 result = gfc_copy_expr (src);
2502 result->ts.kind = kind;
2503
2504 return result;
2505 }
2506
2507 /* Helper function to set the representation in a Hollerith conversion.
2508 This assumes that the ts.type and ts.kind of the result have already
2509 been set. */
2510
2511 static void
2512 hollerith2representation (gfc_expr *result, gfc_expr *src)
2513 {
2514 size_t src_len, result_len;
2515
2516 src_len = src->representation.length - src->ts.u.pad;
2517 gfc_target_expr_size (result, &result_len);
2518
2519 if (src_len > result_len)
2520 {
2521 gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
2522 "is truncated in conversion to %qs", &src->where,
2523 gfc_typename(&result->ts));
2524 }
2525
2526 result->representation.string = XCNEWVEC (char, result_len + 1);
2527 memcpy (result->representation.string, src->representation.string,
2528 MIN (result_len, src_len));
2529
2530 if (src_len < result_len)
2531 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2532
2533 result->representation.string[result_len] = '\0'; /* For debugger */
2534 result->representation.length = result_len;
2535 }
2536
2537
2538 /* Helper function to set the representation in a character conversion.
2539 This assumes that the ts.type and ts.kind of the result have already
2540 been set. */
2541
2542 static void
2543 character2representation (gfc_expr *result, gfc_expr *src)
2544 {
2545 size_t src_len, result_len, i;
2546 src_len = src->value.character.length;
2547 gfc_target_expr_size (result, &result_len);
2548
2549 if (src_len > result_len)
2550 gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
2551 "truncated in conversion to %s", &src->where,
2552 gfc_typename(&result->ts));
2553
2554 result->representation.string = XCNEWVEC (char, result_len + 1);
2555
2556 for (i = 0; i < MIN (result_len, src_len); i++)
2557 result->representation.string[i] = (char) src->value.character.string[i];
2558
2559 if (src_len < result_len)
2560 memset (&result->representation.string[src_len], ' ',
2561 result_len - src_len);
2562
2563 result->representation.string[result_len] = '\0'; /* For debugger. */
2564 result->representation.length = result_len;
2565 }
2566
2567 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2568
2569 gfc_expr *
2570 gfc_hollerith2int (gfc_expr *src, int kind)
2571 {
2572 gfc_expr *result;
2573 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2574
2575 hollerith2representation (result, src);
2576 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2577 result->representation.length, result->value.integer);
2578
2579 return result;
2580 }
2581
2582 /* Convert character to integer. The constant will be padded or truncated. */
2583
2584 gfc_expr *
2585 gfc_character2int (gfc_expr *src, int kind)
2586 {
2587 gfc_expr *result;
2588 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2589
2590 character2representation (result, src);
2591 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2592 result->representation.length, result->value.integer);
2593 return result;
2594 }
2595
2596 /* Convert Hollerith to real. The constant will be padded or truncated. */
2597
2598 gfc_expr *
2599 gfc_hollerith2real (gfc_expr *src, int kind)
2600 {
2601 gfc_expr *result;
2602 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2603
2604 hollerith2representation (result, src);
2605 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2606 result->representation.length, result->value.real);
2607
2608 return result;
2609 }
2610
2611 /* Convert character to real. The constant will be padded or truncated. */
2612
2613 gfc_expr *
2614 gfc_character2real (gfc_expr *src, int kind)
2615 {
2616 gfc_expr *result;
2617 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2618
2619 character2representation (result, src);
2620 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2621 result->representation.length, result->value.real);
2622
2623 return result;
2624 }
2625
2626
2627 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2628
2629 gfc_expr *
2630 gfc_hollerith2complex (gfc_expr *src, int kind)
2631 {
2632 gfc_expr *result;
2633 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2634
2635 hollerith2representation (result, src);
2636 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2637 result->representation.length, result->value.complex);
2638
2639 return result;
2640 }
2641
2642 /* Convert character to complex. The constant will be padded or truncated. */
2643
2644 gfc_expr *
2645 gfc_character2complex (gfc_expr *src, int kind)
2646 {
2647 gfc_expr *result;
2648 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2649
2650 character2representation (result, src);
2651 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2652 result->representation.length, result->value.complex);
2653
2654 return result;
2655 }
2656
2657
2658 /* Convert Hollerith to character. */
2659
2660 gfc_expr *
2661 gfc_hollerith2character (gfc_expr *src, int kind)
2662 {
2663 gfc_expr *result;
2664
2665 result = gfc_copy_expr (src);
2666 result->ts.type = BT_CHARACTER;
2667 result->ts.kind = kind;
2668 result->ts.u.pad = 0;
2669
2670 result->value.character.length = result->representation.length;
2671 result->value.character.string
2672 = gfc_char_to_widechar (result->representation.string);
2673
2674 return result;
2675 }
2676
2677
2678 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2679
2680 gfc_expr *
2681 gfc_hollerith2logical (gfc_expr *src, int kind)
2682 {
2683 gfc_expr *result;
2684 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2685
2686 hollerith2representation (result, src);
2687 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2688 result->representation.length, &result->value.logical);
2689
2690 return result;
2691 }
2692
2693 /* Convert character to logical. The constant will be padded or truncated. */
2694
2695 gfc_expr *
2696 gfc_character2logical (gfc_expr *src, int kind)
2697 {
2698 gfc_expr *result;
2699 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2700
2701 character2representation (result, src);
2702 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2703 result->representation.length, &result->value.logical);
2704
2705 return result;
2706 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org