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