?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / fortran / arith.c
blob3339585988a5db3aac00606d819b7b2a40245213
1 /* Compiler arithmetic
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 /* Since target arithmetic must be done on the host, there has to
22 be some way of evaluating arithmetic expressions as the host
23 would evaluate them. We use the GNU MP library and the MPFR
24 library to do arithmetic, and this file provides the interface. */
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "flags.h"
30 #include "gfortran.h"
31 #include "arith.h"
32 #include "target-memory.h"
33 #include "constructor.h"
34
35 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
36 It's easily implemented with a few calls though. */
37
38 void
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 (gfc_option.flag_range_check == 0)
305 return result;
306
307 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
308 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
309 result = ARITH_OVERFLOW;
310
311 return result;
312 }
313
314
315 /* Given a real and a kind, make sure that the real lies within the
316 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
317 ARITH_UNDERFLOW. */
318
319 static arith
320 gfc_check_real_range (mpfr_t p, int kind)
321 {
322 arith retval;
323 mpfr_t q;
324 int i;
325
326 i = gfc_validate_kind (BT_REAL, kind, false);
327
328 gfc_set_model (p);
329 mpfr_init (q);
330 mpfr_abs (q, p, GFC_RND_MODE);
331
332 retval = ARITH_OK;
333
334 if (mpfr_inf_p (p))
335 {
336 if (gfc_option.flag_range_check != 0)
337 retval = ARITH_OVERFLOW;
338 }
339 else if (mpfr_nan_p (p))
340 {
341 if (gfc_option.flag_range_check != 0)
342 retval = ARITH_NAN;
343 }
344 else if (mpfr_sgn (q) == 0)
345 {
346 mpfr_clear (q);
347 return retval;
348 }
349 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
350 {
351 if (gfc_option.flag_range_check == 0)
352 mpfr_set_inf (p, mpfr_sgn (p));
353 else
354 retval = ARITH_OVERFLOW;
355 }
356 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
357 {
358 if (gfc_option.flag_range_check == 0)
359 {
360 if (mpfr_sgn (p) < 0)
361 {
362 mpfr_set_ui (p, 0, GFC_RND_MODE);
363 mpfr_set_si (q, -1, GFC_RND_MODE);
364 mpfr_copysign (p, p, q, GFC_RND_MODE);
365 }
366 else
367 mpfr_set_ui (p, 0, GFC_RND_MODE);
368 }
369 else
370 retval = ARITH_UNDERFLOW;
371 }
372 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
373 {
374 mp_exp_t emin, emax;
375 int en;
376
377 /* Save current values of emin and emax. */
378 emin = mpfr_get_emin ();
379 emax = mpfr_get_emax ();
380
381 /* Set emin and emax for the current model number. */
382 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
383 mpfr_set_emin ((mp_exp_t) en);
384 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
385 mpfr_check_range (q, 0, GFC_RND_MODE);
386 mpfr_subnormalize (q, 0, GFC_RND_MODE);
387
388 /* Reset emin and emax. */
389 mpfr_set_emin (emin);
390 mpfr_set_emax (emax);
391
392 /* Copy sign if needed. */
393 if (mpfr_sgn (p) < 0)
394 mpfr_neg (p, q, GMP_RNDN);
395 else
396 mpfr_set (p, q, GMP_RNDN);
397 }
398
399 mpfr_clear (q);
400
401 return retval;
402 }
403
404
405 /* Low-level arithmetic functions. All of these subroutines assume
406 that all operands are of the same type and return an operand of the
407 same type. The other thing about these subroutines is that they
408 can fail in various ways -- overflow, underflow, division by zero,
409 zero raised to the zero, etc. */
410
411 static arith
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 (gfc_option.warn_underflow)
548 gfc_warning (gfc_arith_error (val), &x->where);
549 val = ARITH_OK;
550 }
551
552 if (val == ARITH_ASYMMETRIC)
553 {
554 gfc_warning (gfc_arith_error (val), &x->where);
555 val = ARITH_OK;
556 }
557
558 if (val != ARITH_OK)
559 gfc_free_expr (r);
560 else
561 *rp = r;
562
563 return val;
564 }
565
566
567 /* It may seem silly to have a subroutine that actually computes the
568 unary plus of a constant, but it prevents us from making exceptions
569 in the code elsewhere. Used for unary plus and parenthesized
570 expressions. */
571
572 static arith
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 mpz_tdiv_q (result->value.integer, op1->value.integer,
735 op2->value.integer);
736 break;
737
738 case BT_REAL:
739 if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
740 {
741 rc = ARITH_DIV0;
742 break;
743 }
744
745 mpfr_div (result->value.real, op1->value.real, op2->value.real,
746 GFC_RND_MODE);
747 break;
748
749 case BT_COMPLEX:
750 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
751 && gfc_option.flag_range_check == 1)
752 {
753 rc = ARITH_DIV0;
754 break;
755 }
756
757 gfc_set_model (mpc_realref (op1->value.complex));
758 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
759 {
760 /* In Fortran, return (NaN + NaN I) for any zero divisor. See
761 PR 40318. */
762 mpfr_set_nan (mpc_realref (result->value.complex));
763 mpfr_set_nan (mpc_imagref (result->value.complex));
764 }
765 else
766 mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
767 GFC_MPC_RND_MODE);
768 break;
769
770 default:
771 gfc_internal_error ("gfc_arith_divide(): Bad basic type");
772 }
773
774 if (rc == ARITH_OK)
775 rc = gfc_range_check (result);
776
777 return check_result (rc, op1, result, resultp);
778 }
779
780 /* Raise a number to a power. */
781
782 static arith
783 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
784 {
785 int power_sign;
786 gfc_expr *result;
787 arith rc;
788
789 rc = ARITH_OK;
790 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
791
792 switch (op2->ts.type)
793 {
794 case BT_INTEGER:
795 power_sign = mpz_sgn (op2->value.integer);
796
797 if (power_sign == 0)
798 {
799 /* Handle something to the zeroth power. Since we're dealing
800 with integral exponents, there is no ambiguity in the
801 limiting procedure used to determine the value of 0**0. */
802 switch (op1->ts.type)
803 {
804 case BT_INTEGER:
805 mpz_set_ui (result->value.integer, 1);
806 break;
807
808 case BT_REAL:
809 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
810 break;
811
812 case BT_COMPLEX:
813 mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
814 break;
815
816 default:
817 gfc_internal_error ("arith_power(): Bad base");
818 }
819 }
820 else
821 {
822 switch (op1->ts.type)
823 {
824 case BT_INTEGER:
825 {
826 int power;
827
828 /* First, we simplify the cases of op1 == 1, 0 or -1. */
829 if (mpz_cmp_si (op1->value.integer, 1) == 0)
830 {
831 /* 1**op2 == 1 */
832 mpz_set_si (result->value.integer, 1);
833 }
834 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
835 {
836 /* 0**op2 == 0, if op2 > 0
837 0**op2 overflow, if op2 < 0 ; in that case, we
838 set the result to 0 and return ARITH_DIV0. */
839 mpz_set_si (result->value.integer, 0);
840 if (mpz_cmp_si (op2->value.integer, 0) < 0)
841 rc = ARITH_DIV0;
842 }
843 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
844 {
845 /* (-1)**op2 == (-1)**(mod(op2,2)) */
846 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
847 if (odd)
848 mpz_set_si (result->value.integer, -1);
849 else
850 mpz_set_si (result->value.integer, 1);
851 }
852 /* Then, we take care of op2 < 0. */
853 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
854 {
855 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
856 mpz_set_si (result->value.integer, 0);
857 }
858 else if (gfc_extract_int (op2, &power) != NULL)
859 {
860 /* If op2 doesn't fit in an int, the exponentiation will
861 overflow, because op2 > 0 and abs(op1) > 1. */
862 mpz_t max;
863 int i;
864 i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
865
866 if (gfc_option.flag_range_check)
867 rc = ARITH_OVERFLOW;
868
869 /* Still, we want to give the same value as the
870 processor. */
871 mpz_init (max);
872 mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
873 mpz_mul_ui (max, max, 2);
874 mpz_powm (result->value.integer, op1->value.integer,
875 op2->value.integer, max);
876 mpz_clear (max);
877 }
878 else
879 mpz_pow_ui (result->value.integer, op1->value.integer,
880 power);
881 }
882 break;
883
884 case BT_REAL:
885 mpfr_pow_z (result->value.real, op1->value.real,
886 op2->value.integer, GFC_RND_MODE);
887 break;
888
889 case BT_COMPLEX:
890 mpc_pow_z (result->value.complex, op1->value.complex,
891 op2->value.integer, GFC_MPC_RND_MODE);
892 break;
893
894 default:
895 break;
896 }
897 }
898 break;
899
900 case BT_REAL:
901
902 if (gfc_init_expr_flag)
903 {
904 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
905 "exponent in an initialization "
906 "expression at %L", &op2->where))
907 {
908 gfc_free_expr (result);
909 return ARITH_PROHIBIT;
910 }
911 }
912
913 if (mpfr_cmp_si (op1->value.real, 0) < 0)
914 {
915 gfc_error ("Raising a negative REAL at %L to "
916 "a REAL power is prohibited", &op1->where);
917 gfc_free_expr (result);
918 return ARITH_PROHIBIT;
919 }
920
921 mpfr_pow (result->value.real, op1->value.real, op2->value.real,
922 GFC_RND_MODE);
923 break;
924
925 case BT_COMPLEX:
926 {
927 if (gfc_init_expr_flag)
928 {
929 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
930 "exponent in an initialization "
931 "expression at %L", &op2->where))
932 {
933 gfc_free_expr (result);
934 return ARITH_PROHIBIT;
935 }
936 }
937
938 mpc_pow (result->value.complex, op1->value.complex,
939 op2->value.complex, GFC_MPC_RND_MODE);
940 }
941 break;
942 default:
943 gfc_internal_error ("arith_power(): unknown type");
944 }
945
946 if (rc == ARITH_OK)
947 rc = gfc_range_check (result);
948
949 return check_result (rc, op1, result, resultp);
950 }
951
952
953 /* Concatenate two string constants. */
954
955 static arith
956 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
957 {
958 gfc_expr *result;
959 int len;
960
961 gcc_assert (op1->ts.kind == op2->ts.kind);
962 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
963 &op1->where);
964
965 len = op1->value.character.length + op2->value.character.length;
966
967 result->value.character.string = gfc_get_wide_string (len + 1);
968 result->value.character.length = len;
969
970 memcpy (result->value.character.string, op1->value.character.string,
971 op1->value.character.length * sizeof (gfc_char_t));
972
973 memcpy (&result->value.character.string[op1->value.character.length],
974 op2->value.character.string,
975 op2->value.character.length * sizeof (gfc_char_t));
976
977 result->value.character.string[len] = '\0';
978
979 *resultp = result;
980
981 return ARITH_OK;
982 }
983
984 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
985 This function mimics mpfr_cmp but takes NaN into account. */
986
987 static int
988 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
989 {
990 int rc;
991 switch (op)
992 {
993 case INTRINSIC_EQ:
994 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
995 break;
996 case INTRINSIC_GT:
997 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
998 break;
999 case INTRINSIC_GE:
1000 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1001 break;
1002 case INTRINSIC_LT:
1003 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1004 break;
1005 case INTRINSIC_LE:
1006 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1007 break;
1008 default:
1009 gfc_internal_error ("compare_real(): Bad operator");
1010 }
1011
1012 return rc;
1013 }
1014
1015 /* Comparison operators. Assumes that the two expression nodes
1016 contain two constants of the same type. The op argument is
1017 needed to handle NaN correctly. */
1018
1019 int
1020 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1021 {
1022 int rc;
1023
1024 switch (op1->ts.type)
1025 {
1026 case BT_INTEGER:
1027 rc = mpz_cmp (op1->value.integer, op2->value.integer);
1028 break;
1029
1030 case BT_REAL:
1031 rc = compare_real (op1, op2, op);
1032 break;
1033
1034 case BT_CHARACTER:
1035 rc = gfc_compare_string (op1, op2);
1036 break;
1037
1038 case BT_LOGICAL:
1039 rc = ((!op1->value.logical && op2->value.logical)
1040 || (op1->value.logical && !op2->value.logical));
1041 break;
1042
1043 default:
1044 gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1045 }
1046
1047 return rc;
1048 }
1049
1050
1051 /* Compare a pair of complex numbers. Naturally, this is only for
1052 equality and inequality. */
1053
1054 static int
1055 compare_complex (gfc_expr *op1, gfc_expr *op2)
1056 {
1057 return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1058 }
1059
1060
1061 /* Given two constant strings and the inverse collating sequence, compare the
1062 strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1063 We use the processor's default collating sequence. */
1064
1065 int
1066 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1067 {
1068 int len, alen, blen, i;
1069 gfc_char_t ac, bc;
1070
1071 alen = a->value.character.length;
1072 blen = b->value.character.length;
1073
1074 len = MAX(alen, blen);
1075
1076 for (i = 0; i < len; i++)
1077 {
1078 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1079 bc = ((i < blen) ? b->value.character.string[i] : ' ');
1080
1081 if (ac < bc)
1082 return -1;
1083 if (ac > bc)
1084 return 1;
1085 }
1086
1087 /* Strings are equal */
1088 return 0;
1089 }
1090
1091
1092 int
1093 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1094 {
1095 int len, alen, blen, i;
1096 gfc_char_t ac, bc;
1097
1098 alen = a->value.character.length;
1099 blen = strlen (b);
1100
1101 len = MAX(alen, blen);
1102
1103 for (i = 0; i < len; i++)
1104 {
1105 ac = ((i < alen) ? a->value.character.string[i] : ' ');
1106 bc = ((i < blen) ? b[i] : ' ');
1107
1108 if (!case_sensitive)
1109 {
1110 ac = TOLOWER (ac);
1111 bc = TOLOWER (bc);
1112 }
1113
1114 if (ac < bc)
1115 return -1;
1116 if (ac > bc)
1117 return 1;
1118 }
1119
1120 /* Strings are equal */
1121 return 0;
1122 }
1123
1124
1125 /* Specific comparison subroutines. */
1126
1127 static arith
1128 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1129 {
1130 gfc_expr *result;
1131
1132 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1133 &op1->where);
1134 result->value.logical = (op1->ts.type == BT_COMPLEX)
1135 ? compare_complex (op1, op2)
1136 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1137
1138 *resultp = result;
1139 return ARITH_OK;
1140 }
1141
1142
1143 static arith
1144 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1145 {
1146 gfc_expr *result;
1147
1148 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1149 &op1->where);
1150 result->value.logical = (op1->ts.type == BT_COMPLEX)
1151 ? !compare_complex (op1, op2)
1152 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1153
1154 *resultp = result;
1155 return ARITH_OK;
1156 }
1157
1158
1159 static arith
1160 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1161 {
1162 gfc_expr *result;
1163
1164 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1165 &op1->where);
1166 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1167 *resultp = result;
1168
1169 return ARITH_OK;
1170 }
1171
1172
1173 static arith
1174 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1175 {
1176 gfc_expr *result;
1177
1178 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1179 &op1->where);
1180 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1181 *resultp = result;
1182
1183 return ARITH_OK;
1184 }
1185
1186
1187 static arith
1188 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1189 {
1190 gfc_expr *result;
1191
1192 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1193 &op1->where);
1194 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1195 *resultp = result;
1196
1197 return ARITH_OK;
1198 }
1199
1200
1201 static arith
1202 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1203 {
1204 gfc_expr *result;
1205
1206 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1207 &op1->where);
1208 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1209 *resultp = result;
1210
1211 return ARITH_OK;
1212 }
1213
1214
1215 static arith
1216 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1217 gfc_expr **result)
1218 {
1219 gfc_constructor_base head;
1220 gfc_constructor *c;
1221 gfc_expr *r;
1222 arith rc;
1223
1224 if (op->expr_type == EXPR_CONSTANT)
1225 return eval (op, result);
1226
1227 rc = ARITH_OK;
1228 head = gfc_constructor_copy (op->value.constructor);
1229 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1230 {
1231 rc = reduce_unary (eval, c->expr, &r);
1232
1233 if (rc != ARITH_OK)
1234 break;
1235
1236 gfc_replace_expr (c->expr, r);
1237 }
1238
1239 if (rc != ARITH_OK)
1240 gfc_constructor_free (head);
1241 else
1242 {
1243 gfc_constructor *c = gfc_constructor_first (head);
1244 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1245 &op->where);
1246 r->shape = gfc_copy_shape (op->shape, op->rank);
1247 r->rank = op->rank;
1248 r->value.constructor = head;
1249 *result = r;
1250 }
1251
1252 return rc;
1253 }
1254
1255
1256 static arith
1257 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1258 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1259 {
1260 gfc_constructor_base head;
1261 gfc_constructor *c;
1262 gfc_expr *r;
1263 arith rc = ARITH_OK;
1264
1265 head = gfc_constructor_copy (op1->value.constructor);
1266 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1267 {
1268 if (c->expr->expr_type == EXPR_CONSTANT)
1269 rc = eval (c->expr, op2, &r);
1270 else
1271 rc = reduce_binary_ac (eval, c->expr, op2, &r);
1272
1273 if (rc != ARITH_OK)
1274 break;
1275
1276 gfc_replace_expr (c->expr, r);
1277 }
1278
1279 if (rc != ARITH_OK)
1280 gfc_constructor_free (head);
1281 else
1282 {
1283 gfc_constructor *c = gfc_constructor_first (head);
1284 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1285 &op1->where);
1286 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1287 r->rank = op1->rank;
1288 r->value.constructor = head;
1289 *result = r;
1290 }
1291
1292 return rc;
1293 }
1294
1295
1296 static arith
1297 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1298 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1299 {
1300 gfc_constructor_base head;
1301 gfc_constructor *c;
1302 gfc_expr *r;
1303 arith rc = ARITH_OK;
1304
1305 head = gfc_constructor_copy (op2->value.constructor);
1306 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1307 {
1308 if (c->expr->expr_type == EXPR_CONSTANT)
1309 rc = eval (op1, c->expr, &r);
1310 else
1311 rc = reduce_binary_ca (eval, op1, c->expr, &r);
1312
1313 if (rc != ARITH_OK)
1314 break;
1315
1316 gfc_replace_expr (c->expr, r);
1317 }
1318
1319 if (rc != ARITH_OK)
1320 gfc_constructor_free (head);
1321 else
1322 {
1323 gfc_constructor *c = gfc_constructor_first (head);
1324 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1325 &op2->where);
1326 r->shape = gfc_copy_shape (op2->shape, op2->rank);
1327 r->rank = op2->rank;
1328 r->value.constructor = head;
1329 *result = r;
1330 }
1331
1332 return rc;
1333 }
1334
1335
1336 /* We need a forward declaration of reduce_binary. */
1337 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1338 gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1339
1340
1341 static arith
1342 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1343 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1344 {
1345 gfc_constructor_base head;
1346 gfc_constructor *c, *d;
1347 gfc_expr *r;
1348 arith rc = ARITH_OK;
1349
1350 if (!gfc_check_conformance (op1, op2, "elemental binary operation"))
1351 return ARITH_INCOMMENSURATE;
1352
1353 head = gfc_constructor_copy (op1->value.constructor);
1354 for (c = gfc_constructor_first (head),
1355 d = gfc_constructor_first (op2->value.constructor);
1356 c && d;
1357 c = gfc_constructor_next (c), d = gfc_constructor_next (d))
1358 {
1359 rc = reduce_binary (eval, c->expr, d->expr, &r);
1360 if (rc != ARITH_OK)
1361 break;
1362
1363 gfc_replace_expr (c->expr, r);
1364 }
1365
1366 if (c || d)
1367 rc = ARITH_INCOMMENSURATE;
1368
1369 if (rc != ARITH_OK)
1370 gfc_constructor_free (head);
1371 else
1372 {
1373 gfc_constructor *c = gfc_constructor_first (head);
1374 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
1375 &op1->where);
1376 r->shape = gfc_copy_shape (op1->shape, op1->rank);
1377 r->rank = op1->rank;
1378 r->value.constructor = head;
1379 *result = r;
1380 }
1381
1382 return rc;
1383 }
1384
1385
1386 static arith
1387 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1388 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1389 {
1390 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1391 return eval (op1, op2, result);
1392
1393 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1394 return reduce_binary_ca (eval, op1, op2, result);
1395
1396 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1397 return reduce_binary_ac (eval, op1, op2, result);
1398
1399 return reduce_binary_aa (eval, op1, op2, result);
1400 }
1401
1402
1403 typedef union
1404 {
1405 arith (*f2)(gfc_expr *, gfc_expr **);
1406 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1407 }
1408 eval_f;
1409
1410 /* High level arithmetic subroutines. These subroutines go into
1411 eval_intrinsic(), which can do one of several things to its
1412 operands. If the operands are incompatible with the intrinsic
1413 operation, we return a node pointing to the operands and hope that
1414 an operator interface is found during resolution.
1415
1416 If the operands are compatible and are constants, then we try doing
1417 the arithmetic. We also handle the cases where either or both
1418 operands are array constructors. */
1419
1420 static gfc_expr *
1421 eval_intrinsic (gfc_intrinsic_op op,
1422 eval_f eval, gfc_expr *op1, gfc_expr *op2)
1423 {
1424 gfc_expr temp, *result;
1425 int unary;
1426 arith rc;
1427
1428 gfc_clear_ts (&temp.ts);
1429
1430 switch (op)
1431 {
1432 /* Logical unary */
1433 case INTRINSIC_NOT:
1434 if (op1->ts.type != BT_LOGICAL)
1435 goto runtime;
1436
1437 temp.ts.type = BT_LOGICAL;
1438 temp.ts.kind = gfc_default_logical_kind;
1439 unary = 1;
1440 break;
1441
1442 /* Logical binary operators */
1443 case INTRINSIC_OR:
1444 case INTRINSIC_AND:
1445 case INTRINSIC_NEQV:
1446 case INTRINSIC_EQV:
1447 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1448 goto runtime;
1449
1450 temp.ts.type = BT_LOGICAL;
1451 temp.ts.kind = gfc_default_logical_kind;
1452 unary = 0;
1453 break;
1454
1455 /* Numeric unary */
1456 case INTRINSIC_UPLUS:
1457 case INTRINSIC_UMINUS:
1458 if (!gfc_numeric_ts (&op1->ts))
1459 goto runtime;
1460
1461 temp.ts = op1->ts;
1462 unary = 1;
1463 break;
1464
1465 case INTRINSIC_PARENTHESES:
1466 temp.ts = op1->ts;
1467 unary = 1;
1468 break;
1469
1470 /* Additional restrictions for ordering relations. */
1471 case INTRINSIC_GE:
1472 case INTRINSIC_GE_OS:
1473 case INTRINSIC_LT:
1474 case INTRINSIC_LT_OS:
1475 case INTRINSIC_LE:
1476 case INTRINSIC_LE_OS:
1477 case INTRINSIC_GT:
1478 case INTRINSIC_GT_OS:
1479 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1480 {
1481 temp.ts.type = BT_LOGICAL;
1482 temp.ts.kind = gfc_default_logical_kind;
1483 goto runtime;
1484 }
1485
1486 /* Fall through */
1487 case INTRINSIC_EQ:
1488 case INTRINSIC_EQ_OS:
1489 case INTRINSIC_NE:
1490 case INTRINSIC_NE_OS:
1491 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1492 {
1493 unary = 0;
1494 temp.ts.type = BT_LOGICAL;
1495 temp.ts.kind = gfc_default_logical_kind;
1496
1497 /* If kind mismatch, exit and we'll error out later. */
1498 if (op1->ts.kind != op2->ts.kind)
1499 goto runtime;
1500
1501 break;
1502 }
1503
1504 /* Fall through */
1505 /* Numeric binary */
1506 case INTRINSIC_PLUS:
1507 case INTRINSIC_MINUS:
1508 case INTRINSIC_TIMES:
1509 case INTRINSIC_DIVIDE:
1510 case INTRINSIC_POWER:
1511 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1512 goto runtime;
1513
1514 /* Insert any necessary type conversions to make the operands
1515 compatible. */
1516
1517 temp.expr_type = EXPR_OP;
1518 gfc_clear_ts (&temp.ts);
1519 temp.value.op.op = op;
1520
1521 temp.value.op.op1 = op1;
1522 temp.value.op.op2 = op2;
1523
1524 gfc_type_convert_binary (&temp, 0);
1525
1526 if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1527 || op == INTRINSIC_GE || op == INTRINSIC_GT
1528 || op == INTRINSIC_LE || op == INTRINSIC_LT
1529 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1530 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1531 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1532 {
1533 temp.ts.type = BT_LOGICAL;
1534 temp.ts.kind = gfc_default_logical_kind;
1535 }
1536
1537 unary = 0;
1538 break;
1539
1540 /* Character binary */
1541 case INTRINSIC_CONCAT:
1542 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1543 || op1->ts.kind != op2->ts.kind)
1544 goto runtime;
1545
1546 temp.ts.type = BT_CHARACTER;
1547 temp.ts.kind = op1->ts.kind;
1548 unary = 0;
1549 break;
1550
1551 case INTRINSIC_USER:
1552 goto runtime;
1553
1554 default:
1555 gfc_internal_error ("eval_intrinsic(): Bad operator");
1556 }
1557
1558 if (op1->expr_type != EXPR_CONSTANT
1559 && (op1->expr_type != EXPR_ARRAY
1560 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1561 goto runtime;
1562
1563 if (op2 != NULL
1564 && op2->expr_type != EXPR_CONSTANT
1565 && (op2->expr_type != EXPR_ARRAY
1566 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1567 goto runtime;
1568
1569 if (unary)
1570 rc = reduce_unary (eval.f2, op1, &result);
1571 else
1572 rc = reduce_binary (eval.f3, op1, op2, &result);
1573
1574
1575 /* Something went wrong. */
1576 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1577 return NULL;
1578
1579 if (rc != ARITH_OK)
1580 {
1581 gfc_error (gfc_arith_error (rc), &op1->where);
1582 return NULL;
1583 }
1584
1585 gfc_free_expr (op1);
1586 gfc_free_expr (op2);
1587 return result;
1588
1589 runtime:
1590 /* Create a run-time expression. */
1591 result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1592 result->ts = temp.ts;
1593
1594 return result;
1595 }
1596
1597
1598 /* Modify type of expression for zero size array. */
1599
1600 static gfc_expr *
1601 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1602 {
1603 if (op == NULL)
1604 gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1605
1606 switch (iop)
1607 {
1608 case INTRINSIC_GE:
1609 case INTRINSIC_GE_OS:
1610 case INTRINSIC_LT:
1611 case INTRINSIC_LT_OS:
1612 case INTRINSIC_LE:
1613 case INTRINSIC_LE_OS:
1614 case INTRINSIC_GT:
1615 case INTRINSIC_GT_OS:
1616 case INTRINSIC_EQ:
1617 case INTRINSIC_EQ_OS:
1618 case INTRINSIC_NE:
1619 case INTRINSIC_NE_OS:
1620 op->ts.type = BT_LOGICAL;
1621 op->ts.kind = gfc_default_logical_kind;
1622 break;
1623
1624 default:
1625 break;
1626 }
1627
1628 return op;
1629 }
1630
1631
1632 /* Return nonzero if the expression is a zero size array. */
1633
1634 static int
1635 gfc_zero_size_array (gfc_expr *e)
1636 {
1637 if (e->expr_type != EXPR_ARRAY)
1638 return 0;
1639
1640 return e->value.constructor == NULL;
1641 }
1642
1643
1644 /* Reduce a binary expression where at least one of the operands
1645 involves a zero-length array. Returns NULL if neither of the
1646 operands is a zero-length array. */
1647
1648 static gfc_expr *
1649 reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1650 {
1651 if (gfc_zero_size_array (op1))
1652 {
1653 gfc_free_expr (op2);
1654 return op1;
1655 }
1656
1657 if (gfc_zero_size_array (op2))
1658 {
1659 gfc_free_expr (op1);
1660 return op2;
1661 }
1662
1663 return NULL;
1664 }
1665
1666
1667 static gfc_expr *
1668 eval_intrinsic_f2 (gfc_intrinsic_op op,
1669 arith (*eval) (gfc_expr *, gfc_expr **),
1670 gfc_expr *op1, gfc_expr *op2)
1671 {
1672 gfc_expr *result;
1673 eval_f f;
1674
1675 if (op2 == NULL)
1676 {
1677 if (gfc_zero_size_array (op1))
1678 return eval_type_intrinsic0 (op, op1);
1679 }
1680 else
1681 {
1682 result = reduce_binary0 (op1, op2);
1683 if (result != NULL)
1684 return eval_type_intrinsic0 (op, result);
1685 }
1686
1687 f.f2 = eval;
1688 return eval_intrinsic (op, f, op1, op2);
1689 }
1690
1691
1692 static gfc_expr *
1693 eval_intrinsic_f3 (gfc_intrinsic_op op,
1694 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1695 gfc_expr *op1, gfc_expr *op2)
1696 {
1697 gfc_expr *result;
1698 eval_f f;
1699
1700 result = reduce_binary0 (op1, op2);
1701 if (result != NULL)
1702 return eval_type_intrinsic0(op, result);
1703
1704 f.f3 = eval;
1705 return eval_intrinsic (op, f, op1, op2);
1706 }
1707
1708
1709 gfc_expr *
1710 gfc_parentheses (gfc_expr *op)
1711 {
1712 if (gfc_is_constant_expr (op))
1713 return op;
1714
1715 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1716 op, NULL);
1717 }
1718
1719 gfc_expr *
1720 gfc_uplus (gfc_expr *op)
1721 {
1722 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1723 }
1724
1725
1726 gfc_expr *
1727 gfc_uminus (gfc_expr *op)
1728 {
1729 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1730 }
1731
1732
1733 gfc_expr *
1734 gfc_add (gfc_expr *op1, gfc_expr *op2)
1735 {
1736 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1737 }
1738
1739
1740 gfc_expr *
1741 gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1742 {
1743 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1744 }
1745
1746
1747 gfc_expr *
1748 gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1749 {
1750 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1751 }
1752
1753
1754 gfc_expr *
1755 gfc_divide (gfc_expr *op1, gfc_expr *op2)
1756 {
1757 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1758 }
1759
1760
1761 gfc_expr *
1762 gfc_power (gfc_expr *op1, gfc_expr *op2)
1763 {
1764 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1765 }
1766
1767
1768 gfc_expr *
1769 gfc_concat (gfc_expr *op1, gfc_expr *op2)
1770 {
1771 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1772 }
1773
1774
1775 gfc_expr *
1776 gfc_and (gfc_expr *op1, gfc_expr *op2)
1777 {
1778 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1779 }
1780
1781
1782 gfc_expr *
1783 gfc_or (gfc_expr *op1, gfc_expr *op2)
1784 {
1785 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1786 }
1787
1788
1789 gfc_expr *
1790 gfc_not (gfc_expr *op1)
1791 {
1792 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1793 }
1794
1795
1796 gfc_expr *
1797 gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1798 {
1799 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1800 }
1801
1802
1803 gfc_expr *
1804 gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1805 {
1806 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1807 }
1808
1809
1810 gfc_expr *
1811 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1812 {
1813 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1814 }
1815
1816
1817 gfc_expr *
1818 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1819 {
1820 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1821 }
1822
1823
1824 gfc_expr *
1825 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1826 {
1827 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1828 }
1829
1830
1831 gfc_expr *
1832 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1833 {
1834 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1835 }
1836
1837
1838 gfc_expr *
1839 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1840 {
1841 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1842 }
1843
1844
1845 gfc_expr *
1846 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1847 {
1848 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1849 }
1850
1851
1852 /* Convert an integer string to an expression node. */
1853
1854 gfc_expr *
1855 gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1856 {
1857 gfc_expr *e;
1858 const char *t;
1859
1860 e = gfc_get_constant_expr (BT_INTEGER, kind, where);
1861 /* A leading plus is allowed, but not by mpz_set_str. */
1862 if (buffer[0] == '+')
1863 t = buffer + 1;
1864 else
1865 t = buffer;
1866 mpz_set_str (e->value.integer, t, radix);
1867
1868 return e;
1869 }
1870
1871
1872 /* Convert a real string to an expression node. */
1873
1874 gfc_expr *
1875 gfc_convert_real (const char *buffer, int kind, locus *where)
1876 {
1877 gfc_expr *e;
1878
1879 e = gfc_get_constant_expr (BT_REAL, kind, where);
1880 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1881
1882 return e;
1883 }
1884
1885
1886 /* Convert a pair of real, constant expression nodes to a single
1887 complex expression node. */
1888
1889 gfc_expr *
1890 gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1891 {
1892 gfc_expr *e;
1893
1894 e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
1895 mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1896 GFC_MPC_RND_MODE);
1897
1898 return e;
1899 }
1900
1901
1902 /******* Simplification of intrinsic functions with constant arguments *****/
1903
1904
1905 /* Deal with an arithmetic error. */
1906
1907 static void
1908 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1909 {
1910 switch (rc)
1911 {
1912 case ARITH_OK:
1913 gfc_error ("Arithmetic OK converting %s to %s at %L",
1914 gfc_typename (from), gfc_typename (to), where);
1915 break;
1916 case ARITH_OVERFLOW:
1917 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1918 "can be disabled with the option -fno-range-check",
1919 gfc_typename (from), gfc_typename (to), where);
1920 break;
1921 case ARITH_UNDERFLOW:
1922 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1923 "can be disabled with the option -fno-range-check",
1924 gfc_typename (from), gfc_typename (to), where);
1925 break;
1926 case ARITH_NAN:
1927 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1928 "can be disabled with the option -fno-range-check",
1929 gfc_typename (from), gfc_typename (to), where);
1930 break;
1931 case ARITH_DIV0:
1932 gfc_error ("Division by zero converting %s to %s at %L",
1933 gfc_typename (from), gfc_typename (to), where);
1934 break;
1935 case ARITH_INCOMMENSURATE:
1936 gfc_error ("Array operands are incommensurate converting %s to %s at %L",
1937 gfc_typename (from), gfc_typename (to), where);
1938 break;
1939 case ARITH_ASYMMETRIC:
1940 gfc_error ("Integer outside symmetric range implied by Standard Fortran"
1941 " converting %s to %s at %L",
1942 gfc_typename (from), gfc_typename (to), where);
1943 break;
1944 default:
1945 gfc_internal_error ("gfc_arith_error(): Bad error code");
1946 }
1947
1948 /* TODO: Do something about the error, i.e., throw exception, return
1949 NaN, etc. */
1950 }
1951
1952
1953 /* Convert integers to integers. */
1954
1955 gfc_expr *
1956 gfc_int2int (gfc_expr *src, int kind)
1957 {
1958 gfc_expr *result;
1959 arith rc;
1960
1961 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
1962
1963 mpz_set (result->value.integer, src->value.integer);
1964
1965 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
1966 {
1967 if (rc == ARITH_ASYMMETRIC)
1968 {
1969 gfc_warning (gfc_arith_error (rc), &src->where);
1970 }
1971 else
1972 {
1973 arith_error (rc, &src->ts, &result->ts, &src->where);
1974 gfc_free_expr (result);
1975 return NULL;
1976 }
1977 }
1978
1979 return result;
1980 }
1981
1982
1983 /* Convert integers to reals. */
1984
1985 gfc_expr *
1986 gfc_int2real (gfc_expr *src, int kind)
1987 {
1988 gfc_expr *result;
1989 arith rc;
1990
1991 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
1992
1993 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
1994
1995 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
1996 {
1997 arith_error (rc, &src->ts, &result->ts, &src->where);
1998 gfc_free_expr (result);
1999 return NULL;
2000 }
2001
2002 return result;
2003 }
2004
2005
2006 /* Convert default integer to default complex. */
2007
2008 gfc_expr *
2009 gfc_int2complex (gfc_expr *src, int kind)
2010 {
2011 gfc_expr *result;
2012 arith rc;
2013
2014 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2015
2016 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2017
2018 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2019 != ARITH_OK)
2020 {
2021 arith_error (rc, &src->ts, &result->ts, &src->where);
2022 gfc_free_expr (result);
2023 return NULL;
2024 }
2025
2026 return result;
2027 }
2028
2029
2030 /* Convert default real to default integer. */
2031
2032 gfc_expr *
2033 gfc_real2int (gfc_expr *src, int kind)
2034 {
2035 gfc_expr *result;
2036 arith rc;
2037
2038 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2039
2040 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2041
2042 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2043 {
2044 arith_error (rc, &src->ts, &result->ts, &src->where);
2045 gfc_free_expr (result);
2046 return NULL;
2047 }
2048
2049 return result;
2050 }
2051
2052
2053 /* Convert real to real. */
2054
2055 gfc_expr *
2056 gfc_real2real (gfc_expr *src, int kind)
2057 {
2058 gfc_expr *result;
2059 arith rc;
2060
2061 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2062
2063 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2064
2065 rc = gfc_check_real_range (result->value.real, kind);
2066
2067 if (rc == ARITH_UNDERFLOW)
2068 {
2069 if (gfc_option.warn_underflow)
2070 gfc_warning (gfc_arith_error (rc), &src->where);
2071 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2072 }
2073 else if (rc != ARITH_OK)
2074 {
2075 arith_error (rc, &src->ts, &result->ts, &src->where);
2076 gfc_free_expr (result);
2077 return NULL;
2078 }
2079
2080 return result;
2081 }
2082
2083
2084 /* Convert real to complex. */
2085
2086 gfc_expr *
2087 gfc_real2complex (gfc_expr *src, int kind)
2088 {
2089 gfc_expr *result;
2090 arith rc;
2091
2092 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2093
2094 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2095
2096 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2097
2098 if (rc == ARITH_UNDERFLOW)
2099 {
2100 if (gfc_option.warn_underflow)
2101 gfc_warning (gfc_arith_error (rc), &src->where);
2102 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2103 }
2104 else if (rc != ARITH_OK)
2105 {
2106 arith_error (rc, &src->ts, &result->ts, &src->where);
2107 gfc_free_expr (result);
2108 return NULL;
2109 }
2110
2111 return result;
2112 }
2113
2114
2115 /* Convert complex to integer. */
2116
2117 gfc_expr *
2118 gfc_complex2int (gfc_expr *src, int kind)
2119 {
2120 gfc_expr *result;
2121 arith rc;
2122
2123 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2124
2125 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2126 &src->where);
2127
2128 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2129 {
2130 arith_error (rc, &src->ts, &result->ts, &src->where);
2131 gfc_free_expr (result);
2132 return NULL;
2133 }
2134
2135 return result;
2136 }
2137
2138
2139 /* Convert complex to real. */
2140
2141 gfc_expr *
2142 gfc_complex2real (gfc_expr *src, int kind)
2143 {
2144 gfc_expr *result;
2145 arith rc;
2146
2147 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2148
2149 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2150
2151 rc = gfc_check_real_range (result->value.real, kind);
2152
2153 if (rc == ARITH_UNDERFLOW)
2154 {
2155 if (gfc_option.warn_underflow)
2156 gfc_warning (gfc_arith_error (rc), &src->where);
2157 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2158 }
2159 if (rc != ARITH_OK)
2160 {
2161 arith_error (rc, &src->ts, &result->ts, &src->where);
2162 gfc_free_expr (result);
2163 return NULL;
2164 }
2165
2166 return result;
2167 }
2168
2169
2170 /* Convert complex to complex. */
2171
2172 gfc_expr *
2173 gfc_complex2complex (gfc_expr *src, int kind)
2174 {
2175 gfc_expr *result;
2176 arith rc;
2177
2178 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2179
2180 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2181
2182 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2183
2184 if (rc == ARITH_UNDERFLOW)
2185 {
2186 if (gfc_option.warn_underflow)
2187 gfc_warning (gfc_arith_error (rc), &src->where);
2188 mpfr_set_ui (mpc_realref (result->value.complex), 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 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2198
2199 if (rc == ARITH_UNDERFLOW)
2200 {
2201 if (gfc_option.warn_underflow)
2202 gfc_warning (gfc_arith_error (rc), &src->where);
2203 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2204 }
2205 else if (rc != ARITH_OK)
2206 {
2207 arith_error (rc, &src->ts, &result->ts, &src->where);
2208 gfc_free_expr (result);
2209 return NULL;
2210 }
2211
2212 return result;
2213 }
2214
2215
2216 /* Logical kind conversion. */
2217
2218 gfc_expr *
2219 gfc_log2log (gfc_expr *src, int kind)
2220 {
2221 gfc_expr *result;
2222
2223 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2224 result->value.logical = src->value.logical;
2225
2226 return result;
2227 }
2228
2229
2230 /* Convert logical to integer. */
2231
2232 gfc_expr *
2233 gfc_log2int (gfc_expr *src, int kind)
2234 {
2235 gfc_expr *result;
2236
2237 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2238 mpz_set_si (result->value.integer, src->value.logical);
2239
2240 return result;
2241 }
2242
2243
2244 /* Convert integer to logical. */
2245
2246 gfc_expr *
2247 gfc_int2log (gfc_expr *src, int kind)
2248 {
2249 gfc_expr *result;
2250
2251 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2252 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2253
2254 return result;
2255 }
2256
2257
2258 /* Helper function to set the representation in a Hollerith conversion.
2259 This assumes that the ts.type and ts.kind of the result have already
2260 been set. */
2261
2262 static void
2263 hollerith2representation (gfc_expr *result, gfc_expr *src)
2264 {
2265 int src_len, result_len;
2266
2267 src_len = src->representation.length - src->ts.u.pad;
2268 result_len = gfc_target_expr_size (result);
2269
2270 if (src_len > result_len)
2271 {
2272 gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2273 &src->where, gfc_typename(&result->ts));
2274 }
2275
2276 result->representation.string = XCNEWVEC (char, result_len + 1);
2277 memcpy (result->representation.string, src->representation.string,
2278 MIN (result_len, src_len));
2279
2280 if (src_len < result_len)
2281 memset (&result->representation.string[src_len], ' ', result_len - src_len);
2282
2283 result->representation.string[result_len] = '\0'; /* For debugger */
2284 result->representation.length = result_len;
2285 }
2286
2287
2288 /* Convert Hollerith to integer. The constant will be padded or truncated. */
2289
2290 gfc_expr *
2291 gfc_hollerith2int (gfc_expr *src, int kind)
2292 {
2293 gfc_expr *result;
2294 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2295
2296 hollerith2representation (result, src);
2297 gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2298 result->representation.length, result->value.integer);
2299
2300 return result;
2301 }
2302
2303
2304 /* Convert Hollerith to real. The constant will be padded or truncated. */
2305
2306 gfc_expr *
2307 gfc_hollerith2real (gfc_expr *src, int kind)
2308 {
2309 gfc_expr *result;
2310 result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2311
2312 hollerith2representation (result, src);
2313 gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2314 result->representation.length, result->value.real);
2315
2316 return result;
2317 }
2318
2319
2320 /* Convert Hollerith to complex. The constant will be padded or truncated. */
2321
2322 gfc_expr *
2323 gfc_hollerith2complex (gfc_expr *src, int kind)
2324 {
2325 gfc_expr *result;
2326 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2327
2328 hollerith2representation (result, src);
2329 gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2330 result->representation.length, result->value.complex);
2331
2332 return result;
2333 }
2334
2335
2336 /* Convert Hollerith to character. */
2337
2338 gfc_expr *
2339 gfc_hollerith2character (gfc_expr *src, int kind)
2340 {
2341 gfc_expr *result;
2342
2343 result = gfc_copy_expr (src);
2344 result->ts.type = BT_CHARACTER;
2345 result->ts.kind = kind;
2346
2347 result->value.character.length = result->representation.length;
2348 result->value.character.string
2349 = gfc_char_to_widechar (result->representation.string);
2350
2351 return result;
2352 }
2353
2354
2355 /* Convert Hollerith to logical. The constant will be padded or truncated. */
2356
2357 gfc_expr *
2358 gfc_hollerith2logical (gfc_expr *src, int kind)
2359 {
2360 gfc_expr *result;
2361 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2362
2363 hollerith2representation (result, src);
2364 gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2365 result->representation.length, &result->value.logical);
2366
2367 return result;
2368 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org