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