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