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