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