?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
pr70100.c: Add -mvsx.
[official-gcc.git] / gcc / fortran / arith.c
blobff279db49926c6068add85217ac789859d033474
1 /* Compiler arithmetic
2 Copyright (C) 2000-2019 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 /* First, we simplify the cases of op1 == 1, 0 or -1. */
852 if (mpz_cmp_si (op1->value.integer, 1) == 0)
853 {
854 /* 1**op2 == 1 */
855 mpz_set_si (result->value.integer, 1);
856 }
857 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
858 {
859 /* 0**op2 == 0, if op2 > 0
860 0**op2 overflow, if op2 < 0 ; in that case, we
861 set the result to 0 and return ARITH_DIV0. */
862 mpz_set_si (result->value.integer, 0);
863 if (mpz_cmp_si (op2->value.integer, 0) < 0)
864 rc = ARITH_DIV0;
865 }
866 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
867 {
868 /* (-1)**op2 == (-1)**(mod(op2,2)) */
869 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
870 if (odd)
871 mpz_set_si (result->value.integer, -1);
872 else
873 mpz_set_si (result->value.integer, 1);
874 }
875 /* Then, we take care of op2 < 0. */
876 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
877 {
878 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
879 mpz_set_si (result->value.integer, 0);
880 if (warn_integer_division)
881 gfc_warning_now (OPT_Winteger_division, "Negative "
882 "exponent of integer has zero "
883 "result at %L", &result->where);
884 }
885 else
886 {
887 /* We have abs(op1) > 1 and op2 > 1.
888 If op2 > bit_size(op1), we'll have an out-of-range
889 result. */
890 int k, power;
891
892 k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
893 power = gfc_integer_kinds[k].bit_size;
894 if (mpz_cmp_si (op2->value.integer, power) < 0)
895 {
896 gfc_extract_int (op2, &power);
897 mpz_pow_ui (result->value.integer, op1->value.integer,
898 power);
899 rc = gfc_range_check (result);
900 if (rc == ARITH_OVERFLOW)
901 gfc_error_now ("Result of exponentiation at %L "
902 "exceeds the range of %s", &op1->where,
903 gfc_typename (&(op1->ts)));
904 }
905 else
906 {
907 /* Provide a nonsense value to propagate up. */
908 mpz_set (result->value.integer,
909 gfc_integer_kinds[k].huge);
910 mpz_add_ui (result->value.integer,
911 result->value.integer, 1);
912 rc = ARITH_OVERFLOW;
913 }
914 }
915 }
916 break;
917
918 case BT_REAL:
919 mpfr_pow_z (result->value.real, op1->value.real,
920 op2->value.integer, GFC_RND_MODE);
921 break;
922
923 case BT_COMPLEX:
924 mpc_pow_z (result->value.complex, op1->value.complex,
925 op2->value.integer, GFC_MPC_RND_MODE);
926 break;
927
928 default:
929 break;
930 }
931 }
932 break;
933
934 case BT_REAL:
935
936 if (gfc_init_expr_flag)
937 {
938 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
939 "exponent in an initialization "
940 "expression at %L", &op2->where))
941 {
942 gfc_free_expr (result);
943 return ARITH_PROHIBIT;
944 }
945 }
946
947 if (mpfr_cmp_si (op1->value.real, 0) < 0)
948 {
949 gfc_error ("Raising a negative REAL at %L to "
950 "a REAL power is prohibited", &op1->where);
951 gfc_free_expr (result);
952 return ARITH_PROHIBIT;
953 }
954
955 mpfr_pow (result->value.real, op1->value.real, op2->value.real,
956 GFC_RND_MODE);
957 break;
958
959 case BT_COMPLEX:
960 {
961 if (gfc_init_expr_flag)
962 {
963 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
964 "exponent in an initialization "
965 "expression at %L", &op2->where))
966 {
967 gfc_free_expr (result);
968 return ARITH_PROHIBIT;
969 }
970 }
971
972 mpc_pow (result->value.complex, op1->value.complex,
973 op2->value.complex, GFC_MPC_RND_MODE);
974 }
975 break;
976 default:
977 gfc_internal_error ("arith_power(): unknown type");
978 }
979
980 if (rc == ARITH_OK)
981 rc = gfc_range_check (result);
982
983 return check_result (rc, op1, result, resultp);
984 }
985
986
987 /* Concatenate two string constants. */
988
989 static arith
990 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
991 {
992 gfc_expr *result;
993 size_t len;
994
995 /* By cleverly playing around with constructors, is is possible
996 to get mismaching types here. */
997 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
998 || op1->ts.kind != op2->ts.kind)
999 return ARITH_WRONGCONCAT;
1000
1001 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1002 &op1->where);
1003
1004 len = op1->value.character.length + op2->value.character.length;
1005
1006 result->value.character.string = gfc_get_wide_string (len + 1);
1007 result->value.character.length = len;
1008
1009 memcpy (result->value.character.string, op1->value.character.string,
1010 op1->value.character.length * sizeof (gfc_char_t));
1011
1012 memcpy (&result->value.character.string[op1->value.character.length],
1013 op2->value.character.string,
1014 op2->value.character.length * sizeof (gfc_char_t));
1015
1016 result->value.character.string[len] = '\0';
1017
1018 *resultp = result;
1019
1020 return ARITH_OK;
1021 }
1022
1023 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1024 This function mimics mpfr_cmp but takes NaN into account. */
1025
1026 static int
1027 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1028 {
1029 int rc;
1030 switch (op)
1031 {
1032 case INTRINSIC_EQ:
1033 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1034 break;
1035 case INTRINSIC_GT:
1036 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1037 break;
1038 case INTRINSIC_GE:
1039 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1040 break;
1041 case INTRINSIC_LT:
1042 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1043 break;
1044 case INTRINSIC_LE:
1045 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1046 break;
1047 default:
1048 gfc_internal_error ("compare_real(): Bad operator");
1049 }
1050
1051 return rc;
1052 }
1053
1054 /* Comparison operators. Assumes that the two expression nodes
1055 contain two constants of the same type. The op argument is
1056 needed to handle NaN correctly. */
1057
1058 int
1059 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1060 {
1061 int rc;
1062
1063 switch (op1->ts.type)
1064 {
1065 case BT_INTEGER:
1066 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1067 break;
1068
1069 case BT_REAL:
1070 rc = compare_real (op1, op2, op);
1071 break;
1072
1073 case BT_CHARACTER:
1074 rc = gfc_compare_string (op1, op2);
1075 break;
1076
1077 case BT_LOGICAL:
1078 rc = ((!op1->value.logical && op2->value.logical)
1079 || (op1->value.logical && !op2->value.logical));
1080 break;
1081
1082 default:
1083 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1084 }
1085
1086 return rc;
1087 }
1088
1089
1090 /* Compare a pair of complex numbers. Naturally, this is only for
1091 equality and inequality. */
1092
1093 static int
1094 compare_complex (gfc_expr *op1, gfc_expr *op2)
1095 {
1096 return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1097 }
1098
1099
1100 /* Given two constant strings and the inverse collating sequence, compare the
1101 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1102 We use the processor's default collating sequence. */
1103
1104 int
1105 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1106 {
1107 size_t len, alen, blen, i;
1108 gfc_char_t ac, bc;
1109
1110 alen = a->value.character.length;
1111 blen = b->value.character.length;
1112
1113 len = MAX(alen, blen);
1114
1115 for (i = 0; i < len; i++)
1116 {
1117 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1118 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1119
1120 if (ac < bc)
1121 return -1;
1122 if (ac > bc)
1123 return 1;
1124 }
1125
1126 /* Strings are equal */
1127 return 0;
1128 }
1129
1130
1131 int
1132 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1133 {
1134 size_t len, alen, blen, i;
1135 gfc_char_t ac, bc;
1136
1137 alen = a->value.character.length;
1138 blen = strlen (b);
1139
1140 len = MAX(alen, blen);
1141
1142 for (i = 0; i < len; i++)
1143 {
1144 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1145 bc = ((i < blen) ? b[i] : ' ');
1146
1147 if (!case_sensitive)
1148 {
1149 ac = TOLOWER (ac);
1150 bc = TOLOWER (bc);
1151 }
1152
1153 if (ac < bc)
1154 return -1;
1155 if (ac > bc)
1156 return 1;
1157 }
1158
1159 /* Strings are equal */
1160 return 0;
1161 }
1162
1163
1164 /* Specific comparison subroutines. */
1165
1166 static arith
1167 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1168 {
1169 gfc_expr *result;
1170
1171 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1172 &op1->where);
1173 result->value.logical = (op1->ts.type == BT_COMPLEX)
1174 ? compare_complex (op1, op2)
1175 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1176
1177 *resultp = result;
1178 return ARITH_OK;
1179 }
1180
1181
1182 static arith
1183 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1184 {
1185 gfc_expr *result;
1186
1187 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1188 &op1->where);
1189 result->value.logical = (op1->ts.type == BT_COMPLEX)
1190 ? !compare_complex (op1, op2)
1191 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1192
1193 *resultp = result;
1194 return ARITH_OK;
1195 }
1196
1197
1198 static arith
1199 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1200 {
1201 gfc_expr *result;
1202
1203 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1204 &op1->where);
1205 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1206 *resultp = result;
1207
1208 return ARITH_OK;
1209 }
1210
1211
1212 static arith
1213 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1214 {
1215 gfc_expr *result;
1216
1217 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1218 &op1->where);
1219 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1220 *resultp = result;
1221
1222 return ARITH_OK;
1223 }
1224
1225
1226 static arith
1227 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1228 {
1229 gfc_expr *result;
1230
1231 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1232 &op1->where);
1233 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1234 *resultp = result;
1235
1236 return ARITH_OK;
1237 }
1238
1239
1240 static arith
1241 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1242 {
1243 gfc_expr *result;
1244
1245 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1246 &op1->where);
1247 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1248 *resultp = result;
1249
1250 return ARITH_OK;
1251 }
1252
1253
1254 static arith
1255 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1256 gfc_expr **result)
1257 {
1258 gfc_constructor_base head;
1259 gfc_constructor *c;
1260 gfc_expr *r;
1261 arith rc;
1262
1263 if (op->expr_type == EXPR_CONSTANT)
1264 return eval (op, result);
1265
1266 rc = ARITH_OK;
1267 head = gfc_constructor_copy (op->value.constructor);
1268 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1269 {
1270 rc = reduce_unary (eval, c->expr, &r);
1271
1272 if (rc != ARITH_OK)
1273 break;
1274
1275 gfc_replace_expr (c->expr, r);
1276 }
1277
1278 if (rc != ARITH_OK)
1279 gfc_constructor_free (head);
1280 else
1281 {
1282 gfc_constructor *c = gfc_constructor_first (head);
1283 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1284 &op->where);
1285 r->shape = gfc_copy_shape (op->shape, op->rank);
1286 r->rank = op->rank;
1287 r->value.constructor = head;
1288 *result = r;
1289 }
1290
1291 return rc;
1292 }
1293
1294
1295 static arith
1296 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1297 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1298 {
1299 gfc_constructor_base head;
1300 gfc_constructor *c;
1301 gfc_expr *r;
1302 arith rc = ARITH_OK;
1303
1304 head = gfc_constructor_copy (op1->value.constructor);
1305 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1306 {
1307 if (c->expr->expr_type == EXPR_CONSTANT)
1308 rc = eval (c->expr, op2, &r);
1309 else
1310 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1311
1312 if (rc != ARITH_OK)
1313 break;
1314
1315 gfc_replace_expr (c->expr, r);
1316 }
1317
1318 if (rc != ARITH_OK)
1319 gfc_constructor_free (head);
1320 else
1321 {
1322 gfc_constructor *c = gfc_constructor_first (head);
1323 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1324 &op1->where);
1325 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1326 r->rank = op1->rank;
1327 r->value.constructor = head;
1328 *result = r;
1329 }
1330
1331 return rc;
1332 }
1333
1334
1335 static arith
1336 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1337 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1338 {
1339 gfc_constructor_base head;
1340 gfc_constructor *c;
1341 gfc_expr *r;
1342 arith rc = ARITH_OK;
1343
1344 head = gfc_constructor_copy (op2->value.constructor);
1345 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1346 {
1347 if (c->expr->expr_type == EXPR_CONSTANT)
1348 rc = eval (op1, c->expr, &r);
1349 else
1350 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1351
1352 if (rc != ARITH_OK)
1353 break;
1354
1355 gfc_replace_expr (c->expr, r);
1356 }
1357
1358 if (rc != ARITH_OK)
1359 gfc_constructor_free (head);
1360 else
1361 {
1362 gfc_constructor *c = gfc_constructor_first (head);
1363 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1364 &op2->where);
1365 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1366 r->rank = op2->rank;
1367 r->value.constructor = head;
1368 *result = r;
1369 }
1370
1371 return rc;
1372 }
1373
1374
1375 /* We need a forward declaration of reduce_binary. */
1376 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1377 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1378
1379
1380 static arith
1381 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1382 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1383 {
1384 gfc_constructor_base head;
1385 gfc_constructor *c, *d;
1386 gfc_expr *r;
1387 arith rc = ARITH_OK;
1388
1389 if (!gfc_check_conformance (op1, op2, "elemental binary operation"))
1390 return ARITH_INCOMMENSURATE;
1391
1392 head = gfc_constructor_copy (op1->value.constructor);
1393 for (c = gfc_constructor_first (head),
1394 d = gfc_constructor_first (op2->value.constructor);
1395 c && d;
1396 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1397 {
1398 rc = reduce_binary (eval, c->expr, d->expr, &r);
1399 if (rc != ARITH_OK)
1400 break;
1401
1402 gfc_replace_expr (c->expr, r);
1403 }
1404
1405 if (c || d)
1406 rc = ARITH_INCOMMENSURATE;
1407
1408 if (rc != ARITH_OK)
1409 gfc_constructor_free (head);
1410 else
1411 {
1412 gfc_constructor *c = gfc_constructor_first (head);
1413 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1414 &op1->where);
1415 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1416 r->rank = op1->rank;
1417 r->value.constructor = head;
1418 *result = r;
1419 }
1420
1421 return rc;
1422 }
1423
1424
1425 static arith
1426 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1427 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1428 {
1429 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1430 return eval (op1, op2, result);
1431
1432 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1433 return reduce_binary_ca (eval, op1, op2, result);
1434
1435 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1436 return reduce_binary_ac (eval, op1, op2, result);
1437
1438 return reduce_binary_aa (eval, op1, op2, result);
1439 }
1440
1441
1442 typedef union
1443 {
1444 arith (*f2)(gfc_expr *, gfc_expr **);
1445 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1446 }
1447 eval_f;
1448
1449 /* High level arithmetic subroutines. These subroutines go into
1450 eval_intrinsic(), which can do one of several things to its
1451 operands. If the operands are incompatible with the intrinsic
1452 operation, we return a node pointing to the operands and hope that
1453 an operator interface is found during resolution.
1454
1455 If the operands are compatible and are constants, then we try doing
1456 the arithmetic. We also handle the cases where either or both
1457 operands are array constructors. */
1458
1459 static gfc_expr *
1460 eval_intrinsic (gfc_intrinsic_op op,
1461 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1462 {
1463 gfc_expr temp, *result;
1464 int unary;
1465 arith rc;
1466
1467 gfc_clear_ts (&temp.ts);
1468
1469 switch (op)
1470 {
1471 /* Logical unary */
1472 case INTRINSIC_NOT:
1473 if (op1->ts.type != BT_LOGICAL)
1474 goto runtime;
1475
1476 temp.ts.type = BT_LOGICAL;
1477 temp.ts.kind = gfc_default_logical_kind;
1478 unary = 1;
1479 break;
1480
1481 /* Logical binary operators */
1482 case INTRINSIC_OR:
1483 case INTRINSIC_AND:
1484 case INTRINSIC_NEQV:
1485 case INTRINSIC_EQV:
1486 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1487 goto runtime;
1488
1489 temp.ts.type = BT_LOGICAL;
1490 temp.ts.kind = gfc_default_logical_kind;
1491 unary = 0;
1492 break;
1493
1494 /* Numeric unary */
1495 case INTRINSIC_UPLUS:
1496 case INTRINSIC_UMINUS:
1497 if (!gfc_numeric_ts (&op1->ts))
1498 goto runtime;
1499
1500 temp.ts = op1->ts;
1501 unary = 1;
1502 break;
1503
1504 case INTRINSIC_PARENTHESES:
1505 temp.ts = op1->ts;
1506 unary = 1;
1507 break;
1508
1509 /* Additional restrictions for ordering relations. */
1510 case INTRINSIC_GE:
1511 case INTRINSIC_GE_OS:
1512 case INTRINSIC_LT:
1513 case INTRINSIC_LT_OS:
1514 case INTRINSIC_LE:
1515 case INTRINSIC_LE_OS:
1516 case INTRINSIC_GT:
1517 case INTRINSIC_GT_OS:
1518 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1519 {
1520 temp.ts.type = BT_LOGICAL;
1521 temp.ts.kind = gfc_default_logical_kind;
1522 goto runtime;
1523 }
1524
1525 /* Fall through */
1526 case INTRINSIC_EQ:
1527 case INTRINSIC_EQ_OS:
1528 case INTRINSIC_NE:
1529 case INTRINSIC_NE_OS:
1530 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1531 {
1532 unary = 0;
1533 temp.ts.type = BT_LOGICAL;
1534 temp.ts.kind = gfc_default_logical_kind;
1535
1536 /* If kind mismatch, exit and we'll error out later. */
1537 if (op1->ts.kind != op2->ts.kind)
1538 goto runtime;
1539
1540 break;
1541 }
1542
1543 gcc_fallthrough ();
1544 /* Numeric binary */
1545 case INTRINSIC_PLUS:
1546 case INTRINSIC_MINUS:
1547 case INTRINSIC_TIMES:
1548 case INTRINSIC_DIVIDE:
1549 case INTRINSIC_POWER:
1550 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1551 goto runtime;
1552
1553 /* Insert any necessary type conversions to make the operands
1554 compatible. */
1555
1556 temp.expr_type = EXPR_OP;
1557 gfc_clear_ts (&temp.ts);
1558 temp.value.op.op = op;
1559
1560 temp.value.op.op1 = op1;
1561 temp.value.op.op2 = op2;
1562
1563 gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1564
1565 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1566 || op == INTRINSIC_GE || op == INTRINSIC_GT
1567 || op == INTRINSIC_LE || op == INTRINSIC_LT
1568 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1569 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1570 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1571 {
1572 temp.ts.type = BT_LOGICAL;
1573 temp.ts.kind = gfc_default_logical_kind;
1574 }
1575
1576 unary = 0;
1577 break;
1578
1579 /* Character binary */
1580 case INTRINSIC_CONCAT:
1581 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1582 || op1->ts.kind != op2->ts.kind)
1583 goto runtime;
1584
1585 temp.ts.type = BT_CHARACTER;
1586 temp.ts.kind = op1->ts.kind;
1587 unary = 0;
1588 break;
1589
1590 case INTRINSIC_USER:
1591 goto runtime;
1592
1593 default:
1594 gfc_internal_error ("eval_intrinsic(): Bad operator");
1595 }
1596
1597 if (op1->expr_type != EXPR_CONSTANT
1598 && (op1->expr_type != EXPR_ARRAY
1599 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1600 goto runtime;
1601
1602 if (op2 != NULL
1603 && op2->expr_type != EXPR_CONSTANT
1604 && (op2->expr_type != EXPR_ARRAY
1605 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1606 goto runtime;
1607
1608 if (unary)
1609 rc = reduce_unary (eval.f2, op1, &result);
1610 else
1611 rc = reduce_binary (eval.f3, op1, op2, &result);
1612
1613
1614 /* Something went wrong. */
1615 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1616 return NULL;
1617
1618 if (rc != ARITH_OK)
1619 {
1620 gfc_error (gfc_arith_error (rc), &op1->where);
1621 if (rc == ARITH_OVERFLOW)
1622 goto done;
1623 return NULL;
1624 }
1625
1626 done:
1627
1628 gfc_free_expr (op1);
1629 gfc_free_expr (op2);
1630 return result;
1631
1632 runtime:
1633 /* Create a run-time expression. */
1634 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1635 result->ts = temp.ts;
1636
1637 return result;
1638 }
1639
1640
1641 /* Modify type of expression for zero size array. */
1642
1643 static gfc_expr *
1644 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1645 {
1646 if (op == NULL)
1647 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1648
1649 switch (iop)
1650 {
1651 case INTRINSIC_GE:
1652 case INTRINSIC_GE_OS:
1653 case INTRINSIC_LT:
1654 case INTRINSIC_LT_OS:
1655 case INTRINSIC_LE:
1656 case INTRINSIC_LE_OS:
1657 case INTRINSIC_GT:
1658 case INTRINSIC_GT_OS:
1659 case INTRINSIC_EQ:
1660 case INTRINSIC_EQ_OS:
1661 case INTRINSIC_NE:
1662 case INTRINSIC_NE_OS:
1663 op->ts.type = BT_LOGICAL;
1664 op->ts.kind = gfc_default_logical_kind;
1665 break;
1666
1667 default:
1668 break;
1669 }
1670
1671 return op;
1672 }
1673
1674
1675 /* Return nonzero if the expression is a zero size array. */
1676
1677 static int
1678 gfc_zero_size_array (gfc_expr *e)
1679 {
1680 if (e->expr_type != EXPR_ARRAY)
1681 return 0;
1682
1683 return e->value.constructor == NULL;
1684 }
1685
1686
1687 /* Reduce a binary expression where at least one of the operands
1688 involves a zero-length array. Returns NULL if neither of the
1689 operands is a zero-length array. */
1690
1691 static gfc_expr *
1692 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1693 {
1694 if (gfc_zero_size_array (op1))
1695 {
1696 gfc_free_expr (op2);
1697 return op1;
1698 }
1699
1700 if (gfc_zero_size_array (op2))
1701 {
1702 gfc_free_expr (op1);
1703 return op2;
1704 }
1705
1706 return NULL;
1707 }
1708
1709
1710 static gfc_expr *
1711 eval_intrinsic_f2 (gfc_intrinsic_op op,
1712 arith (*eval) (gfc_expr *, gfc_expr **),
1713 gfc_expr *op1, gfc_expr *op2)
1714 {
1715 gfc_expr *result;
1716 eval_f f;
1717
1718 if (op2 == NULL)
1719 {
1720 if (gfc_zero_size_array (op1))
1721 return eval_type_intrinsic0 (op, op1);
1722 }
1723 else
1724 {
1725 result = reduce_binary0 (op1, op2);
1726 if (result != NULL)
1727 return eval_type_intrinsic0 (op, result);
1728 }
1729
1730 f.f2 = eval;
1731 return eval_intrinsic (op, f, op1, op2);
1732 }
1733
1734
1735 static gfc_expr *
1736 eval_intrinsic_f3 (gfc_intrinsic_op op,
1737 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1738 gfc_expr *op1, gfc_expr *op2)
1739 {
1740 gfc_expr *result;
1741 eval_f f;
1742
1743 result = reduce_binary0 (op1, op2);
1744 if (result != NULL)
1745 return eval_type_intrinsic0(op, result);
1746
1747 f.f3 = eval;
1748 return eval_intrinsic (op, f, op1, op2);
1749 }
1750
1751
1752 gfc_expr *
1753 gfc_parentheses (gfc_expr *op)
1754 {
1755 if (gfc_is_constant_expr (op))
1756 return op;
1757
1758 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1759 op, NULL);
1760 }
1761
1762 gfc_expr *
1763 gfc_uplus (gfc_expr *op)
1764 {
1765 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1766 }
1767
1768
1769 gfc_expr *
1770 gfc_uminus (gfc_expr *op)
1771 {
1772 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1773 }
1774
1775
1776 gfc_expr *
1777 gfc_add (gfc_expr *op1, gfc_expr *op2)
1778 {
1779 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1780 }
1781
1782
1783 gfc_expr *
1784 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1785 {
1786 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1787 }
1788
1789
1790 gfc_expr *
1791 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1792 {
1793 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1794 }
1795
1796
1797 gfc_expr *
1798 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1799 {
1800 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1801 }
1802
1803
1804 gfc_expr *
1805 gfc_power (gfc_expr *op1, gfc_expr *op2)
1806 {
1807 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1808 }
1809
1810
1811 gfc_expr *
1812 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1813 {
1814 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1815 }
1816
1817
1818 gfc_expr *
1819 gfc_and (gfc_expr *op1, gfc_expr *op2)
1820 {
1821 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1822 }
1823
1824
1825 gfc_expr *
1826 gfc_or (gfc_expr *op1, gfc_expr *op2)
1827 {
1828 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1829 }
1830
1831
1832 gfc_expr *
1833 gfc_not (gfc_expr *op1)
1834 {
1835 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1836 }
1837
1838
1839 gfc_expr *
1840 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1841 {
1842 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1843 }
1844
1845
1846 gfc_expr *
1847 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1848 {
1849 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1850 }
1851
1852
1853 gfc_expr *
1854 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1855 {
1856 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1857 }
1858
1859
1860 gfc_expr *
1861 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1862 {
1863 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1864 }
1865
1866
1867 gfc_expr *
1868 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1869 {
1870 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1871 }
1872
1873
1874 gfc_expr *
1875 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1876 {
1877 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1878 }
1879
1880
1881 gfc_expr *
1882 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1883 {
1884 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1885 }
1886
1887
1888 gfc_expr *
1889 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1890 {
1891 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1892 }
1893
1894
1895 /******* Simplification of intrinsic functions with constant arguments *****/
1896
1897
1898 /* Deal with an arithmetic error. */
1899
1900 static void
1901 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1902 {
1903 switch (rc)
1904 {
1905 case ARITH_OK:
1906 gfc_error ("Arithmetic OK converting %s to %s at %L",
1907 gfc_typename (from), gfc_typename (to), where);
1908 break;
1909 case ARITH_OVERFLOW:
1910 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1911 "can be disabled with the option %<-fno-range-check%>",
1912 gfc_typename (from), gfc_typename (to), where);
1913 break;
1914 case ARITH_UNDERFLOW:
1915 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1916 "can be disabled with the option %<-fno-range-check%>",
1917 gfc_typename (from), gfc_typename (to), where);
1918 break;
1919 case ARITH_NAN:
1920 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1921 "can be disabled with the option %<-fno-range-check%>",
1922 gfc_typename (from), gfc_typename (to), where);
1923 break;
1924 case ARITH_DIV0:
1925 gfc_error ("Division by zero converting %s to %s at %L",
1926 gfc_typename (from), gfc_typename (to), where);
1927 break;
1928 case ARITH_INCOMMENSURATE:
1929 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1930 gfc_typename (from), gfc_typename (to), where);
1931 break;
1932 case ARITH_ASYMMETRIC:
1933 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1934 " converting %s to %s at %L",
1935 gfc_typename (from), gfc_typename (to), where);
1936 break;
1937 default:
1938 gfc_internal_error ("gfc_arith_error(): Bad error code");
1939 }
1940
1941 /* TODO: Do something about the error, i.e., throw exception, return
1942 NaN, etc. */
1943 }
1944
1945 /* Returns true if significant bits were lost when converting real
1946 constant r from from_kind to to_kind. */
1947
1948 static bool
1949 wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
1950 {
1951 mpfr_t rv, diff;
1952 bool ret;
1953
1954 gfc_set_model_kind (to_kind);
1955 mpfr_init (rv);
1956 gfc_set_model_kind (from_kind);
1957 mpfr_init (diff);
1958
1959 mpfr_set (rv, r, GFC_RND_MODE);
1960 mpfr_sub (diff, rv, r, GFC_RND_MODE);
1961
1962 ret = ! mpfr_zero_p (diff);
1963 mpfr_clear (rv);
1964 mpfr_clear (diff);
1965 return ret;
1966 }
1967
1968 /* Return true if conversion from an integer to a real loses precision. */
1969
1970 static bool
1971 wprecision_int_real (mpz_t n, mpfr_t r)
1972 {
1973 bool ret;
1974 mpz_t i;
1975 mpz_init (i);
1976 mpfr_get_z (i, r, GFC_RND_MODE);
1977 mpz_sub (i, i, n);
1978 ret = mpz_cmp_si (i, 0) != 0;
1979 mpz_clear (i);
1980 return ret;
1981 }
1982
1983 /* Convert integers to integers. */
1984
1985 gfc_expr *
1986 gfc_int2int (gfc_expr *src, int kind)
1987 {
1988 gfc_expr *result;
1989 arith rc;
1990
1991 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
1992
1993 mpz_set (result->value.integer, src->value.integer);
1994
1995 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1996 {
1997 if (rc == ARITH_ASYMMETRIC)
1998 {
1999 gfc_warning (0, gfc_arith_error (rc), &src->where);
2000 }
2001 else
2002 {
2003 arith_error (rc, &src->ts, &result->ts, &src->where);
2004 gfc_free_expr (result);
2005 return NULL;
2006 }
2007 }
2008
2009 /* If we do not trap numeric overflow, we need to convert the number to
2010 signed, throwing away high-order bits if necessary. */
2011 if (flag_range_check == 0)
2012 {
2013 int k;
2014
2015 k = gfc_validate_kind (BT_INTEGER, kind, false);
2016 gfc_convert_mpz_to_signed (result->value.integer,
2017 gfc_integer_kinds[k].bit_size);
2018
2019 if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2020 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2021 gfc_typename (&src->ts), gfc_typename (&result->ts),
2022 &src->where);
2023 }
2024 return result;
2025 }
2026
2027
2028 /* Convert integers to reals. */
2029
2030 gfc_expr *
2031 gfc_int2real (gfc_expr *src, int kind)
2032 {
2033 gfc_expr *result;
2034 arith rc;
2035
2036 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2037
2038 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2039
2040 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2041 {
2042 arith_error (rc, &src->ts, &result->ts, &src->where);
2043 gfc_free_expr (result);
2044 return NULL;
2045 }
2046
2047 if (warn_conversion
2048 && wprecision_int_real (src->value.integer, result->value.real))
2049 gfc_warning (OPT_Wconversion, "Change of value in conversion "
2050 "from %qs to %qs at %L",
2051 gfc_typename (&src->ts),
2052 gfc_typename (&result->ts),
2053 &src->where);
2054
2055 return result;
2056 }
2057
2058
2059 /* Convert default integer to default complex. */
2060
2061 gfc_expr *
2062 gfc_int2complex (gfc_expr *src, int kind)
2063 {
2064 gfc_expr *result;
2065 arith rc;
2066
2067 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2068
2069 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2070
2071 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2072 != ARITH_OK)
2073 {
2074 arith_error (rc, &src->ts, &result->ts, &src->where);
2075 gfc_free_expr (result);
2076 return NULL;
2077 }
2078
2079 if (warn_conversion
2080 && wprecision_int_real (src->value.integer,
2081 mpc_realref (result->value.complex)))
2082 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2083 "from %qs to %qs at %L",
2084 gfc_typename (&src->ts),
2085 gfc_typename (&result->ts),
2086 &src->where);
2087
2088 return result;
2089 }
2090
2091
2092 /* Convert default real to default integer. */
2093
2094 gfc_expr *
2095 gfc_real2int (gfc_expr *src, int kind)
2096 {
2097 gfc_expr *result;
2098 arith rc;
2099 bool did_warn = false;
2100
2101 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2102
2103 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2104
2105 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2106 {
2107 arith_error (rc, &src->ts, &result->ts, &src->where);
2108 gfc_free_expr (result);
2109 return NULL;
2110 }
2111
2112 /* If there was a fractional part, warn about this. */
2113
2114 if (warn_conversion)
2115 {
2116 mpfr_t f;
2117 mpfr_init (f);
2118 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2119 if (mpfr_cmp_si (f, 0) != 0)
2120 {
2121 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
2122 "from %qs to %qs at %L", gfc_typename (&src->ts),
2123 gfc_typename (&result->ts), &src->where);
2124 did_warn = true;
2125 }
2126 }
2127 if (!did_warn && warn_conversion_extra)
2128 {
2129 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2130 "at %L", gfc_typename (&src->ts),
2131 gfc_typename (&result->ts), &src->where);
2132 }
2133
2134 return result;
2135 }
2136
2137
2138 /* Convert real to real. */
2139
2140 gfc_expr *
2141 gfc_real2real (gfc_expr *src, int kind)
2142 {
2143 gfc_expr *result;
2144 arith rc;
2145 bool did_warn = false;
2146
2147 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2148
2149 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2150
2151 rc = gfc_check_real_range (result->value.real, kind);
2152
2153 if (rc == ARITH_UNDERFLOW)
2154 {
2155 if (warn_underflow)
2156 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2157 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2158 }
2159 else if (rc != ARITH_OK)
2160 {
2161 arith_error (rc, &src->ts, &result->ts, &src->where);
2162 gfc_free_expr (result);
2163 return NULL;
2164 }
2165
2166 /* As a special bonus, don't warn about REAL values which are not changed by
2167 the conversion if -Wconversion is specified and -Wconversion-extra is
2168 not. */
2169
2170 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2171 {
2172 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2173
2174 /* Calculate the difference between the constant and the rounded
2175 value and check it against zero. */
2176
2177 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2178 {
2179 gfc_warning_now (w, "Change of value in conversion from "
2180 "%qs to %qs at %L",
2181 gfc_typename (&src->ts), gfc_typename (&result->ts),
2182 &src->where);
2183 /* Make sure the conversion warning is not emitted again. */
2184 did_warn = true;
2185 }
2186 }
2187
2188 if (!did_warn && warn_conversion_extra)
2189 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2190 "at %L", gfc_typename(&src->ts),
2191 gfc_typename(&result->ts), &src->where);
2192
2193 return result;
2194 }
2195
2196
2197 /* Convert real to complex. */
2198
2199 gfc_expr *
2200 gfc_real2complex (gfc_expr *src, int kind)
2201 {
2202 gfc_expr *result;
2203 arith rc;
2204 bool did_warn = false;
2205
2206 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2207
2208 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2209
2210 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2211
2212 if (rc == ARITH_UNDERFLOW)
2213 {
2214 if (warn_underflow)
2215 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2216 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2217 }
2218 else if (rc != ARITH_OK)
2219 {
2220 arith_error (rc, &src->ts, &result->ts, &src->where);
2221 gfc_free_expr (result);
2222 return NULL;
2223 }
2224
2225 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2226 {
2227 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2228
2229 if (wprecision_real_real (src->value.real, src->ts.kind, kind))
2230 {
2231 gfc_warning_now (w, "Change of value in conversion from "
2232 "%qs to %qs at %L",
2233 gfc_typename (&src->ts), gfc_typename (&result->ts),
2234 &src->where);
2235 /* Make sure the conversion warning is not emitted again. */
2236 did_warn = true;
2237 }
2238 }
2239
2240 if (!did_warn && warn_conversion_extra)
2241 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2242 "at %L", gfc_typename(&src->ts),
2243 gfc_typename(&result->ts), &src->where);
2244
2245 return result;
2246 }
2247
2248
2249 /* Convert complex to integer. */
2250
2251 gfc_expr *
2252 gfc_complex2int (gfc_expr *src, int kind)
2253 {
2254 gfc_expr *result;
2255 arith rc;
2256 bool did_warn = false;
2257
2258 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2259
2260 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2261 &src->where);
2262
2263 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != 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)
2271 {
2272 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2273
2274 /* See if we discarded an imaginary part. */
2275 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2276 {
2277 gfc_warning_now (w, "Non-zero imaginary part discarded "
2278 "in conversion from %qs to %qs at %L",
2279 gfc_typename(&src->ts), gfc_typename (&result->ts),
2280 &src->where);
2281 did_warn = true;
2282 }
2283
2284 else {
2285 mpfr_t f;
2286
2287 mpfr_init (f);
2288 mpfr_frac (f, src->value.real, GFC_RND_MODE);
2289 if (mpfr_cmp_si (f, 0) != 0)
2290 {
2291 gfc_warning_now (w, "Change of value in conversion from "
2292 "%qs to %qs at %L", gfc_typename (&src->ts),
2293 gfc_typename (&result->ts), &src->where);
2294 did_warn = true;
2295 }
2296 mpfr_clear (f);
2297 }
2298
2299 if (!did_warn && warn_conversion_extra)
2300 {
2301 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2302 "at %L", gfc_typename (&src->ts),
2303 gfc_typename (&result->ts), &src->where);
2304 }
2305 }
2306
2307 return result;
2308 }
2309
2310
2311 /* Convert complex to real. */
2312
2313 gfc_expr *
2314 gfc_complex2real (gfc_expr *src, int kind)
2315 {
2316 gfc_expr *result;
2317 arith rc;
2318 bool did_warn = false;
2319
2320 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2321
2322 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2323
2324 rc = gfc_check_real_range (result->value.real, kind);
2325
2326 if (rc == ARITH_UNDERFLOW)
2327 {
2328 if (warn_underflow)
2329 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2330 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2331 }
2332 if (rc != ARITH_OK)
2333 {
2334 arith_error (rc, &src->ts, &result->ts, &src->where);
2335 gfc_free_expr (result);
2336 return NULL;
2337 }
2338
2339 if (warn_conversion || warn_conversion_extra)
2340 {
2341 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2342
2343 /* See if we discarded an imaginary part. */
2344 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2345 {
2346 gfc_warning (w, "Non-zero imaginary part discarded "
2347 "in conversion from %qs to %qs at %L",
2348 gfc_typename(&src->ts), gfc_typename (&result->ts),
2349 &src->where);
2350 did_warn = true;
2351 }
2352
2353 /* Calculate the difference between the real constant and the rounded
2354 value and check it against zero. */
2355
2356 if (kind > src->ts.kind
2357 && wprecision_real_real (mpc_realref (src->value.complex),
2358 src->ts.kind, kind))
2359 {
2360 gfc_warning_now (w, "Change of value in conversion from "
2361 "%qs to %qs at %L",
2362 gfc_typename (&src->ts), gfc_typename (&result->ts),
2363 &src->where);
2364 /* Make sure the conversion warning is not emitted again. */
2365 did_warn = true;
2366 }
2367 }
2368
2369 if (!did_warn && warn_conversion_extra)
2370 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
2371 gfc_typename(&src->ts), gfc_typename (&result->ts),
2372 &src->where);
2373
2374 return result;
2375 }
2376
2377
2378 /* Convert complex to complex. */
2379
2380 gfc_expr *
2381 gfc_complex2complex (gfc_expr *src, int kind)
2382 {
2383 gfc_expr *result;
2384 arith rc;
2385 bool did_warn = false;
2386
2387 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2388
2389 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2390
2391 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2392
2393 if (rc == ARITH_UNDERFLOW)
2394 {
2395 if (warn_underflow)
2396 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2397 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2398 }
2399 else if (rc != ARITH_OK)
2400 {
2401 arith_error (rc, &src->ts, &result->ts, &src->where);
2402 gfc_free_expr (result);
2403 return NULL;
2404 }
2405
2406 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2407
2408 if (rc == ARITH_UNDERFLOW)
2409 {
2410 if (warn_underflow)
2411 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
2412 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2413 }
2414 else if (rc != ARITH_OK)
2415 {
2416 arith_error (rc, &src->ts, &result->ts, &src->where);
2417 gfc_free_expr (result);
2418 return NULL;
2419 }
2420
2421 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2422 && (wprecision_real_real (mpc_realref (src->value.complex),
2423 src->ts.kind, kind)
2424 || wprecision_real_real (mpc_imagref (src->value.complex),
2425 src->ts.kind, kind)))
2426 {
2427 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2428
2429 gfc_warning_now (w, "Change of value in conversion from "
2430 "%qs to %qs at %L",
2431 gfc_typename (&src->ts), gfc_typename (&result->ts),
2432 &src->where);
2433 did_warn = true;
2434 }
2435
2436 if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2437 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
2438 "at %L", gfc_typename(&src->ts),
2439 gfc_typename (&result->ts), &src->where);
2440
2441 return result;
2442 }
2443
2444
2445 /* Logical kind conversion. */
2446
2447 gfc_expr *
2448 gfc_log2log (gfc_expr *src, int kind)
2449 {
2450 gfc_expr *result;
2451
2452 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2453 result->value.logical = src->value.logical;
2454
2455 return result;
2456 }
2457
2458
2459 /* Convert logical to integer. */
2460
2461 gfc_expr *
2462 gfc_log2int (gfc_expr *src, int kind)
2463 {
2464 gfc_expr *result;
2465
2466 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2467 mpz_set_si (result->value.integer, src->value.logical);
2468
2469 return result;
2470 }
2471
2472
2473 /* Convert integer to logical. */
2474
2475 gfc_expr *
2476 gfc_int2log (gfc_expr *src, int kind)
2477 {
2478 gfc_expr *result;
2479
2480 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2481 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2482
2483 return result;
2484 }
2485
2486 /* Convert character to character. We only use wide strings internally,
2487 so we only set the kind. */
2488
2489 gfc_expr *
2490 gfc_character2character (gfc_expr *src, int kind)
2491 {
2492 gfc_expr *result;
2493 result = gfc_copy_expr (src);
2494 result->ts.kind = kind;
2495
2496 return result;
2497 }
2498
2499 /* Helper function to set the representation in a Hollerith conversion.
2500 This assumes that the ts.type and ts.kind of the result have already
2501 been set. */
2502
2503 static void
2504 hollerith2representation (gfc_expr *result, gfc_expr *src)
2505 {
2506 size_t src_len, result_len;
2507
2508 src_len = src->representation.length - src->ts.u.pad;
2509 gfc_target_expr_size (result, &result_len);
2510
2511 if (src_len > result_len)
2512 {
2513 gfc_warning (0,
2514 "The Hollerith constant at %L is too long to convert to %qs",
2515 &src->where, gfc_typename(&result->ts));
2516 }
2517
2518 result->representation.string = XCNEWVEC (char, result_len + 1);
2519 memcpy (result->representation.string, src->representation.string,
2520 MIN (result_len, src_len));
2521
2522 if (src_len < result_len)
2523 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2524
2525 result->representation.string[result_len] = '\0'; /* For debugger */
2526 result->representation.length = result_len;
2527 }
2528
2529
2530 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2531
2532 gfc_expr *
2533 gfc_hollerith2int (gfc_expr *src, int kind)
2534 {
2535 gfc_expr *result;
2536 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2537
2538 hollerith2representation (result, src);
2539 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2540 result->representation.length, result->value.integer);
2541
2542 return result;
2543 }
2544
2545
2546 /* Convert Hollerith to real. The constant will be padded or truncated. */
2547
2548 gfc_expr *
2549 gfc_hollerith2real (gfc_expr *src, int kind)
2550 {
2551 gfc_expr *result;
2552 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2553
2554 hollerith2representation (result, src);
2555 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2556 result->representation.length, result->value.real);
2557
2558 return result;
2559 }
2560
2561
2562 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2563
2564 gfc_expr *
2565 gfc_hollerith2complex (gfc_expr *src, int kind)
2566 {
2567 gfc_expr *result;
2568 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2569
2570 hollerith2representation (result, src);
2571 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2572 result->representation.length, result->value.complex);
2573
2574 return result;
2575 }
2576
2577
2578 /* Convert Hollerith to character. */
2579
2580 gfc_expr *
2581 gfc_hollerith2character (gfc_expr *src, int kind)
2582 {
2583 gfc_expr *result;
2584
2585 result = gfc_copy_expr (src);
2586 result->ts.type = BT_CHARACTER;
2587 result->ts.kind = kind;
2588 result->ts.u.pad = 0;
2589
2590 result->value.character.length = result->representation.length;
2591 result->value.character.string
2592 = gfc_char_to_widechar (result->representation.string);
2593
2594 return result;
2595 }
2596
2597
2598 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2599
2600 gfc_expr *
2601 gfc_hollerith2logical (gfc_expr *src, int kind)
2602 {
2603 gfc_expr *result;
2604 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2605
2606 hollerith2representation (result, src);
2607 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2608 result->representation.length, &result->value.logical);
2609
2610 return result;
2611 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org