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