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