arith.cc revision 1.1.1.1
1 /* Compiler arithmetic 2 Copyright (C) 2000-2022 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 mpfr_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 = G_("Arithmetic OK at %L"); 98 break; 99 case ARITH_OVERFLOW: 100 p = G_("Arithmetic overflow at %L"); 101 break; 102 case ARITH_UNDERFLOW: 103 p = G_("Arithmetic underflow at %L"); 104 break; 105 case ARITH_NAN: 106 p = G_("Arithmetic NaN at %L"); 107 break; 108 case ARITH_DIV0: 109 p = G_("Division by zero at %L"); 110 break; 111 case ARITH_INCOMMENSURATE: 112 p = G_("Array operands are incommensurate at %L"); 113 break; 114 case ARITH_ASYMMETRIC: 115 p = G_("Integer outside symmetric range implied by Standard Fortran" 116 " at %L"); 117 break; 118 case ARITH_WRONGCONCAT: 119 p = G_("Illegal type in character concatenation at %L"); 120 break; 121 122 default: 123 gfc_internal_error ("gfc_arith_error(): Bad error code"); 124 } 125 126 return p; 127 } 128 129 130 /* Get things ready to do math. */ 131 132 void 133 gfc_arith_init_1 (void) 134 { 135 gfc_integer_info *int_info; 136 gfc_real_info *real_info; 137 mpfr_t a, b; 138 int i; 139 140 mpfr_set_default_prec (128); 141 mpfr_init (a); 142 143 /* Convert the minimum and maximum values for each kind into their 144 GNU MP representation. */ 145 for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) 146 { 147 /* Huge */ 148 mpz_init (int_info->huge); 149 mpz_set_ui (int_info->huge, int_info->radix); 150 mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits); 151 mpz_sub_ui (int_info->huge, int_info->huge, 1); 152 153 /* These are the numbers that are actually representable by the 154 target. For bases other than two, this needs to be changed. */ 155 if (int_info->radix != 2) 156 gfc_internal_error ("Fix min_int calculation"); 157 158 /* See PRs 13490 and 17912, related to integer ranges. 159 The pedantic_min_int exists for range checking when a program 160 is compiled with -pedantic, and reflects the belief that 161 Standard Fortran requires integers to be symmetrical, i.e. 162 every negative integer must have a representable positive 163 absolute value, and vice versa. */ 164 165 mpz_init (int_info->pedantic_min_int); 166 mpz_neg (int_info->pedantic_min_int, int_info->huge); 167 168 mpz_init (int_info->min_int); 169 mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1); 170 171 /* Range */ 172 mpfr_set_z (a, int_info->huge, GFC_RND_MODE); 173 mpfr_log10 (a, a, GFC_RND_MODE); 174 mpfr_trunc (a, a); 175 int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); 176 } 177 178 mpfr_clear (a); 179 180 for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) 181 { 182 gfc_set_model_kind (real_info->kind); 183 184 mpfr_init (a); 185 mpfr_init (b); 186 187 /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ 188 /* 1 - b**(-p) */ 189 mpfr_init (real_info->huge); 190 mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE); 191 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); 192 mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE); 193 mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE); 194 195 /* b**(emax-1) */ 196 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); 197 mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE); 198 199 /* (1 - b**(-p)) * b**(emax-1) */ 200 mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE); 201 202 /* (1 - b**(-p)) * b**(emax-1) * b */ 203 mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix, 204 GFC_RND_MODE); 205 206 /* tiny(x) = b**(emin-1) */ 207 mpfr_init (real_info->tiny); 208 mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE); 209 mpfr_pow_si (real_info->tiny, real_info->tiny, 210 real_info->min_exponent - 1, GFC_RND_MODE); 211 212 /* subnormal (x) = b**(emin - digit) */ 213 mpfr_init (real_info->subnormal); 214 mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE); 215 mpfr_pow_si (real_info->subnormal, real_info->subnormal, 216 real_info->min_exponent - real_info->digits, GFC_RND_MODE); 217 218 /* epsilon(x) = b**(1-p) */ 219 mpfr_init (real_info->epsilon); 220 mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE); 221 mpfr_pow_si (real_info->epsilon, real_info->epsilon, 222 1 - real_info->digits, GFC_RND_MODE); 223 224 /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */ 225 mpfr_log10 (a, real_info->huge, GFC_RND_MODE); 226 mpfr_log10 (b, real_info->tiny, GFC_RND_MODE); 227 mpfr_neg (b, b, GFC_RND_MODE); 228 229 /* a = min(a, b) */ 230 mpfr_min (a, a, b, GFC_RND_MODE); 231 mpfr_trunc (a, a); 232 real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); 233 234 /* precision(x) = int((p - 1) * log10(b)) + k */ 235 mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); 236 mpfr_log10 (a, a, GFC_RND_MODE); 237 mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); 238 mpfr_trunc (a, a); 239 real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE); 240 241 /* If the radix is an integral power of 10, add one to the precision. */ 242 for (i = 10; i <= real_info->radix; i *= 10) 243 if (i == real_info->radix) 244 real_info->precision++; 245 246 mpfr_clears (a, b, NULL); 247 } 248 } 249 250 251 /* Clean up, get rid of numeric constants. */ 252 253 void 254 gfc_arith_done_1 (void) 255 { 256 gfc_integer_info *ip; 257 gfc_real_info *rp; 258 259 for (ip = gfc_integer_kinds; ip->kind; ip++) 260 { 261 mpz_clear (ip->min_int); 262 mpz_clear (ip->pedantic_min_int); 263 mpz_clear (ip->huge); 264 } 265 266 for (rp = gfc_real_kinds; rp->kind; rp++) 267 mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); 268 269 mpfr_free_cache (); 270 } 271 272 273 /* Given a wide character value and a character kind, determine whether 274 the character is representable for that kind. */ 275 bool 276 gfc_check_character_range (gfc_char_t c, int kind) 277 { 278 /* As wide characters are stored as 32-bit values, they're all 279 representable in UCS=4. */ 280 if (kind == 4) 281 return true; 282 283 if (kind == 1) 284 return c <= 255 ? true : false; 285 286 gcc_unreachable (); 287 } 288 289 290 /* Given an integer and a kind, make sure that the integer lies within 291 the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or 292 ARITH_OVERFLOW. */ 293 294 arith 295 gfc_check_integer_range (mpz_t p, int kind) 296 { 297 arith result; 298 int i; 299 300 i = gfc_validate_kind (BT_INTEGER, kind, false); 301 result = ARITH_OK; 302 303 if (pedantic) 304 { 305 if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0) 306 result = ARITH_ASYMMETRIC; 307 } 308 309 310 if (flag_range_check == 0) 311 return result; 312 313 if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0 314 || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0) 315 result = ARITH_OVERFLOW; 316 317 return result; 318 } 319 320 321 /* Given a real and a kind, make sure that the real lies within the 322 range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or 323 ARITH_UNDERFLOW. */ 324 325 static arith 326 gfc_check_real_range (mpfr_t p, int kind) 327 { 328 arith retval; 329 mpfr_t q; 330 int i; 331 332 i = gfc_validate_kind (BT_REAL, kind, false); 333 334 gfc_set_model (p); 335 mpfr_init (q); 336 mpfr_abs (q, p, GFC_RND_MODE); 337 338 retval = ARITH_OK; 339 340 if (mpfr_inf_p (p)) 341 { 342 if (flag_range_check != 0) 343 retval = ARITH_OVERFLOW; 344 } 345 else if (mpfr_nan_p (p)) 346 { 347 if (flag_range_check != 0) 348 retval = ARITH_NAN; 349 } 350 else if (mpfr_sgn (q) == 0) 351 { 352 mpfr_clear (q); 353 return retval; 354 } 355 else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) 356 { 357 if (flag_range_check == 0) 358 mpfr_set_inf (p, mpfr_sgn (p)); 359 else 360 retval = ARITH_OVERFLOW; 361 } 362 else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0) 363 { 364 if (flag_range_check == 0) 365 { 366 if (mpfr_sgn (p) < 0) 367 { 368 mpfr_set_ui (p, 0, GFC_RND_MODE); 369 mpfr_set_si (q, -1, GFC_RND_MODE); 370 mpfr_copysign (p, p, q, GFC_RND_MODE); 371 } 372 else 373 mpfr_set_ui (p, 0, GFC_RND_MODE); 374 } 375 else 376 retval = ARITH_UNDERFLOW; 377 } 378 else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0) 379 { 380 mpfr_exp_t emin, emax; 381 int en; 382 383 /* Save current values of emin and emax. */ 384 emin = mpfr_get_emin (); 385 emax = mpfr_get_emax (); 386 387 /* Set emin and emax for the current model number. */ 388 en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1; 389 mpfr_set_emin ((mpfr_exp_t) en); 390 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent); 391 mpfr_check_range (q, 0, GFC_RND_MODE); 392 mpfr_subnormalize (q, 0, GFC_RND_MODE); 393 394 /* Reset emin and emax. */ 395 mpfr_set_emin (emin); 396 mpfr_set_emax (emax); 397 398 /* Copy sign if needed. */ 399 if (mpfr_sgn (p) < 0) 400 mpfr_neg (p, q, MPFR_RNDN); 401 else 402 mpfr_set (p, q, MPFR_RNDN); 403 } 404 405 mpfr_clear (q); 406 407 return retval; 408 } 409 410 411 /* Low-level arithmetic functions. All of these subroutines assume 412 that all operands are of the same type and return an operand of the 413 same type. The other thing about these subroutines is that they 414 can fail in various ways -- overflow, underflow, division by zero, 415 zero raised to the zero, etc. */ 416 417 static arith 418 gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) 419 { 420 gfc_expr *result; 421 422 result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where); 423 result->value.logical = !op1->value.logical; 424 *resultp = result; 425 426 return ARITH_OK; 427 } 428 429 430 static arith 431 gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 432 { 433 gfc_expr *result; 434 435 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), 436 &op1->where); 437 result->value.logical = op1->value.logical && op2->value.logical; 438 *resultp = result; 439 440 return ARITH_OK; 441 } 442 443 444 static arith 445 gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 446 { 447 gfc_expr *result; 448 449 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), 450 &op1->where); 451 result->value.logical = op1->value.logical || op2->value.logical; 452 *resultp = result; 453 454 return ARITH_OK; 455 } 456 457 458 static arith 459 gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 460 { 461 gfc_expr *result; 462 463 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), 464 &op1->where); 465 result->value.logical = op1->value.logical == op2->value.logical; 466 *resultp = result; 467 468 return ARITH_OK; 469 } 470 471 472 static arith 473 gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 474 { 475 gfc_expr *result; 476 477 result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), 478 &op1->where); 479 result->value.logical = op1->value.logical != op2->value.logical; 480 *resultp = result; 481 482 return ARITH_OK; 483 } 484 485 486 /* Make sure a constant numeric expression is within the range for 487 its type and kind. Note that there's also a gfc_check_range(), 488 but that one deals with the intrinsic RANGE function. */ 489 490 arith 491 gfc_range_check (gfc_expr *e) 492 { 493 arith rc; 494 arith rc2; 495 496 switch (e->ts.type) 497 { 498 case BT_INTEGER: 499 rc = gfc_check_integer_range (e->value.integer, e->ts.kind); 500 break; 501 502 case BT_REAL: 503 rc = gfc_check_real_range (e->value.real, e->ts.kind); 504 if (rc == ARITH_UNDERFLOW) 505 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); 506 if (rc == ARITH_OVERFLOW) 507 mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real)); 508 if (rc == ARITH_NAN) 509 mpfr_set_nan (e->value.real); 510 break; 511 512 case BT_COMPLEX: 513 rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind); 514 if (rc == ARITH_UNDERFLOW) 515 mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE); 516 if (rc == ARITH_OVERFLOW) 517 mpfr_set_inf (mpc_realref (e->value.complex), 518 mpfr_sgn (mpc_realref (e->value.complex))); 519 if (rc == ARITH_NAN) 520 mpfr_set_nan (mpc_realref (e->value.complex)); 521 522 rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind); 523 if (rc == ARITH_UNDERFLOW) 524 mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE); 525 if (rc == ARITH_OVERFLOW) 526 mpfr_set_inf (mpc_imagref (e->value.complex), 527 mpfr_sgn (mpc_imagref (e->value.complex))); 528 if (rc == ARITH_NAN) 529 mpfr_set_nan (mpc_imagref (e->value.complex)); 530 531 if (rc == ARITH_OK) 532 rc = rc2; 533 break; 534 535 default: 536 gfc_internal_error ("gfc_range_check(): Bad type"); 537 } 538 539 return rc; 540 } 541 542 543 /* Several of the following routines use the same set of statements to 544 check the validity of the result. Encapsulate the checking here. */ 545 546 static arith 547 check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp) 548 { 549 arith val = rc; 550 551 if (val == ARITH_UNDERFLOW) 552 { 553 if (warn_underflow) 554 gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where); 555 val = ARITH_OK; 556 } 557 558 if (val == ARITH_ASYMMETRIC) 559 { 560 gfc_warning (0, gfc_arith_error (val), &x->where); 561 val = ARITH_OK; 562 } 563 564 if (val == ARITH_OK || val == ARITH_OVERFLOW) 565 *rp = r; 566 else 567 gfc_free_expr (r); 568 569 return val; 570 } 571 572 573 /* It may seem silly to have a subroutine that actually computes the 574 unary plus of a constant, but it prevents us from making exceptions 575 in the code elsewhere. Used for unary plus and parenthesized 576 expressions. */ 577 578 static arith 579 gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp) 580 { 581 *resultp = gfc_copy_expr (op1); 582 return ARITH_OK; 583 } 584 585 586 static arith 587 gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) 588 { 589 gfc_expr *result; 590 arith rc; 591 592 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 593 594 switch (op1->ts.type) 595 { 596 case BT_INTEGER: 597 mpz_neg (result->value.integer, op1->value.integer); 598 break; 599 600 case BT_REAL: 601 mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE); 602 break; 603 604 case BT_COMPLEX: 605 mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE); 606 break; 607 608 default: 609 gfc_internal_error ("gfc_arith_uminus(): Bad basic type"); 610 } 611 612 rc = gfc_range_check (result); 613 614 return check_result (rc, op1, result, resultp); 615 } 616 617 618 static arith 619 gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 620 { 621 gfc_expr *result; 622 arith rc; 623 624 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 625 626 switch (op1->ts.type) 627 { 628 case BT_INTEGER: 629 mpz_add (result->value.integer, op1->value.integer, op2->value.integer); 630 break; 631 632 case BT_REAL: 633 mpfr_add (result->value.real, op1->value.real, op2->value.real, 634 GFC_RND_MODE); 635 break; 636 637 case BT_COMPLEX: 638 mpc_add (result->value.complex, op1->value.complex, op2->value.complex, 639 GFC_MPC_RND_MODE); 640 break; 641 642 default: 643 gfc_internal_error ("gfc_arith_plus(): Bad basic type"); 644 } 645 646 rc = gfc_range_check (result); 647 648 return check_result (rc, op1, result, resultp); 649 } 650 651 652 static arith 653 gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 654 { 655 gfc_expr *result; 656 arith rc; 657 658 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 659 660 switch (op1->ts.type) 661 { 662 case BT_INTEGER: 663 mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); 664 break; 665 666 case BT_REAL: 667 mpfr_sub (result->value.real, op1->value.real, op2->value.real, 668 GFC_RND_MODE); 669 break; 670 671 case BT_COMPLEX: 672 mpc_sub (result->value.complex, op1->value.complex, 673 op2->value.complex, GFC_MPC_RND_MODE); 674 break; 675 676 default: 677 gfc_internal_error ("gfc_arith_minus(): Bad basic type"); 678 } 679 680 rc = gfc_range_check (result); 681 682 return check_result (rc, op1, result, resultp); 683 } 684 685 686 static arith 687 gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 688 { 689 gfc_expr *result; 690 arith rc; 691 692 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 693 694 switch (op1->ts.type) 695 { 696 case BT_INTEGER: 697 mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); 698 break; 699 700 case BT_REAL: 701 mpfr_mul (result->value.real, op1->value.real, op2->value.real, 702 GFC_RND_MODE); 703 break; 704 705 case BT_COMPLEX: 706 gfc_set_model (mpc_realref (op1->value.complex)); 707 mpc_mul (result->value.complex, op1->value.complex, op2->value.complex, 708 GFC_MPC_RND_MODE); 709 break; 710 711 default: 712 gfc_internal_error ("gfc_arith_times(): Bad basic type"); 713 } 714 715 rc = gfc_range_check (result); 716 717 return check_result (rc, op1, result, resultp); 718 } 719 720 721 static arith 722 gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 723 { 724 gfc_expr *result; 725 arith rc; 726 727 rc = ARITH_OK; 728 729 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 730 731 switch (op1->ts.type) 732 { 733 case BT_INTEGER: 734 if (mpz_sgn (op2->value.integer) == 0) 735 { 736 rc = ARITH_DIV0; 737 break; 738 } 739 740 if (warn_integer_division) 741 { 742 mpz_t r; 743 mpz_init (r); 744 mpz_tdiv_qr (result->value.integer, r, op1->value.integer, 745 op2->value.integer); 746 747 if (mpz_cmp_si (r, 0) != 0) 748 { 749 char *p; 750 p = mpz_get_str (NULL, 10, result->value.integer); 751 gfc_warning_now (OPT_Winteger_division, "Integer division " 752 "truncated to constant %qs at %L", p, 753 &op1->where); 754 free (p); 755 } 756 mpz_clear (r); 757 } 758 else 759 mpz_tdiv_q (result->value.integer, op1->value.integer, 760 op2->value.integer); 761 762 break; 763 764 case BT_REAL: 765 if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1) 766 { 767 rc = ARITH_DIV0; 768 break; 769 } 770 771 mpfr_div (result->value.real, op1->value.real, op2->value.real, 772 GFC_RND_MODE); 773 break; 774 775 case BT_COMPLEX: 776 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0 777 && flag_range_check == 1) 778 { 779 rc = ARITH_DIV0; 780 break; 781 } 782 783 gfc_set_model (mpc_realref (op1->value.complex)); 784 if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0) 785 { 786 /* In Fortran, return (NaN + NaN I) for any zero divisor. See 787 PR 40318. */ 788 mpfr_set_nan (mpc_realref (result->value.complex)); 789 mpfr_set_nan (mpc_imagref (result->value.complex)); 790 } 791 else 792 mpc_div (result->value.complex, op1->value.complex, op2->value.complex, 793 GFC_MPC_RND_MODE); 794 break; 795 796 default: 797 gfc_internal_error ("gfc_arith_divide(): Bad basic type"); 798 } 799 800 if (rc == ARITH_OK) 801 rc = gfc_range_check (result); 802 803 return check_result (rc, op1, result, resultp); 804 } 805 806 /* Raise a number to a power. */ 807 808 static arith 809 arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 810 { 811 int power_sign; 812 gfc_expr *result; 813 arith rc; 814 815 rc = ARITH_OK; 816 result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); 817 818 switch (op2->ts.type) 819 { 820 case BT_INTEGER: 821 power_sign = mpz_sgn (op2->value.integer); 822 823 if (power_sign == 0) 824 { 825 /* Handle something to the zeroth power. Since we're dealing 826 with integral exponents, there is no ambiguity in the 827 limiting procedure used to determine the value of 0**0. */ 828 switch (op1->ts.type) 829 { 830 case BT_INTEGER: 831 mpz_set_ui (result->value.integer, 1); 832 break; 833 834 case BT_REAL: 835 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); 836 break; 837 838 case BT_COMPLEX: 839 mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); 840 break; 841 842 default: 843 gfc_internal_error ("arith_power(): Bad base"); 844 } 845 } 846 else 847 { 848 switch (op1->ts.type) 849 { 850 case BT_INTEGER: 851 { 852 /* First, we simplify the cases of op1 == 1, 0 or -1. */ 853 if (mpz_cmp_si (op1->value.integer, 1) == 0) 854 { 855 /* 1**op2 == 1 */ 856 mpz_set_si (result->value.integer, 1); 857 } 858 else if (mpz_cmp_si (op1->value.integer, 0) == 0) 859 { 860 /* 0**op2 == 0, if op2 > 0 861 0**op2 overflow, if op2 < 0 ; in that case, we 862 set the result to 0 and return ARITH_DIV0. */ 863 mpz_set_si (result->value.integer, 0); 864 if (mpz_cmp_si (op2->value.integer, 0) < 0) 865 rc = ARITH_DIV0; 866 } 867 else if (mpz_cmp_si (op1->value.integer, -1) == 0) 868 { 869 /* (-1)**op2 == (-1)**(mod(op2,2)) */ 870 unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2); 871 if (odd) 872 mpz_set_si (result->value.integer, -1); 873 else 874 mpz_set_si (result->value.integer, 1); 875 } 876 /* Then, we take care of op2 < 0. */ 877 else if (mpz_cmp_si (op2->value.integer, 0) < 0) 878 { 879 /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */ 880 mpz_set_si (result->value.integer, 0); 881 if (warn_integer_division) 882 gfc_warning_now (OPT_Winteger_division, "Negative " 883 "exponent of integer has zero " 884 "result at %L", &result->where); 885 } 886 else 887 { 888 /* We have abs(op1) > 1 and op2 > 1. 889 If op2 > bit_size(op1), we'll have an out-of-range 890 result. */ 891 int k, power; 892 893 k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false); 894 power = gfc_integer_kinds[k].bit_size; 895 if (mpz_cmp_si (op2->value.integer, power) < 0) 896 { 897 gfc_extract_int (op2, &power); 898 mpz_pow_ui (result->value.integer, op1->value.integer, 899 power); 900 rc = gfc_range_check (result); 901 if (rc == ARITH_OVERFLOW) 902 gfc_error_now ("Result of exponentiation at %L " 903 "exceeds the range of %s", &op1->where, 904 gfc_typename (&(op1->ts))); 905 } 906 else 907 { 908 /* Provide a nonsense value to propagate up. */ 909 mpz_set (result->value.integer, 910 gfc_integer_kinds[k].huge); 911 mpz_add_ui (result->value.integer, 912 result->value.integer, 1); 913 rc = ARITH_OVERFLOW; 914 } 915 } 916 } 917 break; 918 919 case BT_REAL: 920 mpfr_pow_z (result->value.real, op1->value.real, 921 op2->value.integer, GFC_RND_MODE); 922 break; 923 924 case BT_COMPLEX: 925 mpc_pow_z (result->value.complex, op1->value.complex, 926 op2->value.integer, GFC_MPC_RND_MODE); 927 break; 928 929 default: 930 break; 931 } 932 } 933 break; 934 935 case BT_REAL: 936 937 if (gfc_init_expr_flag) 938 { 939 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " 940 "exponent in an initialization " 941 "expression at %L", &op2->where)) 942 { 943 gfc_free_expr (result); 944 return ARITH_PROHIBIT; 945 } 946 } 947 948 if (mpfr_cmp_si (op1->value.real, 0) < 0) 949 { 950 gfc_error ("Raising a negative REAL at %L to " 951 "a REAL power is prohibited", &op1->where); 952 gfc_free_expr (result); 953 return ARITH_PROHIBIT; 954 } 955 956 mpfr_pow (result->value.real, op1->value.real, op2->value.real, 957 GFC_RND_MODE); 958 break; 959 960 case BT_COMPLEX: 961 { 962 if (gfc_init_expr_flag) 963 { 964 if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " 965 "exponent in an initialization " 966 "expression at %L", &op2->where)) 967 { 968 gfc_free_expr (result); 969 return ARITH_PROHIBIT; 970 } 971 } 972 973 mpc_pow (result->value.complex, op1->value.complex, 974 op2->value.complex, GFC_MPC_RND_MODE); 975 } 976 break; 977 default: 978 gfc_internal_error ("arith_power(): unknown type"); 979 } 980 981 if (rc == ARITH_OK) 982 rc = gfc_range_check (result); 983 984 return check_result (rc, op1, result, resultp); 985 } 986 987 988 /* Concatenate two string constants. */ 989 990 static arith 991 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 992 { 993 gfc_expr *result; 994 size_t len; 995 996 /* By cleverly playing around with constructors, it is possible 997 to get mismaching types here. */ 998 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER 999 || op1->ts.kind != op2->ts.kind) 1000 return ARITH_WRONGCONCAT; 1001 1002 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, 1003 &op1->where); 1004 1005 len = op1->value.character.length + op2->value.character.length; 1006 1007 result->value.character.string = gfc_get_wide_string (len + 1); 1008 result->value.character.length = len; 1009 1010 memcpy (result->value.character.string, op1->value.character.string, 1011 op1->value.character.length * sizeof (gfc_char_t)); 1012 1013 memcpy (&result->value.character.string[op1->value.character.length], 1014 op2->value.character.string, 1015 op2->value.character.length * sizeof (gfc_char_t)); 1016 1017 result->value.character.string[len] = '\0'; 1018 1019 *resultp = result; 1020 1021 return ARITH_OK; 1022 } 1023 1024 /* Comparison between real values; returns 0 if (op1 .op. op2) is true. 1025 This function mimics mpfr_cmp but takes NaN into account. */ 1026 1027 static int 1028 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1029 { 1030 int rc; 1031 switch (op) 1032 { 1033 case INTRINSIC_EQ: 1034 rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1; 1035 break; 1036 case INTRINSIC_GT: 1037 rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1; 1038 break; 1039 case INTRINSIC_GE: 1040 rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1; 1041 break; 1042 case INTRINSIC_LT: 1043 rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1; 1044 break; 1045 case INTRINSIC_LE: 1046 rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1; 1047 break; 1048 default: 1049 gfc_internal_error ("compare_real(): Bad operator"); 1050 } 1051 1052 return rc; 1053 } 1054 1055 /* Comparison operators. Assumes that the two expression nodes 1056 contain two constants of the same type. The op argument is 1057 needed to handle NaN correctly. */ 1058 1059 int 1060 gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1061 { 1062 int rc; 1063 1064 switch (op1->ts.type) 1065 { 1066 case BT_INTEGER: 1067 rc = mpz_cmp (op1->value.integer, op2->value.integer); 1068 break; 1069 1070 case BT_REAL: 1071 rc = compare_real (op1, op2, op); 1072 break; 1073 1074 case BT_CHARACTER: 1075 rc = gfc_compare_string (op1, op2); 1076 break; 1077 1078 case BT_LOGICAL: 1079 rc = ((!op1->value.logical && op2->value.logical) 1080 || (op1->value.logical && !op2->value.logical)); 1081 break; 1082 1083 case BT_COMPLEX: 1084 gcc_assert (op == INTRINSIC_EQ); 1085 rc = mpc_cmp (op1->value.complex, op2->value.complex); 1086 break; 1087 1088 default: 1089 gfc_internal_error ("gfc_compare_expr(): Bad basic type"); 1090 } 1091 1092 return rc; 1093 } 1094 1095 1096 /* Compare a pair of complex numbers. Naturally, this is only for 1097 equality and inequality. */ 1098 1099 static int 1100 compare_complex (gfc_expr *op1, gfc_expr *op2) 1101 { 1102 return mpc_cmp (op1->value.complex, op2->value.complex) == 0; 1103 } 1104 1105 1106 /* Given two constant strings and the inverse collating sequence, compare the 1107 strings. We return -1 for a < b, 0 for a == b and 1 for a > b. 1108 We use the processor's default collating sequence. */ 1109 1110 int 1111 gfc_compare_string (gfc_expr *a, gfc_expr *b) 1112 { 1113 size_t len, alen, blen, i; 1114 gfc_char_t ac, bc; 1115 1116 alen = a->value.character.length; 1117 blen = b->value.character.length; 1118 1119 len = MAX(alen, blen); 1120 1121 for (i = 0; i < len; i++) 1122 { 1123 ac = ((i < alen) ? a->value.character.string[i] : ' '); 1124 bc = ((i < blen) ? b->value.character.string[i] : ' '); 1125 1126 if (ac < bc) 1127 return -1; 1128 if (ac > bc) 1129 return 1; 1130 } 1131 1132 /* Strings are equal */ 1133 return 0; 1134 } 1135 1136 1137 int 1138 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) 1139 { 1140 size_t len, alen, blen, i; 1141 gfc_char_t ac, bc; 1142 1143 alen = a->value.character.length; 1144 blen = strlen (b); 1145 1146 len = MAX(alen, blen); 1147 1148 for (i = 0; i < len; i++) 1149 { 1150 ac = ((i < alen) ? a->value.character.string[i] : ' '); 1151 bc = ((i < blen) ? b[i] : ' '); 1152 1153 if (!case_sensitive) 1154 { 1155 ac = TOLOWER (ac); 1156 bc = TOLOWER (bc); 1157 } 1158 1159 if (ac < bc) 1160 return -1; 1161 if (ac > bc) 1162 return 1; 1163 } 1164 1165 /* Strings are equal */ 1166 return 0; 1167 } 1168 1169 1170 /* Specific comparison subroutines. */ 1171 1172 static arith 1173 gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1174 { 1175 gfc_expr *result; 1176 1177 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1178 &op1->where); 1179 result->value.logical = (op1->ts.type == BT_COMPLEX) 1180 ? compare_complex (op1, op2) 1181 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0); 1182 1183 *resultp = result; 1184 return ARITH_OK; 1185 } 1186 1187 1188 static arith 1189 gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1190 { 1191 gfc_expr *result; 1192 1193 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1194 &op1->where); 1195 result->value.logical = (op1->ts.type == BT_COMPLEX) 1196 ? !compare_complex (op1, op2) 1197 : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0); 1198 1199 *resultp = result; 1200 return ARITH_OK; 1201 } 1202 1203 1204 static arith 1205 gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1206 { 1207 gfc_expr *result; 1208 1209 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1210 &op1->where); 1211 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0); 1212 *resultp = result; 1213 1214 return ARITH_OK; 1215 } 1216 1217 1218 static arith 1219 gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1220 { 1221 gfc_expr *result; 1222 1223 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1224 &op1->where); 1225 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0); 1226 *resultp = result; 1227 1228 return ARITH_OK; 1229 } 1230 1231 1232 static arith 1233 gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1234 { 1235 gfc_expr *result; 1236 1237 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1238 &op1->where); 1239 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0); 1240 *resultp = result; 1241 1242 return ARITH_OK; 1243 } 1244 1245 1246 static arith 1247 gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 1248 { 1249 gfc_expr *result; 1250 1251 result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, 1252 &op1->where); 1253 result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0); 1254 *resultp = result; 1255 1256 return ARITH_OK; 1257 } 1258 1259 1260 static arith 1261 reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, 1262 gfc_expr **result) 1263 { 1264 gfc_constructor_base head; 1265 gfc_constructor *c; 1266 gfc_expr *r; 1267 arith rc; 1268 1269 if (op->expr_type == EXPR_CONSTANT) 1270 return eval (op, result); 1271 1272 rc = ARITH_OK; 1273 head = gfc_constructor_copy (op->value.constructor); 1274 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) 1275 { 1276 rc = reduce_unary (eval, c->expr, &r); 1277 1278 if (rc != ARITH_OK) 1279 break; 1280 1281 gfc_replace_expr (c->expr, r); 1282 } 1283 1284 if (rc != ARITH_OK) 1285 gfc_constructor_free (head); 1286 else 1287 { 1288 gfc_constructor *c = gfc_constructor_first (head); 1289 if (c == NULL) 1290 { 1291 /* Handle zero-sized arrays. */ 1292 r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where); 1293 } 1294 else 1295 { 1296 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, 1297 &op->where); 1298 } 1299 r->shape = gfc_copy_shape (op->shape, op->rank); 1300 r->rank = op->rank; 1301 r->value.constructor = head; 1302 *result = r; 1303 } 1304 1305 return rc; 1306 } 1307 1308 1309 static arith 1310 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1311 gfc_expr *op1, gfc_expr *op2, gfc_expr **result) 1312 { 1313 gfc_constructor_base head; 1314 gfc_constructor *c; 1315 gfc_expr *r; 1316 arith rc = ARITH_OK; 1317 1318 head = gfc_constructor_copy (op1->value.constructor); 1319 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) 1320 { 1321 gfc_simplify_expr (c->expr, 0); 1322 1323 if (c->expr->expr_type == EXPR_CONSTANT) 1324 rc = eval (c->expr, op2, &r); 1325 else 1326 rc = reduce_binary_ac (eval, c->expr, op2, &r); 1327 1328 if (rc != ARITH_OK) 1329 break; 1330 1331 gfc_replace_expr (c->expr, r); 1332 } 1333 1334 if (rc != ARITH_OK) 1335 gfc_constructor_free (head); 1336 else 1337 { 1338 gfc_constructor *c = gfc_constructor_first (head); 1339 if (c) 1340 { 1341 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, 1342 &op1->where); 1343 r->shape = gfc_copy_shape (op1->shape, op1->rank); 1344 } 1345 else 1346 { 1347 gcc_assert (op1->ts.type != BT_UNKNOWN); 1348 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, 1349 &op1->where); 1350 r->shape = gfc_get_shape (op1->rank); 1351 } 1352 r->rank = op1->rank; 1353 r->value.constructor = head; 1354 *result = r; 1355 } 1356 1357 return rc; 1358 } 1359 1360 1361 static arith 1362 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1363 gfc_expr *op1, gfc_expr *op2, gfc_expr **result) 1364 { 1365 gfc_constructor_base head; 1366 gfc_constructor *c; 1367 gfc_expr *r; 1368 arith rc = ARITH_OK; 1369 1370 head = gfc_constructor_copy (op2->value.constructor); 1371 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) 1372 { 1373 gfc_simplify_expr (c->expr, 0); 1374 1375 if (c->expr->expr_type == EXPR_CONSTANT) 1376 rc = eval (op1, c->expr, &r); 1377 else 1378 rc = reduce_binary_ca (eval, op1, c->expr, &r); 1379 1380 if (rc != ARITH_OK) 1381 break; 1382 1383 gfc_replace_expr (c->expr, r); 1384 } 1385 1386 if (rc != ARITH_OK) 1387 gfc_constructor_free (head); 1388 else 1389 { 1390 gfc_constructor *c = gfc_constructor_first (head); 1391 if (c) 1392 { 1393 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, 1394 &op2->where); 1395 r->shape = gfc_copy_shape (op2->shape, op2->rank); 1396 } 1397 else 1398 { 1399 gcc_assert (op2->ts.type != BT_UNKNOWN); 1400 r = gfc_get_array_expr (op2->ts.type, op2->ts.kind, 1401 &op2->where); 1402 r->shape = gfc_get_shape (op2->rank); 1403 } 1404 r->rank = op2->rank; 1405 r->value.constructor = head; 1406 *result = r; 1407 } 1408 1409 return rc; 1410 } 1411 1412 1413 /* We need a forward declaration of reduce_binary. */ 1414 static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1415 gfc_expr *op1, gfc_expr *op2, gfc_expr **result); 1416 1417 1418 static arith 1419 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1420 gfc_expr *op1, gfc_expr *op2, gfc_expr **result) 1421 { 1422 gfc_constructor_base head; 1423 gfc_constructor *c, *d; 1424 gfc_expr *r; 1425 arith rc = ARITH_OK; 1426 1427 if (!gfc_check_conformance (op1, op2, _("elemental binary operation"))) 1428 return ARITH_INCOMMENSURATE; 1429 1430 head = gfc_constructor_copy (op1->value.constructor); 1431 for (c = gfc_constructor_first (head), 1432 d = gfc_constructor_first (op2->value.constructor); 1433 c && d; 1434 c = gfc_constructor_next (c), d = gfc_constructor_next (d)) 1435 { 1436 rc = reduce_binary (eval, c->expr, d->expr, &r); 1437 if (rc != ARITH_OK) 1438 break; 1439 1440 gfc_replace_expr (c->expr, r); 1441 } 1442 1443 if (c || d) 1444 rc = ARITH_INCOMMENSURATE; 1445 1446 if (rc != ARITH_OK) 1447 gfc_constructor_free (head); 1448 else 1449 { 1450 gfc_constructor *c = gfc_constructor_first (head); 1451 if (c == NULL) 1452 { 1453 /* Handle zero-sized arrays. */ 1454 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); 1455 } 1456 else 1457 { 1458 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, 1459 &op1->where); 1460 } 1461 r->shape = gfc_copy_shape (op1->shape, op1->rank); 1462 r->rank = op1->rank; 1463 r->value.constructor = head; 1464 *result = r; 1465 } 1466 1467 return rc; 1468 } 1469 1470 1471 static arith 1472 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1473 gfc_expr *op1, gfc_expr *op2, gfc_expr **result) 1474 { 1475 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT) 1476 return eval (op1, op2, result); 1477 1478 if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY) 1479 return reduce_binary_ca (eval, op1, op2, result); 1480 1481 if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT) 1482 return reduce_binary_ac (eval, op1, op2, result); 1483 1484 return reduce_binary_aa (eval, op1, op2, result); 1485 } 1486 1487 1488 typedef union 1489 { 1490 arith (*f2)(gfc_expr *, gfc_expr **); 1491 arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **); 1492 } 1493 eval_f; 1494 1495 /* High level arithmetic subroutines. These subroutines go into 1496 eval_intrinsic(), which can do one of several things to its 1497 operands. If the operands are incompatible with the intrinsic 1498 operation, we return a node pointing to the operands and hope that 1499 an operator interface is found during resolution. 1500 1501 If the operands are compatible and are constants, then we try doing 1502 the arithmetic. We also handle the cases where either or both 1503 operands are array constructors. */ 1504 1505 static gfc_expr * 1506 eval_intrinsic (gfc_intrinsic_op op, 1507 eval_f eval, gfc_expr *op1, gfc_expr *op2) 1508 { 1509 gfc_expr temp, *result; 1510 int unary; 1511 arith rc; 1512 1513 if (!op1) 1514 return NULL; 1515 1516 gfc_clear_ts (&temp.ts); 1517 1518 switch (op) 1519 { 1520 /* Logical unary */ 1521 case INTRINSIC_NOT: 1522 if (op1->ts.type != BT_LOGICAL) 1523 goto runtime; 1524 1525 temp.ts.type = BT_LOGICAL; 1526 temp.ts.kind = gfc_default_logical_kind; 1527 unary = 1; 1528 break; 1529 1530 /* Logical binary operators */ 1531 case INTRINSIC_OR: 1532 case INTRINSIC_AND: 1533 case INTRINSIC_NEQV: 1534 case INTRINSIC_EQV: 1535 if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL) 1536 goto runtime; 1537 1538 temp.ts.type = BT_LOGICAL; 1539 temp.ts.kind = gfc_default_logical_kind; 1540 unary = 0; 1541 break; 1542 1543 /* Numeric unary */ 1544 case INTRINSIC_UPLUS: 1545 case INTRINSIC_UMINUS: 1546 if (!gfc_numeric_ts (&op1->ts)) 1547 goto runtime; 1548 1549 temp.ts = op1->ts; 1550 unary = 1; 1551 break; 1552 1553 case INTRINSIC_PARENTHESES: 1554 temp.ts = op1->ts; 1555 unary = 1; 1556 break; 1557 1558 /* Additional restrictions for ordering relations. */ 1559 case INTRINSIC_GE: 1560 case INTRINSIC_GE_OS: 1561 case INTRINSIC_LT: 1562 case INTRINSIC_LT_OS: 1563 case INTRINSIC_LE: 1564 case INTRINSIC_LE_OS: 1565 case INTRINSIC_GT: 1566 case INTRINSIC_GT_OS: 1567 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) 1568 { 1569 temp.ts.type = BT_LOGICAL; 1570 temp.ts.kind = gfc_default_logical_kind; 1571 goto runtime; 1572 } 1573 1574 /* Fall through */ 1575 case INTRINSIC_EQ: 1576 case INTRINSIC_EQ_OS: 1577 case INTRINSIC_NE: 1578 case INTRINSIC_NE_OS: 1579 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) 1580 { 1581 unary = 0; 1582 temp.ts.type = BT_LOGICAL; 1583 temp.ts.kind = gfc_default_logical_kind; 1584 1585 /* If kind mismatch, exit and we'll error out later. */ 1586 if (op1->ts.kind != op2->ts.kind) 1587 goto runtime; 1588 1589 break; 1590 } 1591 1592 gcc_fallthrough (); 1593 /* Numeric binary */ 1594 case INTRINSIC_PLUS: 1595 case INTRINSIC_MINUS: 1596 case INTRINSIC_TIMES: 1597 case INTRINSIC_DIVIDE: 1598 case INTRINSIC_POWER: 1599 if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) 1600 goto runtime; 1601 1602 /* Insert any necessary type conversions to make the operands 1603 compatible. */ 1604 1605 temp.expr_type = EXPR_OP; 1606 gfc_clear_ts (&temp.ts); 1607 temp.value.op.op = op; 1608 1609 temp.value.op.op1 = op1; 1610 temp.value.op.op2 = op2; 1611 1612 gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra); 1613 1614 if (op == INTRINSIC_EQ || op == INTRINSIC_NE 1615 || op == INTRINSIC_GE || op == INTRINSIC_GT 1616 || op == INTRINSIC_LE || op == INTRINSIC_LT 1617 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS 1618 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS 1619 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS) 1620 { 1621 temp.ts.type = BT_LOGICAL; 1622 temp.ts.kind = gfc_default_logical_kind; 1623 } 1624 1625 unary = 0; 1626 break; 1627 1628 /* Character binary */ 1629 case INTRINSIC_CONCAT: 1630 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER 1631 || op1->ts.kind != op2->ts.kind) 1632 goto runtime; 1633 1634 temp.ts.type = BT_CHARACTER; 1635 temp.ts.kind = op1->ts.kind; 1636 unary = 0; 1637 break; 1638 1639 case INTRINSIC_USER: 1640 goto runtime; 1641 1642 default: 1643 gfc_internal_error ("eval_intrinsic(): Bad operator"); 1644 } 1645 1646 if (op1->expr_type != EXPR_CONSTANT 1647 && (op1->expr_type != EXPR_ARRAY 1648 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))) 1649 goto runtime; 1650 1651 if (op2 != NULL 1652 && op2->expr_type != EXPR_CONSTANT 1653 && (op2->expr_type != EXPR_ARRAY 1654 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) 1655 goto runtime; 1656 1657 if (unary) 1658 rc = reduce_unary (eval.f2, op1, &result); 1659 else 1660 rc = reduce_binary (eval.f3, op1, op2, &result); 1661 1662 1663 /* Something went wrong. */ 1664 if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT) 1665 return NULL; 1666 1667 if (rc != ARITH_OK) 1668 { 1669 gfc_error (gfc_arith_error (rc), &op1->where); 1670 if (rc == ARITH_OVERFLOW) 1671 goto done; 1672 1673 if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER) 1674 gfc_seen_div0 = true; 1675 1676 return NULL; 1677 } 1678 1679 done: 1680 1681 gfc_free_expr (op1); 1682 gfc_free_expr (op2); 1683 return result; 1684 1685 runtime: 1686 /* Create a run-time expression. */ 1687 result = gfc_get_operator_expr (&op1->where, op, op1, op2); 1688 result->ts = temp.ts; 1689 1690 return result; 1691 } 1692 1693 1694 /* Modify type of expression for zero size array. */ 1695 1696 static gfc_expr * 1697 eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op) 1698 { 1699 if (op == NULL) 1700 gfc_internal_error ("eval_type_intrinsic0(): op NULL"); 1701 1702 switch (iop) 1703 { 1704 case INTRINSIC_GE: 1705 case INTRINSIC_GE_OS: 1706 case INTRINSIC_LT: 1707 case INTRINSIC_LT_OS: 1708 case INTRINSIC_LE: 1709 case INTRINSIC_LE_OS: 1710 case INTRINSIC_GT: 1711 case INTRINSIC_GT_OS: 1712 case INTRINSIC_EQ: 1713 case INTRINSIC_EQ_OS: 1714 case INTRINSIC_NE: 1715 case INTRINSIC_NE_OS: 1716 op->ts.type = BT_LOGICAL; 1717 op->ts.kind = gfc_default_logical_kind; 1718 break; 1719 1720 default: 1721 break; 1722 } 1723 1724 return op; 1725 } 1726 1727 1728 /* Return nonzero if the expression is a zero size array. */ 1729 1730 static bool 1731 gfc_zero_size_array (gfc_expr *e) 1732 { 1733 if (e == NULL || e->expr_type != EXPR_ARRAY) 1734 return false; 1735 1736 return e->value.constructor == NULL; 1737 } 1738 1739 1740 /* Reduce a binary expression where at least one of the operands 1741 involves a zero-length array. Returns NULL if neither of the 1742 operands is a zero-length array. */ 1743 1744 static gfc_expr * 1745 reduce_binary0 (gfc_expr *op1, gfc_expr *op2) 1746 { 1747 if (gfc_zero_size_array (op1)) 1748 { 1749 gfc_free_expr (op2); 1750 return op1; 1751 } 1752 1753 if (gfc_zero_size_array (op2)) 1754 { 1755 gfc_free_expr (op1); 1756 return op2; 1757 } 1758 1759 return NULL; 1760 } 1761 1762 1763 static gfc_expr * 1764 eval_intrinsic_f2 (gfc_intrinsic_op op, 1765 arith (*eval) (gfc_expr *, gfc_expr **), 1766 gfc_expr *op1, gfc_expr *op2) 1767 { 1768 gfc_expr *result; 1769 eval_f f; 1770 1771 if (op2 == NULL) 1772 { 1773 if (gfc_zero_size_array (op1)) 1774 return eval_type_intrinsic0 (op, op1); 1775 } 1776 else 1777 { 1778 result = reduce_binary0 (op1, op2); 1779 if (result != NULL) 1780 return eval_type_intrinsic0 (op, result); 1781 } 1782 1783 f.f2 = eval; 1784 return eval_intrinsic (op, f, op1, op2); 1785 } 1786 1787 1788 static gfc_expr * 1789 eval_intrinsic_f3 (gfc_intrinsic_op op, 1790 arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), 1791 gfc_expr *op1, gfc_expr *op2) 1792 { 1793 gfc_expr *result; 1794 eval_f f; 1795 1796 if (!op1 && !op2) 1797 return NULL; 1798 1799 result = reduce_binary0 (op1, op2); 1800 if (result != NULL) 1801 return eval_type_intrinsic0(op, result); 1802 1803 f.f3 = eval; 1804 return eval_intrinsic (op, f, op1, op2); 1805 } 1806 1807 1808 gfc_expr * 1809 gfc_parentheses (gfc_expr *op) 1810 { 1811 if (gfc_is_constant_expr (op)) 1812 return op; 1813 1814 return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity, 1815 op, NULL); 1816 } 1817 1818 gfc_expr * 1819 gfc_uplus (gfc_expr *op) 1820 { 1821 return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL); 1822 } 1823 1824 1825 gfc_expr * 1826 gfc_uminus (gfc_expr *op) 1827 { 1828 return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL); 1829 } 1830 1831 1832 gfc_expr * 1833 gfc_add (gfc_expr *op1, gfc_expr *op2) 1834 { 1835 return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2); 1836 } 1837 1838 1839 gfc_expr * 1840 gfc_subtract (gfc_expr *op1, gfc_expr *op2) 1841 { 1842 return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2); 1843 } 1844 1845 1846 gfc_expr * 1847 gfc_multiply (gfc_expr *op1, gfc_expr *op2) 1848 { 1849 return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2); 1850 } 1851 1852 1853 gfc_expr * 1854 gfc_divide (gfc_expr *op1, gfc_expr *op2) 1855 { 1856 return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2); 1857 } 1858 1859 1860 gfc_expr * 1861 gfc_power (gfc_expr *op1, gfc_expr *op2) 1862 { 1863 return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2); 1864 } 1865 1866 1867 gfc_expr * 1868 gfc_concat (gfc_expr *op1, gfc_expr *op2) 1869 { 1870 return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2); 1871 } 1872 1873 1874 gfc_expr * 1875 gfc_and (gfc_expr *op1, gfc_expr *op2) 1876 { 1877 return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2); 1878 } 1879 1880 1881 gfc_expr * 1882 gfc_or (gfc_expr *op1, gfc_expr *op2) 1883 { 1884 return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2); 1885 } 1886 1887 1888 gfc_expr * 1889 gfc_not (gfc_expr *op1) 1890 { 1891 return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL); 1892 } 1893 1894 1895 gfc_expr * 1896 gfc_eqv (gfc_expr *op1, gfc_expr *op2) 1897 { 1898 return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2); 1899 } 1900 1901 1902 gfc_expr * 1903 gfc_neqv (gfc_expr *op1, gfc_expr *op2) 1904 { 1905 return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2); 1906 } 1907 1908 1909 gfc_expr * 1910 gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1911 { 1912 return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2); 1913 } 1914 1915 1916 gfc_expr * 1917 gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1918 { 1919 return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2); 1920 } 1921 1922 1923 gfc_expr * 1924 gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1925 { 1926 return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2); 1927 } 1928 1929 1930 gfc_expr * 1931 gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1932 { 1933 return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2); 1934 } 1935 1936 1937 gfc_expr * 1938 gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1939 { 1940 return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2); 1941 } 1942 1943 1944 gfc_expr * 1945 gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) 1946 { 1947 return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2); 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 (OPT_Wcharacter_truncation, "The Hollerith constant at %L " 2570 "is truncated in conversion to %qs", &src->where, 2571 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 /* Helper function to set the representation in a character conversion. 2587 This assumes that the ts.type and ts.kind of the result have already 2588 been set. */ 2589 2590 static void 2591 character2representation (gfc_expr *result, gfc_expr *src) 2592 { 2593 size_t src_len, result_len, i; 2594 src_len = src->value.character.length; 2595 gfc_target_expr_size (result, &result_len); 2596 2597 if (src_len > result_len) 2598 gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is " 2599 "truncated in conversion to %s", &src->where, 2600 gfc_typename(&result->ts)); 2601 2602 result->representation.string = XCNEWVEC (char, result_len + 1); 2603 2604 for (i = 0; i < MIN (result_len, src_len); i++) 2605 result->representation.string[i] = (char) src->value.character.string[i]; 2606 2607 if (src_len < result_len) 2608 memset (&result->representation.string[src_len], ' ', 2609 result_len - src_len); 2610 2611 result->representation.string[result_len] = '\0'; /* For debugger. */ 2612 result->representation.length = result_len; 2613 } 2614 2615 /* Convert Hollerith to integer. The constant will be padded or truncated. */ 2616 2617 gfc_expr * 2618 gfc_hollerith2int (gfc_expr *src, int kind) 2619 { 2620 gfc_expr *result; 2621 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2622 2623 hollerith2representation (result, src); 2624 gfc_interpret_integer (kind, (unsigned char *) result->representation.string, 2625 result->representation.length, result->value.integer); 2626 2627 return result; 2628 } 2629 2630 /* Convert character to integer. The constant will be padded or truncated. */ 2631 2632 gfc_expr * 2633 gfc_character2int (gfc_expr *src, int kind) 2634 { 2635 gfc_expr *result; 2636 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2637 2638 character2representation (result, src); 2639 gfc_interpret_integer (kind, (unsigned char *) result->representation.string, 2640 result->representation.length, result->value.integer); 2641 return result; 2642 } 2643 2644 /* Convert Hollerith to real. The constant will be padded or truncated. */ 2645 2646 gfc_expr * 2647 gfc_hollerith2real (gfc_expr *src, int kind) 2648 { 2649 gfc_expr *result; 2650 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2651 2652 hollerith2representation (result, src); 2653 gfc_interpret_float (kind, (unsigned char *) result->representation.string, 2654 result->representation.length, result->value.real); 2655 2656 return result; 2657 } 2658 2659 /* Convert character to real. The constant will be padded or truncated. */ 2660 2661 gfc_expr * 2662 gfc_character2real (gfc_expr *src, int kind) 2663 { 2664 gfc_expr *result; 2665 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2666 2667 character2representation (result, src); 2668 gfc_interpret_float (kind, (unsigned char *) result->representation.string, 2669 result->representation.length, result->value.real); 2670 2671 return result; 2672 } 2673 2674 2675 /* Convert Hollerith to complex. The constant will be padded or truncated. */ 2676 2677 gfc_expr * 2678 gfc_hollerith2complex (gfc_expr *src, int kind) 2679 { 2680 gfc_expr *result; 2681 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2682 2683 hollerith2representation (result, src); 2684 gfc_interpret_complex (kind, (unsigned char *) result->representation.string, 2685 result->representation.length, result->value.complex); 2686 2687 return result; 2688 } 2689 2690 /* Convert character to complex. The constant will be padded or truncated. */ 2691 2692 gfc_expr * 2693 gfc_character2complex (gfc_expr *src, int kind) 2694 { 2695 gfc_expr *result; 2696 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2697 2698 character2representation (result, src); 2699 gfc_interpret_complex (kind, (unsigned char *) result->representation.string, 2700 result->representation.length, result->value.complex); 2701 2702 return result; 2703 } 2704 2705 2706 /* Convert Hollerith to character. */ 2707 2708 gfc_expr * 2709 gfc_hollerith2character (gfc_expr *src, int kind) 2710 { 2711 gfc_expr *result; 2712 2713 result = gfc_copy_expr (src); 2714 result->ts.type = BT_CHARACTER; 2715 result->ts.kind = kind; 2716 result->ts.u.pad = 0; 2717 2718 result->value.character.length = result->representation.length; 2719 result->value.character.string 2720 = gfc_char_to_widechar (result->representation.string); 2721 2722 return result; 2723 } 2724 2725 2726 /* Convert Hollerith to logical. The constant will be padded or truncated. */ 2727 2728 gfc_expr * 2729 gfc_hollerith2logical (gfc_expr *src, int kind) 2730 { 2731 gfc_expr *result; 2732 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2733 2734 hollerith2representation (result, src); 2735 gfc_interpret_logical (kind, (unsigned char *) result->representation.string, 2736 result->representation.length, &result->value.logical); 2737 2738 return result; 2739 } 2740 2741 /* Convert character to logical. The constant will be padded or truncated. */ 2742 2743 gfc_expr * 2744 gfc_character2logical (gfc_expr *src, int kind) 2745 { 2746 gfc_expr *result; 2747 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2748 2749 character2representation (result, src); 2750 gfc_interpret_logical (kind, (unsigned char *) result->representation.string, 2751 result->representation.length, &result->value.logical); 2752 2753 return result; 2754 } 2755
Indexes created Sun Apr 26 00:22:38 UTC 2026