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