1/* Simplify intrinsic functions at compile-time. 2 Copyright (C) 2000-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught & Katherine Holcomb 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#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "flags.h" 25#include "gfortran.h" 26#include "arith.h" 27#include "intrinsic.h" 28#include "target-memory.h" 29#include "constructor.h" 30#include "tm.h" /* For BITS_PER_UNIT. */ 31#include "version.h" /* For version_string. */ 32 33 34gfc_expr gfc_bad_expr; 35 36static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); 37 38 39/* Note that 'simplification' is not just transforming expressions. 40 For functions that are not simplified at compile time, range 41 checking is done if possible. 42 43 The return convention is that each simplification function returns: 44 45 A new expression node corresponding to the simplified arguments. 46 The original arguments are destroyed by the caller, and must not 47 be a part of the new expression. 48 49 NULL pointer indicating that no simplification was possible and 50 the original expression should remain intact. 51 52 An expression pointer to gfc_bad_expr (a static placeholder) 53 indicating that some error has prevented simplification. The 54 error is generated within the function and should be propagated 55 upwards 56 57 By the time a simplification function gets control, it has been 58 decided that the function call is really supposed to be the 59 intrinsic. No type checking is strictly necessary, since only 60 valid types will be passed on. On the other hand, a simplification 61 subroutine may have to look at the type of an argument as part of 62 its processing. 63 64 Array arguments are only passed to these subroutines that implement 65 the simplification of transformational intrinsics. 66 67 The functions in this file don't have much comment with them, but 68 everything is reasonably straight-forward. The Standard, chapter 13 69 is the best comment you'll find for this file anyway. */ 70 71/* Range checks an expression node. If all goes well, returns the 72 node, otherwise returns &gfc_bad_expr and frees the node. */ 73 74static gfc_expr * 75range_check (gfc_expr *result, const char *name) 76{ 77 if (result == NULL) 78 return &gfc_bad_expr; 79 80 if (result->expr_type != EXPR_CONSTANT) 81 return result; 82 83 switch (gfc_range_check (result)) 84 { 85 case ARITH_OK: 86 return result; 87 88 case ARITH_OVERFLOW: 89 gfc_error ("Result of %s overflows its kind at %L", name, 90 &result->where); 91 break; 92 93 case ARITH_UNDERFLOW: 94 gfc_error ("Result of %s underflows its kind at %L", name, 95 &result->where); 96 break; 97 98 case ARITH_NAN: 99 gfc_error ("Result of %s is NaN at %L", name, &result->where); 100 break; 101 102 default: 103 gfc_error ("Result of %s gives range error for its kind at %L", name, 104 &result->where); 105 break; 106 } 107 108 gfc_free_expr (result); 109 return &gfc_bad_expr; 110} 111 112 113/* A helper function that gets an optional and possibly missing 114 kind parameter. Returns the kind, -1 if something went wrong. */ 115 116static int 117get_kind (bt type, gfc_expr *k, const char *name, int default_kind) 118{ 119 int kind; 120 121 if (k == NULL) 122 return default_kind; 123 124 if (k->expr_type != EXPR_CONSTANT) 125 { 126 gfc_error ("KIND parameter of %s at %L must be an initialization " 127 "expression", name, &k->where); 128 return -1; 129 } 130 131 if (gfc_extract_int (k, &kind) != NULL 132 || gfc_validate_kind (type, kind, true) < 0) 133 { 134 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); 135 return -1; 136 } 137 138 return kind; 139} 140 141 142/* Converts an mpz_t signed variable into an unsigned one, assuming 143 two's complement representations and a binary width of bitsize. 144 The conversion is a no-op unless x is negative; otherwise, it can 145 be accomplished by masking out the high bits. */ 146 147static void 148convert_mpz_to_unsigned (mpz_t x, int bitsize) 149{ 150 mpz_t mask; 151 152 if (mpz_sgn (x) < 0) 153 { 154 /* Confirm that no bits above the signed range are unset if we 155 are doing range checking. */ 156 if (flag_range_check != 0) 157 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); 158 159 mpz_init_set_ui (mask, 1); 160 mpz_mul_2exp (mask, mask, bitsize); 161 mpz_sub_ui (mask, mask, 1); 162 163 mpz_and (x, x, mask); 164 165 mpz_clear (mask); 166 } 167 else 168 { 169 /* Confirm that no bits above the signed range are set. */ 170 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); 171 } 172} 173 174 175/* Converts an mpz_t unsigned variable into a signed one, assuming 176 two's complement representations and a binary width of bitsize. 177 If the bitsize-1 bit is set, this is taken as a sign bit and 178 the number is converted to the corresponding negative number. */ 179 180void 181gfc_convert_mpz_to_signed (mpz_t x, int bitsize) 182{ 183 mpz_t mask; 184 185 /* Confirm that no bits above the unsigned range are set if we are 186 doing range checking. */ 187 if (flag_range_check != 0) 188 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); 189 190 if (mpz_tstbit (x, bitsize - 1) == 1) 191 { 192 mpz_init_set_ui (mask, 1); 193 mpz_mul_2exp (mask, mask, bitsize); 194 mpz_sub_ui (mask, mask, 1); 195 196 /* We negate the number by hand, zeroing the high bits, that is 197 make it the corresponding positive number, and then have it 198 negated by GMP, giving the correct representation of the 199 negative number. */ 200 mpz_com (x, x); 201 mpz_add_ui (x, x, 1); 202 mpz_and (x, x, mask); 203 204 mpz_neg (x, x); 205 206 mpz_clear (mask); 207 } 208} 209 210 211/* In-place convert BOZ to REAL of the specified kind. */ 212 213static gfc_expr * 214convert_boz (gfc_expr *x, int kind) 215{ 216 if (x && x->ts.type == BT_INTEGER && x->is_boz) 217 { 218 gfc_typespec ts; 219 gfc_clear_ts (&ts); 220 ts.type = BT_REAL; 221 ts.kind = kind; 222 223 if (!gfc_convert_boz (x, &ts)) 224 return &gfc_bad_expr; 225 } 226 227 return x; 228} 229 230 231/* Test that the expression is an constant array. */ 232 233static bool 234is_constant_array_expr (gfc_expr *e) 235{ 236 gfc_constructor *c; 237 238 if (e == NULL) 239 return true; 240 241 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) 242 return false; 243 244 for (c = gfc_constructor_first (e->value.constructor); 245 c; c = gfc_constructor_next (c)) 246 if (c->expr->expr_type != EXPR_CONSTANT 247 && c->expr->expr_type != EXPR_STRUCTURE) 248 return false; 249 250 return true; 251} 252 253 254/* Initialize a transformational result expression with a given value. */ 255 256static void 257init_result_expr (gfc_expr *e, int init, gfc_expr *array) 258{ 259 if (e && e->expr_type == EXPR_ARRAY) 260 { 261 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); 262 while (ctor) 263 { 264 init_result_expr (ctor->expr, init, array); 265 ctor = gfc_constructor_next (ctor); 266 } 267 } 268 else if (e && e->expr_type == EXPR_CONSTANT) 269 { 270 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 271 int length; 272 gfc_char_t *string; 273 274 switch (e->ts.type) 275 { 276 case BT_LOGICAL: 277 e->value.logical = (init ? 1 : 0); 278 break; 279 280 case BT_INTEGER: 281 if (init == INT_MIN) 282 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int); 283 else if (init == INT_MAX) 284 mpz_set (e->value.integer, gfc_integer_kinds[i].huge); 285 else 286 mpz_set_si (e->value.integer, init); 287 break; 288 289 case BT_REAL: 290 if (init == INT_MIN) 291 { 292 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 293 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); 294 } 295 else if (init == INT_MAX) 296 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 297 else 298 mpfr_set_si (e->value.real, init, GFC_RND_MODE); 299 break; 300 301 case BT_COMPLEX: 302 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); 303 break; 304 305 case BT_CHARACTER: 306 if (init == INT_MIN) 307 { 308 gfc_expr *len = gfc_simplify_len (array, NULL); 309 gfc_extract_int (len, &length); 310 string = gfc_get_wide_string (length + 1); 311 gfc_wide_memset (string, 0, length); 312 } 313 else if (init == INT_MAX) 314 { 315 gfc_expr *len = gfc_simplify_len (array, NULL); 316 gfc_extract_int (len, &length); 317 string = gfc_get_wide_string (length + 1); 318 gfc_wide_memset (string, 255, length); 319 } 320 else 321 { 322 length = 0; 323 string = gfc_get_wide_string (1); 324 } 325 326 string[length] = '\0'; 327 e->value.character.length = length; 328 e->value.character.string = string; 329 break; 330 331 default: 332 gcc_unreachable(); 333 } 334 } 335 else 336 gcc_unreachable(); 337} 338 339 340/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul; 341 if conj_a is true, the matrix_a is complex conjugated. */ 342 343static gfc_expr * 344compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, 345 gfc_expr *matrix_b, int stride_b, int offset_b, 346 bool conj_a) 347{ 348 gfc_expr *result, *a, *b, *c; 349 350 result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind, 351 &matrix_a->where); 352 init_result_expr (result, 0, NULL); 353 354 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); 355 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); 356 while (a && b) 357 { 358 /* Copying of expressions is required as operands are free'd 359 by the gfc_arith routines. */ 360 switch (result->ts.type) 361 { 362 case BT_LOGICAL: 363 result = gfc_or (result, 364 gfc_and (gfc_copy_expr (a), 365 gfc_copy_expr (b))); 366 break; 367 368 case BT_INTEGER: 369 case BT_REAL: 370 case BT_COMPLEX: 371 if (conj_a && a->ts.type == BT_COMPLEX) 372 c = gfc_simplify_conjg (a); 373 else 374 c = gfc_copy_expr (a); 375 result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b))); 376 break; 377 378 default: 379 gcc_unreachable(); 380 } 381 382 offset_a += stride_a; 383 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); 384 385 offset_b += stride_b; 386 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); 387 } 388 389 return result; 390} 391 392 393/* Build a result expression for transformational intrinsics, 394 depending on DIM. */ 395 396static gfc_expr * 397transformational_result (gfc_expr *array, gfc_expr *dim, bt type, 398 int kind, locus* where) 399{ 400 gfc_expr *result; 401 int i, nelem; 402 403 if (!dim || array->rank == 1) 404 return gfc_get_constant_expr (type, kind, where); 405 406 result = gfc_get_array_expr (type, kind, where); 407 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); 408 result->rank = array->rank - 1; 409 410 /* gfc_array_size() would count the number of elements in the constructor, 411 we have not built those yet. */ 412 nelem = 1; 413 for (i = 0; i < result->rank; ++i) 414 nelem *= mpz_get_ui (result->shape[i]); 415 416 for (i = 0; i < nelem; ++i) 417 { 418 gfc_constructor_append_expr (&result->value.constructor, 419 gfc_get_constant_expr (type, kind, where), 420 NULL); 421 } 422 423 return result; 424} 425 426 427typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); 428 429/* Wrapper function, implements 'op1 += 1'. Only called if MASK 430 of COUNT intrinsic is .TRUE.. 431 432 Interface and implementation mimics arith functions as 433 gfc_add, gfc_multiply, etc. */ 434 435static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2) 436{ 437 gfc_expr *result; 438 439 gcc_assert (op1->ts.type == BT_INTEGER); 440 gcc_assert (op2->ts.type == BT_LOGICAL); 441 gcc_assert (op2->value.logical); 442 443 result = gfc_copy_expr (op1); 444 mpz_add_ui (result->value.integer, result->value.integer, 1); 445 446 gfc_free_expr (op1); 447 gfc_free_expr (op2); 448 return result; 449} 450 451 452/* Transforms an ARRAY with operation OP, according to MASK, to a 453 scalar RESULT. E.g. called if 454 455 REAL, PARAMETER :: array(n, m) = ... 456 REAL, PARAMETER :: s = SUM(array) 457 458 where OP == gfc_add(). */ 459 460static gfc_expr * 461simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, 462 transformational_op op) 463{ 464 gfc_expr *a, *m; 465 gfc_constructor *array_ctor, *mask_ctor; 466 467 /* Shortcut for constant .FALSE. MASK. */ 468 if (mask 469 && mask->expr_type == EXPR_CONSTANT 470 && !mask->value.logical) 471 return result; 472 473 array_ctor = gfc_constructor_first (array->value.constructor); 474 mask_ctor = NULL; 475 if (mask && mask->expr_type == EXPR_ARRAY) 476 mask_ctor = gfc_constructor_first (mask->value.constructor); 477 478 while (array_ctor) 479 { 480 a = array_ctor->expr; 481 array_ctor = gfc_constructor_next (array_ctor); 482 483 /* A constant MASK equals .TRUE. here and can be ignored. */ 484 if (mask_ctor) 485 { 486 m = mask_ctor->expr; 487 mask_ctor = gfc_constructor_next (mask_ctor); 488 if (!m->value.logical) 489 continue; 490 } 491 492 result = op (result, gfc_copy_expr (a)); 493 } 494 495 return result; 496} 497 498/* Transforms an ARRAY with operation OP, according to MASK, to an 499 array RESULT. E.g. called if 500 501 REAL, PARAMETER :: array(n, m) = ... 502 REAL, PARAMETER :: s(n) = PROD(array, DIM=1) 503 504 where OP == gfc_multiply(). 505 The result might be post processed using post_op. */ 506 507static gfc_expr * 508simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, 509 gfc_expr *mask, transformational_op op, 510 transformational_op post_op) 511{ 512 mpz_t size; 513 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 514 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 515 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 516 517 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 518 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 519 tmpstride[GFC_MAX_DIMENSIONS]; 520 521 /* Shortcut for constant .FALSE. MASK. */ 522 if (mask 523 && mask->expr_type == EXPR_CONSTANT 524 && !mask->value.logical) 525 return result; 526 527 /* Build an indexed table for array element expressions to minimize 528 linked-list traversal. Masked elements are set to NULL. */ 529 gfc_array_size (array, &size); 530 arraysize = mpz_get_ui (size); 531 mpz_clear (size); 532 533 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 534 535 array_ctor = gfc_constructor_first (array->value.constructor); 536 mask_ctor = NULL; 537 if (mask && mask->expr_type == EXPR_ARRAY) 538 mask_ctor = gfc_constructor_first (mask->value.constructor); 539 540 for (i = 0; i < arraysize; ++i) 541 { 542 arrayvec[i] = array_ctor->expr; 543 array_ctor = gfc_constructor_next (array_ctor); 544 545 if (mask_ctor) 546 { 547 if (!mask_ctor->expr->value.logical) 548 arrayvec[i] = NULL; 549 550 mask_ctor = gfc_constructor_next (mask_ctor); 551 } 552 } 553 554 /* Same for the result expression. */ 555 gfc_array_size (result, &size); 556 resultsize = mpz_get_ui (size); 557 mpz_clear (size); 558 559 resultvec = XCNEWVEC (gfc_expr*, resultsize); 560 result_ctor = gfc_constructor_first (result->value.constructor); 561 for (i = 0; i < resultsize; ++i) 562 { 563 resultvec[i] = result_ctor->expr; 564 result_ctor = gfc_constructor_next (result_ctor); 565 } 566 567 gfc_extract_int (dim, &dim_index); 568 dim_index -= 1; /* zero-base index */ 569 dim_extent = 0; 570 dim_stride = 0; 571 572 for (i = 0, n = 0; i < array->rank; ++i) 573 { 574 count[i] = 0; 575 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 576 if (i == dim_index) 577 { 578 dim_extent = mpz_get_si (array->shape[i]); 579 dim_stride = tmpstride[i]; 580 continue; 581 } 582 583 extent[n] = mpz_get_si (array->shape[i]); 584 sstride[n] = tmpstride[i]; 585 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 586 n += 1; 587 } 588 589 done = false; 590 base = arrayvec; 591 dest = resultvec; 592 while (!done) 593 { 594 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 595 if (*src) 596 *dest = op (*dest, gfc_copy_expr (*src)); 597 598 count[0]++; 599 base += sstride[0]; 600 dest += dstride[0]; 601 602 n = 0; 603 while (!done && count[n] == extent[n]) 604 { 605 count[n] = 0; 606 base -= sstride[n] * extent[n]; 607 dest -= dstride[n] * extent[n]; 608 609 n++; 610 if (n < result->rank) 611 { 612 count [n]++; 613 base += sstride[n]; 614 dest += dstride[n]; 615 } 616 else 617 done = true; 618 } 619 } 620 621 /* Place updated expression in result constructor. */ 622 result_ctor = gfc_constructor_first (result->value.constructor); 623 for (i = 0; i < resultsize; ++i) 624 { 625 if (post_op) 626 result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); 627 else 628 result_ctor->expr = resultvec[i]; 629 result_ctor = gfc_constructor_next (result_ctor); 630 } 631 632 free (arrayvec); 633 free (resultvec); 634 return result; 635} 636 637 638static gfc_expr * 639simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 640 int init_val, transformational_op op) 641{ 642 gfc_expr *result; 643 644 if (!is_constant_array_expr (array) 645 || !gfc_is_constant_expr (dim)) 646 return NULL; 647 648 if (mask 649 && !is_constant_array_expr (mask) 650 && mask->expr_type != EXPR_CONSTANT) 651 return NULL; 652 653 result = transformational_result (array, dim, array->ts.type, 654 array->ts.kind, &array->where); 655 init_result_expr (result, init_val, NULL); 656 657 return !dim || array->rank == 1 ? 658 simplify_transformation_to_scalar (result, array, mask, op) : 659 simplify_transformation_to_array (result, array, dim, mask, op, NULL); 660} 661 662 663/********************** Simplification functions *****************************/ 664 665gfc_expr * 666gfc_simplify_abs (gfc_expr *e) 667{ 668 gfc_expr *result; 669 670 if (e->expr_type != EXPR_CONSTANT) 671 return NULL; 672 673 switch (e->ts.type) 674 { 675 case BT_INTEGER: 676 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); 677 mpz_abs (result->value.integer, e->value.integer); 678 return range_check (result, "IABS"); 679 680 case BT_REAL: 681 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 682 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); 683 return range_check (result, "ABS"); 684 685 case BT_COMPLEX: 686 gfc_set_model_kind (e->ts.kind); 687 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 688 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); 689 return range_check (result, "CABS"); 690 691 default: 692 gfc_internal_error ("gfc_simplify_abs(): Bad type"); 693 } 694} 695 696 697static gfc_expr * 698simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) 699{ 700 gfc_expr *result; 701 int kind; 702 bool too_large = false; 703 704 if (e->expr_type != EXPR_CONSTANT) 705 return NULL; 706 707 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); 708 if (kind == -1) 709 return &gfc_bad_expr; 710 711 if (mpz_cmp_si (e->value.integer, 0) < 0) 712 { 713 gfc_error ("Argument of %s function at %L is negative", name, 714 &e->where); 715 return &gfc_bad_expr; 716 } 717 718 if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0) 719 gfc_warning (OPT_Wsurprising, 720 "Argument of %s function at %L outside of range [0,127]", 721 name, &e->where); 722 723 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) 724 too_large = true; 725 else if (kind == 4) 726 { 727 mpz_t t; 728 mpz_init_set_ui (t, 2); 729 mpz_pow_ui (t, t, 32); 730 mpz_sub_ui (t, t, 1); 731 if (mpz_cmp (e->value.integer, t) > 0) 732 too_large = true; 733 mpz_clear (t); 734 } 735 736 if (too_large) 737 { 738 gfc_error ("Argument of %s function at %L is too large for the " 739 "collating sequence of kind %d", name, &e->where, kind); 740 return &gfc_bad_expr; 741 } 742 743 result = gfc_get_character_expr (kind, &e->where, NULL, 1); 744 result->value.character.string[0] = mpz_get_ui (e->value.integer); 745 746 return result; 747} 748 749 750 751/* We use the processor's collating sequence, because all 752 systems that gfortran currently works on are ASCII. */ 753 754gfc_expr * 755gfc_simplify_achar (gfc_expr *e, gfc_expr *k) 756{ 757 return simplify_achar_char (e, k, "ACHAR", true); 758} 759 760 761gfc_expr * 762gfc_simplify_acos (gfc_expr *x) 763{ 764 gfc_expr *result; 765 766 if (x->expr_type != EXPR_CONSTANT) 767 return NULL; 768 769 switch (x->ts.type) 770 { 771 case BT_REAL: 772 if (mpfr_cmp_si (x->value.real, 1) > 0 773 || mpfr_cmp_si (x->value.real, -1) < 0) 774 { 775 gfc_error ("Argument of ACOS at %L must be between -1 and 1", 776 &x->where); 777 return &gfc_bad_expr; 778 } 779 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 780 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); 781 break; 782 783 case BT_COMPLEX: 784 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 785 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 786 break; 787 788 default: 789 gfc_internal_error ("in gfc_simplify_acos(): Bad type"); 790 } 791 792 return range_check (result, "ACOS"); 793} 794 795gfc_expr * 796gfc_simplify_acosh (gfc_expr *x) 797{ 798 gfc_expr *result; 799 800 if (x->expr_type != EXPR_CONSTANT) 801 return NULL; 802 803 switch (x->ts.type) 804 { 805 case BT_REAL: 806 if (mpfr_cmp_si (x->value.real, 1) < 0) 807 { 808 gfc_error ("Argument of ACOSH at %L must not be less than 1", 809 &x->where); 810 return &gfc_bad_expr; 811 } 812 813 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 814 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); 815 break; 816 817 case BT_COMPLEX: 818 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 819 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 820 break; 821 822 default: 823 gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); 824 } 825 826 return range_check (result, "ACOSH"); 827} 828 829gfc_expr * 830gfc_simplify_adjustl (gfc_expr *e) 831{ 832 gfc_expr *result; 833 int count, i, len; 834 gfc_char_t ch; 835 836 if (e->expr_type != EXPR_CONSTANT) 837 return NULL; 838 839 len = e->value.character.length; 840 841 for (count = 0, i = 0; i < len; ++i) 842 { 843 ch = e->value.character.string[i]; 844 if (ch != ' ') 845 break; 846 ++count; 847 } 848 849 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); 850 for (i = 0; i < len - count; ++i) 851 result->value.character.string[i] = e->value.character.string[count + i]; 852 853 return result; 854} 855 856 857gfc_expr * 858gfc_simplify_adjustr (gfc_expr *e) 859{ 860 gfc_expr *result; 861 int count, i, len; 862 gfc_char_t ch; 863 864 if (e->expr_type != EXPR_CONSTANT) 865 return NULL; 866 867 len = e->value.character.length; 868 869 for (count = 0, i = len - 1; i >= 0; --i) 870 { 871 ch = e->value.character.string[i]; 872 if (ch != ' ') 873 break; 874 ++count; 875 } 876 877 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); 878 for (i = 0; i < count; ++i) 879 result->value.character.string[i] = ' '; 880 881 for (i = count; i < len; ++i) 882 result->value.character.string[i] = e->value.character.string[i - count]; 883 884 return result; 885} 886 887 888gfc_expr * 889gfc_simplify_aimag (gfc_expr *e) 890{ 891 gfc_expr *result; 892 893 if (e->expr_type != EXPR_CONSTANT) 894 return NULL; 895 896 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 897 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); 898 899 return range_check (result, "AIMAG"); 900} 901 902 903gfc_expr * 904gfc_simplify_aint (gfc_expr *e, gfc_expr *k) 905{ 906 gfc_expr *rtrunc, *result; 907 int kind; 908 909 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); 910 if (kind == -1) 911 return &gfc_bad_expr; 912 913 if (e->expr_type != EXPR_CONSTANT) 914 return NULL; 915 916 rtrunc = gfc_copy_expr (e); 917 mpfr_trunc (rtrunc->value.real, e->value.real); 918 919 result = gfc_real2real (rtrunc, kind); 920 921 gfc_free_expr (rtrunc); 922 923 return range_check (result, "AINT"); 924} 925 926 927gfc_expr * 928gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) 929{ 930 return simplify_transformation (mask, dim, NULL, true, gfc_and); 931} 932 933 934gfc_expr * 935gfc_simplify_dint (gfc_expr *e) 936{ 937 gfc_expr *rtrunc, *result; 938 939 if (e->expr_type != EXPR_CONSTANT) 940 return NULL; 941 942 rtrunc = gfc_copy_expr (e); 943 mpfr_trunc (rtrunc->value.real, e->value.real); 944 945 result = gfc_real2real (rtrunc, gfc_default_double_kind); 946 947 gfc_free_expr (rtrunc); 948 949 return range_check (result, "DINT"); 950} 951 952 953gfc_expr * 954gfc_simplify_dreal (gfc_expr *e) 955{ 956 gfc_expr *result = NULL; 957 958 if (e->expr_type != EXPR_CONSTANT) 959 return NULL; 960 961 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 962 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); 963 964 return range_check (result, "DREAL"); 965} 966 967 968gfc_expr * 969gfc_simplify_anint (gfc_expr *e, gfc_expr *k) 970{ 971 gfc_expr *result; 972 int kind; 973 974 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); 975 if (kind == -1) 976 return &gfc_bad_expr; 977 978 if (e->expr_type != EXPR_CONSTANT) 979 return NULL; 980 981 result = gfc_get_constant_expr (e->ts.type, kind, &e->where); 982 mpfr_round (result->value.real, e->value.real); 983 984 return range_check (result, "ANINT"); 985} 986 987 988gfc_expr * 989gfc_simplify_and (gfc_expr *x, gfc_expr *y) 990{ 991 gfc_expr *result; 992 int kind; 993 994 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 995 return NULL; 996 997 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 998 999 switch (x->ts.type) 1000 { 1001 case BT_INTEGER: 1002 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 1003 mpz_and (result->value.integer, x->value.integer, y->value.integer); 1004 return range_check (result, "AND"); 1005 1006 case BT_LOGICAL: 1007 return gfc_get_logical_expr (kind, &x->where, 1008 x->value.logical && y->value.logical); 1009 1010 default: 1011 gcc_unreachable (); 1012 } 1013} 1014 1015 1016gfc_expr * 1017gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) 1018{ 1019 return simplify_transformation (mask, dim, NULL, false, gfc_or); 1020} 1021 1022 1023gfc_expr * 1024gfc_simplify_dnint (gfc_expr *e) 1025{ 1026 gfc_expr *result; 1027 1028 if (e->expr_type != EXPR_CONSTANT) 1029 return NULL; 1030 1031 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); 1032 mpfr_round (result->value.real, e->value.real); 1033 1034 return range_check (result, "DNINT"); 1035} 1036 1037 1038gfc_expr * 1039gfc_simplify_asin (gfc_expr *x) 1040{ 1041 gfc_expr *result; 1042 1043 if (x->expr_type != EXPR_CONSTANT) 1044 return NULL; 1045 1046 switch (x->ts.type) 1047 { 1048 case BT_REAL: 1049 if (mpfr_cmp_si (x->value.real, 1) > 0 1050 || mpfr_cmp_si (x->value.real, -1) < 0) 1051 { 1052 gfc_error ("Argument of ASIN at %L must be between -1 and 1", 1053 &x->where); 1054 return &gfc_bad_expr; 1055 } 1056 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1057 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); 1058 break; 1059 1060 case BT_COMPLEX: 1061 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1062 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1063 break; 1064 1065 default: 1066 gfc_internal_error ("in gfc_simplify_asin(): Bad type"); 1067 } 1068 1069 return range_check (result, "ASIN"); 1070} 1071 1072 1073gfc_expr * 1074gfc_simplify_asinh (gfc_expr *x) 1075{ 1076 gfc_expr *result; 1077 1078 if (x->expr_type != EXPR_CONSTANT) 1079 return NULL; 1080 1081 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1082 1083 switch (x->ts.type) 1084 { 1085 case BT_REAL: 1086 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); 1087 break; 1088 1089 case BT_COMPLEX: 1090 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1091 break; 1092 1093 default: 1094 gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); 1095 } 1096 1097 return range_check (result, "ASINH"); 1098} 1099 1100 1101gfc_expr * 1102gfc_simplify_atan (gfc_expr *x) 1103{ 1104 gfc_expr *result; 1105 1106 if (x->expr_type != EXPR_CONSTANT) 1107 return NULL; 1108 1109 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1110 1111 switch (x->ts.type) 1112 { 1113 case BT_REAL: 1114 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); 1115 break; 1116 1117 case BT_COMPLEX: 1118 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1119 break; 1120 1121 default: 1122 gfc_internal_error ("in gfc_simplify_atan(): Bad type"); 1123 } 1124 1125 return range_check (result, "ATAN"); 1126} 1127 1128 1129gfc_expr * 1130gfc_simplify_atanh (gfc_expr *x) 1131{ 1132 gfc_expr *result; 1133 1134 if (x->expr_type != EXPR_CONSTANT) 1135 return NULL; 1136 1137 switch (x->ts.type) 1138 { 1139 case BT_REAL: 1140 if (mpfr_cmp_si (x->value.real, 1) >= 0 1141 || mpfr_cmp_si (x->value.real, -1) <= 0) 1142 { 1143 gfc_error ("Argument of ATANH at %L must be inside the range -1 " 1144 "to 1", &x->where); 1145 return &gfc_bad_expr; 1146 } 1147 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1148 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); 1149 break; 1150 1151 case BT_COMPLEX: 1152 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1153 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1154 break; 1155 1156 default: 1157 gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); 1158 } 1159 1160 return range_check (result, "ATANH"); 1161} 1162 1163 1164gfc_expr * 1165gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) 1166{ 1167 gfc_expr *result; 1168 1169 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1170 return NULL; 1171 1172 if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) 1173 { 1174 gfc_error ("If first argument of ATAN2 %L is zero, then the " 1175 "second argument must not be zero", &x->where); 1176 return &gfc_bad_expr; 1177 } 1178 1179 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1180 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); 1181 1182 return range_check (result, "ATAN2"); 1183} 1184 1185 1186gfc_expr * 1187gfc_simplify_bessel_j0 (gfc_expr *x) 1188{ 1189 gfc_expr *result; 1190 1191 if (x->expr_type != EXPR_CONSTANT) 1192 return NULL; 1193 1194 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1195 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); 1196 1197 return range_check (result, "BESSEL_J0"); 1198} 1199 1200 1201gfc_expr * 1202gfc_simplify_bessel_j1 (gfc_expr *x) 1203{ 1204 gfc_expr *result; 1205 1206 if (x->expr_type != EXPR_CONSTANT) 1207 return NULL; 1208 1209 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1210 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); 1211 1212 return range_check (result, "BESSEL_J1"); 1213} 1214 1215 1216gfc_expr * 1217gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) 1218{ 1219 gfc_expr *result; 1220 long n; 1221 1222 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1223 return NULL; 1224 1225 n = mpz_get_si (order->value.integer); 1226 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1227 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); 1228 1229 return range_check (result, "BESSEL_JN"); 1230} 1231 1232 1233/* Simplify transformational form of JN and YN. */ 1234 1235static gfc_expr * 1236gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, 1237 bool jn) 1238{ 1239 gfc_expr *result; 1240 gfc_expr *e; 1241 long n1, n2; 1242 int i; 1243 mpfr_t x2rev, last1, last2; 1244 1245 if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT 1246 || order2->expr_type != EXPR_CONSTANT) 1247 return NULL; 1248 1249 n1 = mpz_get_si (order1->value.integer); 1250 n2 = mpz_get_si (order2->value.integer); 1251 result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); 1252 result->rank = 1; 1253 result->shape = gfc_get_shape (1); 1254 mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); 1255 1256 if (n2 < n1) 1257 return result; 1258 1259 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and 1260 YN(N, 0.0) = -Inf. */ 1261 1262 if (mpfr_cmp_ui (x->value.real, 0.0) == 0) 1263 { 1264 if (!jn && flag_range_check) 1265 { 1266 gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); 1267 gfc_free_expr (result); 1268 return &gfc_bad_expr; 1269 } 1270 1271 if (jn && n1 == 0) 1272 { 1273 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1274 mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); 1275 gfc_constructor_append_expr (&result->value.constructor, e, 1276 &x->where); 1277 n1++; 1278 } 1279 1280 for (i = n1; i <= n2; i++) 1281 { 1282 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1283 if (jn) 1284 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); 1285 else 1286 mpfr_set_inf (e->value.real, -1); 1287 gfc_constructor_append_expr (&result->value.constructor, e, 1288 &x->where); 1289 } 1290 1291 return result; 1292 } 1293 1294 /* Use the faster but more verbose recurrence algorithm. Bessel functions 1295 are stable for downward recursion and Neumann functions are stable 1296 for upward recursion. It is 1297 x2rev = 2.0/x, 1298 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), 1299 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). 1300 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ 1301 1302 gfc_set_model_kind (x->ts.kind); 1303 1304 /* Get first recursion anchor. */ 1305 1306 mpfr_init (last1); 1307 if (jn) 1308 mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); 1309 else 1310 mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); 1311 1312 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1313 mpfr_set (e->value.real, last1, GFC_RND_MODE); 1314 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1315 { 1316 mpfr_clear (last1); 1317 gfc_free_expr (e); 1318 gfc_free_expr (result); 1319 return &gfc_bad_expr; 1320 } 1321 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1322 1323 if (n1 == n2) 1324 { 1325 mpfr_clear (last1); 1326 return result; 1327 } 1328 1329 /* Get second recursion anchor. */ 1330 1331 mpfr_init (last2); 1332 if (jn) 1333 mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); 1334 else 1335 mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); 1336 1337 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1338 mpfr_set (e->value.real, last2, GFC_RND_MODE); 1339 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1340 { 1341 mpfr_clear (last1); 1342 mpfr_clear (last2); 1343 gfc_free_expr (e); 1344 gfc_free_expr (result); 1345 return &gfc_bad_expr; 1346 } 1347 if (jn) 1348 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); 1349 else 1350 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1351 1352 if (n1 + 1 == n2) 1353 { 1354 mpfr_clear (last1); 1355 mpfr_clear (last2); 1356 return result; 1357 } 1358 1359 /* Start actual recursion. */ 1360 1361 mpfr_init (x2rev); 1362 mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); 1363 1364 for (i = 2; i <= n2-n1; i++) 1365 { 1366 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1367 1368 /* Special case: For YN, if the previous N gave -INF, set 1369 also N+1 to -INF. */ 1370 if (!jn && !flag_range_check && mpfr_inf_p (last2)) 1371 { 1372 mpfr_set_inf (e->value.real, -1); 1373 gfc_constructor_append_expr (&result->value.constructor, e, 1374 &x->where); 1375 continue; 1376 } 1377 1378 mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), 1379 GFC_RND_MODE); 1380 mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); 1381 mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); 1382 1383 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1384 { 1385 /* Range_check frees "e" in that case. */ 1386 e = NULL; 1387 goto error; 1388 } 1389 1390 if (jn) 1391 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, 1392 -i-1); 1393 else 1394 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1395 1396 mpfr_set (last1, last2, GFC_RND_MODE); 1397 mpfr_set (last2, e->value.real, GFC_RND_MODE); 1398 } 1399 1400 mpfr_clear (last1); 1401 mpfr_clear (last2); 1402 mpfr_clear (x2rev); 1403 return result; 1404 1405error: 1406 mpfr_clear (last1); 1407 mpfr_clear (last2); 1408 mpfr_clear (x2rev); 1409 gfc_free_expr (e); 1410 gfc_free_expr (result); 1411 return &gfc_bad_expr; 1412} 1413 1414 1415gfc_expr * 1416gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1417{ 1418 return gfc_simplify_bessel_n2 (order1, order2, x, true); 1419} 1420 1421 1422gfc_expr * 1423gfc_simplify_bessel_y0 (gfc_expr *x) 1424{ 1425 gfc_expr *result; 1426 1427 if (x->expr_type != EXPR_CONSTANT) 1428 return NULL; 1429 1430 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1431 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); 1432 1433 return range_check (result, "BESSEL_Y0"); 1434} 1435 1436 1437gfc_expr * 1438gfc_simplify_bessel_y1 (gfc_expr *x) 1439{ 1440 gfc_expr *result; 1441 1442 if (x->expr_type != EXPR_CONSTANT) 1443 return NULL; 1444 1445 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1446 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); 1447 1448 return range_check (result, "BESSEL_Y1"); 1449} 1450 1451 1452gfc_expr * 1453gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) 1454{ 1455 gfc_expr *result; 1456 long n; 1457 1458 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1459 return NULL; 1460 1461 n = mpz_get_si (order->value.integer); 1462 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1463 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); 1464 1465 return range_check (result, "BESSEL_YN"); 1466} 1467 1468 1469gfc_expr * 1470gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1471{ 1472 return gfc_simplify_bessel_n2 (order1, order2, x, false); 1473} 1474 1475 1476gfc_expr * 1477gfc_simplify_bit_size (gfc_expr *e) 1478{ 1479 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 1480 return gfc_get_int_expr (e->ts.kind, &e->where, 1481 gfc_integer_kinds[i].bit_size); 1482} 1483 1484 1485gfc_expr * 1486gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) 1487{ 1488 int b; 1489 1490 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) 1491 return NULL; 1492 1493 if (gfc_extract_int (bit, &b) != NULL || b < 0) 1494 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); 1495 1496 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, 1497 mpz_tstbit (e->value.integer, b)); 1498} 1499 1500 1501static int 1502compare_bitwise (gfc_expr *i, gfc_expr *j) 1503{ 1504 mpz_t x, y; 1505 int k, res; 1506 1507 gcc_assert (i->ts.type == BT_INTEGER); 1508 gcc_assert (j->ts.type == BT_INTEGER); 1509 1510 mpz_init_set (x, i->value.integer); 1511 k = gfc_validate_kind (i->ts.type, i->ts.kind, false); 1512 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 1513 1514 mpz_init_set (y, j->value.integer); 1515 k = gfc_validate_kind (j->ts.type, j->ts.kind, false); 1516 convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); 1517 1518 res = mpz_cmp (x, y); 1519 mpz_clear (x); 1520 mpz_clear (y); 1521 return res; 1522} 1523 1524 1525gfc_expr * 1526gfc_simplify_bge (gfc_expr *i, gfc_expr *j) 1527{ 1528 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1529 return NULL; 1530 1531 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1532 compare_bitwise (i, j) >= 0); 1533} 1534 1535 1536gfc_expr * 1537gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) 1538{ 1539 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1540 return NULL; 1541 1542 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1543 compare_bitwise (i, j) > 0); 1544} 1545 1546 1547gfc_expr * 1548gfc_simplify_ble (gfc_expr *i, gfc_expr *j) 1549{ 1550 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1551 return NULL; 1552 1553 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1554 compare_bitwise (i, j) <= 0); 1555} 1556 1557 1558gfc_expr * 1559gfc_simplify_blt (gfc_expr *i, gfc_expr *j) 1560{ 1561 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1562 return NULL; 1563 1564 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1565 compare_bitwise (i, j) < 0); 1566} 1567 1568 1569gfc_expr * 1570gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) 1571{ 1572 gfc_expr *ceil, *result; 1573 int kind; 1574 1575 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); 1576 if (kind == -1) 1577 return &gfc_bad_expr; 1578 1579 if (e->expr_type != EXPR_CONSTANT) 1580 return NULL; 1581 1582 ceil = gfc_copy_expr (e); 1583 mpfr_ceil (ceil->value.real, e->value.real); 1584 1585 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 1586 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); 1587 1588 gfc_free_expr (ceil); 1589 1590 return range_check (result, "CEILING"); 1591} 1592 1593 1594gfc_expr * 1595gfc_simplify_char (gfc_expr *e, gfc_expr *k) 1596{ 1597 return simplify_achar_char (e, k, "CHAR", false); 1598} 1599 1600 1601/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ 1602 1603static gfc_expr * 1604simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 1605{ 1606 gfc_expr *result; 1607 1608 if (convert_boz (x, kind) == &gfc_bad_expr) 1609 return &gfc_bad_expr; 1610 1611 if (convert_boz (y, kind) == &gfc_bad_expr) 1612 return &gfc_bad_expr; 1613 1614 if (x->expr_type != EXPR_CONSTANT 1615 || (y != NULL && y->expr_type != EXPR_CONSTANT)) 1616 return NULL; 1617 1618 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); 1619 1620 switch (x->ts.type) 1621 { 1622 case BT_INTEGER: 1623 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); 1624 break; 1625 1626 case BT_REAL: 1627 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); 1628 break; 1629 1630 case BT_COMPLEX: 1631 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1632 break; 1633 1634 default: 1635 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); 1636 } 1637 1638 if (!y) 1639 return range_check (result, name); 1640 1641 switch (y->ts.type) 1642 { 1643 case BT_INTEGER: 1644 mpfr_set_z (mpc_imagref (result->value.complex), 1645 y->value.integer, GFC_RND_MODE); 1646 break; 1647 1648 case BT_REAL: 1649 mpfr_set (mpc_imagref (result->value.complex), 1650 y->value.real, GFC_RND_MODE); 1651 break; 1652 1653 default: 1654 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); 1655 } 1656 1657 return range_check (result, name); 1658} 1659 1660 1661gfc_expr * 1662gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) 1663{ 1664 int kind; 1665 1666 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); 1667 if (kind == -1) 1668 return &gfc_bad_expr; 1669 1670 return simplify_cmplx ("CMPLX", x, y, kind); 1671} 1672 1673 1674gfc_expr * 1675gfc_simplify_complex (gfc_expr *x, gfc_expr *y) 1676{ 1677 int kind; 1678 1679 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) 1680 kind = gfc_default_complex_kind; 1681 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) 1682 kind = x->ts.kind; 1683 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) 1684 kind = y->ts.kind; 1685 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) 1686 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; 1687 else 1688 gcc_unreachable (); 1689 1690 return simplify_cmplx ("COMPLEX", x, y, kind); 1691} 1692 1693 1694gfc_expr * 1695gfc_simplify_conjg (gfc_expr *e) 1696{ 1697 gfc_expr *result; 1698 1699 if (e->expr_type != EXPR_CONSTANT) 1700 return NULL; 1701 1702 result = gfc_copy_expr (e); 1703 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); 1704 1705 return range_check (result, "CONJG"); 1706} 1707 1708 1709gfc_expr * 1710gfc_simplify_cos (gfc_expr *x) 1711{ 1712 gfc_expr *result; 1713 1714 if (x->expr_type != EXPR_CONSTANT) 1715 return NULL; 1716 1717 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1718 1719 switch (x->ts.type) 1720 { 1721 case BT_REAL: 1722 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); 1723 break; 1724 1725 case BT_COMPLEX: 1726 gfc_set_model_kind (x->ts.kind); 1727 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1728 break; 1729 1730 default: 1731 gfc_internal_error ("in gfc_simplify_cos(): Bad type"); 1732 } 1733 1734 return range_check (result, "COS"); 1735} 1736 1737 1738gfc_expr * 1739gfc_simplify_cosh (gfc_expr *x) 1740{ 1741 gfc_expr *result; 1742 1743 if (x->expr_type != EXPR_CONSTANT) 1744 return NULL; 1745 1746 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1747 1748 switch (x->ts.type) 1749 { 1750 case BT_REAL: 1751 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); 1752 break; 1753 1754 case BT_COMPLEX: 1755 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1756 break; 1757 1758 default: 1759 gcc_unreachable (); 1760 } 1761 1762 return range_check (result, "COSH"); 1763} 1764 1765 1766gfc_expr * 1767gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 1768{ 1769 gfc_expr *result; 1770 1771 if (!is_constant_array_expr (mask) 1772 || !gfc_is_constant_expr (dim) 1773 || !gfc_is_constant_expr (kind)) 1774 return NULL; 1775 1776 result = transformational_result (mask, dim, 1777 BT_INTEGER, 1778 get_kind (BT_INTEGER, kind, "COUNT", 1779 gfc_default_integer_kind), 1780 &mask->where); 1781 1782 init_result_expr (result, 0, NULL); 1783 1784 /* Passing MASK twice, once as data array, once as mask. 1785 Whenever gfc_count is called, '1' is added to the result. */ 1786 return !dim || mask->rank == 1 ? 1787 simplify_transformation_to_scalar (result, mask, mask, gfc_count) : 1788 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); 1789} 1790 1791 1792gfc_expr * 1793gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) 1794{ 1795 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); 1796} 1797 1798 1799gfc_expr * 1800gfc_simplify_dble (gfc_expr *e) 1801{ 1802 gfc_expr *result = NULL; 1803 1804 if (e->expr_type != EXPR_CONSTANT) 1805 return NULL; 1806 1807 if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr) 1808 return &gfc_bad_expr; 1809 1810 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); 1811 if (result == &gfc_bad_expr) 1812 return &gfc_bad_expr; 1813 1814 return range_check (result, "DBLE"); 1815} 1816 1817 1818gfc_expr * 1819gfc_simplify_digits (gfc_expr *x) 1820{ 1821 int i, digits; 1822 1823 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 1824 1825 switch (x->ts.type) 1826 { 1827 case BT_INTEGER: 1828 digits = gfc_integer_kinds[i].digits; 1829 break; 1830 1831 case BT_REAL: 1832 case BT_COMPLEX: 1833 digits = gfc_real_kinds[i].digits; 1834 break; 1835 1836 default: 1837 gcc_unreachable (); 1838 } 1839 1840 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); 1841} 1842 1843 1844gfc_expr * 1845gfc_simplify_dim (gfc_expr *x, gfc_expr *y) 1846{ 1847 gfc_expr *result; 1848 int kind; 1849 1850 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1851 return NULL; 1852 1853 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 1854 result = gfc_get_constant_expr (x->ts.type, kind, &x->where); 1855 1856 switch (x->ts.type) 1857 { 1858 case BT_INTEGER: 1859 if (mpz_cmp (x->value.integer, y->value.integer) > 0) 1860 mpz_sub (result->value.integer, x->value.integer, y->value.integer); 1861 else 1862 mpz_set_ui (result->value.integer, 0); 1863 1864 break; 1865 1866 case BT_REAL: 1867 if (mpfr_cmp (x->value.real, y->value.real) > 0) 1868 mpfr_sub (result->value.real, x->value.real, y->value.real, 1869 GFC_RND_MODE); 1870 else 1871 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 1872 1873 break; 1874 1875 default: 1876 gfc_internal_error ("gfc_simplify_dim(): Bad type"); 1877 } 1878 1879 return range_check (result, "DIM"); 1880} 1881 1882 1883gfc_expr* 1884gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) 1885{ 1886 1887 gfc_expr temp; 1888 1889 if (!is_constant_array_expr (vector_a) 1890 || !is_constant_array_expr (vector_b)) 1891 return NULL; 1892 1893 gcc_assert (vector_a->rank == 1); 1894 gcc_assert (vector_b->rank == 1); 1895 1896 temp.expr_type = EXPR_OP; 1897 gfc_clear_ts (&temp.ts); 1898 temp.value.op.op = INTRINSIC_NONE; 1899 temp.value.op.op1 = vector_a; 1900 temp.value.op.op2 = vector_b; 1901 gfc_type_convert_binary (&temp, 1); 1902 1903 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); 1904} 1905 1906 1907gfc_expr * 1908gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) 1909{ 1910 gfc_expr *a1, *a2, *result; 1911 1912 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1913 return NULL; 1914 1915 a1 = gfc_real2real (x, gfc_default_double_kind); 1916 a2 = gfc_real2real (y, gfc_default_double_kind); 1917 1918 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); 1919 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); 1920 1921 gfc_free_expr (a2); 1922 gfc_free_expr (a1); 1923 1924 return range_check (result, "DPROD"); 1925} 1926 1927 1928static gfc_expr * 1929simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, 1930 bool right) 1931{ 1932 gfc_expr *result; 1933 int i, k, size, shift; 1934 1935 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT 1936 || shiftarg->expr_type != EXPR_CONSTANT) 1937 return NULL; 1938 1939 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); 1940 size = gfc_integer_kinds[k].bit_size; 1941 1942 gfc_extract_int (shiftarg, &shift); 1943 1944 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ 1945 if (right) 1946 shift = size - shift; 1947 1948 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); 1949 mpz_set_ui (result->value.integer, 0); 1950 1951 for (i = 0; i < shift; i++) 1952 if (mpz_tstbit (arg2->value.integer, size - shift + i)) 1953 mpz_setbit (result->value.integer, i); 1954 1955 for (i = 0; i < size - shift; i++) 1956 if (mpz_tstbit (arg1->value.integer, i)) 1957 mpz_setbit (result->value.integer, shift + i); 1958 1959 /* Convert to a signed value. */ 1960 gfc_convert_mpz_to_signed (result->value.integer, size); 1961 1962 return result; 1963} 1964 1965 1966gfc_expr * 1967gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 1968{ 1969 return simplify_dshift (arg1, arg2, shiftarg, true); 1970} 1971 1972 1973gfc_expr * 1974gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 1975{ 1976 return simplify_dshift (arg1, arg2, shiftarg, false); 1977} 1978 1979 1980gfc_expr * 1981gfc_simplify_erf (gfc_expr *x) 1982{ 1983 gfc_expr *result; 1984 1985 if (x->expr_type != EXPR_CONSTANT) 1986 return NULL; 1987 1988 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1989 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); 1990 1991 return range_check (result, "ERF"); 1992} 1993 1994 1995gfc_expr * 1996gfc_simplify_erfc (gfc_expr *x) 1997{ 1998 gfc_expr *result; 1999 2000 if (x->expr_type != EXPR_CONSTANT) 2001 return NULL; 2002 2003 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2004 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); 2005 2006 return range_check (result, "ERFC"); 2007} 2008 2009 2010/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ 2011 2012#define MAX_ITER 200 2013#define ARG_LIMIT 12 2014 2015/* Calculate ERFC_SCALED directly by its definition: 2016 2017 ERFC_SCALED(x) = ERFC(x) * EXP(X**2) 2018 2019 using a large precision for intermediate results. This is used for all 2020 but large values of the argument. */ 2021static void 2022fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) 2023{ 2024 mp_prec_t prec; 2025 mpfr_t a, b; 2026 2027 prec = mpfr_get_default_prec (); 2028 mpfr_set_default_prec (10 * prec); 2029 2030 mpfr_init (a); 2031 mpfr_init (b); 2032 2033 mpfr_set (a, arg, GFC_RND_MODE); 2034 mpfr_sqr (b, a, GFC_RND_MODE); 2035 mpfr_exp (b, b, GFC_RND_MODE); 2036 mpfr_erfc (a, a, GFC_RND_MODE); 2037 mpfr_mul (a, a, b, GFC_RND_MODE); 2038 2039 mpfr_set (res, a, GFC_RND_MODE); 2040 mpfr_set_default_prec (prec); 2041 2042 mpfr_clear (a); 2043 mpfr_clear (b); 2044} 2045 2046/* Calculate ERFC_SCALED using a power series expansion in 1/arg: 2047 2048 ERFC_SCALED(x) = 1 / (x * sqrt(pi)) 2049 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) 2050 / (2 * x**2)**n) 2051 2052 This is used for large values of the argument. Intermediate calculations 2053 are performed with twice the precision. We don't do a fixed number of 2054 iterations of the sum, but stop when it has converged to the required 2055 precision. */ 2056static void 2057asympt_erfc_scaled (mpfr_t res, mpfr_t arg) 2058{ 2059 mpfr_t sum, x, u, v, w, oldsum, sumtrunc; 2060 mpz_t num; 2061 mp_prec_t prec; 2062 unsigned i; 2063 2064 prec = mpfr_get_default_prec (); 2065 mpfr_set_default_prec (2 * prec); 2066 2067 mpfr_init (sum); 2068 mpfr_init (x); 2069 mpfr_init (u); 2070 mpfr_init (v); 2071 mpfr_init (w); 2072 mpz_init (num); 2073 2074 mpfr_init (oldsum); 2075 mpfr_init (sumtrunc); 2076 mpfr_set_prec (oldsum, prec); 2077 mpfr_set_prec (sumtrunc, prec); 2078 2079 mpfr_set (x, arg, GFC_RND_MODE); 2080 mpfr_set_ui (sum, 1, GFC_RND_MODE); 2081 mpz_set_ui (num, 1); 2082 2083 mpfr_set (u, x, GFC_RND_MODE); 2084 mpfr_sqr (u, u, GFC_RND_MODE); 2085 mpfr_mul_ui (u, u, 2, GFC_RND_MODE); 2086 mpfr_pow_si (u, u, -1, GFC_RND_MODE); 2087 2088 for (i = 1; i < MAX_ITER; i++) 2089 { 2090 mpfr_set (oldsum, sum, GFC_RND_MODE); 2091 2092 mpz_mul_ui (num, num, 2 * i - 1); 2093 mpz_neg (num, num); 2094 2095 mpfr_set (w, u, GFC_RND_MODE); 2096 mpfr_pow_ui (w, w, i, GFC_RND_MODE); 2097 2098 mpfr_set_z (v, num, GFC_RND_MODE); 2099 mpfr_mul (v, v, w, GFC_RND_MODE); 2100 2101 mpfr_add (sum, sum, v, GFC_RND_MODE); 2102 2103 mpfr_set (sumtrunc, sum, GFC_RND_MODE); 2104 if (mpfr_cmp (sumtrunc, oldsum) == 0) 2105 break; 2106 } 2107 2108 /* We should have converged by now; otherwise, ARG_LIMIT is probably 2109 set too low. */ 2110 gcc_assert (i < MAX_ITER); 2111 2112 /* Divide by x * sqrt(Pi). */ 2113 mpfr_const_pi (u, GFC_RND_MODE); 2114 mpfr_sqrt (u, u, GFC_RND_MODE); 2115 mpfr_mul (u, u, x, GFC_RND_MODE); 2116 mpfr_div (sum, sum, u, GFC_RND_MODE); 2117 2118 mpfr_set (res, sum, GFC_RND_MODE); 2119 mpfr_set_default_prec (prec); 2120 2121 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL); 2122 mpz_clear (num); 2123} 2124 2125 2126gfc_expr * 2127gfc_simplify_erfc_scaled (gfc_expr *x) 2128{ 2129 gfc_expr *result; 2130 2131 if (x->expr_type != EXPR_CONSTANT) 2132 return NULL; 2133 2134 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2135 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) 2136 asympt_erfc_scaled (result->value.real, x->value.real); 2137 else 2138 fullprec_erfc_scaled (result->value.real, x->value.real); 2139 2140 return range_check (result, "ERFC_SCALED"); 2141} 2142 2143#undef MAX_ITER 2144#undef ARG_LIMIT 2145 2146 2147gfc_expr * 2148gfc_simplify_epsilon (gfc_expr *e) 2149{ 2150 gfc_expr *result; 2151 int i; 2152 2153 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 2154 2155 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 2156 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); 2157 2158 return range_check (result, "EPSILON"); 2159} 2160 2161 2162gfc_expr * 2163gfc_simplify_exp (gfc_expr *x) 2164{ 2165 gfc_expr *result; 2166 2167 if (x->expr_type != EXPR_CONSTANT) 2168 return NULL; 2169 2170 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2171 2172 switch (x->ts.type) 2173 { 2174 case BT_REAL: 2175 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); 2176 break; 2177 2178 case BT_COMPLEX: 2179 gfc_set_model_kind (x->ts.kind); 2180 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 2181 break; 2182 2183 default: 2184 gfc_internal_error ("in gfc_simplify_exp(): Bad type"); 2185 } 2186 2187 return range_check (result, "EXP"); 2188} 2189 2190 2191gfc_expr * 2192gfc_simplify_exponent (gfc_expr *x) 2193{ 2194 long int val; 2195 gfc_expr *result; 2196 2197 if (x->expr_type != EXPR_CONSTANT) 2198 return NULL; 2199 2200 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2201 &x->where); 2202 2203 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ 2204 if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) 2205 { 2206 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); 2207 mpz_set (result->value.integer, gfc_integer_kinds[i].huge); 2208 return result; 2209 } 2210 2211 /* EXPONENT(+/- 0.0) = 0 */ 2212 if (mpfr_zero_p (x->value.real)) 2213 { 2214 mpz_set_ui (result->value.integer, 0); 2215 return result; 2216 } 2217 2218 gfc_set_model (x->value.real); 2219 2220 val = (long int) mpfr_get_exp (x->value.real); 2221 mpz_set_si (result->value.integer, val); 2222 2223 return range_check (result, "EXPONENT"); 2224} 2225 2226 2227gfc_expr * 2228gfc_simplify_float (gfc_expr *a) 2229{ 2230 gfc_expr *result; 2231 2232 if (a->expr_type != EXPR_CONSTANT) 2233 return NULL; 2234 2235 if (a->is_boz) 2236 { 2237 if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr) 2238 return &gfc_bad_expr; 2239 2240 result = gfc_copy_expr (a); 2241 } 2242 else 2243 result = gfc_int2real (a, gfc_default_real_kind); 2244 2245 return range_check (result, "FLOAT"); 2246} 2247 2248 2249static bool 2250is_last_ref_vtab (gfc_expr *e) 2251{ 2252 gfc_ref *ref; 2253 gfc_component *comp = NULL; 2254 2255 if (e->expr_type != EXPR_VARIABLE) 2256 return false; 2257 2258 for (ref = e->ref; ref; ref = ref->next) 2259 if (ref->type == REF_COMPONENT) 2260 comp = ref->u.c.component; 2261 2262 if (!e->ref || !comp) 2263 return e->symtree->n.sym->attr.vtab; 2264 2265 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) 2266 return true; 2267 2268 return false; 2269} 2270 2271 2272gfc_expr * 2273gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) 2274{ 2275 /* Avoid simplification of resolved symbols. */ 2276 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) 2277 return NULL; 2278 2279 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) 2280 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 2281 gfc_type_is_extension_of (mold->ts.u.derived, 2282 a->ts.u.derived)); 2283 2284 if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) 2285 return NULL; 2286 2287 /* Return .false. if the dynamic type can never be the same. */ 2288 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS 2289 && !gfc_type_is_extension_of 2290 (mold->ts.u.derived->components->ts.u.derived, 2291 a->ts.u.derived->components->ts.u.derived) 2292 && !gfc_type_is_extension_of 2293 (a->ts.u.derived->components->ts.u.derived, 2294 mold->ts.u.derived->components->ts.u.derived)) 2295 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS 2296 && !gfc_type_is_extension_of 2297 (a->ts.u.derived, 2298 mold->ts.u.derived->components->ts.u.derived) 2299 && !gfc_type_is_extension_of 2300 (mold->ts.u.derived->components->ts.u.derived, 2301 a->ts.u.derived)) 2302 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED 2303 && !gfc_type_is_extension_of 2304 (mold->ts.u.derived, 2305 a->ts.u.derived->components->ts.u.derived))) 2306 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 2307 2308 if (mold->ts.type == BT_DERIVED 2309 && gfc_type_is_extension_of (mold->ts.u.derived, 2310 a->ts.u.derived->components->ts.u.derived)) 2311 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); 2312 2313 return NULL; 2314} 2315 2316 2317gfc_expr * 2318gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) 2319{ 2320 /* Avoid simplification of resolved symbols. */ 2321 if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) 2322 return NULL; 2323 2324 /* Return .false. if the dynamic type can never be the 2325 same. */ 2326 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok) 2327 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) 2328 && !gfc_type_compatible (&a->ts, &b->ts) 2329 && !gfc_type_compatible (&b->ts, &a->ts)) 2330 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 2331 2332 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) 2333 return NULL; 2334 2335 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 2336 gfc_compare_derived_types (a->ts.u.derived, 2337 b->ts.u.derived)); 2338} 2339 2340 2341gfc_expr * 2342gfc_simplify_floor (gfc_expr *e, gfc_expr *k) 2343{ 2344 gfc_expr *result; 2345 mpfr_t floor; 2346 int kind; 2347 2348 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); 2349 if (kind == -1) 2350 gfc_internal_error ("gfc_simplify_floor(): Bad kind"); 2351 2352 if (e->expr_type != EXPR_CONSTANT) 2353 return NULL; 2354 2355 mpfr_init2 (floor, mpfr_get_prec (e->value.real)); 2356 mpfr_floor (floor, e->value.real); 2357 2358 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 2359 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); 2360 2361 mpfr_clear (floor); 2362 2363 return range_check (result, "FLOOR"); 2364} 2365 2366 2367gfc_expr * 2368gfc_simplify_fraction (gfc_expr *x) 2369{ 2370 gfc_expr *result; 2371 2372#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0) 2373 mpfr_t absv, exp, pow2; 2374#else 2375 mpfr_exp_t e; 2376#endif 2377 2378 if (x->expr_type != EXPR_CONSTANT) 2379 return NULL; 2380 2381 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 2382 2383 /* FRACTION(inf) = NaN. */ 2384 if (mpfr_inf_p (x->value.real)) 2385 { 2386 mpfr_set_nan (result->value.real); 2387 return result; 2388 } 2389 2390#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0) 2391 2392 /* MPFR versions before 3.1.0 do not include mpfr_frexp. 2393 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */ 2394 2395 if (mpfr_sgn (x->value.real) == 0) 2396 { 2397 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 2398 return result; 2399 } 2400 2401 gfc_set_model_kind (x->ts.kind); 2402 mpfr_init (exp); 2403 mpfr_init (absv); 2404 mpfr_init (pow2); 2405 2406 mpfr_abs (absv, x->value.real, GFC_RND_MODE); 2407 mpfr_log2 (exp, absv, GFC_RND_MODE); 2408 2409 mpfr_trunc (exp, exp); 2410 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE); 2411 2412 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); 2413 2414 mpfr_div (result->value.real, x->value.real, pow2, GFC_RND_MODE); 2415 2416 mpfr_clears (exp, absv, pow2, NULL); 2417 2418#else 2419 2420 /* mpfr_frexp() correctly handles zeros and NaNs. */ 2421 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); 2422 2423#endif 2424 2425 return range_check (result, "FRACTION"); 2426} 2427 2428 2429gfc_expr * 2430gfc_simplify_gamma (gfc_expr *x) 2431{ 2432 gfc_expr *result; 2433 2434 if (x->expr_type != EXPR_CONSTANT) 2435 return NULL; 2436 2437 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2438 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); 2439 2440 return range_check (result, "GAMMA"); 2441} 2442 2443 2444gfc_expr * 2445gfc_simplify_huge (gfc_expr *e) 2446{ 2447 gfc_expr *result; 2448 int i; 2449 2450 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 2451 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 2452 2453 switch (e->ts.type) 2454 { 2455 case BT_INTEGER: 2456 mpz_set (result->value.integer, gfc_integer_kinds[i].huge); 2457 break; 2458 2459 case BT_REAL: 2460 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 2461 break; 2462 2463 default: 2464 gcc_unreachable (); 2465 } 2466 2467 return result; 2468} 2469 2470 2471gfc_expr * 2472gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) 2473{ 2474 gfc_expr *result; 2475 2476 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2477 return NULL; 2478 2479 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2480 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); 2481 return range_check (result, "HYPOT"); 2482} 2483 2484 2485/* We use the processor's collating sequence, because all 2486 systems that gfortran currently works on are ASCII. */ 2487 2488gfc_expr * 2489gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) 2490{ 2491 gfc_expr *result; 2492 gfc_char_t index; 2493 int k; 2494 2495 if (e->expr_type != EXPR_CONSTANT) 2496 return NULL; 2497 2498 if (e->value.character.length != 1) 2499 { 2500 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); 2501 return &gfc_bad_expr; 2502 } 2503 2504 index = e->value.character.string[0]; 2505 2506 if (warn_surprising && index > 127) 2507 gfc_warning (OPT_Wsurprising, 2508 "Argument of IACHAR function at %L outside of range 0..127", 2509 &e->where); 2510 2511 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); 2512 if (k == -1) 2513 return &gfc_bad_expr; 2514 2515 result = gfc_get_int_expr (k, &e->where, index); 2516 2517 return range_check (result, "IACHAR"); 2518} 2519 2520 2521static gfc_expr * 2522do_bit_and (gfc_expr *result, gfc_expr *e) 2523{ 2524 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 2525 gcc_assert (result->ts.type == BT_INTEGER 2526 && result->expr_type == EXPR_CONSTANT); 2527 2528 mpz_and (result->value.integer, result->value.integer, e->value.integer); 2529 return result; 2530} 2531 2532 2533gfc_expr * 2534gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 2535{ 2536 return simplify_transformation (array, dim, mask, -1, do_bit_and); 2537} 2538 2539 2540static gfc_expr * 2541do_bit_ior (gfc_expr *result, gfc_expr *e) 2542{ 2543 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 2544 gcc_assert (result->ts.type == BT_INTEGER 2545 && result->expr_type == EXPR_CONSTANT); 2546 2547 mpz_ior (result->value.integer, result->value.integer, e->value.integer); 2548 return result; 2549} 2550 2551 2552gfc_expr * 2553gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 2554{ 2555 return simplify_transformation (array, dim, mask, 0, do_bit_ior); 2556} 2557 2558 2559gfc_expr * 2560gfc_simplify_iand (gfc_expr *x, gfc_expr *y) 2561{ 2562 gfc_expr *result; 2563 2564 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2565 return NULL; 2566 2567 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 2568 mpz_and (result->value.integer, x->value.integer, y->value.integer); 2569 2570 return range_check (result, "IAND"); 2571} 2572 2573 2574gfc_expr * 2575gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) 2576{ 2577 gfc_expr *result; 2578 int k, pos; 2579 2580 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2581 return NULL; 2582 2583 gfc_extract_int (y, &pos); 2584 2585 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 2586 2587 result = gfc_copy_expr (x); 2588 2589 convert_mpz_to_unsigned (result->value.integer, 2590 gfc_integer_kinds[k].bit_size); 2591 2592 mpz_clrbit (result->value.integer, pos); 2593 2594 gfc_convert_mpz_to_signed (result->value.integer, 2595 gfc_integer_kinds[k].bit_size); 2596 2597 return result; 2598} 2599 2600 2601gfc_expr * 2602gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) 2603{ 2604 gfc_expr *result; 2605 int pos, len; 2606 int i, k, bitsize; 2607 int *bits; 2608 2609 if (x->expr_type != EXPR_CONSTANT 2610 || y->expr_type != EXPR_CONSTANT 2611 || z->expr_type != EXPR_CONSTANT) 2612 return NULL; 2613 2614 gfc_extract_int (y, &pos); 2615 gfc_extract_int (z, &len); 2616 2617 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); 2618 2619 bitsize = gfc_integer_kinds[k].bit_size; 2620 2621 if (pos + len > bitsize) 2622 { 2623 gfc_error ("Sum of second and third arguments of IBITS exceeds " 2624 "bit size at %L", &y->where); 2625 return &gfc_bad_expr; 2626 } 2627 2628 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2629 convert_mpz_to_unsigned (result->value.integer, 2630 gfc_integer_kinds[k].bit_size); 2631 2632 bits = XCNEWVEC (int, bitsize); 2633 2634 for (i = 0; i < bitsize; i++) 2635 bits[i] = 0; 2636 2637 for (i = 0; i < len; i++) 2638 bits[i] = mpz_tstbit (x->value.integer, i + pos); 2639 2640 for (i = 0; i < bitsize; i++) 2641 { 2642 if (bits[i] == 0) 2643 mpz_clrbit (result->value.integer, i); 2644 else if (bits[i] == 1) 2645 mpz_setbit (result->value.integer, i); 2646 else 2647 gfc_internal_error ("IBITS: Bad bit"); 2648 } 2649 2650 free (bits); 2651 2652 gfc_convert_mpz_to_signed (result->value.integer, 2653 gfc_integer_kinds[k].bit_size); 2654 2655 return result; 2656} 2657 2658 2659gfc_expr * 2660gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) 2661{ 2662 gfc_expr *result; 2663 int k, pos; 2664 2665 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2666 return NULL; 2667 2668 gfc_extract_int (y, &pos); 2669 2670 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 2671 2672 result = gfc_copy_expr (x); 2673 2674 convert_mpz_to_unsigned (result->value.integer, 2675 gfc_integer_kinds[k].bit_size); 2676 2677 mpz_setbit (result->value.integer, pos); 2678 2679 gfc_convert_mpz_to_signed (result->value.integer, 2680 gfc_integer_kinds[k].bit_size); 2681 2682 return result; 2683} 2684 2685 2686gfc_expr * 2687gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) 2688{ 2689 gfc_expr *result; 2690 gfc_char_t index; 2691 int k; 2692 2693 if (e->expr_type != EXPR_CONSTANT) 2694 return NULL; 2695 2696 if (e->value.character.length != 1) 2697 { 2698 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); 2699 return &gfc_bad_expr; 2700 } 2701 2702 index = e->value.character.string[0]; 2703 2704 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); 2705 if (k == -1) 2706 return &gfc_bad_expr; 2707 2708 result = gfc_get_int_expr (k, &e->where, index); 2709 2710 return range_check (result, "ICHAR"); 2711} 2712 2713 2714gfc_expr * 2715gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) 2716{ 2717 gfc_expr *result; 2718 2719 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2720 return NULL; 2721 2722 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 2723 mpz_xor (result->value.integer, x->value.integer, y->value.integer); 2724 2725 return range_check (result, "IEOR"); 2726} 2727 2728 2729gfc_expr * 2730gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) 2731{ 2732 gfc_expr *result; 2733 int back, len, lensub; 2734 int i, j, k, count, index = 0, start; 2735 2736 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT 2737 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 2738 return NULL; 2739 2740 if (b != NULL && b->value.logical != 0) 2741 back = 1; 2742 else 2743 back = 0; 2744 2745 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); 2746 if (k == -1) 2747 return &gfc_bad_expr; 2748 2749 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 2750 2751 len = x->value.character.length; 2752 lensub = y->value.character.length; 2753 2754 if (len < lensub) 2755 { 2756 mpz_set_si (result->value.integer, 0); 2757 return result; 2758 } 2759 2760 if (back == 0) 2761 { 2762 if (lensub == 0) 2763 { 2764 mpz_set_si (result->value.integer, 1); 2765 return result; 2766 } 2767 else if (lensub == 1) 2768 { 2769 for (i = 0; i < len; i++) 2770 { 2771 for (j = 0; j < lensub; j++) 2772 { 2773 if (y->value.character.string[j] 2774 == x->value.character.string[i]) 2775 { 2776 index = i + 1; 2777 goto done; 2778 } 2779 } 2780 } 2781 } 2782 else 2783 { 2784 for (i = 0; i < len; i++) 2785 { 2786 for (j = 0; j < lensub; j++) 2787 { 2788 if (y->value.character.string[j] 2789 == x->value.character.string[i]) 2790 { 2791 start = i; 2792 count = 0; 2793 2794 for (k = 0; k < lensub; k++) 2795 { 2796 if (y->value.character.string[k] 2797 == x->value.character.string[k + start]) 2798 count++; 2799 } 2800 2801 if (count == lensub) 2802 { 2803 index = start + 1; 2804 goto done; 2805 } 2806 } 2807 } 2808 } 2809 } 2810 2811 } 2812 else 2813 { 2814 if (lensub == 0) 2815 { 2816 mpz_set_si (result->value.integer, len + 1); 2817 return result; 2818 } 2819 else if (lensub == 1) 2820 { 2821 for (i = 0; i < len; i++) 2822 { 2823 for (j = 0; j < lensub; j++) 2824 { 2825 if (y->value.character.string[j] 2826 == x->value.character.string[len - i]) 2827 { 2828 index = len - i + 1; 2829 goto done; 2830 } 2831 } 2832 } 2833 } 2834 else 2835 { 2836 for (i = 0; i < len; i++) 2837 { 2838 for (j = 0; j < lensub; j++) 2839 { 2840 if (y->value.character.string[j] 2841 == x->value.character.string[len - i]) 2842 { 2843 start = len - i; 2844 if (start <= len - lensub) 2845 { 2846 count = 0; 2847 for (k = 0; k < lensub; k++) 2848 if (y->value.character.string[k] 2849 == x->value.character.string[k + start]) 2850 count++; 2851 2852 if (count == lensub) 2853 { 2854 index = start + 1; 2855 goto done; 2856 } 2857 } 2858 else 2859 { 2860 continue; 2861 } 2862 } 2863 } 2864 } 2865 } 2866 } 2867 2868done: 2869 mpz_set_si (result->value.integer, index); 2870 return range_check (result, "INDEX"); 2871} 2872 2873 2874static gfc_expr * 2875simplify_intconv (gfc_expr *e, int kind, const char *name) 2876{ 2877 gfc_expr *result = NULL; 2878 2879 if (e->expr_type != EXPR_CONSTANT) 2880 return NULL; 2881 2882 result = gfc_convert_constant (e, BT_INTEGER, kind); 2883 if (result == &gfc_bad_expr) 2884 return &gfc_bad_expr; 2885 2886 return range_check (result, name); 2887} 2888 2889 2890gfc_expr * 2891gfc_simplify_int (gfc_expr *e, gfc_expr *k) 2892{ 2893 int kind; 2894 2895 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); 2896 if (kind == -1) 2897 return &gfc_bad_expr; 2898 2899 return simplify_intconv (e, kind, "INT"); 2900} 2901 2902gfc_expr * 2903gfc_simplify_int2 (gfc_expr *e) 2904{ 2905 return simplify_intconv (e, 2, "INT2"); 2906} 2907 2908 2909gfc_expr * 2910gfc_simplify_int8 (gfc_expr *e) 2911{ 2912 return simplify_intconv (e, 8, "INT8"); 2913} 2914 2915 2916gfc_expr * 2917gfc_simplify_long (gfc_expr *e) 2918{ 2919 return simplify_intconv (e, 4, "LONG"); 2920} 2921 2922 2923gfc_expr * 2924gfc_simplify_ifix (gfc_expr *e) 2925{ 2926 gfc_expr *rtrunc, *result; 2927 2928 if (e->expr_type != EXPR_CONSTANT) 2929 return NULL; 2930 2931 rtrunc = gfc_copy_expr (e); 2932 mpfr_trunc (rtrunc->value.real, e->value.real); 2933 2934 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2935 &e->where); 2936 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 2937 2938 gfc_free_expr (rtrunc); 2939 2940 return range_check (result, "IFIX"); 2941} 2942 2943 2944gfc_expr * 2945gfc_simplify_idint (gfc_expr *e) 2946{ 2947 gfc_expr *rtrunc, *result; 2948 2949 if (e->expr_type != EXPR_CONSTANT) 2950 return NULL; 2951 2952 rtrunc = gfc_copy_expr (e); 2953 mpfr_trunc (rtrunc->value.real, e->value.real); 2954 2955 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2956 &e->where); 2957 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 2958 2959 gfc_free_expr (rtrunc); 2960 2961 return range_check (result, "IDINT"); 2962} 2963 2964 2965gfc_expr * 2966gfc_simplify_ior (gfc_expr *x, gfc_expr *y) 2967{ 2968 gfc_expr *result; 2969 2970 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2971 return NULL; 2972 2973 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 2974 mpz_ior (result->value.integer, x->value.integer, y->value.integer); 2975 2976 return range_check (result, "IOR"); 2977} 2978 2979 2980static gfc_expr * 2981do_bit_xor (gfc_expr *result, gfc_expr *e) 2982{ 2983 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 2984 gcc_assert (result->ts.type == BT_INTEGER 2985 && result->expr_type == EXPR_CONSTANT); 2986 2987 mpz_xor (result->value.integer, result->value.integer, e->value.integer); 2988 return result; 2989} 2990 2991 2992gfc_expr * 2993gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 2994{ 2995 return simplify_transformation (array, dim, mask, 0, do_bit_xor); 2996} 2997 2998 2999gfc_expr * 3000gfc_simplify_is_iostat_end (gfc_expr *x) 3001{ 3002 if (x->expr_type != EXPR_CONSTANT) 3003 return NULL; 3004 3005 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3006 mpz_cmp_si (x->value.integer, 3007 LIBERROR_END) == 0); 3008} 3009 3010 3011gfc_expr * 3012gfc_simplify_is_iostat_eor (gfc_expr *x) 3013{ 3014 if (x->expr_type != EXPR_CONSTANT) 3015 return NULL; 3016 3017 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3018 mpz_cmp_si (x->value.integer, 3019 LIBERROR_EOR) == 0); 3020} 3021 3022 3023gfc_expr * 3024gfc_simplify_isnan (gfc_expr *x) 3025{ 3026 if (x->expr_type != EXPR_CONSTANT) 3027 return NULL; 3028 3029 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3030 mpfr_nan_p (x->value.real)); 3031} 3032 3033 3034/* Performs a shift on its first argument. Depending on the last 3035 argument, the shift can be arithmetic, i.e. with filling from the 3036 left like in the SHIFTA intrinsic. */ 3037static gfc_expr * 3038simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, 3039 bool arithmetic, int direction) 3040{ 3041 gfc_expr *result; 3042 int ashift, *bits, i, k, bitsize, shift; 3043 3044 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3045 return NULL; 3046 3047 gfc_extract_int (s, &shift); 3048 3049 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); 3050 bitsize = gfc_integer_kinds[k].bit_size; 3051 3052 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3053 3054 if (shift == 0) 3055 { 3056 mpz_set (result->value.integer, e->value.integer); 3057 return result; 3058 } 3059 3060 if (direction > 0 && shift < 0) 3061 { 3062 /* Left shift, as in SHIFTL. */ 3063 gfc_error ("Second argument of %s is negative at %L", name, &e->where); 3064 return &gfc_bad_expr; 3065 } 3066 else if (direction < 0) 3067 { 3068 /* Right shift, as in SHIFTR or SHIFTA. */ 3069 if (shift < 0) 3070 { 3071 gfc_error ("Second argument of %s is negative at %L", 3072 name, &e->where); 3073 return &gfc_bad_expr; 3074 } 3075 3076 shift = -shift; 3077 } 3078 3079 ashift = (shift >= 0 ? shift : -shift); 3080 3081 if (ashift > bitsize) 3082 { 3083 gfc_error ("Magnitude of second argument of %s exceeds bit size " 3084 "at %L", name, &e->where); 3085 return &gfc_bad_expr; 3086 } 3087 3088 bits = XCNEWVEC (int, bitsize); 3089 3090 for (i = 0; i < bitsize; i++) 3091 bits[i] = mpz_tstbit (e->value.integer, i); 3092 3093 if (shift > 0) 3094 { 3095 /* Left shift. */ 3096 for (i = 0; i < shift; i++) 3097 mpz_clrbit (result->value.integer, i); 3098 3099 for (i = 0; i < bitsize - shift; i++) 3100 { 3101 if (bits[i] == 0) 3102 mpz_clrbit (result->value.integer, i + shift); 3103 else 3104 mpz_setbit (result->value.integer, i + shift); 3105 } 3106 } 3107 else 3108 { 3109 /* Right shift. */ 3110 if (arithmetic && bits[bitsize - 1]) 3111 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3112 mpz_setbit (result->value.integer, i); 3113 else 3114 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3115 mpz_clrbit (result->value.integer, i); 3116 3117 for (i = bitsize - 1; i >= ashift; i--) 3118 { 3119 if (bits[i] == 0) 3120 mpz_clrbit (result->value.integer, i - ashift); 3121 else 3122 mpz_setbit (result->value.integer, i - ashift); 3123 } 3124 } 3125 3126 gfc_convert_mpz_to_signed (result->value.integer, bitsize); 3127 free (bits); 3128 3129 return result; 3130} 3131 3132 3133gfc_expr * 3134gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) 3135{ 3136 return simplify_shift (e, s, "ISHFT", false, 0); 3137} 3138 3139 3140gfc_expr * 3141gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) 3142{ 3143 return simplify_shift (e, s, "LSHIFT", false, 1); 3144} 3145 3146 3147gfc_expr * 3148gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) 3149{ 3150 return simplify_shift (e, s, "RSHIFT", true, -1); 3151} 3152 3153 3154gfc_expr * 3155gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) 3156{ 3157 return simplify_shift (e, s, "SHIFTA", true, -1); 3158} 3159 3160 3161gfc_expr * 3162gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) 3163{ 3164 return simplify_shift (e, s, "SHIFTL", false, 1); 3165} 3166 3167 3168gfc_expr * 3169gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) 3170{ 3171 return simplify_shift (e, s, "SHIFTR", false, -1); 3172} 3173 3174 3175gfc_expr * 3176gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) 3177{ 3178 gfc_expr *result; 3179 int shift, ashift, isize, ssize, delta, k; 3180 int i, *bits; 3181 3182 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3183 return NULL; 3184 3185 gfc_extract_int (s, &shift); 3186 3187 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3188 isize = gfc_integer_kinds[k].bit_size; 3189 3190 if (sz != NULL) 3191 { 3192 if (sz->expr_type != EXPR_CONSTANT) 3193 return NULL; 3194 3195 gfc_extract_int (sz, &ssize); 3196 3197 } 3198 else 3199 ssize = isize; 3200 3201 if (shift >= 0) 3202 ashift = shift; 3203 else 3204 ashift = -shift; 3205 3206 if (ashift > ssize) 3207 { 3208 if (sz == NULL) 3209 gfc_error ("Magnitude of second argument of ISHFTC exceeds " 3210 "BIT_SIZE of first argument at %L", &s->where); 3211 return &gfc_bad_expr; 3212 } 3213 3214 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3215 3216 mpz_set (result->value.integer, e->value.integer); 3217 3218 if (shift == 0) 3219 return result; 3220 3221 convert_mpz_to_unsigned (result->value.integer, isize); 3222 3223 bits = XCNEWVEC (int, ssize); 3224 3225 for (i = 0; i < ssize; i++) 3226 bits[i] = mpz_tstbit (e->value.integer, i); 3227 3228 delta = ssize - ashift; 3229 3230 if (shift > 0) 3231 { 3232 for (i = 0; i < delta; i++) 3233 { 3234 if (bits[i] == 0) 3235 mpz_clrbit (result->value.integer, i + shift); 3236 else 3237 mpz_setbit (result->value.integer, i + shift); 3238 } 3239 3240 for (i = delta; i < ssize; i++) 3241 { 3242 if (bits[i] == 0) 3243 mpz_clrbit (result->value.integer, i - delta); 3244 else 3245 mpz_setbit (result->value.integer, i - delta); 3246 } 3247 } 3248 else 3249 { 3250 for (i = 0; i < ashift; i++) 3251 { 3252 if (bits[i] == 0) 3253 mpz_clrbit (result->value.integer, i + delta); 3254 else 3255 mpz_setbit (result->value.integer, i + delta); 3256 } 3257 3258 for (i = ashift; i < ssize; i++) 3259 { 3260 if (bits[i] == 0) 3261 mpz_clrbit (result->value.integer, i + shift); 3262 else 3263 mpz_setbit (result->value.integer, i + shift); 3264 } 3265 } 3266 3267 gfc_convert_mpz_to_signed (result->value.integer, isize); 3268 3269 free (bits); 3270 return result; 3271} 3272 3273 3274gfc_expr * 3275gfc_simplify_kind (gfc_expr *e) 3276{ 3277 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); 3278} 3279 3280 3281static gfc_expr * 3282simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, 3283 gfc_array_spec *as, gfc_ref *ref, bool coarray) 3284{ 3285 gfc_expr *l, *u, *result; 3286 int k; 3287 3288 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 3289 gfc_default_integer_kind); 3290 if (k == -1) 3291 return &gfc_bad_expr; 3292 3293 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 3294 3295 /* For non-variables, LBOUND(expr, DIM=n) = 1 and 3296 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ 3297 if (!coarray && array->expr_type != EXPR_VARIABLE) 3298 { 3299 if (upper) 3300 { 3301 gfc_expr* dim = result; 3302 mpz_set_si (dim->value.integer, d); 3303 3304 result = simplify_size (array, dim, k); 3305 gfc_free_expr (dim); 3306 if (!result) 3307 goto returnNull; 3308 } 3309 else 3310 mpz_set_si (result->value.integer, 1); 3311 3312 goto done; 3313 } 3314 3315 /* Otherwise, we have a variable expression. */ 3316 gcc_assert (array->expr_type == EXPR_VARIABLE); 3317 gcc_assert (as); 3318 3319 if (!gfc_resolve_array_spec (as, 0)) 3320 return NULL; 3321 3322 /* The last dimension of an assumed-size array is special. */ 3323 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) 3324 || (coarray && d == as->rank + as->corank 3325 && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE))) 3326 { 3327 if (as->lower[d-1]->expr_type == EXPR_CONSTANT) 3328 { 3329 gfc_free_expr (result); 3330 return gfc_copy_expr (as->lower[d-1]); 3331 } 3332 3333 goto returnNull; 3334 } 3335 3336 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 3337 3338 /* Then, we need to know the extent of the given dimension. */ 3339 if (coarray || ref->u.ar.type == AR_FULL) 3340 { 3341 l = as->lower[d-1]; 3342 u = as->upper[d-1]; 3343 3344 if (l->expr_type != EXPR_CONSTANT || u == NULL 3345 || u->expr_type != EXPR_CONSTANT) 3346 goto returnNull; 3347 3348 if (mpz_cmp (l->value.integer, u->value.integer) > 0) 3349 { 3350 /* Zero extent. */ 3351 if (upper) 3352 mpz_set_si (result->value.integer, 0); 3353 else 3354 mpz_set_si (result->value.integer, 1); 3355 } 3356 else 3357 { 3358 /* Nonzero extent. */ 3359 if (upper) 3360 mpz_set (result->value.integer, u->value.integer); 3361 else 3362 mpz_set (result->value.integer, l->value.integer); 3363 } 3364 } 3365 else 3366 { 3367 if (upper) 3368 { 3369 if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL)) 3370 goto returnNull; 3371 } 3372 else 3373 mpz_set_si (result->value.integer, (long int) 1); 3374 } 3375 3376done: 3377 return range_check (result, upper ? "UBOUND" : "LBOUND"); 3378 3379returnNull: 3380 gfc_free_expr (result); 3381 return NULL; 3382} 3383 3384 3385static gfc_expr * 3386simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 3387{ 3388 gfc_ref *ref; 3389 gfc_array_spec *as; 3390 int d; 3391 3392 if (array->ts.type == BT_CLASS) 3393 return NULL; 3394 3395 if (array->expr_type != EXPR_VARIABLE) 3396 { 3397 as = NULL; 3398 ref = NULL; 3399 goto done; 3400 } 3401 3402 /* Follow any component references. */ 3403 as = array->symtree->n.sym->as; 3404 for (ref = array->ref; ref; ref = ref->next) 3405 { 3406 switch (ref->type) 3407 { 3408 case REF_ARRAY: 3409 switch (ref->u.ar.type) 3410 { 3411 case AR_ELEMENT: 3412 as = NULL; 3413 continue; 3414 3415 case AR_FULL: 3416 /* We're done because 'as' has already been set in the 3417 previous iteration. */ 3418 if (!ref->next) 3419 goto done; 3420 3421 /* Fall through. */ 3422 3423 case AR_UNKNOWN: 3424 return NULL; 3425 3426 case AR_SECTION: 3427 as = ref->u.ar.as; 3428 goto done; 3429 } 3430 3431 gcc_unreachable (); 3432 3433 case REF_COMPONENT: 3434 as = ref->u.c.component->as; 3435 continue; 3436 3437 case REF_SUBSTRING: 3438 continue; 3439 } 3440 } 3441 3442 gcc_unreachable (); 3443 3444 done: 3445 3446 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE 3447 || as->type == AS_ASSUMED_RANK)) 3448 return NULL; 3449 3450 if (dim == NULL) 3451 { 3452 /* Multi-dimensional bounds. */ 3453 gfc_expr *bounds[GFC_MAX_DIMENSIONS]; 3454 gfc_expr *e; 3455 int k; 3456 3457 /* UBOUND(ARRAY) is not valid for an assumed-size array. */ 3458 if (upper && as && as->type == AS_ASSUMED_SIZE) 3459 { 3460 /* An error message will be emitted in 3461 check_assumed_size_reference (resolve.c). */ 3462 return &gfc_bad_expr; 3463 } 3464 3465 /* Simplify the bounds for each dimension. */ 3466 for (d = 0; d < array->rank; d++) 3467 { 3468 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, 3469 false); 3470 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) 3471 { 3472 int j; 3473 3474 for (j = 0; j < d; j++) 3475 gfc_free_expr (bounds[j]); 3476 return bounds[d]; 3477 } 3478 } 3479 3480 /* Allocate the result expression. */ 3481 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 3482 gfc_default_integer_kind); 3483 if (k == -1) 3484 return &gfc_bad_expr; 3485 3486 e = gfc_get_array_expr (BT_INTEGER, k, &array->where); 3487 3488 /* The result is a rank 1 array; its size is the rank of the first 3489 argument to {L,U}BOUND. */ 3490 e->rank = 1; 3491 e->shape = gfc_get_shape (1); 3492 mpz_init_set_ui (e->shape[0], array->rank); 3493 3494 /* Create the constructor for this array. */ 3495 for (d = 0; d < array->rank; d++) 3496 gfc_constructor_append_expr (&e->value.constructor, 3497 bounds[d], &e->where); 3498 3499 return e; 3500 } 3501 else 3502 { 3503 /* A DIM argument is specified. */ 3504 if (dim->expr_type != EXPR_CONSTANT) 3505 return NULL; 3506 3507 d = mpz_get_si (dim->value.integer); 3508 3509 if ((d < 1 || d > array->rank) 3510 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) 3511 { 3512 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 3513 return &gfc_bad_expr; 3514 } 3515 3516 if (as && as->type == AS_ASSUMED_RANK) 3517 return NULL; 3518 3519 return simplify_bound_dim (array, kind, d, upper, as, ref, false); 3520 } 3521} 3522 3523 3524static gfc_expr * 3525simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 3526{ 3527 gfc_ref *ref; 3528 gfc_array_spec *as; 3529 int d; 3530 3531 if (array->expr_type != EXPR_VARIABLE) 3532 return NULL; 3533 3534 /* Follow any component references. */ 3535 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) 3536 ? array->ts.u.derived->components->as 3537 : array->symtree->n.sym->as; 3538 for (ref = array->ref; ref; ref = ref->next) 3539 { 3540 switch (ref->type) 3541 { 3542 case REF_ARRAY: 3543 switch (ref->u.ar.type) 3544 { 3545 case AR_ELEMENT: 3546 if (ref->u.ar.as->corank > 0) 3547 { 3548 gcc_assert (as == ref->u.ar.as); 3549 goto done; 3550 } 3551 as = NULL; 3552 continue; 3553 3554 case AR_FULL: 3555 /* We're done because 'as' has already been set in the 3556 previous iteration. */ 3557 if (!ref->next) 3558 goto done; 3559 3560 /* Fall through. */ 3561 3562 case AR_UNKNOWN: 3563 return NULL; 3564 3565 case AR_SECTION: 3566 as = ref->u.ar.as; 3567 goto done; 3568 } 3569 3570 gcc_unreachable (); 3571 3572 case REF_COMPONENT: 3573 as = ref->u.c.component->as; 3574 continue; 3575 3576 case REF_SUBSTRING: 3577 continue; 3578 } 3579 } 3580 3581 if (!as) 3582 gcc_unreachable (); 3583 3584 done: 3585 3586 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) 3587 return NULL; 3588 3589 if (dim == NULL) 3590 { 3591 /* Multi-dimensional cobounds. */ 3592 gfc_expr *bounds[GFC_MAX_DIMENSIONS]; 3593 gfc_expr *e; 3594 int k; 3595 3596 /* Simplify the cobounds for each dimension. */ 3597 for (d = 0; d < as->corank; d++) 3598 { 3599 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, 3600 upper, as, ref, true); 3601 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) 3602 { 3603 int j; 3604 3605 for (j = 0; j < d; j++) 3606 gfc_free_expr (bounds[j]); 3607 return bounds[d]; 3608 } 3609 } 3610 3611 /* Allocate the result expression. */ 3612 e = gfc_get_expr (); 3613 e->where = array->where; 3614 e->expr_type = EXPR_ARRAY; 3615 e->ts.type = BT_INTEGER; 3616 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", 3617 gfc_default_integer_kind); 3618 if (k == -1) 3619 { 3620 gfc_free_expr (e); 3621 return &gfc_bad_expr; 3622 } 3623 e->ts.kind = k; 3624 3625 /* The result is a rank 1 array; its size is the rank of the first 3626 argument to {L,U}COBOUND. */ 3627 e->rank = 1; 3628 e->shape = gfc_get_shape (1); 3629 mpz_init_set_ui (e->shape[0], as->corank); 3630 3631 /* Create the constructor for this array. */ 3632 for (d = 0; d < as->corank; d++) 3633 gfc_constructor_append_expr (&e->value.constructor, 3634 bounds[d], &e->where); 3635 return e; 3636 } 3637 else 3638 { 3639 /* A DIM argument is specified. */ 3640 if (dim->expr_type != EXPR_CONSTANT) 3641 return NULL; 3642 3643 d = mpz_get_si (dim->value.integer); 3644 3645 if (d < 1 || d > as->corank) 3646 { 3647 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 3648 return &gfc_bad_expr; 3649 } 3650 3651 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); 3652 } 3653} 3654 3655 3656gfc_expr * 3657gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 3658{ 3659 return simplify_bound (array, dim, kind, 0); 3660} 3661 3662 3663gfc_expr * 3664gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 3665{ 3666 return simplify_cobound (array, dim, kind, 0); 3667} 3668 3669gfc_expr * 3670gfc_simplify_leadz (gfc_expr *e) 3671{ 3672 unsigned long lz, bs; 3673 int i; 3674 3675 if (e->expr_type != EXPR_CONSTANT) 3676 return NULL; 3677 3678 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3679 bs = gfc_integer_kinds[i].bit_size; 3680 if (mpz_cmp_si (e->value.integer, 0) == 0) 3681 lz = bs; 3682 else if (mpz_cmp_si (e->value.integer, 0) < 0) 3683 lz = 0; 3684 else 3685 lz = bs - mpz_sizeinbase (e->value.integer, 2); 3686 3687 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); 3688} 3689 3690 3691gfc_expr * 3692gfc_simplify_len (gfc_expr *e, gfc_expr *kind) 3693{ 3694 gfc_expr *result; 3695 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); 3696 3697 if (k == -1) 3698 return &gfc_bad_expr; 3699 3700 if (e->expr_type == EXPR_CONSTANT) 3701 { 3702 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 3703 mpz_set_si (result->value.integer, e->value.character.length); 3704 return range_check (result, "LEN"); 3705 } 3706 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL 3707 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT 3708 && e->ts.u.cl->length->ts.type == BT_INTEGER) 3709 { 3710 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 3711 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); 3712 return range_check (result, "LEN"); 3713 } 3714 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER 3715 && e->symtree->n.sym 3716 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target 3717 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED) 3718 /* The expression in assoc->target points to a ref to the _data component 3719 of the unlimited polymorphic entity. To get the _len component the last 3720 _data ref needs to be stripped and a ref to the _len component added. */ 3721 return gfc_get_len_component (e->symtree->n.sym->assoc->target); 3722 else 3723 return NULL; 3724} 3725 3726 3727gfc_expr * 3728gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) 3729{ 3730 gfc_expr *result; 3731 int count, len, i; 3732 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); 3733 3734 if (k == -1) 3735 return &gfc_bad_expr; 3736 3737 if (e->expr_type != EXPR_CONSTANT) 3738 return NULL; 3739 3740 len = e->value.character.length; 3741 for (count = 0, i = 1; i <= len; i++) 3742 if (e->value.character.string[len - i] == ' ') 3743 count++; 3744 else 3745 break; 3746 3747 result = gfc_get_int_expr (k, &e->where, len - count); 3748 return range_check (result, "LEN_TRIM"); 3749} 3750 3751gfc_expr * 3752gfc_simplify_lgamma (gfc_expr *x) 3753{ 3754 gfc_expr *result; 3755 int sg; 3756 3757 if (x->expr_type != EXPR_CONSTANT) 3758 return NULL; 3759 3760 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3761 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); 3762 3763 return range_check (result, "LGAMMA"); 3764} 3765 3766 3767gfc_expr * 3768gfc_simplify_lge (gfc_expr *a, gfc_expr *b) 3769{ 3770 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 3771 return NULL; 3772 3773 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3774 gfc_compare_string (a, b) >= 0); 3775} 3776 3777 3778gfc_expr * 3779gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) 3780{ 3781 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 3782 return NULL; 3783 3784 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3785 gfc_compare_string (a, b) > 0); 3786} 3787 3788 3789gfc_expr * 3790gfc_simplify_lle (gfc_expr *a, gfc_expr *b) 3791{ 3792 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 3793 return NULL; 3794 3795 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3796 gfc_compare_string (a, b) <= 0); 3797} 3798 3799 3800gfc_expr * 3801gfc_simplify_llt (gfc_expr *a, gfc_expr *b) 3802{ 3803 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 3804 return NULL; 3805 3806 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3807 gfc_compare_string (a, b) < 0); 3808} 3809 3810 3811gfc_expr * 3812gfc_simplify_log (gfc_expr *x) 3813{ 3814 gfc_expr *result; 3815 3816 if (x->expr_type != EXPR_CONSTANT) 3817 return NULL; 3818 3819 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3820 3821 switch (x->ts.type) 3822 { 3823 case BT_REAL: 3824 if (mpfr_sgn (x->value.real) <= 0) 3825 { 3826 gfc_error ("Argument of LOG at %L cannot be less than or equal " 3827 "to zero", &x->where); 3828 gfc_free_expr (result); 3829 return &gfc_bad_expr; 3830 } 3831 3832 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); 3833 break; 3834 3835 case BT_COMPLEX: 3836 if (mpfr_zero_p (mpc_realref (x->value.complex)) 3837 && mpfr_zero_p (mpc_imagref (x->value.complex))) 3838 { 3839 gfc_error ("Complex argument of LOG at %L cannot be zero", 3840 &x->where); 3841 gfc_free_expr (result); 3842 return &gfc_bad_expr; 3843 } 3844 3845 gfc_set_model_kind (x->ts.kind); 3846 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 3847 break; 3848 3849 default: 3850 gfc_internal_error ("gfc_simplify_log: bad type"); 3851 } 3852 3853 return range_check (result, "LOG"); 3854} 3855 3856 3857gfc_expr * 3858gfc_simplify_log10 (gfc_expr *x) 3859{ 3860 gfc_expr *result; 3861 3862 if (x->expr_type != EXPR_CONSTANT) 3863 return NULL; 3864 3865 if (mpfr_sgn (x->value.real) <= 0) 3866 { 3867 gfc_error ("Argument of LOG10 at %L cannot be less than or equal " 3868 "to zero", &x->where); 3869 return &gfc_bad_expr; 3870 } 3871 3872 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3873 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); 3874 3875 return range_check (result, "LOG10"); 3876} 3877 3878 3879gfc_expr * 3880gfc_simplify_logical (gfc_expr *e, gfc_expr *k) 3881{ 3882 int kind; 3883 3884 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); 3885 if (kind < 0) 3886 return &gfc_bad_expr; 3887 3888 if (e->expr_type != EXPR_CONSTANT) 3889 return NULL; 3890 3891 return gfc_get_logical_expr (kind, &e->where, e->value.logical); 3892} 3893 3894 3895gfc_expr* 3896gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 3897{ 3898 gfc_expr *result; 3899 int row, result_rows, col, result_columns; 3900 int stride_a, offset_a, stride_b, offset_b; 3901 3902 if (!is_constant_array_expr (matrix_a) 3903 || !is_constant_array_expr (matrix_b)) 3904 return NULL; 3905 3906 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts)); 3907 result = gfc_get_array_expr (matrix_a->ts.type, 3908 matrix_a->ts.kind, 3909 &matrix_a->where); 3910 3911 if (matrix_a->rank == 1 && matrix_b->rank == 2) 3912 { 3913 result_rows = 1; 3914 result_columns = mpz_get_si (matrix_b->shape[1]); 3915 stride_a = 1; 3916 stride_b = mpz_get_si (matrix_b->shape[0]); 3917 3918 result->rank = 1; 3919 result->shape = gfc_get_shape (result->rank); 3920 mpz_init_set_si (result->shape[0], result_columns); 3921 } 3922 else if (matrix_a->rank == 2 && matrix_b->rank == 1) 3923 { 3924 result_rows = mpz_get_si (matrix_a->shape[0]); 3925 result_columns = 1; 3926 stride_a = mpz_get_si (matrix_a->shape[0]); 3927 stride_b = 1; 3928 3929 result->rank = 1; 3930 result->shape = gfc_get_shape (result->rank); 3931 mpz_init_set_si (result->shape[0], result_rows); 3932 } 3933 else if (matrix_a->rank == 2 && matrix_b->rank == 2) 3934 { 3935 result_rows = mpz_get_si (matrix_a->shape[0]); 3936 result_columns = mpz_get_si (matrix_b->shape[1]); 3937 stride_a = mpz_get_si (matrix_a->shape[0]); 3938 stride_b = mpz_get_si (matrix_b->shape[0]); 3939 3940 result->rank = 2; 3941 result->shape = gfc_get_shape (result->rank); 3942 mpz_init_set_si (result->shape[0], result_rows); 3943 mpz_init_set_si (result->shape[1], result_columns); 3944 } 3945 else 3946 gcc_unreachable(); 3947 3948 offset_a = offset_b = 0; 3949 for (col = 0; col < result_columns; ++col) 3950 { 3951 offset_a = 0; 3952 3953 for (row = 0; row < result_rows; ++row) 3954 { 3955 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, 3956 matrix_b, 1, offset_b, false); 3957 gfc_constructor_append_expr (&result->value.constructor, 3958 e, NULL); 3959 3960 offset_a += 1; 3961 } 3962 3963 offset_b += stride_b; 3964 } 3965 3966 return result; 3967} 3968 3969 3970gfc_expr * 3971gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) 3972{ 3973 gfc_expr *result; 3974 int kind, arg, k; 3975 const char *s; 3976 3977 if (i->expr_type != EXPR_CONSTANT) 3978 return NULL; 3979 3980 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); 3981 if (kind == -1) 3982 return &gfc_bad_expr; 3983 k = gfc_validate_kind (BT_INTEGER, kind, false); 3984 3985 s = gfc_extract_int (i, &arg); 3986 gcc_assert (!s); 3987 3988 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 3989 3990 /* MASKR(n) = 2^n - 1 */ 3991 mpz_set_ui (result->value.integer, 1); 3992 mpz_mul_2exp (result->value.integer, result->value.integer, arg); 3993 mpz_sub_ui (result->value.integer, result->value.integer, 1); 3994 3995 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 3996 3997 return result; 3998} 3999 4000 4001gfc_expr * 4002gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) 4003{ 4004 gfc_expr *result; 4005 int kind, arg, k; 4006 const char *s; 4007 mpz_t z; 4008 4009 if (i->expr_type != EXPR_CONSTANT) 4010 return NULL; 4011 4012 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); 4013 if (kind == -1) 4014 return &gfc_bad_expr; 4015 k = gfc_validate_kind (BT_INTEGER, kind, false); 4016 4017 s = gfc_extract_int (i, &arg); 4018 gcc_assert (!s); 4019 4020 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4021 4022 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ 4023 mpz_init_set_ui (z, 1); 4024 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); 4025 mpz_set_ui (result->value.integer, 1); 4026 mpz_mul_2exp (result->value.integer, result->value.integer, 4027 gfc_integer_kinds[k].bit_size - arg); 4028 mpz_sub (result->value.integer, z, result->value.integer); 4029 mpz_clear (z); 4030 4031 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4032 4033 return result; 4034} 4035 4036 4037gfc_expr * 4038gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 4039{ 4040 gfc_expr * result; 4041 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; 4042 4043 if (mask->expr_type == EXPR_CONSTANT) 4044 return gfc_get_parentheses (gfc_copy_expr (mask->value.logical 4045 ? tsource : fsource)); 4046 4047 if (!mask->rank || !is_constant_array_expr (mask) 4048 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) 4049 return NULL; 4050 4051 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, 4052 &tsource->where); 4053 if (tsource->ts.type == BT_DERIVED) 4054 result->ts.u.derived = tsource->ts.u.derived; 4055 else if (tsource->ts.type == BT_CHARACTER) 4056 result->ts.u.cl = tsource->ts.u.cl; 4057 4058 tsource_ctor = gfc_constructor_first (tsource->value.constructor); 4059 fsource_ctor = gfc_constructor_first (fsource->value.constructor); 4060 mask_ctor = gfc_constructor_first (mask->value.constructor); 4061 4062 while (mask_ctor) 4063 { 4064 if (mask_ctor->expr->value.logical) 4065 gfc_constructor_append_expr (&result->value.constructor, 4066 gfc_copy_expr (tsource_ctor->expr), 4067 NULL); 4068 else 4069 gfc_constructor_append_expr (&result->value.constructor, 4070 gfc_copy_expr (fsource_ctor->expr), 4071 NULL); 4072 tsource_ctor = gfc_constructor_next (tsource_ctor); 4073 fsource_ctor = gfc_constructor_next (fsource_ctor); 4074 mask_ctor = gfc_constructor_next (mask_ctor); 4075 } 4076 4077 result->shape = gfc_get_shape (1); 4078 gfc_array_size (result, &result->shape[0]); 4079 4080 return result; 4081} 4082 4083 4084gfc_expr * 4085gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) 4086{ 4087 mpz_t arg1, arg2, mask; 4088 gfc_expr *result; 4089 4090 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT 4091 || mask_expr->expr_type != EXPR_CONSTANT) 4092 return NULL; 4093 4094 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); 4095 4096 /* Convert all argument to unsigned. */ 4097 mpz_init_set (arg1, i->value.integer); 4098 mpz_init_set (arg2, j->value.integer); 4099 mpz_init_set (mask, mask_expr->value.integer); 4100 4101 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ 4102 mpz_and (arg1, arg1, mask); 4103 mpz_com (mask, mask); 4104 mpz_and (arg2, arg2, mask); 4105 mpz_ior (result->value.integer, arg1, arg2); 4106 4107 mpz_clear (arg1); 4108 mpz_clear (arg2); 4109 mpz_clear (mask); 4110 4111 return result; 4112} 4113 4114 4115/* Selects between current value and extremum for simplify_min_max 4116 and simplify_minval_maxval. */ 4117static void 4118min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) 4119{ 4120 switch (arg->ts.type) 4121 { 4122 case BT_INTEGER: 4123 if (mpz_cmp (arg->value.integer, 4124 extremum->value.integer) * sign > 0) 4125 mpz_set (extremum->value.integer, arg->value.integer); 4126 break; 4127 4128 case BT_REAL: 4129 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ 4130 if (sign > 0) 4131 mpfr_max (extremum->value.real, extremum->value.real, 4132 arg->value.real, GFC_RND_MODE); 4133 else 4134 mpfr_min (extremum->value.real, extremum->value.real, 4135 arg->value.real, GFC_RND_MODE); 4136 break; 4137 4138 case BT_CHARACTER: 4139#define LENGTH(x) ((x)->value.character.length) 4140#define STRING(x) ((x)->value.character.string) 4141 if (LENGTH (extremum) < LENGTH(arg)) 4142 { 4143 gfc_char_t *tmp = STRING(extremum); 4144 4145 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); 4146 memcpy (STRING(extremum), tmp, 4147 LENGTH(extremum) * sizeof (gfc_char_t)); 4148 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', 4149 LENGTH(arg) - LENGTH(extremum)); 4150 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ 4151 LENGTH(extremum) = LENGTH(arg); 4152 free (tmp); 4153 } 4154 4155 if (gfc_compare_string (arg, extremum) * sign > 0) 4156 { 4157 free (STRING(extremum)); 4158 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); 4159 memcpy (STRING(extremum), STRING(arg), 4160 LENGTH(arg) * sizeof (gfc_char_t)); 4161 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', 4162 LENGTH(extremum) - LENGTH(arg)); 4163 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ 4164 } 4165#undef LENGTH 4166#undef STRING 4167 break; 4168 4169 default: 4170 gfc_internal_error ("simplify_min_max(): Bad type in arglist"); 4171 } 4172} 4173 4174 4175/* This function is special since MAX() can take any number of 4176 arguments. The simplified expression is a rewritten version of the 4177 argument list containing at most one constant element. Other 4178 constant elements are deleted. Because the argument list has 4179 already been checked, this function always succeeds. sign is 1 for 4180 MAX(), -1 for MIN(). */ 4181 4182static gfc_expr * 4183simplify_min_max (gfc_expr *expr, int sign) 4184{ 4185 gfc_actual_arglist *arg, *last, *extremum; 4186 gfc_intrinsic_sym * specific; 4187 4188 last = NULL; 4189 extremum = NULL; 4190 specific = expr->value.function.isym; 4191 4192 arg = expr->value.function.actual; 4193 4194 for (; arg; last = arg, arg = arg->next) 4195 { 4196 if (arg->expr->expr_type != EXPR_CONSTANT) 4197 continue; 4198 4199 if (extremum == NULL) 4200 { 4201 extremum = arg; 4202 continue; 4203 } 4204 4205 min_max_choose (arg->expr, extremum->expr, sign); 4206 4207 /* Delete the extra constant argument. */ 4208 last->next = arg->next; 4209 4210 arg->next = NULL; 4211 gfc_free_actual_arglist (arg); 4212 arg = last; 4213 } 4214 4215 /* If there is one value left, replace the function call with the 4216 expression. */ 4217 if (expr->value.function.actual->next != NULL) 4218 return NULL; 4219 4220 /* Convert to the correct type and kind. */ 4221 if (expr->ts.type != BT_UNKNOWN) 4222 return gfc_convert_constant (expr->value.function.actual->expr, 4223 expr->ts.type, expr->ts.kind); 4224 4225 if (specific->ts.type != BT_UNKNOWN) 4226 return gfc_convert_constant (expr->value.function.actual->expr, 4227 specific->ts.type, specific->ts.kind); 4228 4229 return gfc_copy_expr (expr->value.function.actual->expr); 4230} 4231 4232 4233gfc_expr * 4234gfc_simplify_min (gfc_expr *e) 4235{ 4236 return simplify_min_max (e, -1); 4237} 4238 4239 4240gfc_expr * 4241gfc_simplify_max (gfc_expr *e) 4242{ 4243 return simplify_min_max (e, 1); 4244} 4245 4246 4247/* This is a simplified version of simplify_min_max to provide 4248 simplification of minval and maxval for a vector. */ 4249 4250static gfc_expr * 4251simplify_minval_maxval (gfc_expr *expr, int sign) 4252{ 4253 gfc_constructor *c, *extremum; 4254 gfc_intrinsic_sym * specific; 4255 4256 extremum = NULL; 4257 specific = expr->value.function.isym; 4258 4259 for (c = gfc_constructor_first (expr->value.constructor); 4260 c; c = gfc_constructor_next (c)) 4261 { 4262 if (c->expr->expr_type != EXPR_CONSTANT) 4263 return NULL; 4264 4265 if (extremum == NULL) 4266 { 4267 extremum = c; 4268 continue; 4269 } 4270 4271 min_max_choose (c->expr, extremum->expr, sign); 4272 } 4273 4274 if (extremum == NULL) 4275 return NULL; 4276 4277 /* Convert to the correct type and kind. */ 4278 if (expr->ts.type != BT_UNKNOWN) 4279 return gfc_convert_constant (extremum->expr, 4280 expr->ts.type, expr->ts.kind); 4281 4282 if (specific->ts.type != BT_UNKNOWN) 4283 return gfc_convert_constant (extremum->expr, 4284 specific->ts.type, specific->ts.kind); 4285 4286 return gfc_copy_expr (extremum->expr); 4287} 4288 4289 4290gfc_expr * 4291gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 4292{ 4293 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) 4294 return NULL; 4295 4296 return simplify_minval_maxval (array, -1); 4297} 4298 4299 4300gfc_expr * 4301gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 4302{ 4303 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) 4304 return NULL; 4305 4306 return simplify_minval_maxval (array, 1); 4307} 4308 4309 4310gfc_expr * 4311gfc_simplify_maxexponent (gfc_expr *x) 4312{ 4313 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 4314 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 4315 gfc_real_kinds[i].max_exponent); 4316} 4317 4318 4319gfc_expr * 4320gfc_simplify_minexponent (gfc_expr *x) 4321{ 4322 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 4323 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 4324 gfc_real_kinds[i].min_exponent); 4325} 4326 4327 4328gfc_expr * 4329gfc_simplify_mod (gfc_expr *a, gfc_expr *p) 4330{ 4331 gfc_expr *result; 4332 int kind; 4333 4334 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) 4335 return NULL; 4336 4337 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 4338 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 4339 4340 switch (a->ts.type) 4341 { 4342 case BT_INTEGER: 4343 if (mpz_cmp_ui (p->value.integer, 0) == 0) 4344 { 4345 /* Result is processor-dependent. */ 4346 gfc_error ("Second argument MOD at %L is zero", &a->where); 4347 gfc_free_expr (result); 4348 return &gfc_bad_expr; 4349 } 4350 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); 4351 break; 4352 4353 case BT_REAL: 4354 if (mpfr_cmp_ui (p->value.real, 0) == 0) 4355 { 4356 /* Result is processor-dependent. */ 4357 gfc_error ("Second argument of MOD at %L is zero", &p->where); 4358 gfc_free_expr (result); 4359 return &gfc_bad_expr; 4360 } 4361 4362 gfc_set_model_kind (kind); 4363 mpfr_fmod (result->value.real, a->value.real, p->value.real, 4364 GFC_RND_MODE); 4365 break; 4366 4367 default: 4368 gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); 4369 } 4370 4371 return range_check (result, "MOD"); 4372} 4373 4374 4375gfc_expr * 4376gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 4377{ 4378 gfc_expr *result; 4379 int kind; 4380 4381 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) 4382 return NULL; 4383 4384 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 4385 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 4386 4387 switch (a->ts.type) 4388 { 4389 case BT_INTEGER: 4390 if (mpz_cmp_ui (p->value.integer, 0) == 0) 4391 { 4392 /* Result is processor-dependent. This processor just opts 4393 to not handle it at all. */ 4394 gfc_error ("Second argument of MODULO at %L is zero", &a->where); 4395 gfc_free_expr (result); 4396 return &gfc_bad_expr; 4397 } 4398 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); 4399 4400 break; 4401 4402 case BT_REAL: 4403 if (mpfr_cmp_ui (p->value.real, 0) == 0) 4404 { 4405 /* Result is processor-dependent. */ 4406 gfc_error ("Second argument of MODULO at %L is zero", &p->where); 4407 gfc_free_expr (result); 4408 return &gfc_bad_expr; 4409 } 4410 4411 gfc_set_model_kind (kind); 4412 mpfr_fmod (result->value.real, a->value.real, p->value.real, 4413 GFC_RND_MODE); 4414 if (mpfr_cmp_ui (result->value.real, 0) != 0) 4415 { 4416 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) 4417 mpfr_add (result->value.real, result->value.real, p->value.real, 4418 GFC_RND_MODE); 4419 } 4420 else 4421 mpfr_copysign (result->value.real, result->value.real, 4422 p->value.real, GFC_RND_MODE); 4423 break; 4424 4425 default: 4426 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); 4427 } 4428 4429 return range_check (result, "MODULO"); 4430} 4431 4432 4433/* Exists for the sole purpose of consistency with other intrinsics. */ 4434gfc_expr * 4435gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED, 4436 gfc_expr *fp ATTRIBUTE_UNUSED, 4437 gfc_expr *l ATTRIBUTE_UNUSED, 4438 gfc_expr *to ATTRIBUTE_UNUSED, 4439 gfc_expr *tp ATTRIBUTE_UNUSED) 4440{ 4441 return NULL; 4442} 4443 4444 4445gfc_expr * 4446gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 4447{ 4448 gfc_expr *result; 4449 mp_exp_t emin, emax; 4450 int kind; 4451 4452 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 4453 return NULL; 4454 4455 result = gfc_copy_expr (x); 4456 4457 /* Save current values of emin and emax. */ 4458 emin = mpfr_get_emin (); 4459 emax = mpfr_get_emax (); 4460 4461 /* Set emin and emax for the current model number. */ 4462 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); 4463 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent - 4464 mpfr_get_prec(result->value.real) + 1); 4465 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1); 4466 mpfr_check_range (result->value.real, 0, GMP_RNDU); 4467 4468 if (mpfr_sgn (s->value.real) > 0) 4469 { 4470 mpfr_nextabove (result->value.real); 4471 mpfr_subnormalize (result->value.real, 0, GMP_RNDU); 4472 } 4473 else 4474 { 4475 mpfr_nextbelow (result->value.real); 4476 mpfr_subnormalize (result->value.real, 0, GMP_RNDD); 4477 } 4478 4479 mpfr_set_emin (emin); 4480 mpfr_set_emax (emax); 4481 4482 /* Only NaN can occur. Do not use range check as it gives an 4483 error for denormal numbers. */ 4484 if (mpfr_nan_p (result->value.real) && flag_range_check) 4485 { 4486 gfc_error ("Result of NEAREST is NaN at %L", &result->where); 4487 gfc_free_expr (result); 4488 return &gfc_bad_expr; 4489 } 4490 4491 return result; 4492} 4493 4494 4495static gfc_expr * 4496simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 4497{ 4498 gfc_expr *itrunc, *result; 4499 int kind; 4500 4501 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); 4502 if (kind == -1) 4503 return &gfc_bad_expr; 4504 4505 if (e->expr_type != EXPR_CONSTANT) 4506 return NULL; 4507 4508 itrunc = gfc_copy_expr (e); 4509 mpfr_round (itrunc->value.real, e->value.real); 4510 4511 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 4512 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); 4513 4514 gfc_free_expr (itrunc); 4515 4516 return range_check (result, name); 4517} 4518 4519 4520gfc_expr * 4521gfc_simplify_new_line (gfc_expr *e) 4522{ 4523 gfc_expr *result; 4524 4525 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); 4526 result->value.character.string[0] = '\n'; 4527 4528 return result; 4529} 4530 4531 4532gfc_expr * 4533gfc_simplify_nint (gfc_expr *e, gfc_expr *k) 4534{ 4535 return simplify_nint ("NINT", e, k); 4536} 4537 4538 4539gfc_expr * 4540gfc_simplify_idnint (gfc_expr *e) 4541{ 4542 return simplify_nint ("IDNINT", e, NULL); 4543} 4544 4545 4546static gfc_expr * 4547add_squared (gfc_expr *result, gfc_expr *e) 4548{ 4549 mpfr_t tmp; 4550 4551 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 4552 gcc_assert (result->ts.type == BT_REAL 4553 && result->expr_type == EXPR_CONSTANT); 4554 4555 gfc_set_model_kind (result->ts.kind); 4556 mpfr_init (tmp); 4557 mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); 4558 mpfr_add (result->value.real, result->value.real, tmp, 4559 GFC_RND_MODE); 4560 mpfr_clear (tmp); 4561 4562 return result; 4563} 4564 4565 4566static gfc_expr * 4567do_sqrt (gfc_expr *result, gfc_expr *e) 4568{ 4569 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 4570 gcc_assert (result->ts.type == BT_REAL 4571 && result->expr_type == EXPR_CONSTANT); 4572 4573 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); 4574 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 4575 return result; 4576} 4577 4578 4579gfc_expr * 4580gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) 4581{ 4582 gfc_expr *result; 4583 4584 if (!is_constant_array_expr (e) 4585 || (dim != NULL && !gfc_is_constant_expr (dim))) 4586 return NULL; 4587 4588 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); 4589 init_result_expr (result, 0, NULL); 4590 4591 if (!dim || e->rank == 1) 4592 { 4593 result = simplify_transformation_to_scalar (result, e, NULL, 4594 add_squared); 4595 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 4596 } 4597 else 4598 result = simplify_transformation_to_array (result, e, dim, NULL, 4599 add_squared, &do_sqrt); 4600 4601 return result; 4602} 4603 4604 4605gfc_expr * 4606gfc_simplify_not (gfc_expr *e) 4607{ 4608 gfc_expr *result; 4609 4610 if (e->expr_type != EXPR_CONSTANT) 4611 return NULL; 4612 4613 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 4614 mpz_com (result->value.integer, e->value.integer); 4615 4616 return range_check (result, "NOT"); 4617} 4618 4619 4620gfc_expr * 4621gfc_simplify_null (gfc_expr *mold) 4622{ 4623 gfc_expr *result; 4624 4625 if (mold) 4626 { 4627 result = gfc_copy_expr (mold); 4628 result->expr_type = EXPR_NULL; 4629 } 4630 else 4631 result = gfc_get_null_expr (NULL); 4632 4633 return result; 4634} 4635 4636 4637gfc_expr * 4638gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) 4639{ 4640 gfc_expr *result; 4641 4642 if (flag_coarray == GFC_FCOARRAY_NONE) 4643 { 4644 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 4645 return &gfc_bad_expr; 4646 } 4647 4648 if (flag_coarray != GFC_FCOARRAY_SINGLE) 4649 return NULL; 4650 4651 if (failed && failed->expr_type != EXPR_CONSTANT) 4652 return NULL; 4653 4654 /* FIXME: gfc_current_locus is wrong. */ 4655 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 4656 &gfc_current_locus); 4657 4658 if (failed && failed->value.logical != 0) 4659 mpz_set_si (result->value.integer, 0); 4660 else 4661 mpz_set_si (result->value.integer, 1); 4662 4663 return result; 4664} 4665 4666 4667gfc_expr * 4668gfc_simplify_or (gfc_expr *x, gfc_expr *y) 4669{ 4670 gfc_expr *result; 4671 int kind; 4672 4673 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 4674 return NULL; 4675 4676 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 4677 4678 switch (x->ts.type) 4679 { 4680 case BT_INTEGER: 4681 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 4682 mpz_ior (result->value.integer, x->value.integer, y->value.integer); 4683 return range_check (result, "OR"); 4684 4685 case BT_LOGICAL: 4686 return gfc_get_logical_expr (kind, &x->where, 4687 x->value.logical || y->value.logical); 4688 default: 4689 gcc_unreachable(); 4690 } 4691} 4692 4693 4694gfc_expr * 4695gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 4696{ 4697 gfc_expr *result; 4698 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; 4699 4700 if (!is_constant_array_expr (array) 4701 || !is_constant_array_expr (vector) 4702 || (!gfc_is_constant_expr (mask) 4703 && !is_constant_array_expr (mask))) 4704 return NULL; 4705 4706 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 4707 if (array->ts.type == BT_DERIVED) 4708 result->ts.u.derived = array->ts.u.derived; 4709 4710 array_ctor = gfc_constructor_first (array->value.constructor); 4711 vector_ctor = vector 4712 ? gfc_constructor_first (vector->value.constructor) 4713 : NULL; 4714 4715 if (mask->expr_type == EXPR_CONSTANT 4716 && mask->value.logical) 4717 { 4718 /* Copy all elements of ARRAY to RESULT. */ 4719 while (array_ctor) 4720 { 4721 gfc_constructor_append_expr (&result->value.constructor, 4722 gfc_copy_expr (array_ctor->expr), 4723 NULL); 4724 4725 array_ctor = gfc_constructor_next (array_ctor); 4726 vector_ctor = gfc_constructor_next (vector_ctor); 4727 } 4728 } 4729 else if (mask->expr_type == EXPR_ARRAY) 4730 { 4731 /* Copy only those elements of ARRAY to RESULT whose 4732 MASK equals .TRUE.. */ 4733 mask_ctor = gfc_constructor_first (mask->value.constructor); 4734 while (mask_ctor) 4735 { 4736 if (mask_ctor->expr->value.logical) 4737 { 4738 gfc_constructor_append_expr (&result->value.constructor, 4739 gfc_copy_expr (array_ctor->expr), 4740 NULL); 4741 vector_ctor = gfc_constructor_next (vector_ctor); 4742 } 4743 4744 array_ctor = gfc_constructor_next (array_ctor); 4745 mask_ctor = gfc_constructor_next (mask_ctor); 4746 } 4747 } 4748 4749 /* Append any left-over elements from VECTOR to RESULT. */ 4750 while (vector_ctor) 4751 { 4752 gfc_constructor_append_expr (&result->value.constructor, 4753 gfc_copy_expr (vector_ctor->expr), 4754 NULL); 4755 vector_ctor = gfc_constructor_next (vector_ctor); 4756 } 4757 4758 result->shape = gfc_get_shape (1); 4759 gfc_array_size (result, &result->shape[0]); 4760 4761 if (array->ts.type == BT_CHARACTER) 4762 result->ts.u.cl = array->ts.u.cl; 4763 4764 return result; 4765} 4766 4767 4768static gfc_expr * 4769do_xor (gfc_expr *result, gfc_expr *e) 4770{ 4771 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); 4772 gcc_assert (result->ts.type == BT_LOGICAL 4773 && result->expr_type == EXPR_CONSTANT); 4774 4775 result->value.logical = result->value.logical != e->value.logical; 4776 return result; 4777} 4778 4779 4780 4781gfc_expr * 4782gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) 4783{ 4784 return simplify_transformation (e, dim, NULL, 0, do_xor); 4785} 4786 4787 4788gfc_expr * 4789gfc_simplify_popcnt (gfc_expr *e) 4790{ 4791 int res, k; 4792 mpz_t x; 4793 4794 if (e->expr_type != EXPR_CONSTANT) 4795 return NULL; 4796 4797 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4798 4799 /* Convert argument to unsigned, then count the '1' bits. */ 4800 mpz_init_set (x, e->value.integer); 4801 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 4802 res = mpz_popcount (x); 4803 mpz_clear (x); 4804 4805 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); 4806} 4807 4808 4809gfc_expr * 4810gfc_simplify_poppar (gfc_expr *e) 4811{ 4812 gfc_expr *popcnt; 4813 const char *s; 4814 int i; 4815 4816 if (e->expr_type != EXPR_CONSTANT) 4817 return NULL; 4818 4819 popcnt = gfc_simplify_popcnt (e); 4820 gcc_assert (popcnt); 4821 4822 s = gfc_extract_int (popcnt, &i); 4823 gcc_assert (!s); 4824 4825 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); 4826} 4827 4828 4829gfc_expr * 4830gfc_simplify_precision (gfc_expr *e) 4831{ 4832 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4833 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, 4834 gfc_real_kinds[i].precision); 4835} 4836 4837 4838gfc_expr * 4839gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 4840{ 4841 return simplify_transformation (array, dim, mask, 1, gfc_multiply); 4842} 4843 4844 4845gfc_expr * 4846gfc_simplify_radix (gfc_expr *e) 4847{ 4848 int i; 4849 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4850 4851 switch (e->ts.type) 4852 { 4853 case BT_INTEGER: 4854 i = gfc_integer_kinds[i].radix; 4855 break; 4856 4857 case BT_REAL: 4858 i = gfc_real_kinds[i].radix; 4859 break; 4860 4861 default: 4862 gcc_unreachable (); 4863 } 4864 4865 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 4866} 4867 4868 4869gfc_expr * 4870gfc_simplify_range (gfc_expr *e) 4871{ 4872 int i; 4873 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4874 4875 switch (e->ts.type) 4876 { 4877 case BT_INTEGER: 4878 i = gfc_integer_kinds[i].range; 4879 break; 4880 4881 case BT_REAL: 4882 case BT_COMPLEX: 4883 i = gfc_real_kinds[i].range; 4884 break; 4885 4886 default: 4887 gcc_unreachable (); 4888 } 4889 4890 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 4891} 4892 4893 4894gfc_expr * 4895gfc_simplify_rank (gfc_expr *e) 4896{ 4897 /* Assumed rank. */ 4898 if (e->rank == -1) 4899 return NULL; 4900 4901 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); 4902} 4903 4904 4905gfc_expr * 4906gfc_simplify_real (gfc_expr *e, gfc_expr *k) 4907{ 4908 gfc_expr *result = NULL; 4909 int kind; 4910 4911 if (e->ts.type == BT_COMPLEX) 4912 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); 4913 else 4914 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); 4915 4916 if (kind == -1) 4917 return &gfc_bad_expr; 4918 4919 if (e->expr_type != EXPR_CONSTANT) 4920 return NULL; 4921 4922 if (convert_boz (e, kind) == &gfc_bad_expr) 4923 return &gfc_bad_expr; 4924 4925 result = gfc_convert_constant (e, BT_REAL, kind); 4926 if (result == &gfc_bad_expr) 4927 return &gfc_bad_expr; 4928 4929 return range_check (result, "REAL"); 4930} 4931 4932 4933gfc_expr * 4934gfc_simplify_realpart (gfc_expr *e) 4935{ 4936 gfc_expr *result; 4937 4938 if (e->expr_type != EXPR_CONSTANT) 4939 return NULL; 4940 4941 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 4942 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); 4943 4944 return range_check (result, "REALPART"); 4945} 4946 4947gfc_expr * 4948gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) 4949{ 4950 gfc_expr *result; 4951 int i, j, len, ncop, nlen; 4952 mpz_t ncopies; 4953 bool have_length = false; 4954 4955 /* If NCOPIES isn't a constant, there's nothing we can do. */ 4956 if (n->expr_type != EXPR_CONSTANT) 4957 return NULL; 4958 4959 /* If NCOPIES is negative, it's an error. */ 4960 if (mpz_sgn (n->value.integer) < 0) 4961 { 4962 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", 4963 &n->where); 4964 return &gfc_bad_expr; 4965 } 4966 4967 /* If we don't know the character length, we can do no more. */ 4968 if (e->ts.u.cl && e->ts.u.cl->length 4969 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 4970 { 4971 len = mpz_get_si (e->ts.u.cl->length->value.integer); 4972 have_length = true; 4973 } 4974 else if (e->expr_type == EXPR_CONSTANT 4975 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 4976 { 4977 len = e->value.character.length; 4978 } 4979 else 4980 return NULL; 4981 4982 /* If the source length is 0, any value of NCOPIES is valid 4983 and everything behaves as if NCOPIES == 0. */ 4984 mpz_init (ncopies); 4985 if (len == 0) 4986 mpz_set_ui (ncopies, 0); 4987 else 4988 mpz_set (ncopies, n->value.integer); 4989 4990 /* Check that NCOPIES isn't too large. */ 4991 if (len) 4992 { 4993 mpz_t max, mlen; 4994 int i; 4995 4996 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ 4997 mpz_init (max); 4998 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 4999 5000 if (have_length) 5001 { 5002 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, 5003 e->ts.u.cl->length->value.integer); 5004 } 5005 else 5006 { 5007 mpz_init_set_si (mlen, len); 5008 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); 5009 mpz_clear (mlen); 5010 } 5011 5012 /* The check itself. */ 5013 if (mpz_cmp (ncopies, max) > 0) 5014 { 5015 mpz_clear (max); 5016 mpz_clear (ncopies); 5017 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", 5018 &n->where); 5019 return &gfc_bad_expr; 5020 } 5021 5022 mpz_clear (max); 5023 } 5024 mpz_clear (ncopies); 5025 5026 /* For further simplification, we need the character string to be 5027 constant. */ 5028 if (e->expr_type != EXPR_CONSTANT) 5029 return NULL; 5030 5031 if (len || 5032 (e->ts.u.cl->length && 5033 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) 5034 { 5035 const char *res = gfc_extract_int (n, &ncop); 5036 gcc_assert (res == NULL); 5037 } 5038 else 5039 ncop = 0; 5040 5041 if (ncop == 0) 5042 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); 5043 5044 len = e->value.character.length; 5045 nlen = ncop * len; 5046 5047 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); 5048 for (i = 0; i < ncop; i++) 5049 for (j = 0; j < len; j++) 5050 result->value.character.string[j+i*len]= e->value.character.string[j]; 5051 5052 result->value.character.string[nlen] = '\0'; /* For debugger */ 5053 return result; 5054} 5055 5056 5057/* This one is a bear, but mainly has to do with shuffling elements. */ 5058 5059gfc_expr * 5060gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 5061 gfc_expr *pad, gfc_expr *order_exp) 5062{ 5063 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; 5064 int i, rank, npad, x[GFC_MAX_DIMENSIONS]; 5065 mpz_t index, size; 5066 unsigned long j; 5067 size_t nsource; 5068 gfc_expr *e, *result; 5069 5070 /* Check that argument expression types are OK. */ 5071 if (!is_constant_array_expr (source) 5072 || !is_constant_array_expr (shape_exp) 5073 || !is_constant_array_expr (pad) 5074 || !is_constant_array_expr (order_exp)) 5075 return NULL; 5076 5077 /* Proceed with simplification, unpacking the array. */ 5078 5079 mpz_init (index); 5080 rank = 0; 5081 5082 for (;;) 5083 { 5084 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); 5085 if (e == NULL) 5086 break; 5087 5088 gfc_extract_int (e, &shape[rank]); 5089 5090 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); 5091 gcc_assert (shape[rank] >= 0); 5092 5093 rank++; 5094 } 5095 5096 gcc_assert (rank > 0); 5097 5098 /* Now unpack the order array if present. */ 5099 if (order_exp == NULL) 5100 { 5101 for (i = 0; i < rank; i++) 5102 order[i] = i; 5103 } 5104 else 5105 { 5106 for (i = 0; i < rank; i++) 5107 x[i] = 0; 5108 5109 for (i = 0; i < rank; i++) 5110 { 5111 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); 5112 gcc_assert (e); 5113 5114 gfc_extract_int (e, &order[i]); 5115 5116 gcc_assert (order[i] >= 1 && order[i] <= rank); 5117 order[i]--; 5118 gcc_assert (x[order[i]] == 0); 5119 x[order[i]] = 1; 5120 } 5121 } 5122 5123 /* Count the elements in the source and padding arrays. */ 5124 5125 npad = 0; 5126 if (pad != NULL) 5127 { 5128 gfc_array_size (pad, &size); 5129 npad = mpz_get_ui (size); 5130 mpz_clear (size); 5131 } 5132 5133 gfc_array_size (source, &size); 5134 nsource = mpz_get_ui (size); 5135 mpz_clear (size); 5136 5137 /* If it weren't for that pesky permutation we could just loop 5138 through the source and round out any shortage with pad elements. 5139 But no, someone just had to have the compiler do something the 5140 user should be doing. */ 5141 5142 for (i = 0; i < rank; i++) 5143 x[i] = 0; 5144 5145 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 5146 &source->where); 5147 if (source->ts.type == BT_DERIVED) 5148 result->ts.u.derived = source->ts.u.derived; 5149 result->rank = rank; 5150 result->shape = gfc_get_shape (rank); 5151 for (i = 0; i < rank; i++) 5152 mpz_init_set_ui (result->shape[i], shape[i]); 5153 5154 while (nsource > 0 || npad > 0) 5155 { 5156 /* Figure out which element to extract. */ 5157 mpz_set_ui (index, 0); 5158 5159 for (i = rank - 1; i >= 0; i--) 5160 { 5161 mpz_add_ui (index, index, x[order[i]]); 5162 if (i != 0) 5163 mpz_mul_ui (index, index, shape[order[i - 1]]); 5164 } 5165 5166 if (mpz_cmp_ui (index, INT_MAX) > 0) 5167 gfc_internal_error ("Reshaped array too large at %C"); 5168 5169 j = mpz_get_ui (index); 5170 5171 if (j < nsource) 5172 e = gfc_constructor_lookup_expr (source->value.constructor, j); 5173 else 5174 { 5175 if (npad <= 0) 5176 { 5177 mpz_clear (index); 5178 return NULL; 5179 } 5180 j = j - nsource; 5181 j = j % npad; 5182 e = gfc_constructor_lookup_expr (pad->value.constructor, j); 5183 } 5184 gcc_assert (e); 5185 5186 gfc_constructor_append_expr (&result->value.constructor, 5187 gfc_copy_expr (e), &e->where); 5188 5189 /* Calculate the next element. */ 5190 i = 0; 5191 5192inc: 5193 if (++x[i] < shape[i]) 5194 continue; 5195 x[i++] = 0; 5196 if (i < rank) 5197 goto inc; 5198 5199 break; 5200 } 5201 5202 mpz_clear (index); 5203 5204 return result; 5205} 5206 5207 5208gfc_expr * 5209gfc_simplify_rrspacing (gfc_expr *x) 5210{ 5211 gfc_expr *result; 5212 int i; 5213 long int e, p; 5214 5215 if (x->expr_type != EXPR_CONSTANT) 5216 return NULL; 5217 5218 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 5219 5220 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 5221 5222 /* RRSPACING(+/- 0.0) = 0.0 */ 5223 if (mpfr_zero_p (x->value.real)) 5224 { 5225 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 5226 return result; 5227 } 5228 5229 /* RRSPACING(inf) = NaN */ 5230 if (mpfr_inf_p (x->value.real)) 5231 { 5232 mpfr_set_nan (result->value.real); 5233 return result; 5234 } 5235 5236 /* RRSPACING(NaN) = same NaN */ 5237 if (mpfr_nan_p (x->value.real)) 5238 { 5239 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 5240 return result; 5241 } 5242 5243 /* | x * 2**(-e) | * 2**p. */ 5244 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); 5245 e = - (long int) mpfr_get_exp (x->value.real); 5246 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); 5247 5248 p = (long int) gfc_real_kinds[i].digits; 5249 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); 5250 5251 return range_check (result, "RRSPACING"); 5252} 5253 5254 5255gfc_expr * 5256gfc_simplify_scale (gfc_expr *x, gfc_expr *i) 5257{ 5258 int k, neg_flag, power, exp_range; 5259 mpfr_t scale, radix; 5260 gfc_expr *result; 5261 5262 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 5263 return NULL; 5264 5265 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 5266 5267 if (mpfr_zero_p (x->value.real)) 5268 { 5269 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 5270 return result; 5271 } 5272 5273 k = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5274 5275 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; 5276 5277 /* This check filters out values of i that would overflow an int. */ 5278 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 5279 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) 5280 { 5281 gfc_error ("Result of SCALE overflows its kind at %L", &result->where); 5282 gfc_free_expr (result); 5283 return &gfc_bad_expr; 5284 } 5285 5286 /* Compute scale = radix ** power. */ 5287 power = mpz_get_si (i->value.integer); 5288 5289 if (power >= 0) 5290 neg_flag = 0; 5291 else 5292 { 5293 neg_flag = 1; 5294 power = -power; 5295 } 5296 5297 gfc_set_model_kind (x->ts.kind); 5298 mpfr_init (scale); 5299 mpfr_init (radix); 5300 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); 5301 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); 5302 5303 if (neg_flag) 5304 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); 5305 else 5306 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); 5307 5308 mpfr_clears (scale, radix, NULL); 5309 5310 return range_check (result, "SCALE"); 5311} 5312 5313 5314/* Variants of strspn and strcspn that operate on wide characters. */ 5315 5316static size_t 5317wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) 5318{ 5319 size_t i = 0; 5320 const gfc_char_t *c; 5321 5322 while (s1[i]) 5323 { 5324 for (c = s2; *c; c++) 5325 { 5326 if (s1[i] == *c) 5327 break; 5328 } 5329 if (*c == '\0') 5330 break; 5331 i++; 5332 } 5333 5334 return i; 5335} 5336 5337static size_t 5338wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) 5339{ 5340 size_t i = 0; 5341 const gfc_char_t *c; 5342 5343 while (s1[i]) 5344 { 5345 for (c = s2; *c; c++) 5346 { 5347 if (s1[i] == *c) 5348 break; 5349 } 5350 if (*c) 5351 break; 5352 i++; 5353 } 5354 5355 return i; 5356} 5357 5358 5359gfc_expr * 5360gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) 5361{ 5362 gfc_expr *result; 5363 int back; 5364 size_t i; 5365 size_t indx, len, lenc; 5366 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); 5367 5368 if (k == -1) 5369 return &gfc_bad_expr; 5370 5371 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT 5372 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 5373 return NULL; 5374 5375 if (b != NULL && b->value.logical != 0) 5376 back = 1; 5377 else 5378 back = 0; 5379 5380 len = e->value.character.length; 5381 lenc = c->value.character.length; 5382 5383 if (len == 0 || lenc == 0) 5384 { 5385 indx = 0; 5386 } 5387 else 5388 { 5389 if (back == 0) 5390 { 5391 indx = wide_strcspn (e->value.character.string, 5392 c->value.character.string) + 1; 5393 if (indx > len) 5394 indx = 0; 5395 } 5396 else 5397 { 5398 i = 0; 5399 for (indx = len; indx > 0; indx--) 5400 { 5401 for (i = 0; i < lenc; i++) 5402 { 5403 if (c->value.character.string[i] 5404 == e->value.character.string[indx - 1]) 5405 break; 5406 } 5407 if (i < lenc) 5408 break; 5409 } 5410 } 5411 } 5412 5413 result = gfc_get_int_expr (k, &e->where, indx); 5414 return range_check (result, "SCAN"); 5415} 5416 5417 5418gfc_expr * 5419gfc_simplify_selected_char_kind (gfc_expr *e) 5420{ 5421 int kind; 5422 5423 if (e->expr_type != EXPR_CONSTANT) 5424 return NULL; 5425 5426 if (gfc_compare_with_Cstring (e, "ascii", false) == 0 5427 || gfc_compare_with_Cstring (e, "default", false) == 0) 5428 kind = 1; 5429 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) 5430 kind = 4; 5431 else 5432 kind = -1; 5433 5434 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 5435} 5436 5437 5438gfc_expr * 5439gfc_simplify_selected_int_kind (gfc_expr *e) 5440{ 5441 int i, kind, range; 5442 5443 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) 5444 return NULL; 5445 5446 kind = INT_MAX; 5447 5448 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 5449 if (gfc_integer_kinds[i].range >= range 5450 && gfc_integer_kinds[i].kind < kind) 5451 kind = gfc_integer_kinds[i].kind; 5452 5453 if (kind == INT_MAX) 5454 kind = -1; 5455 5456 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 5457} 5458 5459 5460gfc_expr * 5461gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) 5462{ 5463 int range, precision, radix, i, kind, found_precision, found_range, 5464 found_radix; 5465 locus *loc = &gfc_current_locus; 5466 5467 if (p == NULL) 5468 precision = 0; 5469 else 5470 { 5471 if (p->expr_type != EXPR_CONSTANT 5472 || gfc_extract_int (p, &precision) != NULL) 5473 return NULL; 5474 loc = &p->where; 5475 } 5476 5477 if (q == NULL) 5478 range = 0; 5479 else 5480 { 5481 if (q->expr_type != EXPR_CONSTANT 5482 || gfc_extract_int (q, &range) != NULL) 5483 return NULL; 5484 5485 if (!loc) 5486 loc = &q->where; 5487 } 5488 5489 if (rdx == NULL) 5490 radix = 0; 5491 else 5492 { 5493 if (rdx->expr_type != EXPR_CONSTANT 5494 || gfc_extract_int (rdx, &radix) != NULL) 5495 return NULL; 5496 5497 if (!loc) 5498 loc = &rdx->where; 5499 } 5500 5501 kind = INT_MAX; 5502 found_precision = 0; 5503 found_range = 0; 5504 found_radix = 0; 5505 5506 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 5507 { 5508 if (gfc_real_kinds[i].precision >= precision) 5509 found_precision = 1; 5510 5511 if (gfc_real_kinds[i].range >= range) 5512 found_range = 1; 5513 5514 if (radix == 0 || gfc_real_kinds[i].radix == radix) 5515 found_radix = 1; 5516 5517 if (gfc_real_kinds[i].precision >= precision 5518 && gfc_real_kinds[i].range >= range 5519 && (radix == 0 || gfc_real_kinds[i].radix == radix) 5520 && gfc_real_kinds[i].kind < kind) 5521 kind = gfc_real_kinds[i].kind; 5522 } 5523 5524 if (kind == INT_MAX) 5525 { 5526 if (found_radix && found_range && !found_precision) 5527 kind = -1; 5528 else if (found_radix && found_precision && !found_range) 5529 kind = -2; 5530 else if (found_radix && !found_precision && !found_range) 5531 kind = -3; 5532 else if (found_radix) 5533 kind = -4; 5534 else 5535 kind = -5; 5536 } 5537 5538 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); 5539} 5540 5541 5542gfc_expr * 5543gfc_simplify_ieee_selected_real_kind (gfc_expr *expr) 5544{ 5545 gfc_actual_arglist *arg = expr->value.function.actual; 5546 gfc_expr *p = arg->expr, *r = arg->next->expr, 5547 *rad = arg->next->next->expr; 5548 int precision, range, radix, res; 5549 int found_precision, found_range, found_radix, i; 5550 5551 if (p) 5552 { 5553 if (p->expr_type != EXPR_CONSTANT 5554 || gfc_extract_int (p, &precision) != NULL) 5555 return NULL; 5556 } 5557 else 5558 precision = 0; 5559 5560 if (r) 5561 { 5562 if (r->expr_type != EXPR_CONSTANT 5563 || gfc_extract_int (r, &range) != NULL) 5564 return NULL; 5565 } 5566 else 5567 range = 0; 5568 5569 if (rad) 5570 { 5571 if (rad->expr_type != EXPR_CONSTANT 5572 || gfc_extract_int (rad, &radix) != NULL) 5573 return NULL; 5574 } 5575 else 5576 radix = 0; 5577 5578 res = INT_MAX; 5579 found_precision = 0; 5580 found_range = 0; 5581 found_radix = 0; 5582 5583 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 5584 { 5585 /* We only support the target's float and double types. */ 5586 if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double) 5587 continue; 5588 5589 if (gfc_real_kinds[i].precision >= precision) 5590 found_precision = 1; 5591 5592 if (gfc_real_kinds[i].range >= range) 5593 found_range = 1; 5594 5595 if (radix == 0 || gfc_real_kinds[i].radix == radix) 5596 found_radix = 1; 5597 5598 if (gfc_real_kinds[i].precision >= precision 5599 && gfc_real_kinds[i].range >= range 5600 && (radix == 0 || gfc_real_kinds[i].radix == radix) 5601 && gfc_real_kinds[i].kind < res) 5602 res = gfc_real_kinds[i].kind; 5603 } 5604 5605 if (res == INT_MAX) 5606 { 5607 if (found_radix && found_range && !found_precision) 5608 res = -1; 5609 else if (found_radix && found_precision && !found_range) 5610 res = -2; 5611 else if (found_radix && !found_precision && !found_range) 5612 res = -3; 5613 else if (found_radix) 5614 res = -4; 5615 else 5616 res = -5; 5617 } 5618 5619 return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res); 5620} 5621 5622 5623gfc_expr * 5624gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) 5625{ 5626 gfc_expr *result; 5627 mpfr_t exp, absv, log2, pow2, frac; 5628 unsigned long exp2; 5629 5630 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 5631 return NULL; 5632 5633 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 5634 5635 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 5636 SET_EXPONENT (NaN) = same NaN */ 5637 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) 5638 { 5639 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 5640 return result; 5641 } 5642 5643 /* SET_EXPONENT (inf) = NaN */ 5644 if (mpfr_inf_p (x->value.real)) 5645 { 5646 mpfr_set_nan (result->value.real); 5647 return result; 5648 } 5649 5650 gfc_set_model_kind (x->ts.kind); 5651 mpfr_init (absv); 5652 mpfr_init (log2); 5653 mpfr_init (exp); 5654 mpfr_init (pow2); 5655 mpfr_init (frac); 5656 5657 mpfr_abs (absv, x->value.real, GFC_RND_MODE); 5658 mpfr_log2 (log2, absv, GFC_RND_MODE); 5659 5660 mpfr_trunc (log2, log2); 5661 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); 5662 5663 /* Old exponent value, and fraction. */ 5664 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); 5665 5666 mpfr_div (frac, absv, pow2, GFC_RND_MODE); 5667 5668 /* New exponent. */ 5669 exp2 = (unsigned long) mpz_get_d (i->value.integer); 5670 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); 5671 5672 mpfr_clears (absv, log2, pow2, frac, NULL); 5673 5674 return range_check (result, "SET_EXPONENT"); 5675} 5676 5677 5678gfc_expr * 5679gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) 5680{ 5681 mpz_t shape[GFC_MAX_DIMENSIONS]; 5682 gfc_expr *result, *e, *f; 5683 gfc_array_ref *ar; 5684 int n; 5685 bool t; 5686 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); 5687 5688 if (source->rank == -1) 5689 return NULL; 5690 5691 result = gfc_get_array_expr (BT_INTEGER, k, &source->where); 5692 5693 if (source->rank == 0) 5694 return result; 5695 5696 if (source->expr_type == EXPR_VARIABLE) 5697 { 5698 ar = gfc_find_array_ref (source); 5699 t = gfc_array_ref_shape (ar, shape); 5700 } 5701 else if (source->shape) 5702 { 5703 t = true; 5704 for (n = 0; n < source->rank; n++) 5705 { 5706 mpz_init (shape[n]); 5707 mpz_set (shape[n], source->shape[n]); 5708 } 5709 } 5710 else 5711 t = false; 5712 5713 for (n = 0; n < source->rank; n++) 5714 { 5715 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); 5716 5717 if (t) 5718 mpz_set (e->value.integer, shape[n]); 5719 else 5720 { 5721 mpz_set_ui (e->value.integer, n + 1); 5722 5723 f = simplify_size (source, e, k); 5724 gfc_free_expr (e); 5725 if (f == NULL) 5726 { 5727 gfc_free_expr (result); 5728 return NULL; 5729 } 5730 else 5731 e = f; 5732 } 5733 5734 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) 5735 { 5736 gfc_free_expr (result); 5737 if (t) 5738 gfc_clear_shape (shape, source->rank); 5739 return &gfc_bad_expr; 5740 } 5741 5742 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 5743 } 5744 5745 if (t) 5746 gfc_clear_shape (shape, source->rank); 5747 5748 return result; 5749} 5750 5751 5752static gfc_expr * 5753simplify_size (gfc_expr *array, gfc_expr *dim, int k) 5754{ 5755 mpz_t size; 5756 gfc_expr *return_value; 5757 int d; 5758 5759 /* For unary operations, the size of the result is given by the size 5760 of the operand. For binary ones, it's the size of the first operand 5761 unless it is scalar, then it is the size of the second. */ 5762 if (array->expr_type == EXPR_OP && !array->value.op.uop) 5763 { 5764 gfc_expr* replacement; 5765 gfc_expr* simplified; 5766 5767 switch (array->value.op.op) 5768 { 5769 /* Unary operations. */ 5770 case INTRINSIC_NOT: 5771 case INTRINSIC_UPLUS: 5772 case INTRINSIC_UMINUS: 5773 case INTRINSIC_PARENTHESES: 5774 replacement = array->value.op.op1; 5775 break; 5776 5777 /* Binary operations. If any one of the operands is scalar, take 5778 the other one's size. If both of them are arrays, it does not 5779 matter -- try to find one with known shape, if possible. */ 5780 default: 5781 if (array->value.op.op1->rank == 0) 5782 replacement = array->value.op.op2; 5783 else if (array->value.op.op2->rank == 0) 5784 replacement = array->value.op.op1; 5785 else 5786 { 5787 simplified = simplify_size (array->value.op.op1, dim, k); 5788 if (simplified) 5789 return simplified; 5790 5791 replacement = array->value.op.op2; 5792 } 5793 break; 5794 } 5795 5796 /* Try to reduce it directly if possible. */ 5797 simplified = simplify_size (replacement, dim, k); 5798 5799 /* Otherwise, we build a new SIZE call. This is hopefully at least 5800 simpler than the original one. */ 5801 if (!simplified) 5802 { 5803 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); 5804 simplified = gfc_build_intrinsic_call (gfc_current_ns, 5805 GFC_ISYM_SIZE, "size", 5806 array->where, 3, 5807 gfc_copy_expr (replacement), 5808 gfc_copy_expr (dim), 5809 kind); 5810 } 5811 return simplified; 5812 } 5813 5814 if (dim == NULL) 5815 { 5816 if (!gfc_array_size (array, &size)) 5817 return NULL; 5818 } 5819 else 5820 { 5821 if (dim->expr_type != EXPR_CONSTANT) 5822 return NULL; 5823 5824 d = mpz_get_ui (dim->value.integer) - 1; 5825 if (!gfc_array_dimen_size (array, d, &size)) 5826 return NULL; 5827 } 5828 5829 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 5830 mpz_set (return_value->value.integer, size); 5831 mpz_clear (size); 5832 5833 return return_value; 5834} 5835 5836 5837gfc_expr * 5838gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 5839{ 5840 gfc_expr *result; 5841 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); 5842 5843 if (k == -1) 5844 return &gfc_bad_expr; 5845 5846 result = simplify_size (array, dim, k); 5847 if (result == NULL || result == &gfc_bad_expr) 5848 return result; 5849 5850 return range_check (result, "SIZE"); 5851} 5852 5853 5854/* SIZEOF and C_SIZEOF return the size in bytes of an array element 5855 multiplied by the array size. */ 5856 5857gfc_expr * 5858gfc_simplify_sizeof (gfc_expr *x) 5859{ 5860 gfc_expr *result = NULL; 5861 mpz_t array_size; 5862 5863 if (x->ts.type == BT_CLASS || x->ts.deferred) 5864 return NULL; 5865 5866 if (x->ts.type == BT_CHARACTER 5867 && (!x->ts.u.cl || !x->ts.u.cl->length 5868 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 5869 return NULL; 5870 5871 if (x->rank && x->expr_type != EXPR_ARRAY 5872 && !gfc_array_size (x, &array_size)) 5873 return NULL; 5874 5875 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 5876 &x->where); 5877 mpz_set_si (result->value.integer, gfc_target_expr_size (x)); 5878 5879 return result; 5880} 5881 5882 5883/* STORAGE_SIZE returns the size in bits of a single array element. */ 5884 5885gfc_expr * 5886gfc_simplify_storage_size (gfc_expr *x, 5887 gfc_expr *kind) 5888{ 5889 gfc_expr *result = NULL; 5890 int k; 5891 5892 if (x->ts.type == BT_CLASS || x->ts.deferred) 5893 return NULL; 5894 5895 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT 5896 && (!x->ts.u.cl || !x->ts.u.cl->length 5897 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 5898 return NULL; 5899 5900 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); 5901 if (k == -1) 5902 return &gfc_bad_expr; 5903 5904 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 5905 5906 mpz_set_si (result->value.integer, gfc_element_size (x)); 5907 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); 5908 5909 return range_check (result, "STORAGE_SIZE"); 5910} 5911 5912 5913gfc_expr * 5914gfc_simplify_sign (gfc_expr *x, gfc_expr *y) 5915{ 5916 gfc_expr *result; 5917 5918 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 5919 return NULL; 5920 5921 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 5922 5923 switch (x->ts.type) 5924 { 5925 case BT_INTEGER: 5926 mpz_abs (result->value.integer, x->value.integer); 5927 if (mpz_sgn (y->value.integer) < 0) 5928 mpz_neg (result->value.integer, result->value.integer); 5929 break; 5930 5931 case BT_REAL: 5932 if (flag_sign_zero) 5933 mpfr_copysign (result->value.real, x->value.real, y->value.real, 5934 GFC_RND_MODE); 5935 else 5936 mpfr_setsign (result->value.real, x->value.real, 5937 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); 5938 break; 5939 5940 default: 5941 gfc_internal_error ("Bad type in gfc_simplify_sign"); 5942 } 5943 5944 return result; 5945} 5946 5947 5948gfc_expr * 5949gfc_simplify_sin (gfc_expr *x) 5950{ 5951 gfc_expr *result; 5952 5953 if (x->expr_type != EXPR_CONSTANT) 5954 return NULL; 5955 5956 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 5957 5958 switch (x->ts.type) 5959 { 5960 case BT_REAL: 5961 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); 5962 break; 5963 5964 case BT_COMPLEX: 5965 gfc_set_model (x->value.real); 5966 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 5967 break; 5968 5969 default: 5970 gfc_internal_error ("in gfc_simplify_sin(): Bad type"); 5971 } 5972 5973 return range_check (result, "SIN"); 5974} 5975 5976 5977gfc_expr * 5978gfc_simplify_sinh (gfc_expr *x) 5979{ 5980 gfc_expr *result; 5981 5982 if (x->expr_type != EXPR_CONSTANT) 5983 return NULL; 5984 5985 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 5986 5987 switch (x->ts.type) 5988 { 5989 case BT_REAL: 5990 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); 5991 break; 5992 5993 case BT_COMPLEX: 5994 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 5995 break; 5996 5997 default: 5998 gcc_unreachable (); 5999 } 6000 6001 return range_check (result, "SINH"); 6002} 6003 6004 6005/* The argument is always a double precision real that is converted to 6006 single precision. TODO: Rounding! */ 6007 6008gfc_expr * 6009gfc_simplify_sngl (gfc_expr *a) 6010{ 6011 gfc_expr *result; 6012 6013 if (a->expr_type != EXPR_CONSTANT) 6014 return NULL; 6015 6016 result = gfc_real2real (a, gfc_default_real_kind); 6017 return range_check (result, "SNGL"); 6018} 6019 6020 6021gfc_expr * 6022gfc_simplify_spacing (gfc_expr *x) 6023{ 6024 gfc_expr *result; 6025 int i; 6026 long int en, ep; 6027 6028 if (x->expr_type != EXPR_CONSTANT) 6029 return NULL; 6030 6031 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 6032 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 6033 6034 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ 6035 if (mpfr_zero_p (x->value.real)) 6036 { 6037 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 6038 return result; 6039 } 6040 6041 /* SPACING(inf) = NaN */ 6042 if (mpfr_inf_p (x->value.real)) 6043 { 6044 mpfr_set_nan (result->value.real); 6045 return result; 6046 } 6047 6048 /* SPACING(NaN) = same NaN */ 6049 if (mpfr_nan_p (x->value.real)) 6050 { 6051 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 6052 return result; 6053 } 6054 6055 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p 6056 are the radix, exponent of x, and precision. This excludes the 6057 possibility of subnormal numbers. Fortran 2003 states the result is 6058 b**max(e - p, emin - 1). */ 6059 6060 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; 6061 en = (long int) gfc_real_kinds[i].min_exponent - 1; 6062 en = en > ep ? en : ep; 6063 6064 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); 6065 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); 6066 6067 return range_check (result, "SPACING"); 6068} 6069 6070 6071gfc_expr * 6072gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) 6073{ 6074 gfc_expr *result = 0L; 6075 int i, j, dim, ncopies; 6076 mpz_t size; 6077 6078 if ((!gfc_is_constant_expr (source) 6079 && !is_constant_array_expr (source)) 6080 || !gfc_is_constant_expr (dim_expr) 6081 || !gfc_is_constant_expr (ncopies_expr)) 6082 return NULL; 6083 6084 gcc_assert (dim_expr->ts.type == BT_INTEGER); 6085 gfc_extract_int (dim_expr, &dim); 6086 dim -= 1; /* zero-base DIM */ 6087 6088 gcc_assert (ncopies_expr->ts.type == BT_INTEGER); 6089 gfc_extract_int (ncopies_expr, &ncopies); 6090 ncopies = MAX (ncopies, 0); 6091 6092 /* Do not allow the array size to exceed the limit for an array 6093 constructor. */ 6094 if (source->expr_type == EXPR_ARRAY) 6095 { 6096 if (!gfc_array_size (source, &size)) 6097 gfc_internal_error ("Failure getting length of a constant array."); 6098 } 6099 else 6100 mpz_init_set_ui (size, 1); 6101 6102 if (mpz_get_si (size)*ncopies > flag_max_array_constructor) 6103 return NULL; 6104 6105 if (source->expr_type == EXPR_CONSTANT) 6106 { 6107 gcc_assert (dim == 0); 6108 6109 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 6110 &source->where); 6111 if (source->ts.type == BT_DERIVED) 6112 result->ts.u.derived = source->ts.u.derived; 6113 result->rank = 1; 6114 result->shape = gfc_get_shape (result->rank); 6115 mpz_init_set_si (result->shape[0], ncopies); 6116 6117 for (i = 0; i < ncopies; ++i) 6118 gfc_constructor_append_expr (&result->value.constructor, 6119 gfc_copy_expr (source), NULL); 6120 } 6121 else if (source->expr_type == EXPR_ARRAY) 6122 { 6123 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; 6124 gfc_constructor *source_ctor; 6125 6126 gcc_assert (source->rank < GFC_MAX_DIMENSIONS); 6127 gcc_assert (dim >= 0 && dim <= source->rank); 6128 6129 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 6130 &source->where); 6131 if (source->ts.type == BT_DERIVED) 6132 result->ts.u.derived = source->ts.u.derived; 6133 result->rank = source->rank + 1; 6134 result->shape = gfc_get_shape (result->rank); 6135 6136 for (i = 0, j = 0; i < result->rank; ++i) 6137 { 6138 if (i != dim) 6139 mpz_init_set (result->shape[i], source->shape[j++]); 6140 else 6141 mpz_init_set_si (result->shape[i], ncopies); 6142 6143 extent[i] = mpz_get_si (result->shape[i]); 6144 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; 6145 } 6146 6147 offset = 0; 6148 for (source_ctor = gfc_constructor_first (source->value.constructor); 6149 source_ctor; source_ctor = gfc_constructor_next (source_ctor)) 6150 { 6151 for (i = 0; i < ncopies; ++i) 6152 gfc_constructor_insert_expr (&result->value.constructor, 6153 gfc_copy_expr (source_ctor->expr), 6154 NULL, offset + i * rstride[dim]); 6155 6156 offset += (dim == 0 ? ncopies : 1); 6157 } 6158 } 6159 else 6160 /* FIXME: Returning here avoids a regression in array_simplify_1.f90. 6161 Replace NULL with gcc_unreachable() after implementing 6162 gfc_simplify_cshift(). */ 6163 return NULL; 6164 6165 if (source->ts.type == BT_CHARACTER) 6166 result->ts.u.cl = source->ts.u.cl; 6167 6168 return result; 6169} 6170 6171 6172gfc_expr * 6173gfc_simplify_sqrt (gfc_expr *e) 6174{ 6175 gfc_expr *result = NULL; 6176 6177 if (e->expr_type != EXPR_CONSTANT) 6178 return NULL; 6179 6180 switch (e->ts.type) 6181 { 6182 case BT_REAL: 6183 if (mpfr_cmp_si (e->value.real, 0) < 0) 6184 { 6185 gfc_error ("Argument of SQRT at %L has a negative value", 6186 &e->where); 6187 return &gfc_bad_expr; 6188 } 6189 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6190 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); 6191 break; 6192 6193 case BT_COMPLEX: 6194 gfc_set_model (e->value.real); 6195 6196 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6197 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); 6198 break; 6199 6200 default: 6201 gfc_internal_error ("invalid argument of SQRT at %L", &e->where); 6202 } 6203 6204 return range_check (result, "SQRT"); 6205} 6206 6207 6208gfc_expr * 6209gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 6210{ 6211 return simplify_transformation (array, dim, mask, 0, gfc_add); 6212} 6213 6214 6215gfc_expr * 6216gfc_simplify_tan (gfc_expr *x) 6217{ 6218 gfc_expr *result; 6219 6220 if (x->expr_type != EXPR_CONSTANT) 6221 return NULL; 6222 6223 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 6224 6225 switch (x->ts.type) 6226 { 6227 case BT_REAL: 6228 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); 6229 break; 6230 6231 case BT_COMPLEX: 6232 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 6233 break; 6234 6235 default: 6236 gcc_unreachable (); 6237 } 6238 6239 return range_check (result, "TAN"); 6240} 6241 6242 6243gfc_expr * 6244gfc_simplify_tanh (gfc_expr *x) 6245{ 6246 gfc_expr *result; 6247 6248 if (x->expr_type != EXPR_CONSTANT) 6249 return NULL; 6250 6251 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 6252 6253 switch (x->ts.type) 6254 { 6255 case BT_REAL: 6256 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); 6257 break; 6258 6259 case BT_COMPLEX: 6260 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 6261 break; 6262 6263 default: 6264 gcc_unreachable (); 6265 } 6266 6267 return range_check (result, "TANH"); 6268} 6269 6270 6271gfc_expr * 6272gfc_simplify_tiny (gfc_expr *e) 6273{ 6274 gfc_expr *result; 6275 int i; 6276 6277 i = gfc_validate_kind (BT_REAL, e->ts.kind, false); 6278 6279 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 6280 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 6281 6282 return result; 6283} 6284 6285 6286gfc_expr * 6287gfc_simplify_trailz (gfc_expr *e) 6288{ 6289 unsigned long tz, bs; 6290 int i; 6291 6292 if (e->expr_type != EXPR_CONSTANT) 6293 return NULL; 6294 6295 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6296 bs = gfc_integer_kinds[i].bit_size; 6297 tz = mpz_scan1 (e->value.integer, 0); 6298 6299 return gfc_get_int_expr (gfc_default_integer_kind, 6300 &e->where, MIN (tz, bs)); 6301} 6302 6303 6304gfc_expr * 6305gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 6306{ 6307 gfc_expr *result; 6308 gfc_expr *mold_element; 6309 size_t source_size; 6310 size_t result_size; 6311 size_t buffer_size; 6312 mpz_t tmp; 6313 unsigned char *buffer; 6314 size_t result_length; 6315 6316 6317 if (!gfc_is_constant_expr (source) 6318 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) 6319 || !gfc_is_constant_expr (size)) 6320 return NULL; 6321 6322 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 6323 &result_size, &result_length)) 6324 return NULL; 6325 6326 /* Calculate the size of the source. */ 6327 if (source->expr_type == EXPR_ARRAY 6328 && !gfc_array_size (source, &tmp)) 6329 gfc_internal_error ("Failure getting length of a constant array."); 6330 6331 /* Create an empty new expression with the appropriate characteristics. */ 6332 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, 6333 &source->where); 6334 result->ts = mold->ts; 6335 6336 mold_element = mold->expr_type == EXPR_ARRAY 6337 ? gfc_constructor_first (mold->value.constructor)->expr 6338 : mold; 6339 6340 /* Set result character length, if needed. Note that this needs to be 6341 set even for array expressions, in order to pass this information into 6342 gfc_target_interpret_expr. */ 6343 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) 6344 result->value.character.length = mold_element->value.character.length; 6345 6346 /* Set the number of elements in the result, and determine its size. */ 6347 6348 if (mold->expr_type == EXPR_ARRAY || mold->rank || size) 6349 { 6350 result->expr_type = EXPR_ARRAY; 6351 result->rank = 1; 6352 result->shape = gfc_get_shape (1); 6353 mpz_init_set_ui (result->shape[0], result_length); 6354 } 6355 else 6356 result->rank = 0; 6357 6358 /* Allocate the buffer to store the binary version of the source. */ 6359 buffer_size = MAX (source_size, result_size); 6360 buffer = (unsigned char*)alloca (buffer_size); 6361 memset (buffer, 0, buffer_size); 6362 6363 /* Now write source to the buffer. */ 6364 gfc_target_encode_expr (source, buffer, buffer_size); 6365 6366 /* And read the buffer back into the new expression. */ 6367 gfc_target_interpret_expr (buffer, buffer_size, result, false); 6368 6369 return result; 6370} 6371 6372 6373gfc_expr * 6374gfc_simplify_transpose (gfc_expr *matrix) 6375{ 6376 int row, matrix_rows, col, matrix_cols; 6377 gfc_expr *result; 6378 6379 if (!is_constant_array_expr (matrix)) 6380 return NULL; 6381 6382 gcc_assert (matrix->rank == 2); 6383 6384 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, 6385 &matrix->where); 6386 result->rank = 2; 6387 result->shape = gfc_get_shape (result->rank); 6388 mpz_set (result->shape[0], matrix->shape[1]); 6389 mpz_set (result->shape[1], matrix->shape[0]); 6390 6391 if (matrix->ts.type == BT_CHARACTER) 6392 result->ts.u.cl = matrix->ts.u.cl; 6393 else if (matrix->ts.type == BT_DERIVED) 6394 result->ts.u.derived = matrix->ts.u.derived; 6395 6396 matrix_rows = mpz_get_si (matrix->shape[0]); 6397 matrix_cols = mpz_get_si (matrix->shape[1]); 6398 for (row = 0; row < matrix_rows; ++row) 6399 for (col = 0; col < matrix_cols; ++col) 6400 { 6401 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, 6402 col * matrix_rows + row); 6403 gfc_constructor_insert_expr (&result->value.constructor, 6404 gfc_copy_expr (e), &matrix->where, 6405 row * matrix_cols + col); 6406 } 6407 6408 return result; 6409} 6410 6411 6412gfc_expr * 6413gfc_simplify_trim (gfc_expr *e) 6414{ 6415 gfc_expr *result; 6416 int count, i, len, lentrim; 6417 6418 if (e->expr_type != EXPR_CONSTANT) 6419 return NULL; 6420 6421 len = e->value.character.length; 6422 for (count = 0, i = 1; i <= len; ++i) 6423 { 6424 if (e->value.character.string[len - i] == ' ') 6425 count++; 6426 else 6427 break; 6428 } 6429 6430 lentrim = len - count; 6431 6432 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); 6433 for (i = 0; i < lentrim; i++) 6434 result->value.character.string[i] = e->value.character.string[i]; 6435 6436 return result; 6437} 6438 6439 6440gfc_expr * 6441gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) 6442{ 6443 gfc_expr *result; 6444 gfc_ref *ref; 6445 gfc_array_spec *as; 6446 gfc_constructor *sub_cons; 6447 bool first_image; 6448 int d; 6449 6450 if (!is_constant_array_expr (sub)) 6451 return NULL; 6452 6453 /* Follow any component references. */ 6454 as = coarray->symtree->n.sym->as; 6455 for (ref = coarray->ref; ref; ref = ref->next) 6456 if (ref->type == REF_COMPONENT) 6457 as = ref->u.ar.as; 6458 6459 if (as->type == AS_DEFERRED) 6460 return NULL; 6461 6462 /* "valid sequence of cosubscripts" are required; thus, return 0 unless 6463 the cosubscript addresses the first image. */ 6464 6465 sub_cons = gfc_constructor_first (sub->value.constructor); 6466 first_image = true; 6467 6468 for (d = 1; d <= as->corank; d++) 6469 { 6470 gfc_expr *ca_bound; 6471 int cmp; 6472 6473 gcc_assert (sub_cons != NULL); 6474 6475 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, 6476 NULL, true); 6477 if (ca_bound == NULL) 6478 return NULL; 6479 6480 if (ca_bound == &gfc_bad_expr) 6481 return ca_bound; 6482 6483 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); 6484 6485 if (cmp == 0) 6486 { 6487 gfc_free_expr (ca_bound); 6488 sub_cons = gfc_constructor_next (sub_cons); 6489 continue; 6490 } 6491 6492 first_image = false; 6493 6494 if (cmp > 0) 6495 { 6496 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 6497 "SUB has %ld and COARRAY lower bound is %ld)", 6498 &coarray->where, d, 6499 mpz_get_si (sub_cons->expr->value.integer), 6500 mpz_get_si (ca_bound->value.integer)); 6501 gfc_free_expr (ca_bound); 6502 return &gfc_bad_expr; 6503 } 6504 6505 gfc_free_expr (ca_bound); 6506 6507 /* Check whether upperbound is valid for the multi-images case. */ 6508 if (d < as->corank) 6509 { 6510 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, 6511 NULL, true); 6512 if (ca_bound == &gfc_bad_expr) 6513 return ca_bound; 6514 6515 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT 6516 && mpz_cmp (ca_bound->value.integer, 6517 sub_cons->expr->value.integer) < 0) 6518 { 6519 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 6520 "SUB has %ld and COARRAY upper bound is %ld)", 6521 &coarray->where, d, 6522 mpz_get_si (sub_cons->expr->value.integer), 6523 mpz_get_si (ca_bound->value.integer)); 6524 gfc_free_expr (ca_bound); 6525 return &gfc_bad_expr; 6526 } 6527 6528 if (ca_bound) 6529 gfc_free_expr (ca_bound); 6530 } 6531 6532 sub_cons = gfc_constructor_next (sub_cons); 6533 } 6534 6535 gcc_assert (sub_cons == NULL); 6536 6537 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image) 6538 return NULL; 6539 6540 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6541 &gfc_current_locus); 6542 if (first_image) 6543 mpz_set_si (result->value.integer, 1); 6544 else 6545 mpz_set_si (result->value.integer, 0); 6546 6547 return result; 6548} 6549 6550 6551gfc_expr * 6552gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, 6553 gfc_expr *distance ATTRIBUTE_UNUSED) 6554{ 6555 if (flag_coarray != GFC_FCOARRAY_SINGLE) 6556 return NULL; 6557 6558 /* If no coarray argument has been passed or when the first argument 6559 is actually a distance argment. */ 6560 if (coarray == NULL || !gfc_is_coarray (coarray)) 6561 { 6562 gfc_expr *result; 6563 /* FIXME: gfc_current_locus is wrong. */ 6564 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6565 &gfc_current_locus); 6566 mpz_set_si (result->value.integer, 1); 6567 return result; 6568 } 6569 6570 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ 6571 return simplify_cobound (coarray, dim, NULL, 0); 6572} 6573 6574 6575gfc_expr * 6576gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 6577{ 6578 return simplify_bound (array, dim, kind, 1); 6579} 6580 6581gfc_expr * 6582gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 6583{ 6584 return simplify_cobound (array, dim, kind, 1); 6585} 6586 6587 6588gfc_expr * 6589gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 6590{ 6591 gfc_expr *result, *e; 6592 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; 6593 6594 if (!is_constant_array_expr (vector) 6595 || !is_constant_array_expr (mask) 6596 || (!gfc_is_constant_expr (field) 6597 && !is_constant_array_expr (field))) 6598 return NULL; 6599 6600 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, 6601 &vector->where); 6602 if (vector->ts.type == BT_DERIVED) 6603 result->ts.u.derived = vector->ts.u.derived; 6604 result->rank = mask->rank; 6605 result->shape = gfc_copy_shape (mask->shape, mask->rank); 6606 6607 if (vector->ts.type == BT_CHARACTER) 6608 result->ts.u.cl = vector->ts.u.cl; 6609 6610 vector_ctor = gfc_constructor_first (vector->value.constructor); 6611 mask_ctor = gfc_constructor_first (mask->value.constructor); 6612 field_ctor 6613 = field->expr_type == EXPR_ARRAY 6614 ? gfc_constructor_first (field->value.constructor) 6615 : NULL; 6616 6617 while (mask_ctor) 6618 { 6619 if (mask_ctor->expr->value.logical) 6620 { 6621 gcc_assert (vector_ctor); 6622 e = gfc_copy_expr (vector_ctor->expr); 6623 vector_ctor = gfc_constructor_next (vector_ctor); 6624 } 6625 else if (field->expr_type == EXPR_ARRAY) 6626 e = gfc_copy_expr (field_ctor->expr); 6627 else 6628 e = gfc_copy_expr (field); 6629 6630 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 6631 6632 mask_ctor = gfc_constructor_next (mask_ctor); 6633 field_ctor = gfc_constructor_next (field_ctor); 6634 } 6635 6636 return result; 6637} 6638 6639 6640gfc_expr * 6641gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) 6642{ 6643 gfc_expr *result; 6644 int back; 6645 size_t index, len, lenset; 6646 size_t i; 6647 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); 6648 6649 if (k == -1) 6650 return &gfc_bad_expr; 6651 6652 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT 6653 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 6654 return NULL; 6655 6656 if (b != NULL && b->value.logical != 0) 6657 back = 1; 6658 else 6659 back = 0; 6660 6661 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); 6662 6663 len = s->value.character.length; 6664 lenset = set->value.character.length; 6665 6666 if (len == 0) 6667 { 6668 mpz_set_ui (result->value.integer, 0); 6669 return result; 6670 } 6671 6672 if (back == 0) 6673 { 6674 if (lenset == 0) 6675 { 6676 mpz_set_ui (result->value.integer, 1); 6677 return result; 6678 } 6679 6680 index = wide_strspn (s->value.character.string, 6681 set->value.character.string) + 1; 6682 if (index > len) 6683 index = 0; 6684 6685 } 6686 else 6687 { 6688 if (lenset == 0) 6689 { 6690 mpz_set_ui (result->value.integer, len); 6691 return result; 6692 } 6693 for (index = len; index > 0; index --) 6694 { 6695 for (i = 0; i < lenset; i++) 6696 { 6697 if (s->value.character.string[index - 1] 6698 == set->value.character.string[i]) 6699 break; 6700 } 6701 if (i == lenset) 6702 break; 6703 } 6704 } 6705 6706 mpz_set_ui (result->value.integer, index); 6707 return result; 6708} 6709 6710 6711gfc_expr * 6712gfc_simplify_xor (gfc_expr *x, gfc_expr *y) 6713{ 6714 gfc_expr *result; 6715 int kind; 6716 6717 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 6718 return NULL; 6719 6720 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 6721 6722 switch (x->ts.type) 6723 { 6724 case BT_INTEGER: 6725 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 6726 mpz_xor (result->value.integer, x->value.integer, y->value.integer); 6727 return range_check (result, "XOR"); 6728 6729 case BT_LOGICAL: 6730 return gfc_get_logical_expr (kind, &x->where, 6731 (x->value.logical && !y->value.logical) 6732 || (!x->value.logical && y->value.logical)); 6733 6734 default: 6735 gcc_unreachable (); 6736 } 6737} 6738 6739 6740/****************** Constant simplification *****************/ 6741 6742/* Master function to convert one constant to another. While this is 6743 used as a simplification function, it requires the destination type 6744 and kind information which is supplied by a special case in 6745 do_simplify(). */ 6746 6747gfc_expr * 6748gfc_convert_constant (gfc_expr *e, bt type, int kind) 6749{ 6750 gfc_expr *g, *result, *(*f) (gfc_expr *, int); 6751 gfc_constructor *c; 6752 6753 switch (e->ts.type) 6754 { 6755 case BT_INTEGER: 6756 switch (type) 6757 { 6758 case BT_INTEGER: 6759 f = gfc_int2int; 6760 break; 6761 case BT_REAL: 6762 f = gfc_int2real; 6763 break; 6764 case BT_COMPLEX: 6765 f = gfc_int2complex; 6766 break; 6767 case BT_LOGICAL: 6768 f = gfc_int2log; 6769 break; 6770 default: 6771 goto oops; 6772 } 6773 break; 6774 6775 case BT_REAL: 6776 switch (type) 6777 { 6778 case BT_INTEGER: 6779 f = gfc_real2int; 6780 break; 6781 case BT_REAL: 6782 f = gfc_real2real; 6783 break; 6784 case BT_COMPLEX: 6785 f = gfc_real2complex; 6786 break; 6787 default: 6788 goto oops; 6789 } 6790 break; 6791 6792 case BT_COMPLEX: 6793 switch (type) 6794 { 6795 case BT_INTEGER: 6796 f = gfc_complex2int; 6797 break; 6798 case BT_REAL: 6799 f = gfc_complex2real; 6800 break; 6801 case BT_COMPLEX: 6802 f = gfc_complex2complex; 6803 break; 6804 6805 default: 6806 goto oops; 6807 } 6808 break; 6809 6810 case BT_LOGICAL: 6811 switch (type) 6812 { 6813 case BT_INTEGER: 6814 f = gfc_log2int; 6815 break; 6816 case BT_LOGICAL: 6817 f = gfc_log2log; 6818 break; 6819 default: 6820 goto oops; 6821 } 6822 break; 6823 6824 case BT_HOLLERITH: 6825 switch (type) 6826 { 6827 case BT_INTEGER: 6828 f = gfc_hollerith2int; 6829 break; 6830 6831 case BT_REAL: 6832 f = gfc_hollerith2real; 6833 break; 6834 6835 case BT_COMPLEX: 6836 f = gfc_hollerith2complex; 6837 break; 6838 6839 case BT_CHARACTER: 6840 f = gfc_hollerith2character; 6841 break; 6842 6843 case BT_LOGICAL: 6844 f = gfc_hollerith2logical; 6845 break; 6846 6847 default: 6848 goto oops; 6849 } 6850 break; 6851 6852 default: 6853 oops: 6854 gfc_internal_error ("gfc_convert_constant(): Unexpected type"); 6855 } 6856 6857 result = NULL; 6858 6859 switch (e->expr_type) 6860 { 6861 case EXPR_CONSTANT: 6862 result = f (e, kind); 6863 if (result == NULL) 6864 return &gfc_bad_expr; 6865 break; 6866 6867 case EXPR_ARRAY: 6868 if (!gfc_is_constant_expr (e)) 6869 break; 6870 6871 result = gfc_get_array_expr (type, kind, &e->where); 6872 result->shape = gfc_copy_shape (e->shape, e->rank); 6873 result->rank = e->rank; 6874 6875 for (c = gfc_constructor_first (e->value.constructor); 6876 c; c = gfc_constructor_next (c)) 6877 { 6878 gfc_expr *tmp; 6879 if (c->iterator == NULL) 6880 tmp = f (c->expr, kind); 6881 else 6882 { 6883 g = gfc_convert_constant (c->expr, type, kind); 6884 if (g == &gfc_bad_expr) 6885 { 6886 gfc_free_expr (result); 6887 return g; 6888 } 6889 tmp = g; 6890 } 6891 6892 if (tmp == NULL) 6893 { 6894 gfc_free_expr (result); 6895 return NULL; 6896 } 6897 6898 gfc_constructor_append_expr (&result->value.constructor, 6899 tmp, &c->where); 6900 } 6901 6902 break; 6903 6904 default: 6905 break; 6906 } 6907 6908 return result; 6909} 6910 6911 6912/* Function for converting character constants. */ 6913gfc_expr * 6914gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) 6915{ 6916 gfc_expr *result; 6917 int i; 6918 6919 if (!gfc_is_constant_expr (e)) 6920 return NULL; 6921 6922 if (e->expr_type == EXPR_CONSTANT) 6923 { 6924 /* Simple case of a scalar. */ 6925 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); 6926 if (result == NULL) 6927 return &gfc_bad_expr; 6928 6929 result->value.character.length = e->value.character.length; 6930 result->value.character.string 6931 = gfc_get_wide_string (e->value.character.length + 1); 6932 memcpy (result->value.character.string, e->value.character.string, 6933 (e->value.character.length + 1) * sizeof (gfc_char_t)); 6934 6935 /* Check we only have values representable in the destination kind. */ 6936 for (i = 0; i < result->value.character.length; i++) 6937 if (!gfc_check_character_range (result->value.character.string[i], 6938 kind)) 6939 { 6940 gfc_error ("Character %qs in string at %L cannot be converted " 6941 "into character kind %d", 6942 gfc_print_wide_char (result->value.character.string[i]), 6943 &e->where, kind); 6944 return &gfc_bad_expr; 6945 } 6946 6947 return result; 6948 } 6949 else if (e->expr_type == EXPR_ARRAY) 6950 { 6951 /* For an array constructor, we convert each constructor element. */ 6952 gfc_constructor *c; 6953 6954 result = gfc_get_array_expr (type, kind, &e->where); 6955 result->shape = gfc_copy_shape (e->shape, e->rank); 6956 result->rank = e->rank; 6957 result->ts.u.cl = e->ts.u.cl; 6958 6959 for (c = gfc_constructor_first (e->value.constructor); 6960 c; c = gfc_constructor_next (c)) 6961 { 6962 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); 6963 if (tmp == &gfc_bad_expr) 6964 { 6965 gfc_free_expr (result); 6966 return &gfc_bad_expr; 6967 } 6968 6969 if (tmp == NULL) 6970 { 6971 gfc_free_expr (result); 6972 return NULL; 6973 } 6974 6975 gfc_constructor_append_expr (&result->value.constructor, 6976 tmp, &c->where); 6977 } 6978 6979 return result; 6980 } 6981 else 6982 return NULL; 6983} 6984 6985 6986gfc_expr * 6987gfc_simplify_compiler_options (void) 6988{ 6989 char *str; 6990 gfc_expr *result; 6991 6992 str = gfc_get_option_string (); 6993 result = gfc_get_character_expr (gfc_default_character_kind, 6994 &gfc_current_locus, str, strlen (str)); 6995 free (str); 6996 return result; 6997} 6998 6999 7000gfc_expr * 7001gfc_simplify_compiler_version (void) 7002{ 7003 char *buffer; 7004 size_t len; 7005 7006 len = strlen ("GCC version ") + strlen (version_string); 7007 buffer = XALLOCAVEC (char, len + 1); 7008 snprintf (buffer, len + 1, "GCC version %s", version_string); 7009 return gfc_get_character_expr (gfc_default_character_kind, 7010 &gfc_current_locus, buffer, len); 7011} 7012