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