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