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