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