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