1 /* Compiler arithmetic 2 Copyright (C) 2000-2020 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 = _("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 mpfr_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 ((mpfr_exp_t) en); 391 mpfr_set_emax ((mpfr_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, MPFR_RNDN); 402 else 403 mpfr_set (p, q, MPFR_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, it 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 /******* Simplification of intrinsic functions with constant arguments *****/ 1902 1903 1904 /* Deal with an arithmetic error. */ 1905 1906 static void 1907 arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where) 1908 { 1909 switch (rc) 1910 { 1911 case ARITH_OK: 1912 gfc_error ("Arithmetic OK converting %s to %s at %L", 1913 gfc_typename (from), gfc_typename (to), where); 1914 break; 1915 case ARITH_OVERFLOW: 1916 gfc_error ("Arithmetic overflow converting %s to %s at %L. This check " 1917 "can be disabled with the option %<-fno-range-check%>", 1918 gfc_typename (from), gfc_typename (to), where); 1919 break; 1920 case ARITH_UNDERFLOW: 1921 gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " 1922 "can be disabled with the option %<-fno-range-check%>", 1923 gfc_typename (from), gfc_typename (to), where); 1924 break; 1925 case ARITH_NAN: 1926 gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " 1927 "can be disabled with the option %<-fno-range-check%>", 1928 gfc_typename (from), gfc_typename (to), where); 1929 break; 1930 case ARITH_DIV0: 1931 gfc_error ("Division by zero converting %s to %s at %L", 1932 gfc_typename (from), gfc_typename (to), where); 1933 break; 1934 case ARITH_INCOMMENSURATE: 1935 gfc_error ("Array operands are incommensurate converting %s to %s at %L", 1936 gfc_typename (from), gfc_typename (to), where); 1937 break; 1938 case ARITH_ASYMMETRIC: 1939 gfc_error ("Integer outside symmetric range implied by Standard Fortran" 1940 " converting %s to %s at %L", 1941 gfc_typename (from), gfc_typename (to), where); 1942 break; 1943 default: 1944 gfc_internal_error ("gfc_arith_error(): Bad error code"); 1945 } 1946 1947 /* TODO: Do something about the error, i.e., throw exception, return 1948 NaN, etc. */ 1949 } 1950 1951 /* Returns true if significant bits were lost when converting real 1952 constant r from from_kind to to_kind. */ 1953 1954 static bool 1955 wprecision_real_real (mpfr_t r, int from_kind, int to_kind) 1956 { 1957 mpfr_t rv, diff; 1958 bool ret; 1959 1960 gfc_set_model_kind (to_kind); 1961 mpfr_init (rv); 1962 gfc_set_model_kind (from_kind); 1963 mpfr_init (diff); 1964 1965 mpfr_set (rv, r, GFC_RND_MODE); 1966 mpfr_sub (diff, rv, r, GFC_RND_MODE); 1967 1968 ret = ! mpfr_zero_p (diff); 1969 mpfr_clear (rv); 1970 mpfr_clear (diff); 1971 return ret; 1972 } 1973 1974 /* Return true if conversion from an integer to a real loses precision. */ 1975 1976 static bool 1977 wprecision_int_real (mpz_t n, mpfr_t r) 1978 { 1979 bool ret; 1980 mpz_t i; 1981 mpz_init (i); 1982 mpfr_get_z (i, r, GFC_RND_MODE); 1983 mpz_sub (i, i, n); 1984 ret = mpz_cmp_si (i, 0) != 0; 1985 mpz_clear (i); 1986 return ret; 1987 } 1988 1989 /* Convert integers to integers. */ 1990 1991 gfc_expr * 1992 gfc_int2int (gfc_expr *src, int kind) 1993 { 1994 gfc_expr *result; 1995 arith rc; 1996 1997 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 1998 1999 mpz_set (result->value.integer, src->value.integer); 2000 2001 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) 2002 { 2003 if (rc == ARITH_ASYMMETRIC) 2004 { 2005 gfc_warning (0, gfc_arith_error (rc), &src->where); 2006 } 2007 else 2008 { 2009 arith_error (rc, &src->ts, &result->ts, &src->where); 2010 gfc_free_expr (result); 2011 return NULL; 2012 } 2013 } 2014 2015 /* If we do not trap numeric overflow, we need to convert the number to 2016 signed, throwing away high-order bits if necessary. */ 2017 if (flag_range_check == 0) 2018 { 2019 int k; 2020 2021 k = gfc_validate_kind (BT_INTEGER, kind, false); 2022 gfc_convert_mpz_to_signed (result->value.integer, 2023 gfc_integer_kinds[k].bit_size); 2024 2025 if (warn_conversion && !src->do_not_warn && kind < src->ts.kind) 2026 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", 2027 gfc_typename (&src->ts), gfc_typename (&result->ts), 2028 &src->where); 2029 } 2030 return result; 2031 } 2032 2033 2034 /* Convert integers to reals. */ 2035 2036 gfc_expr * 2037 gfc_int2real (gfc_expr *src, int kind) 2038 { 2039 gfc_expr *result; 2040 arith rc; 2041 2042 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2043 2044 mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); 2045 2046 if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) 2047 { 2048 arith_error (rc, &src->ts, &result->ts, &src->where); 2049 gfc_free_expr (result); 2050 return NULL; 2051 } 2052 2053 if (warn_conversion 2054 && wprecision_int_real (src->value.integer, result->value.real)) 2055 gfc_warning (OPT_Wconversion, "Change of value in conversion " 2056 "from %qs to %qs at %L", 2057 gfc_typename (&src->ts), 2058 gfc_typename (&result->ts), 2059 &src->where); 2060 2061 return result; 2062 } 2063 2064 2065 /* Convert default integer to default complex. */ 2066 2067 gfc_expr * 2068 gfc_int2complex (gfc_expr *src, int kind) 2069 { 2070 gfc_expr *result; 2071 arith rc; 2072 2073 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2074 2075 mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); 2076 2077 if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind)) 2078 != ARITH_OK) 2079 { 2080 arith_error (rc, &src->ts, &result->ts, &src->where); 2081 gfc_free_expr (result); 2082 return NULL; 2083 } 2084 2085 if (warn_conversion 2086 && wprecision_int_real (src->value.integer, 2087 mpc_realref (result->value.complex))) 2088 gfc_warning_now (OPT_Wconversion, "Change of value in conversion " 2089 "from %qs to %qs at %L", 2090 gfc_typename (&src->ts), 2091 gfc_typename (&result->ts), 2092 &src->where); 2093 2094 return result; 2095 } 2096 2097 2098 /* Convert default real to default integer. */ 2099 2100 gfc_expr * 2101 gfc_real2int (gfc_expr *src, int kind) 2102 { 2103 gfc_expr *result; 2104 arith rc; 2105 bool did_warn = false; 2106 2107 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2108 2109 gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); 2110 2111 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) 2112 { 2113 arith_error (rc, &src->ts, &result->ts, &src->where); 2114 gfc_free_expr (result); 2115 return NULL; 2116 } 2117 2118 /* If there was a fractional part, warn about this. */ 2119 2120 if (warn_conversion) 2121 { 2122 mpfr_t f; 2123 mpfr_init (f); 2124 mpfr_frac (f, src->value.real, GFC_RND_MODE); 2125 if (mpfr_cmp_si (f, 0) != 0) 2126 { 2127 gfc_warning_now (OPT_Wconversion, "Change of value in conversion " 2128 "from %qs to %qs at %L", gfc_typename (&src->ts), 2129 gfc_typename (&result->ts), &src->where); 2130 did_warn = true; 2131 } 2132 } 2133 if (!did_warn && warn_conversion_extra) 2134 { 2135 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " 2136 "at %L", gfc_typename (&src->ts), 2137 gfc_typename (&result->ts), &src->where); 2138 } 2139 2140 return result; 2141 } 2142 2143 2144 /* Convert real to real. */ 2145 2146 gfc_expr * 2147 gfc_real2real (gfc_expr *src, int kind) 2148 { 2149 gfc_expr *result; 2150 arith rc; 2151 bool did_warn = false; 2152 2153 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2154 2155 mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); 2156 2157 rc = gfc_check_real_range (result->value.real, kind); 2158 2159 if (rc == ARITH_UNDERFLOW) 2160 { 2161 if (warn_underflow) 2162 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); 2163 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 2164 } 2165 else if (rc != ARITH_OK) 2166 { 2167 arith_error (rc, &src->ts, &result->ts, &src->where); 2168 gfc_free_expr (result); 2169 return NULL; 2170 } 2171 2172 /* As a special bonus, don't warn about REAL values which are not changed by 2173 the conversion if -Wconversion is specified and -Wconversion-extra is 2174 not. */ 2175 2176 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) 2177 { 2178 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; 2179 2180 /* Calculate the difference between the constant and the rounded 2181 value and check it against zero. */ 2182 2183 if (wprecision_real_real (src->value.real, src->ts.kind, kind)) 2184 { 2185 gfc_warning_now (w, "Change of value in conversion from " 2186 "%qs to %qs at %L", 2187 gfc_typename (&src->ts), gfc_typename (&result->ts), 2188 &src->where); 2189 /* Make sure the conversion warning is not emitted again. */ 2190 did_warn = true; 2191 } 2192 } 2193 2194 if (!did_warn && warn_conversion_extra) 2195 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " 2196 "at %L", gfc_typename(&src->ts), 2197 gfc_typename(&result->ts), &src->where); 2198 2199 return result; 2200 } 2201 2202 2203 /* Convert real to complex. */ 2204 2205 gfc_expr * 2206 gfc_real2complex (gfc_expr *src, int kind) 2207 { 2208 gfc_expr *result; 2209 arith rc; 2210 bool did_warn = false; 2211 2212 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2213 2214 mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); 2215 2216 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); 2217 2218 if (rc == ARITH_UNDERFLOW) 2219 { 2220 if (warn_underflow) 2221 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); 2222 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); 2223 } 2224 else if (rc != ARITH_OK) 2225 { 2226 arith_error (rc, &src->ts, &result->ts, &src->where); 2227 gfc_free_expr (result); 2228 return NULL; 2229 } 2230 2231 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) 2232 { 2233 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; 2234 2235 if (wprecision_real_real (src->value.real, src->ts.kind, kind)) 2236 { 2237 gfc_warning_now (w, "Change of value in conversion from " 2238 "%qs to %qs at %L", 2239 gfc_typename (&src->ts), gfc_typename (&result->ts), 2240 &src->where); 2241 /* Make sure the conversion warning is not emitted again. */ 2242 did_warn = true; 2243 } 2244 } 2245 2246 if (!did_warn && warn_conversion_extra) 2247 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " 2248 "at %L", gfc_typename(&src->ts), 2249 gfc_typename(&result->ts), &src->where); 2250 2251 return result; 2252 } 2253 2254 2255 /* Convert complex to integer. */ 2256 2257 gfc_expr * 2258 gfc_complex2int (gfc_expr *src, int kind) 2259 { 2260 gfc_expr *result; 2261 arith rc; 2262 bool did_warn = false; 2263 2264 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2265 2266 gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), 2267 &src->where); 2268 2269 if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) 2270 { 2271 arith_error (rc, &src->ts, &result->ts, &src->where); 2272 gfc_free_expr (result); 2273 return NULL; 2274 } 2275 2276 if (warn_conversion || warn_conversion_extra) 2277 { 2278 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; 2279 2280 /* See if we discarded an imaginary part. */ 2281 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) 2282 { 2283 gfc_warning_now (w, "Non-zero imaginary part discarded " 2284 "in conversion from %qs to %qs at %L", 2285 gfc_typename(&src->ts), gfc_typename (&result->ts), 2286 &src->where); 2287 did_warn = true; 2288 } 2289 2290 else { 2291 mpfr_t f; 2292 2293 mpfr_init (f); 2294 mpfr_frac (f, src->value.real, GFC_RND_MODE); 2295 if (mpfr_cmp_si (f, 0) != 0) 2296 { 2297 gfc_warning_now (w, "Change of value in conversion from " 2298 "%qs to %qs at %L", gfc_typename (&src->ts), 2299 gfc_typename (&result->ts), &src->where); 2300 did_warn = true; 2301 } 2302 mpfr_clear (f); 2303 } 2304 2305 if (!did_warn && warn_conversion_extra) 2306 { 2307 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " 2308 "at %L", gfc_typename (&src->ts), 2309 gfc_typename (&result->ts), &src->where); 2310 } 2311 } 2312 2313 return result; 2314 } 2315 2316 2317 /* Convert complex to real. */ 2318 2319 gfc_expr * 2320 gfc_complex2real (gfc_expr *src, int kind) 2321 { 2322 gfc_expr *result; 2323 arith rc; 2324 bool did_warn = false; 2325 2326 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2327 2328 mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); 2329 2330 rc = gfc_check_real_range (result->value.real, kind); 2331 2332 if (rc == ARITH_UNDERFLOW) 2333 { 2334 if (warn_underflow) 2335 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); 2336 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 2337 } 2338 if (rc != ARITH_OK) 2339 { 2340 arith_error (rc, &src->ts, &result->ts, &src->where); 2341 gfc_free_expr (result); 2342 return NULL; 2343 } 2344 2345 if (warn_conversion || warn_conversion_extra) 2346 { 2347 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; 2348 2349 /* See if we discarded an imaginary part. */ 2350 if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) 2351 { 2352 gfc_warning (w, "Non-zero imaginary part discarded " 2353 "in conversion from %qs to %qs at %L", 2354 gfc_typename(&src->ts), gfc_typename (&result->ts), 2355 &src->where); 2356 did_warn = true; 2357 } 2358 2359 /* Calculate the difference between the real constant and the rounded 2360 value and check it against zero. */ 2361 2362 if (kind > src->ts.kind 2363 && wprecision_real_real (mpc_realref (src->value.complex), 2364 src->ts.kind, kind)) 2365 { 2366 gfc_warning_now (w, "Change of value in conversion from " 2367 "%qs to %qs at %L", 2368 gfc_typename (&src->ts), gfc_typename (&result->ts), 2369 &src->where); 2370 /* Make sure the conversion warning is not emitted again. */ 2371 did_warn = true; 2372 } 2373 } 2374 2375 if (!did_warn && warn_conversion_extra) 2376 gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", 2377 gfc_typename(&src->ts), gfc_typename (&result->ts), 2378 &src->where); 2379 2380 return result; 2381 } 2382 2383 2384 /* Convert complex to complex. */ 2385 2386 gfc_expr * 2387 gfc_complex2complex (gfc_expr *src, int kind) 2388 { 2389 gfc_expr *result; 2390 arith rc; 2391 bool did_warn = false; 2392 2393 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2394 2395 mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); 2396 2397 rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); 2398 2399 if (rc == ARITH_UNDERFLOW) 2400 { 2401 if (warn_underflow) 2402 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); 2403 mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); 2404 } 2405 else if (rc != ARITH_OK) 2406 { 2407 arith_error (rc, &src->ts, &result->ts, &src->where); 2408 gfc_free_expr (result); 2409 return NULL; 2410 } 2411 2412 rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind); 2413 2414 if (rc == ARITH_UNDERFLOW) 2415 { 2416 if (warn_underflow) 2417 gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); 2418 mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE); 2419 } 2420 else if (rc != ARITH_OK) 2421 { 2422 arith_error (rc, &src->ts, &result->ts, &src->where); 2423 gfc_free_expr (result); 2424 return NULL; 2425 } 2426 2427 if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind 2428 && (wprecision_real_real (mpc_realref (src->value.complex), 2429 src->ts.kind, kind) 2430 || wprecision_real_real (mpc_imagref (src->value.complex), 2431 src->ts.kind, kind))) 2432 { 2433 int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; 2434 2435 gfc_warning_now (w, "Change of value in conversion from " 2436 "%qs to %qs at %L", 2437 gfc_typename (&src->ts), gfc_typename (&result->ts), 2438 &src->where); 2439 did_warn = true; 2440 } 2441 2442 if (!did_warn && warn_conversion_extra && src->ts.kind != kind) 2443 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " 2444 "at %L", gfc_typename(&src->ts), 2445 gfc_typename (&result->ts), &src->where); 2446 2447 return result; 2448 } 2449 2450 2451 /* Logical kind conversion. */ 2452 2453 gfc_expr * 2454 gfc_log2log (gfc_expr *src, int kind) 2455 { 2456 gfc_expr *result; 2457 2458 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2459 result->value.logical = src->value.logical; 2460 2461 return result; 2462 } 2463 2464 2465 /* Convert logical to integer. */ 2466 2467 gfc_expr * 2468 gfc_log2int (gfc_expr *src, int kind) 2469 { 2470 gfc_expr *result; 2471 2472 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2473 mpz_set_si (result->value.integer, src->value.logical); 2474 2475 return result; 2476 } 2477 2478 2479 /* Convert integer to logical. */ 2480 2481 gfc_expr * 2482 gfc_int2log (gfc_expr *src, int kind) 2483 { 2484 gfc_expr *result; 2485 2486 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2487 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); 2488 2489 return result; 2490 } 2491 2492 /* Convert character to character. We only use wide strings internally, 2493 so we only set the kind. */ 2494 2495 gfc_expr * 2496 gfc_character2character (gfc_expr *src, int kind) 2497 { 2498 gfc_expr *result; 2499 result = gfc_copy_expr (src); 2500 result->ts.kind = kind; 2501 2502 return result; 2503 } 2504 2505 /* Helper function to set the representation in a Hollerith conversion. 2506 This assumes that the ts.type and ts.kind of the result have already 2507 been set. */ 2508 2509 static void 2510 hollerith2representation (gfc_expr *result, gfc_expr *src) 2511 { 2512 size_t src_len, result_len; 2513 2514 src_len = src->representation.length - src->ts.u.pad; 2515 gfc_target_expr_size (result, &result_len); 2516 2517 if (src_len > result_len) 2518 { 2519 gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L " 2520 "is truncated in conversion to %qs", &src->where, 2521 gfc_typename(&result->ts)); 2522 } 2523 2524 result->representation.string = XCNEWVEC (char, result_len + 1); 2525 memcpy (result->representation.string, src->representation.string, 2526 MIN (result_len, src_len)); 2527 2528 if (src_len < result_len) 2529 memset (&result->representation.string[src_len], ' ', result_len - src_len); 2530 2531 result->representation.string[result_len] = '\0'; /* For debugger */ 2532 result->representation.length = result_len; 2533 } 2534 2535 2536 /* Helper function to set the representation in a character conversion. 2537 This assumes that the ts.type and ts.kind of the result have already 2538 been set. */ 2539 2540 static void 2541 character2representation (gfc_expr *result, gfc_expr *src) 2542 { 2543 size_t src_len, result_len, i; 2544 src_len = src->value.character.length; 2545 gfc_target_expr_size (result, &result_len); 2546 2547 if (src_len > result_len) 2548 gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is " 2549 "truncated in conversion to %s", &src->where, 2550 gfc_typename(&result->ts)); 2551 2552 result->representation.string = XCNEWVEC (char, result_len + 1); 2553 2554 for (i = 0; i < MIN (result_len, src_len); i++) 2555 result->representation.string[i] = (char) src->value.character.string[i]; 2556 2557 if (src_len < result_len) 2558 memset (&result->representation.string[src_len], ' ', 2559 result_len - src_len); 2560 2561 result->representation.string[result_len] = '\0'; /* For debugger. */ 2562 result->representation.length = result_len; 2563 } 2564 2565 /* Convert Hollerith to integer. The constant will be padded or truncated. */ 2566 2567 gfc_expr * 2568 gfc_hollerith2int (gfc_expr *src, int kind) 2569 { 2570 gfc_expr *result; 2571 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2572 2573 hollerith2representation (result, src); 2574 gfc_interpret_integer (kind, (unsigned char *) result->representation.string, 2575 result->representation.length, result->value.integer); 2576 2577 return result; 2578 } 2579 2580 /* Convert character to integer. The constant will be padded or truncated. */ 2581 2582 gfc_expr * 2583 gfc_character2int (gfc_expr *src, int kind) 2584 { 2585 gfc_expr *result; 2586 result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); 2587 2588 character2representation (result, src); 2589 gfc_interpret_integer (kind, (unsigned char *) result->representation.string, 2590 result->representation.length, result->value.integer); 2591 return result; 2592 } 2593 2594 /* Convert Hollerith to real. The constant will be padded or truncated. */ 2595 2596 gfc_expr * 2597 gfc_hollerith2real (gfc_expr *src, int kind) 2598 { 2599 gfc_expr *result; 2600 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2601 2602 hollerith2representation (result, src); 2603 gfc_interpret_float (kind, (unsigned char *) result->representation.string, 2604 result->representation.length, result->value.real); 2605 2606 return result; 2607 } 2608 2609 /* Convert character to real. The constant will be padded or truncated. */ 2610 2611 gfc_expr * 2612 gfc_character2real (gfc_expr *src, int kind) 2613 { 2614 gfc_expr *result; 2615 result = gfc_get_constant_expr (BT_REAL, kind, &src->where); 2616 2617 character2representation (result, src); 2618 gfc_interpret_float (kind, (unsigned char *) result->representation.string, 2619 result->representation.length, result->value.real); 2620 2621 return result; 2622 } 2623 2624 2625 /* Convert Hollerith to complex. The constant will be padded or truncated. */ 2626 2627 gfc_expr * 2628 gfc_hollerith2complex (gfc_expr *src, int kind) 2629 { 2630 gfc_expr *result; 2631 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2632 2633 hollerith2representation (result, src); 2634 gfc_interpret_complex (kind, (unsigned char *) result->representation.string, 2635 result->representation.length, result->value.complex); 2636 2637 return result; 2638 } 2639 2640 /* Convert character to complex. The constant will be padded or truncated. */ 2641 2642 gfc_expr * 2643 gfc_character2complex (gfc_expr *src, int kind) 2644 { 2645 gfc_expr *result; 2646 result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); 2647 2648 character2representation (result, src); 2649 gfc_interpret_complex (kind, (unsigned char *) result->representation.string, 2650 result->representation.length, result->value.complex); 2651 2652 return result; 2653 } 2654 2655 2656 /* Convert Hollerith to character. */ 2657 2658 gfc_expr * 2659 gfc_hollerith2character (gfc_expr *src, int kind) 2660 { 2661 gfc_expr *result; 2662 2663 result = gfc_copy_expr (src); 2664 result->ts.type = BT_CHARACTER; 2665 result->ts.kind = kind; 2666 result->ts.u.pad = 0; 2667 2668 result->value.character.length = result->representation.length; 2669 result->value.character.string 2670 = gfc_char_to_widechar (result->representation.string); 2671 2672 return result; 2673 } 2674 2675 2676 /* Convert Hollerith to logical. The constant will be padded or truncated. */ 2677 2678 gfc_expr * 2679 gfc_hollerith2logical (gfc_expr *src, int kind) 2680 { 2681 gfc_expr *result; 2682 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2683 2684 hollerith2representation (result, src); 2685 gfc_interpret_logical (kind, (unsigned char *) result->representation.string, 2686 result->representation.length, &result->value.logical); 2687 2688 return result; 2689 } 2690 2691 /* Convert character to logical. The constant will be padded or truncated. */ 2692 2693 gfc_expr * 2694 gfc_character2logical (gfc_expr *src, int kind) 2695 { 2696 gfc_expr *result; 2697 result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); 2698 2699 character2representation (result, src); 2700 gfc_interpret_logical (kind, (unsigned char *) result->representation.string, 2701 result->representation.length, &result->value.logical); 2702 2703 return result; 2704 } 2705