1/* Simplify intrinsic functions at compile-time. 2 Copyright (C) 2000-2020 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 "tm.h" /* For BITS_PER_UNIT. */ 25#include "gfortran.h" 26#include "arith.h" 27#include "intrinsic.h" 28#include "match.h" 29#include "target-memory.h" 30#include "constructor.h" 31#include "version.h" /* For version_string. */ 32 33/* Prototypes. */ 34 35static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false); 36 37gfc_expr gfc_bad_expr; 38 39static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); 40 41 42/* Note that 'simplification' is not just transforming expressions. 43 For functions that are not simplified at compile time, range 44 checking is done if possible. 45 46 The return convention is that each simplification function returns: 47 48 A new expression node corresponding to the simplified arguments. 49 The original arguments are destroyed by the caller, and must not 50 be a part of the new expression. 51 52 NULL pointer indicating that no simplification was possible and 53 the original expression should remain intact. 54 55 An expression pointer to gfc_bad_expr (a static placeholder) 56 indicating that some error has prevented simplification. The 57 error is generated within the function and should be propagated 58 upwards 59 60 By the time a simplification function gets control, it has been 61 decided that the function call is really supposed to be the 62 intrinsic. No type checking is strictly necessary, since only 63 valid types will be passed on. On the other hand, a simplification 64 subroutine may have to look at the type of an argument as part of 65 its processing. 66 67 Array arguments are only passed to these subroutines that implement 68 the simplification of transformational intrinsics. 69 70 The functions in this file don't have much comment with them, but 71 everything is reasonably straight-forward. The Standard, chapter 13 72 is the best comment you'll find for this file anyway. */ 73 74/* Range checks an expression node. If all goes well, returns the 75 node, otherwise returns &gfc_bad_expr and frees the node. */ 76 77static gfc_expr * 78range_check (gfc_expr *result, const char *name) 79{ 80 if (result == NULL) 81 return &gfc_bad_expr; 82 83 if (result->expr_type != EXPR_CONSTANT) 84 return result; 85 86 switch (gfc_range_check (result)) 87 { 88 case ARITH_OK: 89 return result; 90 91 case ARITH_OVERFLOW: 92 gfc_error ("Result of %s overflows its kind at %L", name, 93 &result->where); 94 break; 95 96 case ARITH_UNDERFLOW: 97 gfc_error ("Result of %s underflows its kind at %L", name, 98 &result->where); 99 break; 100 101 case ARITH_NAN: 102 gfc_error ("Result of %s is NaN at %L", name, &result->where); 103 break; 104 105 default: 106 gfc_error ("Result of %s gives range error for its kind at %L", name, 107 &result->where); 108 break; 109 } 110 111 gfc_free_expr (result); 112 return &gfc_bad_expr; 113} 114 115 116/* A helper function that gets an optional and possibly missing 117 kind parameter. Returns the kind, -1 if something went wrong. */ 118 119static int 120get_kind (bt type, gfc_expr *k, const char *name, int default_kind) 121{ 122 int kind; 123 124 if (k == NULL) 125 return default_kind; 126 127 if (k->expr_type != EXPR_CONSTANT) 128 { 129 gfc_error ("KIND parameter of %s at %L must be an initialization " 130 "expression", name, &k->where); 131 return -1; 132 } 133 134 if (gfc_extract_int (k, &kind) 135 || gfc_validate_kind (type, kind, true) < 0) 136 { 137 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); 138 return -1; 139 } 140 141 return kind; 142} 143 144 145/* Converts an mpz_t signed variable into an unsigned one, assuming 146 two's complement representations and a binary width of bitsize. 147 The conversion is a no-op unless x is negative; otherwise, it can 148 be accomplished by masking out the high bits. */ 149 150static void 151convert_mpz_to_unsigned (mpz_t x, int bitsize) 152{ 153 mpz_t mask; 154 155 if (mpz_sgn (x) < 0) 156 { 157 /* Confirm that no bits above the signed range are unset if we 158 are doing range checking. */ 159 if (flag_range_check != 0) 160 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); 161 162 mpz_init_set_ui (mask, 1); 163 mpz_mul_2exp (mask, mask, bitsize); 164 mpz_sub_ui (mask, mask, 1); 165 166 mpz_and (x, x, mask); 167 168 mpz_clear (mask); 169 } 170 else 171 { 172 /* Confirm that no bits above the signed range are set if we 173 are doing range checking. */ 174 if (flag_range_check != 0) 175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); 176 } 177} 178 179 180/* Converts an mpz_t unsigned variable into a signed one, assuming 181 two's complement representations and a binary width of bitsize. 182 If the bitsize-1 bit is set, this is taken as a sign bit and 183 the number is converted to the corresponding negative number. */ 184 185void 186gfc_convert_mpz_to_signed (mpz_t x, int bitsize) 187{ 188 mpz_t mask; 189 190 /* Confirm that no bits above the unsigned range are set if we are 191 doing range checking. */ 192 if (flag_range_check != 0) 193 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); 194 195 if (mpz_tstbit (x, bitsize - 1) == 1) 196 { 197 mpz_init_set_ui (mask, 1); 198 mpz_mul_2exp (mask, mask, bitsize); 199 mpz_sub_ui (mask, mask, 1); 200 201 /* We negate the number by hand, zeroing the high bits, that is 202 make it the corresponding positive number, and then have it 203 negated by GMP, giving the correct representation of the 204 negative number. */ 205 mpz_com (x, x); 206 mpz_add_ui (x, x, 1); 207 mpz_and (x, x, mask); 208 209 mpz_neg (x, x); 210 211 mpz_clear (mask); 212 } 213} 214 215 216/* Test that the expression is a constant array, simplifying if 217 we are dealing with a parameter array. */ 218 219static bool 220is_constant_array_expr (gfc_expr *e) 221{ 222 gfc_constructor *c; 223 224 if (e == NULL) 225 return true; 226 227 if (e->expr_type == EXPR_VARIABLE && e->rank > 0 228 && e->symtree->n.sym->attr.flavor == FL_PARAMETER) 229 gfc_simplify_expr (e, 1); 230 231 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) 232 return false; 233 234 for (c = gfc_constructor_first (e->value.constructor); 235 c; c = gfc_constructor_next (c)) 236 if (c->expr->expr_type != EXPR_CONSTANT 237 && c->expr->expr_type != EXPR_STRUCTURE) 238 return false; 239 240 return true; 241} 242 243/* Test for a size zero array. */ 244bool 245gfc_is_size_zero_array (gfc_expr *array) 246{ 247 248 if (array->rank == 0) 249 return false; 250 251 if (array->expr_type == EXPR_VARIABLE && array->rank > 0 252 && array->symtree->n.sym->attr.flavor == FL_PARAMETER 253 && array->shape != NULL) 254 { 255 for (int i = 0; i < array->rank; i++) 256 if (mpz_cmp_si (array->shape[i], 0) <= 0) 257 return true; 258 259 return false; 260 } 261 262 if (array->expr_type == EXPR_ARRAY) 263 return array->value.constructor == NULL; 264 265 return false; 266} 267 268 269/* Initialize a transformational result expression with a given value. */ 270 271static void 272init_result_expr (gfc_expr *e, int init, gfc_expr *array) 273{ 274 if (e && e->expr_type == EXPR_ARRAY) 275 { 276 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); 277 while (ctor) 278 { 279 init_result_expr (ctor->expr, init, array); 280 ctor = gfc_constructor_next (ctor); 281 } 282 } 283 else if (e && e->expr_type == EXPR_CONSTANT) 284 { 285 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 286 HOST_WIDE_INT length; 287 gfc_char_t *string; 288 289 switch (e->ts.type) 290 { 291 case BT_LOGICAL: 292 e->value.logical = (init ? 1 : 0); 293 break; 294 295 case BT_INTEGER: 296 if (init == INT_MIN) 297 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int); 298 else if (init == INT_MAX) 299 mpz_set (e->value.integer, gfc_integer_kinds[i].huge); 300 else 301 mpz_set_si (e->value.integer, init); 302 break; 303 304 case BT_REAL: 305 if (init == INT_MIN) 306 { 307 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 308 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); 309 } 310 else if (init == INT_MAX) 311 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 312 else 313 mpfr_set_si (e->value.real, init, GFC_RND_MODE); 314 break; 315 316 case BT_COMPLEX: 317 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); 318 break; 319 320 case BT_CHARACTER: 321 if (init == INT_MIN) 322 { 323 gfc_expr *len = gfc_simplify_len (array, NULL); 324 gfc_extract_hwi (len, &length); 325 string = gfc_get_wide_string (length + 1); 326 gfc_wide_memset (string, 0, length); 327 } 328 else if (init == INT_MAX) 329 { 330 gfc_expr *len = gfc_simplify_len (array, NULL); 331 gfc_extract_hwi (len, &length); 332 string = gfc_get_wide_string (length + 1); 333 gfc_wide_memset (string, 255, length); 334 } 335 else 336 { 337 length = 0; 338 string = gfc_get_wide_string (1); 339 } 340 341 string[length] = '\0'; 342 e->value.character.length = length; 343 e->value.character.string = string; 344 break; 345 346 default: 347 gcc_unreachable(); 348 } 349 } 350 else 351 gcc_unreachable(); 352} 353 354 355/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul; 356 if conj_a is true, the matrix_a is complex conjugated. */ 357 358static gfc_expr * 359compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, 360 gfc_expr *matrix_b, int stride_b, int offset_b, 361 bool conj_a) 362{ 363 gfc_expr *result, *a, *b, *c; 364 365 /* Set result to an INTEGER(1) 0 for numeric types and .false. for 366 LOGICAL. Mixed-mode math in the loop will promote result to the 367 correct type and kind. */ 368 if (matrix_a->ts.type == BT_LOGICAL) 369 result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); 370 else 371 result = gfc_get_int_expr (1, NULL, 0); 372 result->where = matrix_a->where; 373 374 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); 375 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); 376 while (a && b) 377 { 378 /* Copying of expressions is required as operands are free'd 379 by the gfc_arith routines. */ 380 switch (result->ts.type) 381 { 382 case BT_LOGICAL: 383 result = gfc_or (result, 384 gfc_and (gfc_copy_expr (a), 385 gfc_copy_expr (b))); 386 break; 387 388 case BT_INTEGER: 389 case BT_REAL: 390 case BT_COMPLEX: 391 if (conj_a && a->ts.type == BT_COMPLEX) 392 c = gfc_simplify_conjg (a); 393 else 394 c = gfc_copy_expr (a); 395 result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b))); 396 break; 397 398 default: 399 gcc_unreachable(); 400 } 401 402 offset_a += stride_a; 403 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); 404 405 offset_b += stride_b; 406 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); 407 } 408 409 return result; 410} 411 412 413/* Build a result expression for transformational intrinsics, 414 depending on DIM. */ 415 416static gfc_expr * 417transformational_result (gfc_expr *array, gfc_expr *dim, bt type, 418 int kind, locus* where) 419{ 420 gfc_expr *result; 421 int i, nelem; 422 423 if (!dim || array->rank == 1) 424 return gfc_get_constant_expr (type, kind, where); 425 426 result = gfc_get_array_expr (type, kind, where); 427 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); 428 result->rank = array->rank - 1; 429 430 /* gfc_array_size() would count the number of elements in the constructor, 431 we have not built those yet. */ 432 nelem = 1; 433 for (i = 0; i < result->rank; ++i) 434 nelem *= mpz_get_ui (result->shape[i]); 435 436 for (i = 0; i < nelem; ++i) 437 { 438 gfc_constructor_append_expr (&result->value.constructor, 439 gfc_get_constant_expr (type, kind, where), 440 NULL); 441 } 442 443 return result; 444} 445 446 447typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); 448 449/* Wrapper function, implements 'op1 += 1'. Only called if MASK 450 of COUNT intrinsic is .TRUE.. 451 452 Interface and implementation mimics arith functions as 453 gfc_add, gfc_multiply, etc. */ 454 455static gfc_expr * 456gfc_count (gfc_expr *op1, gfc_expr *op2) 457{ 458 gfc_expr *result; 459 460 gcc_assert (op1->ts.type == BT_INTEGER); 461 gcc_assert (op2->ts.type == BT_LOGICAL); 462 gcc_assert (op2->value.logical); 463 464 result = gfc_copy_expr (op1); 465 mpz_add_ui (result->value.integer, result->value.integer, 1); 466 467 gfc_free_expr (op1); 468 gfc_free_expr (op2); 469 return result; 470} 471 472 473/* Transforms an ARRAY with operation OP, according to MASK, to a 474 scalar RESULT. E.g. called if 475 476 REAL, PARAMETER :: array(n, m) = ... 477 REAL, PARAMETER :: s = SUM(array) 478 479 where OP == gfc_add(). */ 480 481static gfc_expr * 482simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, 483 transformational_op op) 484{ 485 gfc_expr *a, *m; 486 gfc_constructor *array_ctor, *mask_ctor; 487 488 /* Shortcut for constant .FALSE. MASK. */ 489 if (mask 490 && mask->expr_type == EXPR_CONSTANT 491 && !mask->value.logical) 492 return result; 493 494 array_ctor = gfc_constructor_first (array->value.constructor); 495 mask_ctor = NULL; 496 if (mask && mask->expr_type == EXPR_ARRAY) 497 mask_ctor = gfc_constructor_first (mask->value.constructor); 498 499 while (array_ctor) 500 { 501 a = array_ctor->expr; 502 array_ctor = gfc_constructor_next (array_ctor); 503 504 /* A constant MASK equals .TRUE. here and can be ignored. */ 505 if (mask_ctor) 506 { 507 m = mask_ctor->expr; 508 mask_ctor = gfc_constructor_next (mask_ctor); 509 if (!m->value.logical) 510 continue; 511 } 512 513 result = op (result, gfc_copy_expr (a)); 514 if (!result) 515 return result; 516 } 517 518 return result; 519} 520 521/* Transforms an ARRAY with operation OP, according to MASK, to an 522 array RESULT. E.g. called if 523 524 REAL, PARAMETER :: array(n, m) = ... 525 REAL, PARAMETER :: s(n) = PROD(array, DIM=1) 526 527 where OP == gfc_multiply(). 528 The result might be post processed using post_op. */ 529 530static gfc_expr * 531simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, 532 gfc_expr *mask, transformational_op op, 533 transformational_op post_op) 534{ 535 mpz_t size; 536 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 537 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 538 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 539 540 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 541 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 542 tmpstride[GFC_MAX_DIMENSIONS]; 543 544 /* Shortcut for constant .FALSE. MASK. */ 545 if (mask 546 && mask->expr_type == EXPR_CONSTANT 547 && !mask->value.logical) 548 return result; 549 550 /* Build an indexed table for array element expressions to minimize 551 linked-list traversal. Masked elements are set to NULL. */ 552 gfc_array_size (array, &size); 553 arraysize = mpz_get_ui (size); 554 mpz_clear (size); 555 556 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 557 558 array_ctor = gfc_constructor_first (array->value.constructor); 559 mask_ctor = NULL; 560 if (mask && mask->expr_type == EXPR_ARRAY) 561 mask_ctor = gfc_constructor_first (mask->value.constructor); 562 563 for (i = 0; i < arraysize; ++i) 564 { 565 arrayvec[i] = array_ctor->expr; 566 array_ctor = gfc_constructor_next (array_ctor); 567 568 if (mask_ctor) 569 { 570 if (!mask_ctor->expr->value.logical) 571 arrayvec[i] = NULL; 572 573 mask_ctor = gfc_constructor_next (mask_ctor); 574 } 575 } 576 577 /* Same for the result expression. */ 578 gfc_array_size (result, &size); 579 resultsize = mpz_get_ui (size); 580 mpz_clear (size); 581 582 resultvec = XCNEWVEC (gfc_expr*, resultsize); 583 result_ctor = gfc_constructor_first (result->value.constructor); 584 for (i = 0; i < resultsize; ++i) 585 { 586 resultvec[i] = result_ctor->expr; 587 result_ctor = gfc_constructor_next (result_ctor); 588 } 589 590 gfc_extract_int (dim, &dim_index); 591 dim_index -= 1; /* zero-base index */ 592 dim_extent = 0; 593 dim_stride = 0; 594 595 for (i = 0, n = 0; i < array->rank; ++i) 596 { 597 count[i] = 0; 598 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 599 if (i == dim_index) 600 { 601 dim_extent = mpz_get_si (array->shape[i]); 602 dim_stride = tmpstride[i]; 603 continue; 604 } 605 606 extent[n] = mpz_get_si (array->shape[i]); 607 sstride[n] = tmpstride[i]; 608 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 609 n += 1; 610 } 611 612 done = resultsize <= 0; 613 base = arrayvec; 614 dest = resultvec; 615 while (!done) 616 { 617 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 618 if (*src) 619 *dest = op (*dest, gfc_copy_expr (*src)); 620 621 if (post_op) 622 *dest = post_op (*dest, *dest); 623 624 count[0]++; 625 base += sstride[0]; 626 dest += dstride[0]; 627 628 n = 0; 629 while (!done && count[n] == extent[n]) 630 { 631 count[n] = 0; 632 base -= sstride[n] * extent[n]; 633 dest -= dstride[n] * extent[n]; 634 635 n++; 636 if (n < result->rank) 637 { 638 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 639 times, we'd warn for the last iteration, because the 640 array index will have already been incremented to the 641 array sizes, and we can't tell that this must make 642 the test against result->rank false, because ranks 643 must not exceed GFC_MAX_DIMENSIONS. */ 644 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 645 count[n]++; 646 base += sstride[n]; 647 dest += dstride[n]; 648 GCC_DIAGNOSTIC_POP 649 } 650 else 651 done = true; 652 } 653 } 654 655 /* Place updated expression in result constructor. */ 656 result_ctor = gfc_constructor_first (result->value.constructor); 657 for (i = 0; i < resultsize; ++i) 658 { 659 result_ctor->expr = resultvec[i]; 660 result_ctor = gfc_constructor_next (result_ctor); 661 } 662 663 free (arrayvec); 664 free (resultvec); 665 return result; 666} 667 668 669static gfc_expr * 670simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 671 int init_val, transformational_op op) 672{ 673 gfc_expr *result; 674 bool size_zero; 675 676 size_zero = gfc_is_size_zero_array (array); 677 678 if (!(is_constant_array_expr (array) || size_zero) 679 || array->shape == NULL 680 || !gfc_is_constant_expr (dim)) 681 return NULL; 682 683 if (mask 684 && !is_constant_array_expr (mask) 685 && mask->expr_type != EXPR_CONSTANT) 686 return NULL; 687 688 result = transformational_result (array, dim, array->ts.type, 689 array->ts.kind, &array->where); 690 init_result_expr (result, init_val, array); 691 692 if (size_zero) 693 return result; 694 695 return !dim || array->rank == 1 ? 696 simplify_transformation_to_scalar (result, array, mask, op) : 697 simplify_transformation_to_array (result, array, dim, mask, op, NULL); 698} 699 700 701/********************** Simplification functions *****************************/ 702 703gfc_expr * 704gfc_simplify_abs (gfc_expr *e) 705{ 706 gfc_expr *result; 707 708 if (e->expr_type != EXPR_CONSTANT) 709 return NULL; 710 711 switch (e->ts.type) 712 { 713 case BT_INTEGER: 714 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); 715 mpz_abs (result->value.integer, e->value.integer); 716 return range_check (result, "IABS"); 717 718 case BT_REAL: 719 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 720 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); 721 return range_check (result, "ABS"); 722 723 case BT_COMPLEX: 724 gfc_set_model_kind (e->ts.kind); 725 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 726 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); 727 return range_check (result, "CABS"); 728 729 default: 730 gfc_internal_error ("gfc_simplify_abs(): Bad type"); 731 } 732} 733 734 735static gfc_expr * 736simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) 737{ 738 gfc_expr *result; 739 int kind; 740 bool too_large = false; 741 742 if (e->expr_type != EXPR_CONSTANT) 743 return NULL; 744 745 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); 746 if (kind == -1) 747 return &gfc_bad_expr; 748 749 if (mpz_cmp_si (e->value.integer, 0) < 0) 750 { 751 gfc_error ("Argument of %s function at %L is negative", name, 752 &e->where); 753 return &gfc_bad_expr; 754 } 755 756 if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0) 757 gfc_warning (OPT_Wsurprising, 758 "Argument of %s function at %L outside of range [0,127]", 759 name, &e->where); 760 761 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) 762 too_large = true; 763 else if (kind == 4) 764 { 765 mpz_t t; 766 mpz_init_set_ui (t, 2); 767 mpz_pow_ui (t, t, 32); 768 mpz_sub_ui (t, t, 1); 769 if (mpz_cmp (e->value.integer, t) > 0) 770 too_large = true; 771 mpz_clear (t); 772 } 773 774 if (too_large) 775 { 776 gfc_error ("Argument of %s function at %L is too large for the " 777 "collating sequence of kind %d", name, &e->where, kind); 778 return &gfc_bad_expr; 779 } 780 781 result = gfc_get_character_expr (kind, &e->where, NULL, 1); 782 result->value.character.string[0] = mpz_get_ui (e->value.integer); 783 784 return result; 785} 786 787 788 789/* We use the processor's collating sequence, because all 790 systems that gfortran currently works on are ASCII. */ 791 792gfc_expr * 793gfc_simplify_achar (gfc_expr *e, gfc_expr *k) 794{ 795 return simplify_achar_char (e, k, "ACHAR", true); 796} 797 798 799gfc_expr * 800gfc_simplify_acos (gfc_expr *x) 801{ 802 gfc_expr *result; 803 804 if (x->expr_type != EXPR_CONSTANT) 805 return NULL; 806 807 switch (x->ts.type) 808 { 809 case BT_REAL: 810 if (mpfr_cmp_si (x->value.real, 1) > 0 811 || mpfr_cmp_si (x->value.real, -1) < 0) 812 { 813 gfc_error ("Argument of ACOS at %L must be between -1 and 1", 814 &x->where); 815 return &gfc_bad_expr; 816 } 817 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 818 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); 819 break; 820 821 case BT_COMPLEX: 822 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 823 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 824 break; 825 826 default: 827 gfc_internal_error ("in gfc_simplify_acos(): Bad type"); 828 } 829 830 return range_check (result, "ACOS"); 831} 832 833gfc_expr * 834gfc_simplify_acosh (gfc_expr *x) 835{ 836 gfc_expr *result; 837 838 if (x->expr_type != EXPR_CONSTANT) 839 return NULL; 840 841 switch (x->ts.type) 842 { 843 case BT_REAL: 844 if (mpfr_cmp_si (x->value.real, 1) < 0) 845 { 846 gfc_error ("Argument of ACOSH at %L must not be less than 1", 847 &x->where); 848 return &gfc_bad_expr; 849 } 850 851 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 852 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); 853 break; 854 855 case BT_COMPLEX: 856 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 857 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 858 break; 859 860 default: 861 gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); 862 } 863 864 return range_check (result, "ACOSH"); 865} 866 867gfc_expr * 868gfc_simplify_adjustl (gfc_expr *e) 869{ 870 gfc_expr *result; 871 int count, i, len; 872 gfc_char_t ch; 873 874 if (e->expr_type != EXPR_CONSTANT) 875 return NULL; 876 877 len = e->value.character.length; 878 879 for (count = 0, i = 0; i < len; ++i) 880 { 881 ch = e->value.character.string[i]; 882 if (ch != ' ') 883 break; 884 ++count; 885 } 886 887 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); 888 for (i = 0; i < len - count; ++i) 889 result->value.character.string[i] = e->value.character.string[count + i]; 890 891 return result; 892} 893 894 895gfc_expr * 896gfc_simplify_adjustr (gfc_expr *e) 897{ 898 gfc_expr *result; 899 int count, i, len; 900 gfc_char_t ch; 901 902 if (e->expr_type != EXPR_CONSTANT) 903 return NULL; 904 905 len = e->value.character.length; 906 907 for (count = 0, i = len - 1; i >= 0; --i) 908 { 909 ch = e->value.character.string[i]; 910 if (ch != ' ') 911 break; 912 ++count; 913 } 914 915 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); 916 for (i = 0; i < count; ++i) 917 result->value.character.string[i] = ' '; 918 919 for (i = count; i < len; ++i) 920 result->value.character.string[i] = e->value.character.string[i - count]; 921 922 return result; 923} 924 925 926gfc_expr * 927gfc_simplify_aimag (gfc_expr *e) 928{ 929 gfc_expr *result; 930 931 if (e->expr_type != EXPR_CONSTANT) 932 return NULL; 933 934 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 935 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); 936 937 return range_check (result, "AIMAG"); 938} 939 940 941gfc_expr * 942gfc_simplify_aint (gfc_expr *e, gfc_expr *k) 943{ 944 gfc_expr *rtrunc, *result; 945 int kind; 946 947 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); 948 if (kind == -1) 949 return &gfc_bad_expr; 950 951 if (e->expr_type != EXPR_CONSTANT) 952 return NULL; 953 954 rtrunc = gfc_copy_expr (e); 955 mpfr_trunc (rtrunc->value.real, e->value.real); 956 957 result = gfc_real2real (rtrunc, kind); 958 959 gfc_free_expr (rtrunc); 960 961 return range_check (result, "AINT"); 962} 963 964 965gfc_expr * 966gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) 967{ 968 return simplify_transformation (mask, dim, NULL, true, gfc_and); 969} 970 971 972gfc_expr * 973gfc_simplify_dint (gfc_expr *e) 974{ 975 gfc_expr *rtrunc, *result; 976 977 if (e->expr_type != EXPR_CONSTANT) 978 return NULL; 979 980 rtrunc = gfc_copy_expr (e); 981 mpfr_trunc (rtrunc->value.real, e->value.real); 982 983 result = gfc_real2real (rtrunc, gfc_default_double_kind); 984 985 gfc_free_expr (rtrunc); 986 987 return range_check (result, "DINT"); 988} 989 990 991gfc_expr * 992gfc_simplify_dreal (gfc_expr *e) 993{ 994 gfc_expr *result = NULL; 995 996 if (e->expr_type != EXPR_CONSTANT) 997 return NULL; 998 999 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 1000 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); 1001 1002 return range_check (result, "DREAL"); 1003} 1004 1005 1006gfc_expr * 1007gfc_simplify_anint (gfc_expr *e, gfc_expr *k) 1008{ 1009 gfc_expr *result; 1010 int kind; 1011 1012 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); 1013 if (kind == -1) 1014 return &gfc_bad_expr; 1015 1016 if (e->expr_type != EXPR_CONSTANT) 1017 return NULL; 1018 1019 result = gfc_get_constant_expr (e->ts.type, kind, &e->where); 1020 mpfr_round (result->value.real, e->value.real); 1021 1022 return range_check (result, "ANINT"); 1023} 1024 1025 1026gfc_expr * 1027gfc_simplify_and (gfc_expr *x, gfc_expr *y) 1028{ 1029 gfc_expr *result; 1030 int kind; 1031 1032 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1033 return NULL; 1034 1035 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 1036 1037 switch (x->ts.type) 1038 { 1039 case BT_INTEGER: 1040 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 1041 mpz_and (result->value.integer, x->value.integer, y->value.integer); 1042 return range_check (result, "AND"); 1043 1044 case BT_LOGICAL: 1045 return gfc_get_logical_expr (kind, &x->where, 1046 x->value.logical && y->value.logical); 1047 1048 default: 1049 gcc_unreachable (); 1050 } 1051} 1052 1053 1054gfc_expr * 1055gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) 1056{ 1057 return simplify_transformation (mask, dim, NULL, false, gfc_or); 1058} 1059 1060 1061gfc_expr * 1062gfc_simplify_dnint (gfc_expr *e) 1063{ 1064 gfc_expr *result; 1065 1066 if (e->expr_type != EXPR_CONSTANT) 1067 return NULL; 1068 1069 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); 1070 mpfr_round (result->value.real, e->value.real); 1071 1072 return range_check (result, "DNINT"); 1073} 1074 1075 1076gfc_expr * 1077gfc_simplify_asin (gfc_expr *x) 1078{ 1079 gfc_expr *result; 1080 1081 if (x->expr_type != EXPR_CONSTANT) 1082 return NULL; 1083 1084 switch (x->ts.type) 1085 { 1086 case BT_REAL: 1087 if (mpfr_cmp_si (x->value.real, 1) > 0 1088 || mpfr_cmp_si (x->value.real, -1) < 0) 1089 { 1090 gfc_error ("Argument of ASIN at %L must be between -1 and 1", 1091 &x->where); 1092 return &gfc_bad_expr; 1093 } 1094 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1095 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); 1096 break; 1097 1098 case BT_COMPLEX: 1099 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1100 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1101 break; 1102 1103 default: 1104 gfc_internal_error ("in gfc_simplify_asin(): Bad type"); 1105 } 1106 1107 return range_check (result, "ASIN"); 1108} 1109 1110 1111/* Convert radians to degrees, i.e., x * 180 / pi. */ 1112 1113static void 1114rad2deg (mpfr_t x) 1115{ 1116 mpfr_t tmp; 1117 1118 mpfr_init (tmp); 1119 mpfr_const_pi (tmp, GFC_RND_MODE); 1120 mpfr_mul_ui (x, x, 180, GFC_RND_MODE); 1121 mpfr_div (x, x, tmp, GFC_RND_MODE); 1122 mpfr_clear (tmp); 1123} 1124 1125 1126/* Simplify ACOSD(X) where the returned value has units of degree. */ 1127 1128gfc_expr * 1129gfc_simplify_acosd (gfc_expr *x) 1130{ 1131 gfc_expr *result; 1132 1133 if (x->expr_type != EXPR_CONSTANT) 1134 return NULL; 1135 1136 if (mpfr_cmp_si (x->value.real, 1) > 0 1137 || mpfr_cmp_si (x->value.real, -1) < 0) 1138 { 1139 gfc_error ("Argument of ACOSD at %L must be between -1 and 1", 1140 &x->where); 1141 return &gfc_bad_expr; 1142 } 1143 1144 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1145 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); 1146 rad2deg (result->value.real); 1147 1148 return range_check (result, "ACOSD"); 1149} 1150 1151 1152/* Simplify asind (x) where the returned value has units of degree. */ 1153 1154gfc_expr * 1155gfc_simplify_asind (gfc_expr *x) 1156{ 1157 gfc_expr *result; 1158 1159 if (x->expr_type != EXPR_CONSTANT) 1160 return NULL; 1161 1162 if (mpfr_cmp_si (x->value.real, 1) > 0 1163 || mpfr_cmp_si (x->value.real, -1) < 0) 1164 { 1165 gfc_error ("Argument of ASIND at %L must be between -1 and 1", 1166 &x->where); 1167 return &gfc_bad_expr; 1168 } 1169 1170 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1171 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); 1172 rad2deg (result->value.real); 1173 1174 return range_check (result, "ASIND"); 1175} 1176 1177 1178/* Simplify atand (x) where the returned value has units of degree. */ 1179 1180gfc_expr * 1181gfc_simplify_atand (gfc_expr *x) 1182{ 1183 gfc_expr *result; 1184 1185 if (x->expr_type != EXPR_CONSTANT) 1186 return NULL; 1187 1188 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1189 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); 1190 rad2deg (result->value.real); 1191 1192 return range_check (result, "ATAND"); 1193} 1194 1195 1196gfc_expr * 1197gfc_simplify_asinh (gfc_expr *x) 1198{ 1199 gfc_expr *result; 1200 1201 if (x->expr_type != EXPR_CONSTANT) 1202 return NULL; 1203 1204 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1205 1206 switch (x->ts.type) 1207 { 1208 case BT_REAL: 1209 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); 1210 break; 1211 1212 case BT_COMPLEX: 1213 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1214 break; 1215 1216 default: 1217 gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); 1218 } 1219 1220 return range_check (result, "ASINH"); 1221} 1222 1223 1224gfc_expr * 1225gfc_simplify_atan (gfc_expr *x) 1226{ 1227 gfc_expr *result; 1228 1229 if (x->expr_type != EXPR_CONSTANT) 1230 return NULL; 1231 1232 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1233 1234 switch (x->ts.type) 1235 { 1236 case BT_REAL: 1237 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); 1238 break; 1239 1240 case BT_COMPLEX: 1241 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1242 break; 1243 1244 default: 1245 gfc_internal_error ("in gfc_simplify_atan(): Bad type"); 1246 } 1247 1248 return range_check (result, "ATAN"); 1249} 1250 1251 1252gfc_expr * 1253gfc_simplify_atanh (gfc_expr *x) 1254{ 1255 gfc_expr *result; 1256 1257 if (x->expr_type != EXPR_CONSTANT) 1258 return NULL; 1259 1260 switch (x->ts.type) 1261 { 1262 case BT_REAL: 1263 if (mpfr_cmp_si (x->value.real, 1) >= 0 1264 || mpfr_cmp_si (x->value.real, -1) <= 0) 1265 { 1266 gfc_error ("Argument of ATANH at %L must be inside the range -1 " 1267 "to 1", &x->where); 1268 return &gfc_bad_expr; 1269 } 1270 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1271 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); 1272 break; 1273 1274 case BT_COMPLEX: 1275 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1276 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1277 break; 1278 1279 default: 1280 gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); 1281 } 1282 1283 return range_check (result, "ATANH"); 1284} 1285 1286 1287gfc_expr * 1288gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) 1289{ 1290 gfc_expr *result; 1291 1292 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1293 return NULL; 1294 1295 if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) 1296 { 1297 gfc_error ("If first argument of ATAN2 at %L is zero, then the " 1298 "second argument must not be zero", &y->where); 1299 return &gfc_bad_expr; 1300 } 1301 1302 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1303 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); 1304 1305 return range_check (result, "ATAN2"); 1306} 1307 1308 1309gfc_expr * 1310gfc_simplify_bessel_j0 (gfc_expr *x) 1311{ 1312 gfc_expr *result; 1313 1314 if (x->expr_type != EXPR_CONSTANT) 1315 return NULL; 1316 1317 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1318 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); 1319 1320 return range_check (result, "BESSEL_J0"); 1321} 1322 1323 1324gfc_expr * 1325gfc_simplify_bessel_j1 (gfc_expr *x) 1326{ 1327 gfc_expr *result; 1328 1329 if (x->expr_type != EXPR_CONSTANT) 1330 return NULL; 1331 1332 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1333 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); 1334 1335 return range_check (result, "BESSEL_J1"); 1336} 1337 1338 1339gfc_expr * 1340gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) 1341{ 1342 gfc_expr *result; 1343 long n; 1344 1345 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1346 return NULL; 1347 1348 n = mpz_get_si (order->value.integer); 1349 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1350 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); 1351 1352 return range_check (result, "BESSEL_JN"); 1353} 1354 1355 1356/* Simplify transformational form of JN and YN. */ 1357 1358static gfc_expr * 1359gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, 1360 bool jn) 1361{ 1362 gfc_expr *result; 1363 gfc_expr *e; 1364 long n1, n2; 1365 int i; 1366 mpfr_t x2rev, last1, last2; 1367 1368 if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT 1369 || order2->expr_type != EXPR_CONSTANT) 1370 return NULL; 1371 1372 n1 = mpz_get_si (order1->value.integer); 1373 n2 = mpz_get_si (order2->value.integer); 1374 result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); 1375 result->rank = 1; 1376 result->shape = gfc_get_shape (1); 1377 mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); 1378 1379 if (n2 < n1) 1380 return result; 1381 1382 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and 1383 YN(N, 0.0) = -Inf. */ 1384 1385 if (mpfr_cmp_ui (x->value.real, 0.0) == 0) 1386 { 1387 if (!jn && flag_range_check) 1388 { 1389 gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); 1390 gfc_free_expr (result); 1391 return &gfc_bad_expr; 1392 } 1393 1394 if (jn && n1 == 0) 1395 { 1396 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1397 mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); 1398 gfc_constructor_append_expr (&result->value.constructor, e, 1399 &x->where); 1400 n1++; 1401 } 1402 1403 for (i = n1; i <= n2; i++) 1404 { 1405 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1406 if (jn) 1407 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); 1408 else 1409 mpfr_set_inf (e->value.real, -1); 1410 gfc_constructor_append_expr (&result->value.constructor, e, 1411 &x->where); 1412 } 1413 1414 return result; 1415 } 1416 1417 /* Use the faster but more verbose recurrence algorithm. Bessel functions 1418 are stable for downward recursion and Neumann functions are stable 1419 for upward recursion. It is 1420 x2rev = 2.0/x, 1421 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), 1422 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). 1423 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ 1424 1425 gfc_set_model_kind (x->ts.kind); 1426 1427 /* Get first recursion anchor. */ 1428 1429 mpfr_init (last1); 1430 if (jn) 1431 mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); 1432 else 1433 mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); 1434 1435 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1436 mpfr_set (e->value.real, last1, GFC_RND_MODE); 1437 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1438 { 1439 mpfr_clear (last1); 1440 gfc_free_expr (e); 1441 gfc_free_expr (result); 1442 return &gfc_bad_expr; 1443 } 1444 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1445 1446 if (n1 == n2) 1447 { 1448 mpfr_clear (last1); 1449 return result; 1450 } 1451 1452 /* Get second recursion anchor. */ 1453 1454 mpfr_init (last2); 1455 if (jn) 1456 mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); 1457 else 1458 mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); 1459 1460 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1461 mpfr_set (e->value.real, last2, GFC_RND_MODE); 1462 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1463 { 1464 mpfr_clear (last1); 1465 mpfr_clear (last2); 1466 gfc_free_expr (e); 1467 gfc_free_expr (result); 1468 return &gfc_bad_expr; 1469 } 1470 if (jn) 1471 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); 1472 else 1473 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1474 1475 if (n1 + 1 == n2) 1476 { 1477 mpfr_clear (last1); 1478 mpfr_clear (last2); 1479 return result; 1480 } 1481 1482 /* Start actual recursion. */ 1483 1484 mpfr_init (x2rev); 1485 mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); 1486 1487 for (i = 2; i <= n2-n1; i++) 1488 { 1489 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1490 1491 /* Special case: For YN, if the previous N gave -INF, set 1492 also N+1 to -INF. */ 1493 if (!jn && !flag_range_check && mpfr_inf_p (last2)) 1494 { 1495 mpfr_set_inf (e->value.real, -1); 1496 gfc_constructor_append_expr (&result->value.constructor, e, 1497 &x->where); 1498 continue; 1499 } 1500 1501 mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), 1502 GFC_RND_MODE); 1503 mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); 1504 mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); 1505 1506 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1507 { 1508 /* Range_check frees "e" in that case. */ 1509 e = NULL; 1510 goto error; 1511 } 1512 1513 if (jn) 1514 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, 1515 -i-1); 1516 else 1517 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1518 1519 mpfr_set (last1, last2, GFC_RND_MODE); 1520 mpfr_set (last2, e->value.real, GFC_RND_MODE); 1521 } 1522 1523 mpfr_clear (last1); 1524 mpfr_clear (last2); 1525 mpfr_clear (x2rev); 1526 return result; 1527 1528error: 1529 mpfr_clear (last1); 1530 mpfr_clear (last2); 1531 mpfr_clear (x2rev); 1532 gfc_free_expr (e); 1533 gfc_free_expr (result); 1534 return &gfc_bad_expr; 1535} 1536 1537 1538gfc_expr * 1539gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1540{ 1541 return gfc_simplify_bessel_n2 (order1, order2, x, true); 1542} 1543 1544 1545gfc_expr * 1546gfc_simplify_bessel_y0 (gfc_expr *x) 1547{ 1548 gfc_expr *result; 1549 1550 if (x->expr_type != EXPR_CONSTANT) 1551 return NULL; 1552 1553 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1554 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); 1555 1556 return range_check (result, "BESSEL_Y0"); 1557} 1558 1559 1560gfc_expr * 1561gfc_simplify_bessel_y1 (gfc_expr *x) 1562{ 1563 gfc_expr *result; 1564 1565 if (x->expr_type != EXPR_CONSTANT) 1566 return NULL; 1567 1568 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1569 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); 1570 1571 return range_check (result, "BESSEL_Y1"); 1572} 1573 1574 1575gfc_expr * 1576gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) 1577{ 1578 gfc_expr *result; 1579 long n; 1580 1581 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1582 return NULL; 1583 1584 n = mpz_get_si (order->value.integer); 1585 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1586 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); 1587 1588 return range_check (result, "BESSEL_YN"); 1589} 1590 1591 1592gfc_expr * 1593gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1594{ 1595 return gfc_simplify_bessel_n2 (order1, order2, x, false); 1596} 1597 1598 1599gfc_expr * 1600gfc_simplify_bit_size (gfc_expr *e) 1601{ 1602 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 1603 return gfc_get_int_expr (e->ts.kind, &e->where, 1604 gfc_integer_kinds[i].bit_size); 1605} 1606 1607 1608gfc_expr * 1609gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) 1610{ 1611 int b; 1612 1613 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) 1614 return NULL; 1615 1616 if (gfc_extract_int (bit, &b) || b < 0) 1617 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); 1618 1619 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, 1620 mpz_tstbit (e->value.integer, b)); 1621} 1622 1623 1624static int 1625compare_bitwise (gfc_expr *i, gfc_expr *j) 1626{ 1627 mpz_t x, y; 1628 int k, res; 1629 1630 gcc_assert (i->ts.type == BT_INTEGER); 1631 gcc_assert (j->ts.type == BT_INTEGER); 1632 1633 mpz_init_set (x, i->value.integer); 1634 k = gfc_validate_kind (i->ts.type, i->ts.kind, false); 1635 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 1636 1637 mpz_init_set (y, j->value.integer); 1638 k = gfc_validate_kind (j->ts.type, j->ts.kind, false); 1639 convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); 1640 1641 res = mpz_cmp (x, y); 1642 mpz_clear (x); 1643 mpz_clear (y); 1644 return res; 1645} 1646 1647 1648gfc_expr * 1649gfc_simplify_bge (gfc_expr *i, gfc_expr *j) 1650{ 1651 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1652 return NULL; 1653 1654 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1655 compare_bitwise (i, j) >= 0); 1656} 1657 1658 1659gfc_expr * 1660gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) 1661{ 1662 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1663 return NULL; 1664 1665 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1666 compare_bitwise (i, j) > 0); 1667} 1668 1669 1670gfc_expr * 1671gfc_simplify_ble (gfc_expr *i, gfc_expr *j) 1672{ 1673 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1674 return NULL; 1675 1676 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1677 compare_bitwise (i, j) <= 0); 1678} 1679 1680 1681gfc_expr * 1682gfc_simplify_blt (gfc_expr *i, gfc_expr *j) 1683{ 1684 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1685 return NULL; 1686 1687 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1688 compare_bitwise (i, j) < 0); 1689} 1690 1691 1692gfc_expr * 1693gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) 1694{ 1695 gfc_expr *ceil, *result; 1696 int kind; 1697 1698 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); 1699 if (kind == -1) 1700 return &gfc_bad_expr; 1701 1702 if (e->expr_type != EXPR_CONSTANT) 1703 return NULL; 1704 1705 ceil = gfc_copy_expr (e); 1706 mpfr_ceil (ceil->value.real, e->value.real); 1707 1708 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 1709 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); 1710 1711 gfc_free_expr (ceil); 1712 1713 return range_check (result, "CEILING"); 1714} 1715 1716 1717gfc_expr * 1718gfc_simplify_char (gfc_expr *e, gfc_expr *k) 1719{ 1720 return simplify_achar_char (e, k, "CHAR", false); 1721} 1722 1723 1724/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ 1725 1726static gfc_expr * 1727simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 1728{ 1729 gfc_expr *result; 1730 1731 if (x->expr_type != EXPR_CONSTANT 1732 || (y != NULL && y->expr_type != EXPR_CONSTANT)) 1733 return NULL; 1734 1735 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); 1736 1737 switch (x->ts.type) 1738 { 1739 case BT_INTEGER: 1740 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); 1741 break; 1742 1743 case BT_REAL: 1744 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); 1745 break; 1746 1747 case BT_COMPLEX: 1748 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1749 break; 1750 1751 default: 1752 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); 1753 } 1754 1755 if (!y) 1756 return range_check (result, name); 1757 1758 switch (y->ts.type) 1759 { 1760 case BT_INTEGER: 1761 mpfr_set_z (mpc_imagref (result->value.complex), 1762 y->value.integer, GFC_RND_MODE); 1763 break; 1764 1765 case BT_REAL: 1766 mpfr_set (mpc_imagref (result->value.complex), 1767 y->value.real, GFC_RND_MODE); 1768 break; 1769 1770 default: 1771 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); 1772 } 1773 1774 return range_check (result, name); 1775} 1776 1777 1778gfc_expr * 1779gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) 1780{ 1781 int kind; 1782 1783 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); 1784 if (kind == -1) 1785 return &gfc_bad_expr; 1786 1787 return simplify_cmplx ("CMPLX", x, y, kind); 1788} 1789 1790 1791gfc_expr * 1792gfc_simplify_complex (gfc_expr *x, gfc_expr *y) 1793{ 1794 int kind; 1795 1796 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) 1797 kind = gfc_default_complex_kind; 1798 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) 1799 kind = x->ts.kind; 1800 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) 1801 kind = y->ts.kind; 1802 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) 1803 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; 1804 else 1805 gcc_unreachable (); 1806 1807 return simplify_cmplx ("COMPLEX", x, y, kind); 1808} 1809 1810 1811gfc_expr * 1812gfc_simplify_conjg (gfc_expr *e) 1813{ 1814 gfc_expr *result; 1815 1816 if (e->expr_type != EXPR_CONSTANT) 1817 return NULL; 1818 1819 result = gfc_copy_expr (e); 1820 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); 1821 1822 return range_check (result, "CONJG"); 1823} 1824 1825 1826/* Simplify atan2d (x) where the unit is degree. */ 1827 1828gfc_expr * 1829gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) 1830{ 1831 gfc_expr *result; 1832 1833 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1834 return NULL; 1835 1836 if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) 1837 { 1838 gfc_error ("If first argument of ATAN2D at %L is zero, then the " 1839 "second argument must not be zero", &y->where); 1840 return &gfc_bad_expr; 1841 } 1842 1843 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1844 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); 1845 rad2deg (result->value.real); 1846 1847 return range_check (result, "ATAN2D"); 1848} 1849 1850 1851gfc_expr * 1852gfc_simplify_cos (gfc_expr *x) 1853{ 1854 gfc_expr *result; 1855 1856 if (x->expr_type != EXPR_CONSTANT) 1857 return NULL; 1858 1859 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1860 1861 switch (x->ts.type) 1862 { 1863 case BT_REAL: 1864 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); 1865 break; 1866 1867 case BT_COMPLEX: 1868 gfc_set_model_kind (x->ts.kind); 1869 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1870 break; 1871 1872 default: 1873 gfc_internal_error ("in gfc_simplify_cos(): Bad type"); 1874 } 1875 1876 return range_check (result, "COS"); 1877} 1878 1879 1880static void 1881deg2rad (mpfr_t x) 1882{ 1883 mpfr_t d2r; 1884 1885 mpfr_init (d2r); 1886 mpfr_const_pi (d2r, GFC_RND_MODE); 1887 mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE); 1888 mpfr_mul (x, x, d2r, GFC_RND_MODE); 1889 mpfr_clear (d2r); 1890} 1891 1892 1893/* Simplification routines for SIND, COSD, TAND. */ 1894#include "trigd_fe.inc" 1895 1896 1897/* Simplify COSD(X) where X has the unit of degree. */ 1898 1899gfc_expr * 1900gfc_simplify_cosd (gfc_expr *x) 1901{ 1902 gfc_expr *result; 1903 1904 if (x->expr_type != EXPR_CONSTANT) 1905 return NULL; 1906 1907 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1908 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 1909 simplify_cosd (result->value.real); 1910 1911 return range_check (result, "COSD"); 1912} 1913 1914 1915/* Simplify SIND(X) where X has the unit of degree. */ 1916 1917gfc_expr * 1918gfc_simplify_sind (gfc_expr *x) 1919{ 1920 gfc_expr *result; 1921 1922 if (x->expr_type != EXPR_CONSTANT) 1923 return NULL; 1924 1925 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1926 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 1927 simplify_sind (result->value.real); 1928 1929 return range_check (result, "SIND"); 1930} 1931 1932 1933/* Simplify TAND(X) where X has the unit of degree. */ 1934 1935gfc_expr * 1936gfc_simplify_tand (gfc_expr *x) 1937{ 1938 gfc_expr *result; 1939 1940 if (x->expr_type != EXPR_CONSTANT) 1941 return NULL; 1942 1943 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1944 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 1945 simplify_tand (result->value.real); 1946 1947 return range_check (result, "TAND"); 1948} 1949 1950 1951/* Simplify COTAND(X) where X has the unit of degree. */ 1952 1953gfc_expr * 1954gfc_simplify_cotand (gfc_expr *x) 1955{ 1956 gfc_expr *result; 1957 1958 if (x->expr_type != EXPR_CONSTANT) 1959 return NULL; 1960 1961 /* Implement COTAND = -TAND(x+90). 1962 TAND offers correct exact values for multiples of 30 degrees. 1963 This implementation is also compatible with the behavior of some legacy 1964 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */ 1965 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1966 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 1967 mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); 1968 simplify_tand (result->value.real); 1969 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); 1970 1971 return range_check (result, "COTAND"); 1972} 1973 1974 1975gfc_expr * 1976gfc_simplify_cosh (gfc_expr *x) 1977{ 1978 gfc_expr *result; 1979 1980 if (x->expr_type != EXPR_CONSTANT) 1981 return NULL; 1982 1983 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1984 1985 switch (x->ts.type) 1986 { 1987 case BT_REAL: 1988 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); 1989 break; 1990 1991 case BT_COMPLEX: 1992 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 1993 break; 1994 1995 default: 1996 gcc_unreachable (); 1997 } 1998 1999 return range_check (result, "COSH"); 2000} 2001 2002 2003gfc_expr * 2004gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 2005{ 2006 gfc_expr *result; 2007 bool size_zero; 2008 2009 size_zero = gfc_is_size_zero_array (mask); 2010 2011 if (!(is_constant_array_expr (mask) || size_zero) 2012 || !gfc_is_constant_expr (dim) 2013 || !gfc_is_constant_expr (kind)) 2014 return NULL; 2015 2016 result = transformational_result (mask, dim, 2017 BT_INTEGER, 2018 get_kind (BT_INTEGER, kind, "COUNT", 2019 gfc_default_integer_kind), 2020 &mask->where); 2021 2022 init_result_expr (result, 0, NULL); 2023 2024 if (size_zero) 2025 return result; 2026 2027 /* Passing MASK twice, once as data array, once as mask. 2028 Whenever gfc_count is called, '1' is added to the result. */ 2029 return !dim || mask->rank == 1 ? 2030 simplify_transformation_to_scalar (result, mask, mask, gfc_count) : 2031 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); 2032} 2033 2034/* Simplification routine for cshift. This works by copying the array 2035 expressions into a one-dimensional array, shuffling the values into another 2036 one-dimensional array and creating the new array expression from this. The 2037 shuffling part is basically taken from the library routine. */ 2038 2039gfc_expr * 2040gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) 2041{ 2042 gfc_expr *result; 2043 int which; 2044 gfc_expr **arrayvec, **resultvec; 2045 gfc_expr **rptr, **sptr; 2046 mpz_t size; 2047 size_t arraysize, shiftsize, i; 2048 gfc_constructor *array_ctor, *shift_ctor; 2049 ssize_t *shiftvec, *hptr; 2050 ssize_t shift_val, len; 2051 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 2052 hs_ex[GFC_MAX_DIMENSIONS + 1], 2053 hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS], 2054 a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS], 2055 h_extent[GFC_MAX_DIMENSIONS], 2056 ss_ex[GFC_MAX_DIMENSIONS + 1]; 2057 ssize_t rsoffset; 2058 int d, n; 2059 bool continue_loop; 2060 gfc_expr **src, **dest; 2061 2062 if (!is_constant_array_expr (array)) 2063 return NULL; 2064 2065 if (shift->rank > 0) 2066 gfc_simplify_expr (shift, 1); 2067 2068 if (!gfc_is_constant_expr (shift)) 2069 return NULL; 2070 2071 /* Make dim zero-based. */ 2072 if (dim) 2073 { 2074 if (!gfc_is_constant_expr (dim)) 2075 return NULL; 2076 which = mpz_get_si (dim->value.integer) - 1; 2077 } 2078 else 2079 which = 0; 2080 2081 if (array->shape == NULL) 2082 return NULL; 2083 2084 gfc_array_size (array, &size); 2085 arraysize = mpz_get_ui (size); 2086 mpz_clear (size); 2087 2088 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 2089 result->shape = gfc_copy_shape (array->shape, array->rank); 2090 result->rank = array->rank; 2091 result->ts.u.derived = array->ts.u.derived; 2092 2093 if (arraysize == 0) 2094 return result; 2095 2096 arrayvec = XCNEWVEC (gfc_expr *, arraysize); 2097 array_ctor = gfc_constructor_first (array->value.constructor); 2098 for (i = 0; i < arraysize; i++) 2099 { 2100 arrayvec[i] = array_ctor->expr; 2101 array_ctor = gfc_constructor_next (array_ctor); 2102 } 2103 2104 resultvec = XCNEWVEC (gfc_expr *, arraysize); 2105 2106 extent[0] = 1; 2107 count[0] = 0; 2108 2109 for (d=0; d < array->rank; d++) 2110 { 2111 a_extent[d] = mpz_get_si (array->shape[d]); 2112 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; 2113 } 2114 2115 if (shift->rank > 0) 2116 { 2117 gfc_array_size (shift, &size); 2118 shiftsize = mpz_get_ui (size); 2119 mpz_clear (size); 2120 shiftvec = XCNEWVEC (ssize_t, shiftsize); 2121 shift_ctor = gfc_constructor_first (shift->value.constructor); 2122 for (d = 0; d < shift->rank; d++) 2123 { 2124 h_extent[d] = mpz_get_si (shift->shape[d]); 2125 hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; 2126 } 2127 } 2128 else 2129 shiftvec = NULL; 2130 2131 /* Shut up compiler */ 2132 len = 1; 2133 rsoffset = 1; 2134 2135 n = 0; 2136 for (d=0; d < array->rank; d++) 2137 { 2138 if (d == which) 2139 { 2140 rsoffset = a_stride[d]; 2141 len = a_extent[d]; 2142 } 2143 else 2144 { 2145 count[n] = 0; 2146 extent[n] = a_extent[d]; 2147 sstride[n] = a_stride[d]; 2148 ss_ex[n] = sstride[n] * extent[n]; 2149 if (shiftvec) 2150 hs_ex[n] = hstride[n] * extent[n]; 2151 n++; 2152 } 2153 } 2154 ss_ex[n] = 0; 2155 hs_ex[n] = 0; 2156 2157 if (shiftvec) 2158 { 2159 for (i = 0; i < shiftsize; i++) 2160 { 2161 ssize_t val; 2162 val = mpz_get_si (shift_ctor->expr->value.integer); 2163 val = val % len; 2164 if (val < 0) 2165 val += len; 2166 shiftvec[i] = val; 2167 shift_ctor = gfc_constructor_next (shift_ctor); 2168 } 2169 shift_val = 0; 2170 } 2171 else 2172 { 2173 shift_val = mpz_get_si (shift->value.integer); 2174 shift_val = shift_val % len; 2175 if (shift_val < 0) 2176 shift_val += len; 2177 } 2178 2179 continue_loop = true; 2180 d = array->rank; 2181 rptr = resultvec; 2182 sptr = arrayvec; 2183 hptr = shiftvec; 2184 2185 while (continue_loop) 2186 { 2187 ssize_t sh; 2188 if (shiftvec) 2189 sh = *hptr; 2190 else 2191 sh = shift_val; 2192 2193 src = &sptr[sh * rsoffset]; 2194 dest = rptr; 2195 for (n = 0; n < len - sh; n++) 2196 { 2197 *dest = *src; 2198 dest += rsoffset; 2199 src += rsoffset; 2200 } 2201 src = sptr; 2202 for ( n = 0; n < sh; n++) 2203 { 2204 *dest = *src; 2205 dest += rsoffset; 2206 src += rsoffset; 2207 } 2208 rptr += sstride[0]; 2209 sptr += sstride[0]; 2210 if (shiftvec) 2211 hptr += hstride[0]; 2212 count[0]++; 2213 n = 0; 2214 while (count[n] == extent[n]) 2215 { 2216 count[n] = 0; 2217 rptr -= ss_ex[n]; 2218 sptr -= ss_ex[n]; 2219 if (shiftvec) 2220 hptr -= hs_ex[n]; 2221 n++; 2222 if (n >= d - 1) 2223 { 2224 continue_loop = false; 2225 break; 2226 } 2227 else 2228 { 2229 count[n]++; 2230 rptr += sstride[n]; 2231 sptr += sstride[n]; 2232 if (shiftvec) 2233 hptr += hstride[n]; 2234 } 2235 } 2236 } 2237 2238 for (i = 0; i < arraysize; i++) 2239 { 2240 gfc_constructor_append_expr (&result->value.constructor, 2241 gfc_copy_expr (resultvec[i]), 2242 NULL); 2243 } 2244 return result; 2245} 2246 2247 2248gfc_expr * 2249gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) 2250{ 2251 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); 2252} 2253 2254 2255gfc_expr * 2256gfc_simplify_dble (gfc_expr *e) 2257{ 2258 gfc_expr *result = NULL; 2259 int tmp1, tmp2; 2260 2261 if (e->expr_type != EXPR_CONSTANT) 2262 return NULL; 2263 2264 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 2265 warnings. */ 2266 tmp1 = warn_conversion; 2267 tmp2 = warn_conversion_extra; 2268 warn_conversion = warn_conversion_extra = 0; 2269 2270 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); 2271 2272 warn_conversion = tmp1; 2273 warn_conversion_extra = tmp2; 2274 2275 if (result == &gfc_bad_expr) 2276 return &gfc_bad_expr; 2277 2278 return range_check (result, "DBLE"); 2279} 2280 2281 2282gfc_expr * 2283gfc_simplify_digits (gfc_expr *x) 2284{ 2285 int i, digits; 2286 2287 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 2288 2289 switch (x->ts.type) 2290 { 2291 case BT_INTEGER: 2292 digits = gfc_integer_kinds[i].digits; 2293 break; 2294 2295 case BT_REAL: 2296 case BT_COMPLEX: 2297 digits = gfc_real_kinds[i].digits; 2298 break; 2299 2300 default: 2301 gcc_unreachable (); 2302 } 2303 2304 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); 2305} 2306 2307 2308gfc_expr * 2309gfc_simplify_dim (gfc_expr *x, gfc_expr *y) 2310{ 2311 gfc_expr *result; 2312 int kind; 2313 2314 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2315 return NULL; 2316 2317 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 2318 result = gfc_get_constant_expr (x->ts.type, kind, &x->where); 2319 2320 switch (x->ts.type) 2321 { 2322 case BT_INTEGER: 2323 if (mpz_cmp (x->value.integer, y->value.integer) > 0) 2324 mpz_sub (result->value.integer, x->value.integer, y->value.integer); 2325 else 2326 mpz_set_ui (result->value.integer, 0); 2327 2328 break; 2329 2330 case BT_REAL: 2331 if (mpfr_cmp (x->value.real, y->value.real) > 0) 2332 mpfr_sub (result->value.real, x->value.real, y->value.real, 2333 GFC_RND_MODE); 2334 else 2335 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 2336 2337 break; 2338 2339 default: 2340 gfc_internal_error ("gfc_simplify_dim(): Bad type"); 2341 } 2342 2343 return range_check (result, "DIM"); 2344} 2345 2346 2347gfc_expr* 2348gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) 2349{ 2350 /* If vector_a is a zero-sized array, the result is 0 for INTEGER, 2351 REAL, and COMPLEX types and .false. for LOGICAL. */ 2352 if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0) 2353 { 2354 if (vector_a->ts.type == BT_LOGICAL) 2355 return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); 2356 else 2357 return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); 2358 } 2359 2360 if (!is_constant_array_expr (vector_a) 2361 || !is_constant_array_expr (vector_b)) 2362 return NULL; 2363 2364 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); 2365} 2366 2367 2368gfc_expr * 2369gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) 2370{ 2371 gfc_expr *a1, *a2, *result; 2372 2373 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2374 return NULL; 2375 2376 a1 = gfc_real2real (x, gfc_default_double_kind); 2377 a2 = gfc_real2real (y, gfc_default_double_kind); 2378 2379 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); 2380 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); 2381 2382 gfc_free_expr (a2); 2383 gfc_free_expr (a1); 2384 2385 return range_check (result, "DPROD"); 2386} 2387 2388 2389static gfc_expr * 2390simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, 2391 bool right) 2392{ 2393 gfc_expr *result; 2394 int i, k, size, shift; 2395 2396 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT 2397 || shiftarg->expr_type != EXPR_CONSTANT) 2398 return NULL; 2399 2400 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); 2401 size = gfc_integer_kinds[k].bit_size; 2402 2403 gfc_extract_int (shiftarg, &shift); 2404 2405 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ 2406 if (right) 2407 shift = size - shift; 2408 2409 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); 2410 mpz_set_ui (result->value.integer, 0); 2411 2412 for (i = 0; i < shift; i++) 2413 if (mpz_tstbit (arg2->value.integer, size - shift + i)) 2414 mpz_setbit (result->value.integer, i); 2415 2416 for (i = 0; i < size - shift; i++) 2417 if (mpz_tstbit (arg1->value.integer, i)) 2418 mpz_setbit (result->value.integer, shift + i); 2419 2420 /* Convert to a signed value. */ 2421 gfc_convert_mpz_to_signed (result->value.integer, size); 2422 2423 return result; 2424} 2425 2426 2427gfc_expr * 2428gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 2429{ 2430 return simplify_dshift (arg1, arg2, shiftarg, true); 2431} 2432 2433 2434gfc_expr * 2435gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 2436{ 2437 return simplify_dshift (arg1, arg2, shiftarg, false); 2438} 2439 2440 2441gfc_expr * 2442gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, 2443 gfc_expr *dim) 2444{ 2445 bool temp_boundary; 2446 gfc_expr *bnd; 2447 gfc_expr *result; 2448 int which; 2449 gfc_expr **arrayvec, **resultvec; 2450 gfc_expr **rptr, **sptr; 2451 mpz_t size; 2452 size_t arraysize, i; 2453 gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; 2454 ssize_t shift_val, len; 2455 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 2456 sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], 2457 a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1]; 2458 ssize_t rsoffset; 2459 int d, n; 2460 bool continue_loop; 2461 gfc_expr **src, **dest; 2462 size_t s_len; 2463 2464 if (!is_constant_array_expr (array)) 2465 return NULL; 2466 2467 if (shift->rank > 0) 2468 gfc_simplify_expr (shift, 1); 2469 2470 if (!gfc_is_constant_expr (shift)) 2471 return NULL; 2472 2473 if (boundary) 2474 { 2475 if (boundary->rank > 0) 2476 gfc_simplify_expr (boundary, 1); 2477 2478 if (!gfc_is_constant_expr (boundary)) 2479 return NULL; 2480 } 2481 2482 if (dim) 2483 { 2484 if (!gfc_is_constant_expr (dim)) 2485 return NULL; 2486 which = mpz_get_si (dim->value.integer) - 1; 2487 } 2488 else 2489 which = 0; 2490 2491 s_len = 0; 2492 if (boundary == NULL) 2493 { 2494 temp_boundary = true; 2495 switch (array->ts.type) 2496 { 2497 2498 case BT_INTEGER: 2499 bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); 2500 break; 2501 2502 case BT_LOGICAL: 2503 bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); 2504 break; 2505 2506 case BT_REAL: 2507 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); 2508 mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); 2509 break; 2510 2511 case BT_COMPLEX: 2512 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); 2513 mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); 2514 break; 2515 2516 case BT_CHARACTER: 2517 s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); 2518 bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); 2519 break; 2520 2521 default: 2522 gcc_unreachable(); 2523 2524 } 2525 } 2526 else 2527 { 2528 temp_boundary = false; 2529 bnd = boundary; 2530 } 2531 2532 gfc_array_size (array, &size); 2533 arraysize = mpz_get_ui (size); 2534 mpz_clear (size); 2535 2536 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 2537 result->shape = gfc_copy_shape (array->shape, array->rank); 2538 result->rank = array->rank; 2539 result->ts = array->ts; 2540 2541 if (arraysize == 0) 2542 goto final; 2543 2544 if (array->shape == NULL) 2545 goto final; 2546 2547 arrayvec = XCNEWVEC (gfc_expr *, arraysize); 2548 array_ctor = gfc_constructor_first (array->value.constructor); 2549 for (i = 0; i < arraysize; i++) 2550 { 2551 arrayvec[i] = array_ctor->expr; 2552 array_ctor = gfc_constructor_next (array_ctor); 2553 } 2554 2555 resultvec = XCNEWVEC (gfc_expr *, arraysize); 2556 2557 extent[0] = 1; 2558 count[0] = 0; 2559 2560 for (d=0; d < array->rank; d++) 2561 { 2562 a_extent[d] = mpz_get_si (array->shape[d]); 2563 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; 2564 } 2565 2566 if (shift->rank > 0) 2567 { 2568 shift_ctor = gfc_constructor_first (shift->value.constructor); 2569 shift_val = 0; 2570 } 2571 else 2572 { 2573 shift_ctor = NULL; 2574 shift_val = mpz_get_si (shift->value.integer); 2575 } 2576 2577 if (bnd->rank > 0) 2578 bnd_ctor = gfc_constructor_first (bnd->value.constructor); 2579 else 2580 bnd_ctor = NULL; 2581 2582 /* Shut up compiler */ 2583 len = 1; 2584 rsoffset = 1; 2585 2586 n = 0; 2587 for (d=0; d < array->rank; d++) 2588 { 2589 if (d == which) 2590 { 2591 rsoffset = a_stride[d]; 2592 len = a_extent[d]; 2593 } 2594 else 2595 { 2596 count[n] = 0; 2597 extent[n] = a_extent[d]; 2598 sstride[n] = a_stride[d]; 2599 ss_ex[n] = sstride[n] * extent[n]; 2600 n++; 2601 } 2602 } 2603 ss_ex[n] = 0; 2604 2605 continue_loop = true; 2606 d = array->rank; 2607 rptr = resultvec; 2608 sptr = arrayvec; 2609 2610 while (continue_loop) 2611 { 2612 ssize_t sh, delta; 2613 2614 if (shift_ctor) 2615 sh = mpz_get_si (shift_ctor->expr->value.integer); 2616 else 2617 sh = shift_val; 2618 2619 if (( sh >= 0 ? sh : -sh ) > len) 2620 { 2621 delta = len; 2622 sh = len; 2623 } 2624 else 2625 delta = (sh >= 0) ? sh: -sh; 2626 2627 if (sh > 0) 2628 { 2629 src = &sptr[delta * rsoffset]; 2630 dest = rptr; 2631 } 2632 else 2633 { 2634 src = sptr; 2635 dest = &rptr[delta * rsoffset]; 2636 } 2637 2638 for (n = 0; n < len - delta; n++) 2639 { 2640 *dest = *src; 2641 dest += rsoffset; 2642 src += rsoffset; 2643 } 2644 2645 if (sh < 0) 2646 dest = rptr; 2647 2648 n = delta; 2649 2650 if (bnd_ctor) 2651 { 2652 while (n--) 2653 { 2654 *dest = gfc_copy_expr (bnd_ctor->expr); 2655 dest += rsoffset; 2656 } 2657 } 2658 else 2659 { 2660 while (n--) 2661 { 2662 *dest = gfc_copy_expr (bnd); 2663 dest += rsoffset; 2664 } 2665 } 2666 rptr += sstride[0]; 2667 sptr += sstride[0]; 2668 if (shift_ctor) 2669 shift_ctor = gfc_constructor_next (shift_ctor); 2670 2671 if (bnd_ctor) 2672 bnd_ctor = gfc_constructor_next (bnd_ctor); 2673 2674 count[0]++; 2675 n = 0; 2676 while (count[n] == extent[n]) 2677 { 2678 count[n] = 0; 2679 rptr -= ss_ex[n]; 2680 sptr -= ss_ex[n]; 2681 n++; 2682 if (n >= d - 1) 2683 { 2684 continue_loop = false; 2685 break; 2686 } 2687 else 2688 { 2689 count[n]++; 2690 rptr += sstride[n]; 2691 sptr += sstride[n]; 2692 } 2693 } 2694 } 2695 2696 for (i = 0; i < arraysize; i++) 2697 { 2698 gfc_constructor_append_expr (&result->value.constructor, 2699 gfc_copy_expr (resultvec[i]), 2700 NULL); 2701 } 2702 2703 final: 2704 if (temp_boundary) 2705 gfc_free_expr (bnd); 2706 2707 return result; 2708} 2709 2710gfc_expr * 2711gfc_simplify_erf (gfc_expr *x) 2712{ 2713 gfc_expr *result; 2714 2715 if (x->expr_type != EXPR_CONSTANT) 2716 return NULL; 2717 2718 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2719 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); 2720 2721 return range_check (result, "ERF"); 2722} 2723 2724 2725gfc_expr * 2726gfc_simplify_erfc (gfc_expr *x) 2727{ 2728 gfc_expr *result; 2729 2730 if (x->expr_type != EXPR_CONSTANT) 2731 return NULL; 2732 2733 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2734 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); 2735 2736 return range_check (result, "ERFC"); 2737} 2738 2739 2740/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ 2741 2742#define MAX_ITER 200 2743#define ARG_LIMIT 12 2744 2745/* Calculate ERFC_SCALED directly by its definition: 2746 2747 ERFC_SCALED(x) = ERFC(x) * EXP(X**2) 2748 2749 using a large precision for intermediate results. This is used for all 2750 but large values of the argument. */ 2751static void 2752fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) 2753{ 2754 mpfr_prec_t prec; 2755 mpfr_t a, b; 2756 2757 prec = mpfr_get_default_prec (); 2758 mpfr_set_default_prec (10 * prec); 2759 2760 mpfr_init (a); 2761 mpfr_init (b); 2762 2763 mpfr_set (a, arg, GFC_RND_MODE); 2764 mpfr_sqr (b, a, GFC_RND_MODE); 2765 mpfr_exp (b, b, GFC_RND_MODE); 2766 mpfr_erfc (a, a, GFC_RND_MODE); 2767 mpfr_mul (a, a, b, GFC_RND_MODE); 2768 2769 mpfr_set (res, a, GFC_RND_MODE); 2770 mpfr_set_default_prec (prec); 2771 2772 mpfr_clear (a); 2773 mpfr_clear (b); 2774} 2775 2776/* Calculate ERFC_SCALED using a power series expansion in 1/arg: 2777 2778 ERFC_SCALED(x) = 1 / (x * sqrt(pi)) 2779 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) 2780 / (2 * x**2)**n) 2781 2782 This is used for large values of the argument. Intermediate calculations 2783 are performed with twice the precision. We don't do a fixed number of 2784 iterations of the sum, but stop when it has converged to the required 2785 precision. */ 2786static void 2787asympt_erfc_scaled (mpfr_t res, mpfr_t arg) 2788{ 2789 mpfr_t sum, x, u, v, w, oldsum, sumtrunc; 2790 mpz_t num; 2791 mpfr_prec_t prec; 2792 unsigned i; 2793 2794 prec = mpfr_get_default_prec (); 2795 mpfr_set_default_prec (2 * prec); 2796 2797 mpfr_init (sum); 2798 mpfr_init (x); 2799 mpfr_init (u); 2800 mpfr_init (v); 2801 mpfr_init (w); 2802 mpz_init (num); 2803 2804 mpfr_init (oldsum); 2805 mpfr_init (sumtrunc); 2806 mpfr_set_prec (oldsum, prec); 2807 mpfr_set_prec (sumtrunc, prec); 2808 2809 mpfr_set (x, arg, GFC_RND_MODE); 2810 mpfr_set_ui (sum, 1, GFC_RND_MODE); 2811 mpz_set_ui (num, 1); 2812 2813 mpfr_set (u, x, GFC_RND_MODE); 2814 mpfr_sqr (u, u, GFC_RND_MODE); 2815 mpfr_mul_ui (u, u, 2, GFC_RND_MODE); 2816 mpfr_pow_si (u, u, -1, GFC_RND_MODE); 2817 2818 for (i = 1; i < MAX_ITER; i++) 2819 { 2820 mpfr_set (oldsum, sum, GFC_RND_MODE); 2821 2822 mpz_mul_ui (num, num, 2 * i - 1); 2823 mpz_neg (num, num); 2824 2825 mpfr_set (w, u, GFC_RND_MODE); 2826 mpfr_pow_ui (w, w, i, GFC_RND_MODE); 2827 2828 mpfr_set_z (v, num, GFC_RND_MODE); 2829 mpfr_mul (v, v, w, GFC_RND_MODE); 2830 2831 mpfr_add (sum, sum, v, GFC_RND_MODE); 2832 2833 mpfr_set (sumtrunc, sum, GFC_RND_MODE); 2834 if (mpfr_cmp (sumtrunc, oldsum) == 0) 2835 break; 2836 } 2837 2838 /* We should have converged by now; otherwise, ARG_LIMIT is probably 2839 set too low. */ 2840 gcc_assert (i < MAX_ITER); 2841 2842 /* Divide by x * sqrt(Pi). */ 2843 mpfr_const_pi (u, GFC_RND_MODE); 2844 mpfr_sqrt (u, u, GFC_RND_MODE); 2845 mpfr_mul (u, u, x, GFC_RND_MODE); 2846 mpfr_div (sum, sum, u, GFC_RND_MODE); 2847 2848 mpfr_set (res, sum, GFC_RND_MODE); 2849 mpfr_set_default_prec (prec); 2850 2851 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL); 2852 mpz_clear (num); 2853} 2854 2855 2856gfc_expr * 2857gfc_simplify_erfc_scaled (gfc_expr *x) 2858{ 2859 gfc_expr *result; 2860 2861 if (x->expr_type != EXPR_CONSTANT) 2862 return NULL; 2863 2864 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2865 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) 2866 asympt_erfc_scaled (result->value.real, x->value.real); 2867 else 2868 fullprec_erfc_scaled (result->value.real, x->value.real); 2869 2870 return range_check (result, "ERFC_SCALED"); 2871} 2872 2873#undef MAX_ITER 2874#undef ARG_LIMIT 2875 2876 2877gfc_expr * 2878gfc_simplify_epsilon (gfc_expr *e) 2879{ 2880 gfc_expr *result; 2881 int i; 2882 2883 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 2884 2885 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 2886 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); 2887 2888 return range_check (result, "EPSILON"); 2889} 2890 2891 2892gfc_expr * 2893gfc_simplify_exp (gfc_expr *x) 2894{ 2895 gfc_expr *result; 2896 2897 if (x->expr_type != EXPR_CONSTANT) 2898 return NULL; 2899 2900 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2901 2902 switch (x->ts.type) 2903 { 2904 case BT_REAL: 2905 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); 2906 break; 2907 2908 case BT_COMPLEX: 2909 gfc_set_model_kind (x->ts.kind); 2910 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 2911 break; 2912 2913 default: 2914 gfc_internal_error ("in gfc_simplify_exp(): Bad type"); 2915 } 2916 2917 return range_check (result, "EXP"); 2918} 2919 2920 2921gfc_expr * 2922gfc_simplify_exponent (gfc_expr *x) 2923{ 2924 long int val; 2925 gfc_expr *result; 2926 2927 if (x->expr_type != EXPR_CONSTANT) 2928 return NULL; 2929 2930 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2931 &x->where); 2932 2933 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ 2934 if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) 2935 { 2936 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); 2937 mpz_set (result->value.integer, gfc_integer_kinds[i].huge); 2938 return result; 2939 } 2940 2941 /* EXPONENT(+/- 0.0) = 0 */ 2942 if (mpfr_zero_p (x->value.real)) 2943 { 2944 mpz_set_ui (result->value.integer, 0); 2945 return result; 2946 } 2947 2948 gfc_set_model (x->value.real); 2949 2950 val = (long int) mpfr_get_exp (x->value.real); 2951 mpz_set_si (result->value.integer, val); 2952 2953 return range_check (result, "EXPONENT"); 2954} 2955 2956 2957gfc_expr * 2958gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, 2959 gfc_expr *kind) 2960{ 2961 if (flag_coarray == GFC_FCOARRAY_NONE) 2962 { 2963 gfc_current_locus = *gfc_current_intrinsic_where; 2964 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 2965 return &gfc_bad_expr; 2966 } 2967 2968 if (flag_coarray == GFC_FCOARRAY_SINGLE) 2969 { 2970 gfc_expr *result; 2971 int actual_kind; 2972 if (kind) 2973 gfc_extract_int (kind, &actual_kind); 2974 else 2975 actual_kind = gfc_default_integer_kind; 2976 2977 result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); 2978 result->rank = 1; 2979 return result; 2980 } 2981 2982 /* For fcoarray = lib no simplification is possible, because it is not known 2983 what images failed or are stopped at compile time. */ 2984 return NULL; 2985} 2986 2987 2988gfc_expr * 2989gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) 2990{ 2991 if (flag_coarray == GFC_FCOARRAY_NONE) 2992 { 2993 gfc_current_locus = *gfc_current_intrinsic_where; 2994 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 2995 return &gfc_bad_expr; 2996 } 2997 2998 if (flag_coarray == GFC_FCOARRAY_SINGLE) 2999 { 3000 gfc_expr *result; 3001 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); 3002 result->rank = 0; 3003 return result; 3004 } 3005 3006 /* For fcoarray = lib no simplification is possible, because it is not known 3007 what images failed or are stopped at compile time. */ 3008 return NULL; 3009} 3010 3011 3012gfc_expr * 3013gfc_simplify_float (gfc_expr *a) 3014{ 3015 gfc_expr *result; 3016 3017 if (a->expr_type != EXPR_CONSTANT) 3018 return NULL; 3019 3020 result = gfc_int2real (a, gfc_default_real_kind); 3021 3022 return range_check (result, "FLOAT"); 3023} 3024 3025 3026static bool 3027is_last_ref_vtab (gfc_expr *e) 3028{ 3029 gfc_ref *ref; 3030 gfc_component *comp = NULL; 3031 3032 if (e->expr_type != EXPR_VARIABLE) 3033 return false; 3034 3035 for (ref = e->ref; ref; ref = ref->next) 3036 if (ref->type == REF_COMPONENT) 3037 comp = ref->u.c.component; 3038 3039 if (!e->ref || !comp) 3040 return e->symtree->n.sym->attr.vtab; 3041 3042 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) 3043 return true; 3044 3045 return false; 3046} 3047 3048 3049gfc_expr * 3050gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) 3051{ 3052 /* Avoid simplification of resolved symbols. */ 3053 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) 3054 return NULL; 3055 3056 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) 3057 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3058 gfc_type_is_extension_of (mold->ts.u.derived, 3059 a->ts.u.derived)); 3060 3061 if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) 3062 return NULL; 3063 3064 if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok) 3065 || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok)) 3066 return NULL; 3067 3068 /* Return .false. if the dynamic type can never be an extension. */ 3069 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS 3070 && !gfc_type_is_extension_of 3071 (mold->ts.u.derived->components->ts.u.derived, 3072 a->ts.u.derived->components->ts.u.derived) 3073 && !gfc_type_is_extension_of 3074 (a->ts.u.derived->components->ts.u.derived, 3075 mold->ts.u.derived->components->ts.u.derived)) 3076 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS 3077 && !gfc_type_is_extension_of 3078 (mold->ts.u.derived->components->ts.u.derived, 3079 a->ts.u.derived)) 3080 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED 3081 && !gfc_type_is_extension_of 3082 (mold->ts.u.derived, 3083 a->ts.u.derived->components->ts.u.derived) 3084 && !gfc_type_is_extension_of 3085 (a->ts.u.derived->components->ts.u.derived, 3086 mold->ts.u.derived))) 3087 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 3088 3089 /* Return .true. if the dynamic type is guaranteed to be an extension. */ 3090 if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED 3091 && gfc_type_is_extension_of (mold->ts.u.derived, 3092 a->ts.u.derived->components->ts.u.derived)) 3093 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); 3094 3095 return NULL; 3096} 3097 3098 3099gfc_expr * 3100gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) 3101{ 3102 /* Avoid simplification of resolved symbols. */ 3103 if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) 3104 return NULL; 3105 3106 /* Return .false. if the dynamic type can never be the 3107 same. */ 3108 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok) 3109 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) 3110 && !gfc_type_compatible (&a->ts, &b->ts) 3111 && !gfc_type_compatible (&b->ts, &a->ts)) 3112 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 3113 3114 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) 3115 return NULL; 3116 3117 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3118 gfc_compare_derived_types (a->ts.u.derived, 3119 b->ts.u.derived)); 3120} 3121 3122 3123gfc_expr * 3124gfc_simplify_floor (gfc_expr *e, gfc_expr *k) 3125{ 3126 gfc_expr *result; 3127 mpfr_t floor; 3128 int kind; 3129 3130 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); 3131 if (kind == -1) 3132 gfc_internal_error ("gfc_simplify_floor(): Bad kind"); 3133 3134 if (e->expr_type != EXPR_CONSTANT) 3135 return NULL; 3136 3137 mpfr_init2 (floor, mpfr_get_prec (e->value.real)); 3138 mpfr_floor (floor, e->value.real); 3139 3140 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 3141 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); 3142 3143 mpfr_clear (floor); 3144 3145 return range_check (result, "FLOOR"); 3146} 3147 3148 3149gfc_expr * 3150gfc_simplify_fraction (gfc_expr *x) 3151{ 3152 gfc_expr *result; 3153 mpfr_exp_t e; 3154 3155 if (x->expr_type != EXPR_CONSTANT) 3156 return NULL; 3157 3158 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 3159 3160 /* FRACTION(inf) = NaN. */ 3161 if (mpfr_inf_p (x->value.real)) 3162 { 3163 mpfr_set_nan (result->value.real); 3164 return result; 3165 } 3166 3167 /* mpfr_frexp() correctly handles zeros and NaNs. */ 3168 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); 3169 3170 return range_check (result, "FRACTION"); 3171} 3172 3173 3174gfc_expr * 3175gfc_simplify_gamma (gfc_expr *x) 3176{ 3177 gfc_expr *result; 3178 3179 if (x->expr_type != EXPR_CONSTANT) 3180 return NULL; 3181 3182 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3183 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); 3184 3185 return range_check (result, "GAMMA"); 3186} 3187 3188 3189gfc_expr * 3190gfc_simplify_huge (gfc_expr *e) 3191{ 3192 gfc_expr *result; 3193 int i; 3194 3195 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3196 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3197 3198 switch (e->ts.type) 3199 { 3200 case BT_INTEGER: 3201 mpz_set (result->value.integer, gfc_integer_kinds[i].huge); 3202 break; 3203 3204 case BT_REAL: 3205 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); 3206 break; 3207 3208 default: 3209 gcc_unreachable (); 3210 } 3211 3212 return result; 3213} 3214 3215 3216gfc_expr * 3217gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) 3218{ 3219 gfc_expr *result; 3220 3221 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3222 return NULL; 3223 3224 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3225 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); 3226 return range_check (result, "HYPOT"); 3227} 3228 3229 3230/* We use the processor's collating sequence, because all 3231 systems that gfortran currently works on are ASCII. */ 3232 3233gfc_expr * 3234gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) 3235{ 3236 gfc_expr *result; 3237 gfc_char_t index; 3238 int k; 3239 3240 if (e->expr_type != EXPR_CONSTANT) 3241 return NULL; 3242 3243 if (e->value.character.length != 1) 3244 { 3245 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); 3246 return &gfc_bad_expr; 3247 } 3248 3249 index = e->value.character.string[0]; 3250 3251 if (warn_surprising && index > 127) 3252 gfc_warning (OPT_Wsurprising, 3253 "Argument of IACHAR function at %L outside of range 0..127", 3254 &e->where); 3255 3256 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); 3257 if (k == -1) 3258 return &gfc_bad_expr; 3259 3260 result = gfc_get_int_expr (k, &e->where, index); 3261 3262 return range_check (result, "IACHAR"); 3263} 3264 3265 3266static gfc_expr * 3267do_bit_and (gfc_expr *result, gfc_expr *e) 3268{ 3269 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 3270 gcc_assert (result->ts.type == BT_INTEGER 3271 && result->expr_type == EXPR_CONSTANT); 3272 3273 mpz_and (result->value.integer, result->value.integer, e->value.integer); 3274 return result; 3275} 3276 3277 3278gfc_expr * 3279gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3280{ 3281 return simplify_transformation (array, dim, mask, -1, do_bit_and); 3282} 3283 3284 3285static gfc_expr * 3286do_bit_ior (gfc_expr *result, gfc_expr *e) 3287{ 3288 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 3289 gcc_assert (result->ts.type == BT_INTEGER 3290 && result->expr_type == EXPR_CONSTANT); 3291 3292 mpz_ior (result->value.integer, result->value.integer, e->value.integer); 3293 return result; 3294} 3295 3296 3297gfc_expr * 3298gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3299{ 3300 return simplify_transformation (array, dim, mask, 0, do_bit_ior); 3301} 3302 3303 3304gfc_expr * 3305gfc_simplify_iand (gfc_expr *x, gfc_expr *y) 3306{ 3307 gfc_expr *result; 3308 3309 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3310 return NULL; 3311 3312 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3313 mpz_and (result->value.integer, x->value.integer, y->value.integer); 3314 3315 return range_check (result, "IAND"); 3316} 3317 3318 3319gfc_expr * 3320gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) 3321{ 3322 gfc_expr *result; 3323 int k, pos; 3324 3325 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3326 return NULL; 3327 3328 gfc_extract_int (y, &pos); 3329 3330 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 3331 3332 result = gfc_copy_expr (x); 3333 3334 convert_mpz_to_unsigned (result->value.integer, 3335 gfc_integer_kinds[k].bit_size); 3336 3337 mpz_clrbit (result->value.integer, pos); 3338 3339 gfc_convert_mpz_to_signed (result->value.integer, 3340 gfc_integer_kinds[k].bit_size); 3341 3342 return result; 3343} 3344 3345 3346gfc_expr * 3347gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) 3348{ 3349 gfc_expr *result; 3350 int pos, len; 3351 int i, k, bitsize; 3352 int *bits; 3353 3354 if (x->expr_type != EXPR_CONSTANT 3355 || y->expr_type != EXPR_CONSTANT 3356 || z->expr_type != EXPR_CONSTANT) 3357 return NULL; 3358 3359 gfc_extract_int (y, &pos); 3360 gfc_extract_int (z, &len); 3361 3362 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); 3363 3364 bitsize = gfc_integer_kinds[k].bit_size; 3365 3366 if (pos + len > bitsize) 3367 { 3368 gfc_error ("Sum of second and third arguments of IBITS exceeds " 3369 "bit size at %L", &y->where); 3370 return &gfc_bad_expr; 3371 } 3372 3373 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3374 convert_mpz_to_unsigned (result->value.integer, 3375 gfc_integer_kinds[k].bit_size); 3376 3377 bits = XCNEWVEC (int, bitsize); 3378 3379 for (i = 0; i < bitsize; i++) 3380 bits[i] = 0; 3381 3382 for (i = 0; i < len; i++) 3383 bits[i] = mpz_tstbit (x->value.integer, i + pos); 3384 3385 for (i = 0; i < bitsize; i++) 3386 { 3387 if (bits[i] == 0) 3388 mpz_clrbit (result->value.integer, i); 3389 else if (bits[i] == 1) 3390 mpz_setbit (result->value.integer, i); 3391 else 3392 gfc_internal_error ("IBITS: Bad bit"); 3393 } 3394 3395 free (bits); 3396 3397 gfc_convert_mpz_to_signed (result->value.integer, 3398 gfc_integer_kinds[k].bit_size); 3399 3400 return result; 3401} 3402 3403 3404gfc_expr * 3405gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) 3406{ 3407 gfc_expr *result; 3408 int k, pos; 3409 3410 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3411 return NULL; 3412 3413 gfc_extract_int (y, &pos); 3414 3415 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 3416 3417 result = gfc_copy_expr (x); 3418 3419 convert_mpz_to_unsigned (result->value.integer, 3420 gfc_integer_kinds[k].bit_size); 3421 3422 mpz_setbit (result->value.integer, pos); 3423 3424 gfc_convert_mpz_to_signed (result->value.integer, 3425 gfc_integer_kinds[k].bit_size); 3426 3427 return result; 3428} 3429 3430 3431gfc_expr * 3432gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) 3433{ 3434 gfc_expr *result; 3435 gfc_char_t index; 3436 int k; 3437 3438 if (e->expr_type != EXPR_CONSTANT) 3439 return NULL; 3440 3441 if (e->value.character.length != 1) 3442 { 3443 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); 3444 return &gfc_bad_expr; 3445 } 3446 3447 index = e->value.character.string[0]; 3448 3449 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); 3450 if (k == -1) 3451 return &gfc_bad_expr; 3452 3453 result = gfc_get_int_expr (k, &e->where, index); 3454 3455 return range_check (result, "ICHAR"); 3456} 3457 3458 3459gfc_expr * 3460gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) 3461{ 3462 gfc_expr *result; 3463 3464 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3465 return NULL; 3466 3467 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3468 mpz_xor (result->value.integer, x->value.integer, y->value.integer); 3469 3470 return range_check (result, "IEOR"); 3471} 3472 3473 3474gfc_expr * 3475gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) 3476{ 3477 gfc_expr *result; 3478 bool back; 3479 HOST_WIDE_INT len, lensub, start, last, i, index = 0; 3480 int k, delta; 3481 3482 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT 3483 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 3484 return NULL; 3485 3486 back = (b != NULL && b->value.logical != 0); 3487 3488 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); 3489 if (k == -1) 3490 return &gfc_bad_expr; 3491 3492 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 3493 3494 len = x->value.character.length; 3495 lensub = y->value.character.length; 3496 3497 if (len < lensub) 3498 { 3499 mpz_set_si (result->value.integer, 0); 3500 return result; 3501 } 3502 3503 if (lensub == 0) 3504 { 3505 if (back) 3506 index = len + 1; 3507 else 3508 index = 1; 3509 goto done; 3510 } 3511 3512 if (!back) 3513 { 3514 last = len + 1 - lensub; 3515 start = 0; 3516 delta = 1; 3517 } 3518 else 3519 { 3520 last = -1; 3521 start = len - lensub; 3522 delta = -1; 3523 } 3524 3525 for (; start != last; start += delta) 3526 { 3527 for (i = 0; i < lensub; i++) 3528 { 3529 if (x->value.character.string[start + i] 3530 != y->value.character.string[i]) 3531 break; 3532 } 3533 if (i == lensub) 3534 { 3535 index = start + 1; 3536 goto done; 3537 } 3538 } 3539 3540done: 3541 mpz_set_si (result->value.integer, index); 3542 return range_check (result, "INDEX"); 3543} 3544 3545 3546static gfc_expr * 3547simplify_intconv (gfc_expr *e, int kind, const char *name) 3548{ 3549 gfc_expr *result = NULL; 3550 int tmp1, tmp2; 3551 3552 /* Convert BOZ to integer, and return without range checking. */ 3553 if (e->ts.type == BT_BOZ) 3554 { 3555 if (!gfc_boz2int (e, kind)) 3556 return NULL; 3557 result = gfc_copy_expr (e); 3558 return result; 3559 } 3560 3561 if (e->expr_type != EXPR_CONSTANT) 3562 return NULL; 3563 3564 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 3565 warnings. */ 3566 tmp1 = warn_conversion; 3567 tmp2 = warn_conversion_extra; 3568 warn_conversion = warn_conversion_extra = 0; 3569 3570 result = gfc_convert_constant (e, BT_INTEGER, kind); 3571 3572 warn_conversion = tmp1; 3573 warn_conversion_extra = tmp2; 3574 3575 if (result == &gfc_bad_expr) 3576 return &gfc_bad_expr; 3577 3578 return range_check (result, name); 3579} 3580 3581 3582gfc_expr * 3583gfc_simplify_int (gfc_expr *e, gfc_expr *k) 3584{ 3585 int kind; 3586 3587 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); 3588 if (kind == -1) 3589 return &gfc_bad_expr; 3590 3591 return simplify_intconv (e, kind, "INT"); 3592} 3593 3594gfc_expr * 3595gfc_simplify_int2 (gfc_expr *e) 3596{ 3597 return simplify_intconv (e, 2, "INT2"); 3598} 3599 3600 3601gfc_expr * 3602gfc_simplify_int8 (gfc_expr *e) 3603{ 3604 return simplify_intconv (e, 8, "INT8"); 3605} 3606 3607 3608gfc_expr * 3609gfc_simplify_long (gfc_expr *e) 3610{ 3611 return simplify_intconv (e, 4, "LONG"); 3612} 3613 3614 3615gfc_expr * 3616gfc_simplify_ifix (gfc_expr *e) 3617{ 3618 gfc_expr *rtrunc, *result; 3619 3620 if (e->expr_type != EXPR_CONSTANT) 3621 return NULL; 3622 3623 rtrunc = gfc_copy_expr (e); 3624 mpfr_trunc (rtrunc->value.real, e->value.real); 3625 3626 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 3627 &e->where); 3628 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 3629 3630 gfc_free_expr (rtrunc); 3631 3632 return range_check (result, "IFIX"); 3633} 3634 3635 3636gfc_expr * 3637gfc_simplify_idint (gfc_expr *e) 3638{ 3639 gfc_expr *rtrunc, *result; 3640 3641 if (e->expr_type != EXPR_CONSTANT) 3642 return NULL; 3643 3644 rtrunc = gfc_copy_expr (e); 3645 mpfr_trunc (rtrunc->value.real, e->value.real); 3646 3647 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 3648 &e->where); 3649 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 3650 3651 gfc_free_expr (rtrunc); 3652 3653 return range_check (result, "IDINT"); 3654} 3655 3656 3657gfc_expr * 3658gfc_simplify_ior (gfc_expr *x, gfc_expr *y) 3659{ 3660 gfc_expr *result; 3661 3662 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3663 return NULL; 3664 3665 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3666 mpz_ior (result->value.integer, x->value.integer, y->value.integer); 3667 3668 return range_check (result, "IOR"); 3669} 3670 3671 3672static gfc_expr * 3673do_bit_xor (gfc_expr *result, gfc_expr *e) 3674{ 3675 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); 3676 gcc_assert (result->ts.type == BT_INTEGER 3677 && result->expr_type == EXPR_CONSTANT); 3678 3679 mpz_xor (result->value.integer, result->value.integer, e->value.integer); 3680 return result; 3681} 3682 3683 3684gfc_expr * 3685gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3686{ 3687 return simplify_transformation (array, dim, mask, 0, do_bit_xor); 3688} 3689 3690 3691gfc_expr * 3692gfc_simplify_is_iostat_end (gfc_expr *x) 3693{ 3694 if (x->expr_type != EXPR_CONSTANT) 3695 return NULL; 3696 3697 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3698 mpz_cmp_si (x->value.integer, 3699 LIBERROR_END) == 0); 3700} 3701 3702 3703gfc_expr * 3704gfc_simplify_is_iostat_eor (gfc_expr *x) 3705{ 3706 if (x->expr_type != EXPR_CONSTANT) 3707 return NULL; 3708 3709 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3710 mpz_cmp_si (x->value.integer, 3711 LIBERROR_EOR) == 0); 3712} 3713 3714 3715gfc_expr * 3716gfc_simplify_isnan (gfc_expr *x) 3717{ 3718 if (x->expr_type != EXPR_CONSTANT) 3719 return NULL; 3720 3721 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3722 mpfr_nan_p (x->value.real)); 3723} 3724 3725 3726/* Performs a shift on its first argument. Depending on the last 3727 argument, the shift can be arithmetic, i.e. with filling from the 3728 left like in the SHIFTA intrinsic. */ 3729static gfc_expr * 3730simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, 3731 bool arithmetic, int direction) 3732{ 3733 gfc_expr *result; 3734 int ashift, *bits, i, k, bitsize, shift; 3735 3736 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3737 return NULL; 3738 3739 gfc_extract_int (s, &shift); 3740 3741 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); 3742 bitsize = gfc_integer_kinds[k].bit_size; 3743 3744 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3745 3746 if (shift == 0) 3747 { 3748 mpz_set (result->value.integer, e->value.integer); 3749 return result; 3750 } 3751 3752 if (direction > 0 && shift < 0) 3753 { 3754 /* Left shift, as in SHIFTL. */ 3755 gfc_error ("Second argument of %s is negative at %L", name, &e->where); 3756 return &gfc_bad_expr; 3757 } 3758 else if (direction < 0) 3759 { 3760 /* Right shift, as in SHIFTR or SHIFTA. */ 3761 if (shift < 0) 3762 { 3763 gfc_error ("Second argument of %s is negative at %L", 3764 name, &e->where); 3765 return &gfc_bad_expr; 3766 } 3767 3768 shift = -shift; 3769 } 3770 3771 ashift = (shift >= 0 ? shift : -shift); 3772 3773 if (ashift > bitsize) 3774 { 3775 gfc_error ("Magnitude of second argument of %s exceeds bit size " 3776 "at %L", name, &e->where); 3777 return &gfc_bad_expr; 3778 } 3779 3780 bits = XCNEWVEC (int, bitsize); 3781 3782 for (i = 0; i < bitsize; i++) 3783 bits[i] = mpz_tstbit (e->value.integer, i); 3784 3785 if (shift > 0) 3786 { 3787 /* Left shift. */ 3788 for (i = 0; i < shift; i++) 3789 mpz_clrbit (result->value.integer, i); 3790 3791 for (i = 0; i < bitsize - shift; i++) 3792 { 3793 if (bits[i] == 0) 3794 mpz_clrbit (result->value.integer, i + shift); 3795 else 3796 mpz_setbit (result->value.integer, i + shift); 3797 } 3798 } 3799 else 3800 { 3801 /* Right shift. */ 3802 if (arithmetic && bits[bitsize - 1]) 3803 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3804 mpz_setbit (result->value.integer, i); 3805 else 3806 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3807 mpz_clrbit (result->value.integer, i); 3808 3809 for (i = bitsize - 1; i >= ashift; i--) 3810 { 3811 if (bits[i] == 0) 3812 mpz_clrbit (result->value.integer, i - ashift); 3813 else 3814 mpz_setbit (result->value.integer, i - ashift); 3815 } 3816 } 3817 3818 gfc_convert_mpz_to_signed (result->value.integer, bitsize); 3819 free (bits); 3820 3821 return result; 3822} 3823 3824 3825gfc_expr * 3826gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) 3827{ 3828 return simplify_shift (e, s, "ISHFT", false, 0); 3829} 3830 3831 3832gfc_expr * 3833gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) 3834{ 3835 return simplify_shift (e, s, "LSHIFT", false, 1); 3836} 3837 3838 3839gfc_expr * 3840gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) 3841{ 3842 return simplify_shift (e, s, "RSHIFT", true, -1); 3843} 3844 3845 3846gfc_expr * 3847gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) 3848{ 3849 return simplify_shift (e, s, "SHIFTA", true, -1); 3850} 3851 3852 3853gfc_expr * 3854gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) 3855{ 3856 return simplify_shift (e, s, "SHIFTL", false, 1); 3857} 3858 3859 3860gfc_expr * 3861gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) 3862{ 3863 return simplify_shift (e, s, "SHIFTR", false, -1); 3864} 3865 3866 3867gfc_expr * 3868gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) 3869{ 3870 gfc_expr *result; 3871 int shift, ashift, isize, ssize, delta, k; 3872 int i, *bits; 3873 3874 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3875 return NULL; 3876 3877 gfc_extract_int (s, &shift); 3878 3879 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3880 isize = gfc_integer_kinds[k].bit_size; 3881 3882 if (sz != NULL) 3883 { 3884 if (sz->expr_type != EXPR_CONSTANT) 3885 return NULL; 3886 3887 gfc_extract_int (sz, &ssize); 3888 } 3889 else 3890 ssize = isize; 3891 3892 if (shift >= 0) 3893 ashift = shift; 3894 else 3895 ashift = -shift; 3896 3897 if (ashift > ssize) 3898 { 3899 if (sz == NULL) 3900 gfc_error ("Magnitude of second argument of ISHFTC exceeds " 3901 "BIT_SIZE of first argument at %C"); 3902 else 3903 gfc_error ("Absolute value of SHIFT shall be less than or equal " 3904 "to SIZE at %C"); 3905 return &gfc_bad_expr; 3906 } 3907 3908 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3909 3910 mpz_set (result->value.integer, e->value.integer); 3911 3912 if (shift == 0) 3913 return result; 3914 3915 convert_mpz_to_unsigned (result->value.integer, isize); 3916 3917 bits = XCNEWVEC (int, ssize); 3918 3919 for (i = 0; i < ssize; i++) 3920 bits[i] = mpz_tstbit (e->value.integer, i); 3921 3922 delta = ssize - ashift; 3923 3924 if (shift > 0) 3925 { 3926 for (i = 0; i < delta; i++) 3927 { 3928 if (bits[i] == 0) 3929 mpz_clrbit (result->value.integer, i + shift); 3930 else 3931 mpz_setbit (result->value.integer, i + shift); 3932 } 3933 3934 for (i = delta; i < ssize; i++) 3935 { 3936 if (bits[i] == 0) 3937 mpz_clrbit (result->value.integer, i - delta); 3938 else 3939 mpz_setbit (result->value.integer, i - delta); 3940 } 3941 } 3942 else 3943 { 3944 for (i = 0; i < ashift; i++) 3945 { 3946 if (bits[i] == 0) 3947 mpz_clrbit (result->value.integer, i + delta); 3948 else 3949 mpz_setbit (result->value.integer, i + delta); 3950 } 3951 3952 for (i = ashift; i < ssize; i++) 3953 { 3954 if (bits[i] == 0) 3955 mpz_clrbit (result->value.integer, i + shift); 3956 else 3957 mpz_setbit (result->value.integer, i + shift); 3958 } 3959 } 3960 3961 gfc_convert_mpz_to_signed (result->value.integer, isize); 3962 3963 free (bits); 3964 return result; 3965} 3966 3967 3968gfc_expr * 3969gfc_simplify_kind (gfc_expr *e) 3970{ 3971 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); 3972} 3973 3974 3975static gfc_expr * 3976simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, 3977 gfc_array_spec *as, gfc_ref *ref, bool coarray) 3978{ 3979 gfc_expr *l, *u, *result; 3980 int k; 3981 3982 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 3983 gfc_default_integer_kind); 3984 if (k == -1) 3985 return &gfc_bad_expr; 3986 3987 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 3988 3989 /* For non-variables, LBOUND(expr, DIM=n) = 1 and 3990 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ 3991 if (!coarray && array->expr_type != EXPR_VARIABLE) 3992 { 3993 if (upper) 3994 { 3995 gfc_expr* dim = result; 3996 mpz_set_si (dim->value.integer, d); 3997 3998 result = simplify_size (array, dim, k); 3999 gfc_free_expr (dim); 4000 if (!result) 4001 goto returnNull; 4002 } 4003 else 4004 mpz_set_si (result->value.integer, 1); 4005 4006 goto done; 4007 } 4008 4009 /* Otherwise, we have a variable expression. */ 4010 gcc_assert (array->expr_type == EXPR_VARIABLE); 4011 gcc_assert (as); 4012 4013 if (!gfc_resolve_array_spec (as, 0)) 4014 return NULL; 4015 4016 /* The last dimension of an assumed-size array is special. */ 4017 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) 4018 || (coarray && d == as->rank + as->corank 4019 && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE))) 4020 { 4021 if (as->lower[d-1]->expr_type == EXPR_CONSTANT) 4022 { 4023 gfc_free_expr (result); 4024 return gfc_copy_expr (as->lower[d-1]); 4025 } 4026 4027 goto returnNull; 4028 } 4029 4030 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 4031 4032 /* Then, we need to know the extent of the given dimension. */ 4033 if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) 4034 { 4035 gfc_expr *declared_bound; 4036 int empty_bound; 4037 bool constant_lbound, constant_ubound; 4038 4039 l = as->lower[d-1]; 4040 u = as->upper[d-1]; 4041 4042 gcc_assert (l != NULL); 4043 4044 constant_lbound = l->expr_type == EXPR_CONSTANT; 4045 constant_ubound = u && u->expr_type == EXPR_CONSTANT; 4046 4047 empty_bound = upper ? 0 : 1; 4048 declared_bound = upper ? u : l; 4049 4050 if ((!upper && !constant_lbound) 4051 || (upper && !constant_ubound)) 4052 goto returnNull; 4053 4054 if (!coarray) 4055 { 4056 /* For {L,U}BOUND, the value depends on whether the array 4057 is empty. We can nevertheless simplify if the declared bound 4058 has the same value as that of an empty array, in which case 4059 the result isn't dependent on the array emptyness. */ 4060 if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) 4061 mpz_set_si (result->value.integer, empty_bound); 4062 else if (!constant_lbound || !constant_ubound) 4063 /* Array emptyness can't be determined, we can't simplify. */ 4064 goto returnNull; 4065 else if (mpz_cmp (l->value.integer, u->value.integer) > 0) 4066 mpz_set_si (result->value.integer, empty_bound); 4067 else 4068 mpz_set (result->value.integer, declared_bound->value.integer); 4069 } 4070 else 4071 mpz_set (result->value.integer, declared_bound->value.integer); 4072 } 4073 else 4074 { 4075 if (upper) 4076 { 4077 int d2 = 0, cnt = 0; 4078 for (int idx = 0; idx < ref->u.ar.dimen; ++idx) 4079 { 4080 if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT) 4081 d2++; 4082 else if (cnt < d - 1) 4083 cnt++; 4084 else 4085 break; 4086 } 4087 if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL)) 4088 goto returnNull; 4089 } 4090 else 4091 mpz_set_si (result->value.integer, (long int) 1); 4092 } 4093 4094done: 4095 return range_check (result, upper ? "UBOUND" : "LBOUND"); 4096 4097returnNull: 4098 gfc_free_expr (result); 4099 return NULL; 4100} 4101 4102 4103static gfc_expr * 4104simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 4105{ 4106 gfc_ref *ref; 4107 gfc_array_spec *as; 4108 ar_type type = AR_UNKNOWN; 4109 int d; 4110 4111 if (array->ts.type == BT_CLASS) 4112 return NULL; 4113 4114 if (array->expr_type != EXPR_VARIABLE) 4115 { 4116 as = NULL; 4117 ref = NULL; 4118 goto done; 4119 } 4120 4121 /* Do not attempt to resolve if error has already been issued. */ 4122 if (array->symtree->n.sym->error) 4123 return NULL; 4124 4125 /* Follow any component references. */ 4126 as = array->symtree->n.sym->as; 4127 for (ref = array->ref; ref; ref = ref->next) 4128 { 4129 switch (ref->type) 4130 { 4131 case REF_ARRAY: 4132 type = ref->u.ar.type; 4133 switch (ref->u.ar.type) 4134 { 4135 case AR_ELEMENT: 4136 as = NULL; 4137 continue; 4138 4139 case AR_FULL: 4140 /* We're done because 'as' has already been set in the 4141 previous iteration. */ 4142 goto done; 4143 4144 case AR_UNKNOWN: 4145 return NULL; 4146 4147 case AR_SECTION: 4148 as = ref->u.ar.as; 4149 goto done; 4150 } 4151 4152 gcc_unreachable (); 4153 4154 case REF_COMPONENT: 4155 as = ref->u.c.component->as; 4156 continue; 4157 4158 case REF_SUBSTRING: 4159 case REF_INQUIRY: 4160 continue; 4161 } 4162 } 4163 4164 gcc_unreachable (); 4165 4166 done: 4167 4168 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK 4169 || (as->type == AS_ASSUMED_SHAPE && upper))) 4170 return NULL; 4171 4172 /* 'array' shall not be an unallocated allocatable variable or a pointer that 4173 is not associated. */ 4174 if (array->expr_type == EXPR_VARIABLE 4175 && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer)) 4176 return NULL; 4177 4178 gcc_assert (!as 4179 || (as->type != AS_DEFERRED 4180 && array->expr_type == EXPR_VARIABLE 4181 && !gfc_expr_attr (array).allocatable 4182 && !gfc_expr_attr (array).pointer)); 4183 4184 if (dim == NULL) 4185 { 4186 /* Multi-dimensional bounds. */ 4187 gfc_expr *bounds[GFC_MAX_DIMENSIONS]; 4188 gfc_expr *e; 4189 int k; 4190 4191 /* UBOUND(ARRAY) is not valid for an assumed-size array. */ 4192 if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE) 4193 { 4194 /* An error message will be emitted in 4195 check_assumed_size_reference (resolve.c). */ 4196 return &gfc_bad_expr; 4197 } 4198 4199 /* Simplify the bounds for each dimension. */ 4200 for (d = 0; d < array->rank; d++) 4201 { 4202 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, 4203 false); 4204 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) 4205 { 4206 int j; 4207 4208 for (j = 0; j < d; j++) 4209 gfc_free_expr (bounds[j]); 4210 4211 if (gfc_seen_div0) 4212 return &gfc_bad_expr; 4213 else 4214 return bounds[d]; 4215 } 4216 } 4217 4218 /* Allocate the result expression. */ 4219 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 4220 gfc_default_integer_kind); 4221 if (k == -1) 4222 return &gfc_bad_expr; 4223 4224 e = gfc_get_array_expr (BT_INTEGER, k, &array->where); 4225 4226 /* The result is a rank 1 array; its size is the rank of the first 4227 argument to {L,U}BOUND. */ 4228 e->rank = 1; 4229 e->shape = gfc_get_shape (1); 4230 mpz_init_set_ui (e->shape[0], array->rank); 4231 4232 /* Create the constructor for this array. */ 4233 for (d = 0; d < array->rank; d++) 4234 gfc_constructor_append_expr (&e->value.constructor, 4235 bounds[d], &e->where); 4236 4237 return e; 4238 } 4239 else 4240 { 4241 /* A DIM argument is specified. */ 4242 if (dim->expr_type != EXPR_CONSTANT) 4243 return NULL; 4244 4245 d = mpz_get_si (dim->value.integer); 4246 4247 if ((d < 1 || d > array->rank) 4248 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) 4249 { 4250 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 4251 return &gfc_bad_expr; 4252 } 4253 4254 if (as && as->type == AS_ASSUMED_RANK) 4255 return NULL; 4256 4257 return simplify_bound_dim (array, kind, d, upper, as, ref, false); 4258 } 4259} 4260 4261 4262static gfc_expr * 4263simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 4264{ 4265 gfc_ref *ref; 4266 gfc_array_spec *as; 4267 int d; 4268 4269 if (array->expr_type != EXPR_VARIABLE) 4270 return NULL; 4271 4272 /* Follow any component references. */ 4273 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) 4274 ? array->ts.u.derived->components->as 4275 : array->symtree->n.sym->as; 4276 for (ref = array->ref; ref; ref = ref->next) 4277 { 4278 switch (ref->type) 4279 { 4280 case REF_ARRAY: 4281 switch (ref->u.ar.type) 4282 { 4283 case AR_ELEMENT: 4284 if (ref->u.ar.as->corank > 0) 4285 { 4286 gcc_assert (as == ref->u.ar.as); 4287 goto done; 4288 } 4289 as = NULL; 4290 continue; 4291 4292 case AR_FULL: 4293 /* We're done because 'as' has already been set in the 4294 previous iteration. */ 4295 goto done; 4296 4297 case AR_UNKNOWN: 4298 return NULL; 4299 4300 case AR_SECTION: 4301 as = ref->u.ar.as; 4302 goto done; 4303 } 4304 4305 gcc_unreachable (); 4306 4307 case REF_COMPONENT: 4308 as = ref->u.c.component->as; 4309 continue; 4310 4311 case REF_SUBSTRING: 4312 case REF_INQUIRY: 4313 continue; 4314 } 4315 } 4316 4317 if (!as) 4318 gcc_unreachable (); 4319 4320 done: 4321 4322 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) 4323 return NULL; 4324 4325 if (dim == NULL) 4326 { 4327 /* Multi-dimensional cobounds. */ 4328 gfc_expr *bounds[GFC_MAX_DIMENSIONS]; 4329 gfc_expr *e; 4330 int k; 4331 4332 /* Simplify the cobounds for each dimension. */ 4333 for (d = 0; d < as->corank; d++) 4334 { 4335 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, 4336 upper, as, ref, true); 4337 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) 4338 { 4339 int j; 4340 4341 for (j = 0; j < d; j++) 4342 gfc_free_expr (bounds[j]); 4343 return bounds[d]; 4344 } 4345 } 4346 4347 /* Allocate the result expression. */ 4348 e = gfc_get_expr (); 4349 e->where = array->where; 4350 e->expr_type = EXPR_ARRAY; 4351 e->ts.type = BT_INTEGER; 4352 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", 4353 gfc_default_integer_kind); 4354 if (k == -1) 4355 { 4356 gfc_free_expr (e); 4357 return &gfc_bad_expr; 4358 } 4359 e->ts.kind = k; 4360 4361 /* The result is a rank 1 array; its size is the rank of the first 4362 argument to {L,U}COBOUND. */ 4363 e->rank = 1; 4364 e->shape = gfc_get_shape (1); 4365 mpz_init_set_ui (e->shape[0], as->corank); 4366 4367 /* Create the constructor for this array. */ 4368 for (d = 0; d < as->corank; d++) 4369 gfc_constructor_append_expr (&e->value.constructor, 4370 bounds[d], &e->where); 4371 return e; 4372 } 4373 else 4374 { 4375 /* A DIM argument is specified. */ 4376 if (dim->expr_type != EXPR_CONSTANT) 4377 return NULL; 4378 4379 d = mpz_get_si (dim->value.integer); 4380 4381 if (d < 1 || d > as->corank) 4382 { 4383 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 4384 return &gfc_bad_expr; 4385 } 4386 4387 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); 4388 } 4389} 4390 4391 4392gfc_expr * 4393gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 4394{ 4395 return simplify_bound (array, dim, kind, 0); 4396} 4397 4398 4399gfc_expr * 4400gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 4401{ 4402 return simplify_cobound (array, dim, kind, 0); 4403} 4404 4405gfc_expr * 4406gfc_simplify_leadz (gfc_expr *e) 4407{ 4408 unsigned long lz, bs; 4409 int i; 4410 4411 if (e->expr_type != EXPR_CONSTANT) 4412 return NULL; 4413 4414 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4415 bs = gfc_integer_kinds[i].bit_size; 4416 if (mpz_cmp_si (e->value.integer, 0) == 0) 4417 lz = bs; 4418 else if (mpz_cmp_si (e->value.integer, 0) < 0) 4419 lz = 0; 4420 else 4421 lz = bs - mpz_sizeinbase (e->value.integer, 2); 4422 4423 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); 4424} 4425 4426 4427gfc_expr * 4428gfc_simplify_len (gfc_expr *e, gfc_expr *kind) 4429{ 4430 gfc_expr *result; 4431 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); 4432 4433 if (k == -1) 4434 return &gfc_bad_expr; 4435 4436 if (e->expr_type == EXPR_CONSTANT) 4437 { 4438 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 4439 mpz_set_si (result->value.integer, e->value.character.length); 4440 return range_check (result, "LEN"); 4441 } 4442 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL 4443 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT 4444 && e->ts.u.cl->length->ts.type == BT_INTEGER) 4445 { 4446 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 4447 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); 4448 return range_check (result, "LEN"); 4449 } 4450 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER 4451 && e->symtree->n.sym 4452 && e->symtree->n.sym->ts.type != BT_DERIVED 4453 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target 4454 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED 4455 && e->symtree->n.sym->assoc->target->symtree->n.sym 4456 && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)) 4457 4458 /* The expression in assoc->target points to a ref to the _data component 4459 of the unlimited polymorphic entity. To get the _len component the last 4460 _data ref needs to be stripped and a ref to the _len component added. */ 4461 return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); 4462 else 4463 return NULL; 4464} 4465 4466 4467gfc_expr * 4468gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) 4469{ 4470 gfc_expr *result; 4471 size_t count, len, i; 4472 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); 4473 4474 if (k == -1) 4475 return &gfc_bad_expr; 4476 4477 if (e->expr_type != EXPR_CONSTANT) 4478 return NULL; 4479 4480 len = e->value.character.length; 4481 for (count = 0, i = 1; i <= len; i++) 4482 if (e->value.character.string[len - i] == ' ') 4483 count++; 4484 else 4485 break; 4486 4487 result = gfc_get_int_expr (k, &e->where, len - count); 4488 return range_check (result, "LEN_TRIM"); 4489} 4490 4491gfc_expr * 4492gfc_simplify_lgamma (gfc_expr *x) 4493{ 4494 gfc_expr *result; 4495 int sg; 4496 4497 if (x->expr_type != EXPR_CONSTANT) 4498 return NULL; 4499 4500 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4501 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); 4502 4503 return range_check (result, "LGAMMA"); 4504} 4505 4506 4507gfc_expr * 4508gfc_simplify_lge (gfc_expr *a, gfc_expr *b) 4509{ 4510 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4511 return NULL; 4512 4513 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4514 gfc_compare_string (a, b) >= 0); 4515} 4516 4517 4518gfc_expr * 4519gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) 4520{ 4521 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4522 return NULL; 4523 4524 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4525 gfc_compare_string (a, b) > 0); 4526} 4527 4528 4529gfc_expr * 4530gfc_simplify_lle (gfc_expr *a, gfc_expr *b) 4531{ 4532 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4533 return NULL; 4534 4535 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4536 gfc_compare_string (a, b) <= 0); 4537} 4538 4539 4540gfc_expr * 4541gfc_simplify_llt (gfc_expr *a, gfc_expr *b) 4542{ 4543 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4544 return NULL; 4545 4546 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4547 gfc_compare_string (a, b) < 0); 4548} 4549 4550 4551gfc_expr * 4552gfc_simplify_log (gfc_expr *x) 4553{ 4554 gfc_expr *result; 4555 4556 if (x->expr_type != EXPR_CONSTANT) 4557 return NULL; 4558 4559 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4560 4561 switch (x->ts.type) 4562 { 4563 case BT_REAL: 4564 if (mpfr_sgn (x->value.real) <= 0) 4565 { 4566 gfc_error ("Argument of LOG at %L cannot be less than or equal " 4567 "to zero", &x->where); 4568 gfc_free_expr (result); 4569 return &gfc_bad_expr; 4570 } 4571 4572 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); 4573 break; 4574 4575 case BT_COMPLEX: 4576 if (mpfr_zero_p (mpc_realref (x->value.complex)) 4577 && mpfr_zero_p (mpc_imagref (x->value.complex))) 4578 { 4579 gfc_error ("Complex argument of LOG at %L cannot be zero", 4580 &x->where); 4581 gfc_free_expr (result); 4582 return &gfc_bad_expr; 4583 } 4584 4585 gfc_set_model_kind (x->ts.kind); 4586 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 4587 break; 4588 4589 default: 4590 gfc_internal_error ("gfc_simplify_log: bad type"); 4591 } 4592 4593 return range_check (result, "LOG"); 4594} 4595 4596 4597gfc_expr * 4598gfc_simplify_log10 (gfc_expr *x) 4599{ 4600 gfc_expr *result; 4601 4602 if (x->expr_type != EXPR_CONSTANT) 4603 return NULL; 4604 4605 if (mpfr_sgn (x->value.real) <= 0) 4606 { 4607 gfc_error ("Argument of LOG10 at %L cannot be less than or equal " 4608 "to zero", &x->where); 4609 return &gfc_bad_expr; 4610 } 4611 4612 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4613 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); 4614 4615 return range_check (result, "LOG10"); 4616} 4617 4618 4619gfc_expr * 4620gfc_simplify_logical (gfc_expr *e, gfc_expr *k) 4621{ 4622 int kind; 4623 4624 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); 4625 if (kind < 0) 4626 return &gfc_bad_expr; 4627 4628 if (e->expr_type != EXPR_CONSTANT) 4629 return NULL; 4630 4631 return gfc_get_logical_expr (kind, &e->where, e->value.logical); 4632} 4633 4634 4635gfc_expr* 4636gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 4637{ 4638 gfc_expr *result; 4639 int row, result_rows, col, result_columns; 4640 int stride_a, offset_a, stride_b, offset_b; 4641 4642 if (!is_constant_array_expr (matrix_a) 4643 || !is_constant_array_expr (matrix_b)) 4644 return NULL; 4645 4646 /* MATMUL should do mixed-mode arithmetic. Set the result type. */ 4647 if (matrix_a->ts.type != matrix_b->ts.type) 4648 { 4649 gfc_expr e; 4650 e.expr_type = EXPR_OP; 4651 gfc_clear_ts (&e.ts); 4652 e.value.op.op = INTRINSIC_NONE; 4653 e.value.op.op1 = matrix_a; 4654 e.value.op.op2 = matrix_b; 4655 gfc_type_convert_binary (&e, 1); 4656 result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); 4657 } 4658 else 4659 { 4660 result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind, 4661 &matrix_a->where); 4662 } 4663 4664 if (matrix_a->rank == 1 && matrix_b->rank == 2) 4665 { 4666 result_rows = 1; 4667 result_columns = mpz_get_si (matrix_b->shape[1]); 4668 stride_a = 1; 4669 stride_b = mpz_get_si (matrix_b->shape[0]); 4670 4671 result->rank = 1; 4672 result->shape = gfc_get_shape (result->rank); 4673 mpz_init_set_si (result->shape[0], result_columns); 4674 } 4675 else if (matrix_a->rank == 2 && matrix_b->rank == 1) 4676 { 4677 result_rows = mpz_get_si (matrix_a->shape[0]); 4678 result_columns = 1; 4679 stride_a = mpz_get_si (matrix_a->shape[0]); 4680 stride_b = 1; 4681 4682 result->rank = 1; 4683 result->shape = gfc_get_shape (result->rank); 4684 mpz_init_set_si (result->shape[0], result_rows); 4685 } 4686 else if (matrix_a->rank == 2 && matrix_b->rank == 2) 4687 { 4688 result_rows = mpz_get_si (matrix_a->shape[0]); 4689 result_columns = mpz_get_si (matrix_b->shape[1]); 4690 stride_a = mpz_get_si (matrix_a->shape[0]); 4691 stride_b = mpz_get_si (matrix_b->shape[0]); 4692 4693 result->rank = 2; 4694 result->shape = gfc_get_shape (result->rank); 4695 mpz_init_set_si (result->shape[0], result_rows); 4696 mpz_init_set_si (result->shape[1], result_columns); 4697 } 4698 else 4699 gcc_unreachable(); 4700 4701 offset_b = 0; 4702 for (col = 0; col < result_columns; ++col) 4703 { 4704 offset_a = 0; 4705 4706 for (row = 0; row < result_rows; ++row) 4707 { 4708 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, 4709 matrix_b, 1, offset_b, false); 4710 gfc_constructor_append_expr (&result->value.constructor, 4711 e, NULL); 4712 4713 offset_a += 1; 4714 } 4715 4716 offset_b += stride_b; 4717 } 4718 4719 return result; 4720} 4721 4722 4723gfc_expr * 4724gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) 4725{ 4726 gfc_expr *result; 4727 int kind, arg, k; 4728 4729 if (i->expr_type != EXPR_CONSTANT) 4730 return NULL; 4731 4732 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); 4733 if (kind == -1) 4734 return &gfc_bad_expr; 4735 k = gfc_validate_kind (BT_INTEGER, kind, false); 4736 4737 bool fail = gfc_extract_int (i, &arg); 4738 gcc_assert (!fail); 4739 4740 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4741 4742 /* MASKR(n) = 2^n - 1 */ 4743 mpz_set_ui (result->value.integer, 1); 4744 mpz_mul_2exp (result->value.integer, result->value.integer, arg); 4745 mpz_sub_ui (result->value.integer, result->value.integer, 1); 4746 4747 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4748 4749 return result; 4750} 4751 4752 4753gfc_expr * 4754gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) 4755{ 4756 gfc_expr *result; 4757 int kind, arg, k; 4758 mpz_t z; 4759 4760 if (i->expr_type != EXPR_CONSTANT) 4761 return NULL; 4762 4763 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); 4764 if (kind == -1) 4765 return &gfc_bad_expr; 4766 k = gfc_validate_kind (BT_INTEGER, kind, false); 4767 4768 bool fail = gfc_extract_int (i, &arg); 4769 gcc_assert (!fail); 4770 4771 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4772 4773 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ 4774 mpz_init_set_ui (z, 1); 4775 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); 4776 mpz_set_ui (result->value.integer, 1); 4777 mpz_mul_2exp (result->value.integer, result->value.integer, 4778 gfc_integer_kinds[k].bit_size - arg); 4779 mpz_sub (result->value.integer, z, result->value.integer); 4780 mpz_clear (z); 4781 4782 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4783 4784 return result; 4785} 4786 4787 4788gfc_expr * 4789gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 4790{ 4791 gfc_expr * result; 4792 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; 4793 4794 if (mask->expr_type == EXPR_CONSTANT) 4795 { 4796 result = gfc_copy_expr (mask->value.logical ? tsource : fsource); 4797 /* Parenthesis is needed to get lower bounds of 1. */ 4798 result = gfc_get_parentheses (result); 4799 gfc_simplify_expr (result, 1); 4800 return result; 4801 } 4802 4803 if (!mask->rank || !is_constant_array_expr (mask) 4804 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) 4805 return NULL; 4806 4807 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, 4808 &tsource->where); 4809 if (tsource->ts.type == BT_DERIVED) 4810 result->ts.u.derived = tsource->ts.u.derived; 4811 else if (tsource->ts.type == BT_CHARACTER) 4812 result->ts.u.cl = tsource->ts.u.cl; 4813 4814 tsource_ctor = gfc_constructor_first (tsource->value.constructor); 4815 fsource_ctor = gfc_constructor_first (fsource->value.constructor); 4816 mask_ctor = gfc_constructor_first (mask->value.constructor); 4817 4818 while (mask_ctor) 4819 { 4820 if (mask_ctor->expr->value.logical) 4821 gfc_constructor_append_expr (&result->value.constructor, 4822 gfc_copy_expr (tsource_ctor->expr), 4823 NULL); 4824 else 4825 gfc_constructor_append_expr (&result->value.constructor, 4826 gfc_copy_expr (fsource_ctor->expr), 4827 NULL); 4828 tsource_ctor = gfc_constructor_next (tsource_ctor); 4829 fsource_ctor = gfc_constructor_next (fsource_ctor); 4830 mask_ctor = gfc_constructor_next (mask_ctor); 4831 } 4832 4833 result->shape = gfc_get_shape (1); 4834 gfc_array_size (result, &result->shape[0]); 4835 4836 return result; 4837} 4838 4839 4840gfc_expr * 4841gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) 4842{ 4843 mpz_t arg1, arg2, mask; 4844 gfc_expr *result; 4845 4846 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT 4847 || mask_expr->expr_type != EXPR_CONSTANT) 4848 return NULL; 4849 4850 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); 4851 4852 /* Convert all argument to unsigned. */ 4853 mpz_init_set (arg1, i->value.integer); 4854 mpz_init_set (arg2, j->value.integer); 4855 mpz_init_set (mask, mask_expr->value.integer); 4856 4857 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ 4858 mpz_and (arg1, arg1, mask); 4859 mpz_com (mask, mask); 4860 mpz_and (arg2, arg2, mask); 4861 mpz_ior (result->value.integer, arg1, arg2); 4862 4863 mpz_clear (arg1); 4864 mpz_clear (arg2); 4865 mpz_clear (mask); 4866 4867 return result; 4868} 4869 4870 4871/* Selects between current value and extremum for simplify_min_max 4872 and simplify_minval_maxval. */ 4873static int 4874min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) 4875{ 4876 int ret; 4877 4878 switch (arg->ts.type) 4879 { 4880 case BT_INTEGER: 4881 ret = mpz_cmp (arg->value.integer, 4882 extremum->value.integer) * sign; 4883 if (ret > 0) 4884 mpz_set (extremum->value.integer, arg->value.integer); 4885 break; 4886 4887 case BT_REAL: 4888 if (mpfr_nan_p (extremum->value.real)) 4889 { 4890 ret = 1; 4891 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); 4892 } 4893 else if (mpfr_nan_p (arg->value.real)) 4894 ret = -1; 4895 else 4896 { 4897 ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; 4898 if (ret > 0) 4899 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); 4900 } 4901 break; 4902 4903 case BT_CHARACTER: 4904#define LENGTH(x) ((x)->value.character.length) 4905#define STRING(x) ((x)->value.character.string) 4906 if (LENGTH (extremum) < LENGTH(arg)) 4907 { 4908 gfc_char_t *tmp = STRING(extremum); 4909 4910 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); 4911 memcpy (STRING(extremum), tmp, 4912 LENGTH(extremum) * sizeof (gfc_char_t)); 4913 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', 4914 LENGTH(arg) - LENGTH(extremum)); 4915 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ 4916 LENGTH(extremum) = LENGTH(arg); 4917 free (tmp); 4918 } 4919 ret = gfc_compare_string (arg, extremum) * sign; 4920 if (ret > 0) 4921 { 4922 free (STRING(extremum)); 4923 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); 4924 memcpy (STRING(extremum), STRING(arg), 4925 LENGTH(arg) * sizeof (gfc_char_t)); 4926 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', 4927 LENGTH(extremum) - LENGTH(arg)); 4928 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ 4929 } 4930#undef LENGTH 4931#undef STRING 4932 break; 4933 4934 default: 4935 gfc_internal_error ("simplify_min_max(): Bad type in arglist"); 4936 } 4937 if (back_val && ret == 0) 4938 ret = 1; 4939 4940 return ret; 4941} 4942 4943 4944/* This function is special since MAX() can take any number of 4945 arguments. The simplified expression is a rewritten version of the 4946 argument list containing at most one constant element. Other 4947 constant elements are deleted. Because the argument list has 4948 already been checked, this function always succeeds. sign is 1 for 4949 MAX(), -1 for MIN(). */ 4950 4951static gfc_expr * 4952simplify_min_max (gfc_expr *expr, int sign) 4953{ 4954 gfc_actual_arglist *arg, *last, *extremum; 4955 gfc_expr *tmp, *ret; 4956 const char *fname; 4957 4958 last = NULL; 4959 extremum = NULL; 4960 4961 arg = expr->value.function.actual; 4962 4963 for (; arg; last = arg, arg = arg->next) 4964 { 4965 if (arg->expr->expr_type != EXPR_CONSTANT) 4966 continue; 4967 4968 if (extremum == NULL) 4969 { 4970 extremum = arg; 4971 continue; 4972 } 4973 4974 min_max_choose (arg->expr, extremum->expr, sign); 4975 4976 /* Delete the extra constant argument. */ 4977 last->next = arg->next; 4978 4979 arg->next = NULL; 4980 gfc_free_actual_arglist (arg); 4981 arg = last; 4982 } 4983 4984 /* If there is one value left, replace the function call with the 4985 expression. */ 4986 if (expr->value.function.actual->next != NULL) 4987 return NULL; 4988 4989 /* Handle special cases of specific functions (min|max)1 and 4990 a(min|max)0. */ 4991 4992 tmp = expr->value.function.actual->expr; 4993 fname = expr->value.function.isym->name; 4994 4995 if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind) 4996 && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) 4997 { 4998 ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind); 4999 } 5000 else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind) 5001 && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) 5002 { 5003 ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind); 5004 } 5005 else 5006 ret = gfc_copy_expr (tmp); 5007 5008 return ret; 5009 5010} 5011 5012 5013gfc_expr * 5014gfc_simplify_min (gfc_expr *e) 5015{ 5016 return simplify_min_max (e, -1); 5017} 5018 5019 5020gfc_expr * 5021gfc_simplify_max (gfc_expr *e) 5022{ 5023 return simplify_min_max (e, 1); 5024} 5025 5026/* Helper function for gfc_simplify_minval. */ 5027 5028static gfc_expr * 5029gfc_min (gfc_expr *op1, gfc_expr *op2) 5030{ 5031 min_max_choose (op1, op2, -1); 5032 gfc_free_expr (op1); 5033 return op2; 5034} 5035 5036/* Simplify minval for constant arrays. */ 5037 5038gfc_expr * 5039gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5040{ 5041 return simplify_transformation (array, dim, mask, INT_MAX, gfc_min); 5042} 5043 5044/* Helper function for gfc_simplify_maxval. */ 5045 5046static gfc_expr * 5047gfc_max (gfc_expr *op1, gfc_expr *op2) 5048{ 5049 min_max_choose (op1, op2, 1); 5050 gfc_free_expr (op1); 5051 return op2; 5052} 5053 5054 5055/* Simplify maxval for constant arrays. */ 5056 5057gfc_expr * 5058gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5059{ 5060 return simplify_transformation (array, dim, mask, INT_MIN, gfc_max); 5061} 5062 5063 5064/* Transform minloc or maxloc of an array, according to MASK, 5065 to the scalar result. This code is mostly identical to 5066 simplify_transformation_to_scalar. */ 5067 5068static gfc_expr * 5069simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, 5070 gfc_expr *extremum, int sign, bool back_val) 5071{ 5072 gfc_expr *a, *m; 5073 gfc_constructor *array_ctor, *mask_ctor; 5074 mpz_t count; 5075 5076 mpz_set_si (result->value.integer, 0); 5077 5078 5079 /* Shortcut for constant .FALSE. MASK. */ 5080 if (mask 5081 && mask->expr_type == EXPR_CONSTANT 5082 && !mask->value.logical) 5083 return result; 5084 5085 array_ctor = gfc_constructor_first (array->value.constructor); 5086 if (mask && mask->expr_type == EXPR_ARRAY) 5087 mask_ctor = gfc_constructor_first (mask->value.constructor); 5088 else 5089 mask_ctor = NULL; 5090 5091 mpz_init_set_si (count, 0); 5092 while (array_ctor) 5093 { 5094 mpz_add_ui (count, count, 1); 5095 a = array_ctor->expr; 5096 array_ctor = gfc_constructor_next (array_ctor); 5097 /* A constant MASK equals .TRUE. here and can be ignored. */ 5098 if (mask_ctor) 5099 { 5100 m = mask_ctor->expr; 5101 mask_ctor = gfc_constructor_next (mask_ctor); 5102 if (!m->value.logical) 5103 continue; 5104 } 5105 if (min_max_choose (a, extremum, sign, back_val) > 0) 5106 mpz_set (result->value.integer, count); 5107 } 5108 mpz_clear (count); 5109 gfc_free_expr (extremum); 5110 return result; 5111} 5112 5113/* Simplify minloc / maxloc in the absence of a dim argument. */ 5114 5115static gfc_expr * 5116simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, 5117 gfc_expr *array, gfc_expr *mask, int sign, 5118 bool back_val) 5119{ 5120 ssize_t res[GFC_MAX_DIMENSIONS]; 5121 int i, n; 5122 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5123 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5124 sstride[GFC_MAX_DIMENSIONS]; 5125 gfc_expr *a, *m; 5126 bool continue_loop; 5127 bool ma; 5128 5129 for (i = 0; i<array->rank; i++) 5130 res[i] = -1; 5131 5132 /* Shortcut for constant .FALSE. MASK. */ 5133 if (mask 5134 && mask->expr_type == EXPR_CONSTANT 5135 && !mask->value.logical) 5136 goto finish; 5137 5138 for (i = 0; i < array->rank; i++) 5139 { 5140 count[i] = 0; 5141 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); 5142 extent[i] = mpz_get_si (array->shape[i]); 5143 if (extent[i] <= 0) 5144 goto finish; 5145 } 5146 5147 continue_loop = true; 5148 array_ctor = gfc_constructor_first (array->value.constructor); 5149 if (mask && mask->rank > 0) 5150 mask_ctor = gfc_constructor_first (mask->value.constructor); 5151 else 5152 mask_ctor = NULL; 5153 5154 /* Loop over the array elements (and mask), keeping track of 5155 the indices to return. */ 5156 while (continue_loop) 5157 { 5158 do 5159 { 5160 a = array_ctor->expr; 5161 if (mask_ctor) 5162 { 5163 m = mask_ctor->expr; 5164 ma = m->value.logical; 5165 mask_ctor = gfc_constructor_next (mask_ctor); 5166 } 5167 else 5168 ma = true; 5169 5170 if (ma && min_max_choose (a, extremum, sign, back_val) > 0) 5171 { 5172 for (i = 0; i<array->rank; i++) 5173 res[i] = count[i]; 5174 } 5175 array_ctor = gfc_constructor_next (array_ctor); 5176 count[0] ++; 5177 } while (count[0] != extent[0]); 5178 n = 0; 5179 do 5180 { 5181 /* When we get to the end of a dimension, reset it and increment 5182 the next dimension. */ 5183 count[n] = 0; 5184 n++; 5185 if (n >= array->rank) 5186 { 5187 continue_loop = false; 5188 break; 5189 } 5190 else 5191 count[n] ++; 5192 } while (count[n] == extent[n]); 5193 } 5194 5195 finish: 5196 gfc_free_expr (extremum); 5197 result_ctor = gfc_constructor_first (result->value.constructor); 5198 for (i = 0; i<array->rank; i++) 5199 { 5200 gfc_expr *r_expr; 5201 r_expr = result_ctor->expr; 5202 mpz_set_si (r_expr->value.integer, res[i] + 1); 5203 result_ctor = gfc_constructor_next (result_ctor); 5204 } 5205 return result; 5206} 5207 5208/* Helper function for gfc_simplify_minmaxloc - build an array 5209 expression with n elements. */ 5210 5211static gfc_expr * 5212new_array (bt type, int kind, int n, locus *where) 5213{ 5214 gfc_expr *result; 5215 int i; 5216 5217 result = gfc_get_array_expr (type, kind, where); 5218 result->rank = 1; 5219 result->shape = gfc_get_shape(1); 5220 mpz_init_set_si (result->shape[0], n); 5221 for (i = 0; i < n; i++) 5222 { 5223 gfc_constructor_append_expr (&result->value.constructor, 5224 gfc_get_constant_expr (type, kind, where), 5225 NULL); 5226 } 5227 5228 return result; 5229} 5230 5231/* Simplify minloc and maxloc. This code is mostly identical to 5232 simplify_transformation_to_array. */ 5233 5234static gfc_expr * 5235simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, 5236 gfc_expr *dim, gfc_expr *mask, 5237 gfc_expr *extremum, int sign, bool back_val) 5238{ 5239 mpz_t size; 5240 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5241 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5242 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5243 5244 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5245 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 5246 tmpstride[GFC_MAX_DIMENSIONS]; 5247 5248 /* Shortcut for constant .FALSE. MASK. */ 5249 if (mask 5250 && mask->expr_type == EXPR_CONSTANT 5251 && !mask->value.logical) 5252 return result; 5253 5254 /* Build an indexed table for array element expressions to minimize 5255 linked-list traversal. Masked elements are set to NULL. */ 5256 gfc_array_size (array, &size); 5257 arraysize = mpz_get_ui (size); 5258 mpz_clear (size); 5259 5260 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 5261 5262 array_ctor = gfc_constructor_first (array->value.constructor); 5263 mask_ctor = NULL; 5264 if (mask && mask->expr_type == EXPR_ARRAY) 5265 mask_ctor = gfc_constructor_first (mask->value.constructor); 5266 5267 for (i = 0; i < arraysize; ++i) 5268 { 5269 arrayvec[i] = array_ctor->expr; 5270 array_ctor = gfc_constructor_next (array_ctor); 5271 5272 if (mask_ctor) 5273 { 5274 if (!mask_ctor->expr->value.logical) 5275 arrayvec[i] = NULL; 5276 5277 mask_ctor = gfc_constructor_next (mask_ctor); 5278 } 5279 } 5280 5281 /* Same for the result expression. */ 5282 gfc_array_size (result, &size); 5283 resultsize = mpz_get_ui (size); 5284 mpz_clear (size); 5285 5286 resultvec = XCNEWVEC (gfc_expr*, resultsize); 5287 result_ctor = gfc_constructor_first (result->value.constructor); 5288 for (i = 0; i < resultsize; ++i) 5289 { 5290 resultvec[i] = result_ctor->expr; 5291 result_ctor = gfc_constructor_next (result_ctor); 5292 } 5293 5294 gfc_extract_int (dim, &dim_index); 5295 dim_index -= 1; /* zero-base index */ 5296 dim_extent = 0; 5297 dim_stride = 0; 5298 5299 for (i = 0, n = 0; i < array->rank; ++i) 5300 { 5301 count[i] = 0; 5302 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 5303 if (i == dim_index) 5304 { 5305 dim_extent = mpz_get_si (array->shape[i]); 5306 dim_stride = tmpstride[i]; 5307 continue; 5308 } 5309 5310 extent[n] = mpz_get_si (array->shape[i]); 5311 sstride[n] = tmpstride[i]; 5312 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5313 n += 1; 5314 } 5315 5316 done = resultsize <= 0; 5317 base = arrayvec; 5318 dest = resultvec; 5319 while (!done) 5320 { 5321 gfc_expr *ex; 5322 ex = gfc_copy_expr (extremum); 5323 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5324 { 5325 if (*src && min_max_choose (*src, ex, sign, back_val) > 0) 5326 mpz_set_si ((*dest)->value.integer, n + 1); 5327 } 5328 5329 count[0]++; 5330 base += sstride[0]; 5331 dest += dstride[0]; 5332 gfc_free_expr (ex); 5333 5334 n = 0; 5335 while (!done && count[n] == extent[n]) 5336 { 5337 count[n] = 0; 5338 base -= sstride[n] * extent[n]; 5339 dest -= dstride[n] * extent[n]; 5340 5341 n++; 5342 if (n < result->rank) 5343 { 5344 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5345 times, we'd warn for the last iteration, because the 5346 array index will have already been incremented to the 5347 array sizes, and we can't tell that this must make 5348 the test against result->rank false, because ranks 5349 must not exceed GFC_MAX_DIMENSIONS. */ 5350 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5351 count[n]++; 5352 base += sstride[n]; 5353 dest += dstride[n]; 5354 GCC_DIAGNOSTIC_POP 5355 } 5356 else 5357 done = true; 5358 } 5359 } 5360 5361 /* Place updated expression in result constructor. */ 5362 result_ctor = gfc_constructor_first (result->value.constructor); 5363 for (i = 0; i < resultsize; ++i) 5364 { 5365 result_ctor->expr = resultvec[i]; 5366 result_ctor = gfc_constructor_next (result_ctor); 5367 } 5368 5369 free (arrayvec); 5370 free (resultvec); 5371 free (extremum); 5372 return result; 5373} 5374 5375/* Simplify minloc and maxloc for constant arrays. */ 5376 5377static gfc_expr * 5378gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 5379 gfc_expr *kind, gfc_expr *back, int sign) 5380{ 5381 gfc_expr *result; 5382 gfc_expr *extremum; 5383 int ikind; 5384 int init_val; 5385 bool back_val = false; 5386 5387 if (!is_constant_array_expr (array) 5388 || !gfc_is_constant_expr (dim)) 5389 return NULL; 5390 5391 if (mask 5392 && !is_constant_array_expr (mask) 5393 && mask->expr_type != EXPR_CONSTANT) 5394 return NULL; 5395 5396 if (kind) 5397 { 5398 if (gfc_extract_int (kind, &ikind, -1)) 5399 return NULL; 5400 } 5401 else 5402 ikind = gfc_default_integer_kind; 5403 5404 if (back) 5405 { 5406 if (back->expr_type != EXPR_CONSTANT) 5407 return NULL; 5408 5409 back_val = back->value.logical; 5410 } 5411 5412 if (sign < 0) 5413 init_val = INT_MAX; 5414 else if (sign > 0) 5415 init_val = INT_MIN; 5416 else 5417 gcc_unreachable(); 5418 5419 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); 5420 init_result_expr (extremum, init_val, array); 5421 5422 if (dim) 5423 { 5424 result = transformational_result (array, dim, BT_INTEGER, 5425 ikind, &array->where); 5426 init_result_expr (result, 0, array); 5427 5428 if (array->rank == 1) 5429 return simplify_minmaxloc_to_scalar (result, array, mask, extremum, 5430 sign, back_val); 5431 else 5432 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, 5433 sign, back_val); 5434 } 5435 else 5436 { 5437 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5438 return simplify_minmaxloc_nodim (result, extremum, array, mask, 5439 sign, back_val); 5440 } 5441} 5442 5443gfc_expr * 5444gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5445 gfc_expr *back) 5446{ 5447 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); 5448} 5449 5450gfc_expr * 5451gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5452 gfc_expr *back) 5453{ 5454 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); 5455} 5456 5457/* Simplify findloc to scalar. Similar to 5458 simplify_minmaxloc_to_scalar. */ 5459 5460static gfc_expr * 5461simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5462 gfc_expr *mask, int back_val) 5463{ 5464 gfc_expr *a, *m; 5465 gfc_constructor *array_ctor, *mask_ctor; 5466 mpz_t count; 5467 5468 mpz_set_si (result->value.integer, 0); 5469 5470 /* Shortcut for constant .FALSE. MASK. */ 5471 if (mask 5472 && mask->expr_type == EXPR_CONSTANT 5473 && !mask->value.logical) 5474 return result; 5475 5476 array_ctor = gfc_constructor_first (array->value.constructor); 5477 if (mask && mask->expr_type == EXPR_ARRAY) 5478 mask_ctor = gfc_constructor_first (mask->value.constructor); 5479 else 5480 mask_ctor = NULL; 5481 5482 mpz_init_set_si (count, 0); 5483 while (array_ctor) 5484 { 5485 mpz_add_ui (count, count, 1); 5486 a = array_ctor->expr; 5487 array_ctor = gfc_constructor_next (array_ctor); 5488 /* A constant MASK equals .TRUE. here and can be ignored. */ 5489 if (mask_ctor) 5490 { 5491 m = mask_ctor->expr; 5492 mask_ctor = gfc_constructor_next (mask_ctor); 5493 if (!m->value.logical) 5494 continue; 5495 } 5496 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5497 { 5498 /* We have a match. If BACK is true, continue so we find 5499 the last one. */ 5500 mpz_set (result->value.integer, count); 5501 if (!back_val) 5502 break; 5503 } 5504 } 5505 mpz_clear (count); 5506 return result; 5507} 5508 5509/* Simplify findloc in the absence of a dim argument. Similar to 5510 simplify_minmaxloc_nodim. */ 5511 5512static gfc_expr * 5513simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, 5514 gfc_expr *mask, bool back_val) 5515{ 5516 ssize_t res[GFC_MAX_DIMENSIONS]; 5517 int i, n; 5518 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5519 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5520 sstride[GFC_MAX_DIMENSIONS]; 5521 gfc_expr *a, *m; 5522 bool continue_loop; 5523 bool ma; 5524 5525 for (i = 0; i < array->rank; i++) 5526 res[i] = -1; 5527 5528 /* Shortcut for constant .FALSE. MASK. */ 5529 if (mask 5530 && mask->expr_type == EXPR_CONSTANT 5531 && !mask->value.logical) 5532 goto finish; 5533 5534 for (i = 0; i < array->rank; i++) 5535 { 5536 count[i] = 0; 5537 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); 5538 extent[i] = mpz_get_si (array->shape[i]); 5539 if (extent[i] <= 0) 5540 goto finish; 5541 } 5542 5543 continue_loop = true; 5544 array_ctor = gfc_constructor_first (array->value.constructor); 5545 if (mask && mask->rank > 0) 5546 mask_ctor = gfc_constructor_first (mask->value.constructor); 5547 else 5548 mask_ctor = NULL; 5549 5550 /* Loop over the array elements (and mask), keeping track of 5551 the indices to return. */ 5552 while (continue_loop) 5553 { 5554 do 5555 { 5556 a = array_ctor->expr; 5557 if (mask_ctor) 5558 { 5559 m = mask_ctor->expr; 5560 ma = m->value.logical; 5561 mask_ctor = gfc_constructor_next (mask_ctor); 5562 } 5563 else 5564 ma = true; 5565 5566 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5567 { 5568 for (i = 0; i < array->rank; i++) 5569 res[i] = count[i]; 5570 if (!back_val) 5571 goto finish; 5572 } 5573 array_ctor = gfc_constructor_next (array_ctor); 5574 count[0] ++; 5575 } while (count[0] != extent[0]); 5576 n = 0; 5577 do 5578 { 5579 /* When we get to the end of a dimension, reset it and increment 5580 the next dimension. */ 5581 count[n] = 0; 5582 n++; 5583 if (n >= array->rank) 5584 { 5585 continue_loop = false; 5586 break; 5587 } 5588 else 5589 count[n] ++; 5590 } while (count[n] == extent[n]); 5591 } 5592 5593finish: 5594 result_ctor = gfc_constructor_first (result->value.constructor); 5595 for (i = 0; i < array->rank; i++) 5596 { 5597 gfc_expr *r_expr; 5598 r_expr = result_ctor->expr; 5599 mpz_set_si (r_expr->value.integer, res[i] + 1); 5600 result_ctor = gfc_constructor_next (result_ctor); 5601 } 5602 return result; 5603} 5604 5605 5606/* Simplify findloc to an array. Similar to 5607 simplify_minmaxloc_to_array. */ 5608 5609static gfc_expr * 5610simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5611 gfc_expr *dim, gfc_expr *mask, bool back_val) 5612{ 5613 mpz_t size; 5614 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5615 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5616 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5617 5618 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5619 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 5620 tmpstride[GFC_MAX_DIMENSIONS]; 5621 5622 /* Shortcut for constant .FALSE. MASK. */ 5623 if (mask 5624 && mask->expr_type == EXPR_CONSTANT 5625 && !mask->value.logical) 5626 return result; 5627 5628 /* Build an indexed table for array element expressions to minimize 5629 linked-list traversal. Masked elements are set to NULL. */ 5630 gfc_array_size (array, &size); 5631 arraysize = mpz_get_ui (size); 5632 mpz_clear (size); 5633 5634 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 5635 5636 array_ctor = gfc_constructor_first (array->value.constructor); 5637 mask_ctor = NULL; 5638 if (mask && mask->expr_type == EXPR_ARRAY) 5639 mask_ctor = gfc_constructor_first (mask->value.constructor); 5640 5641 for (i = 0; i < arraysize; ++i) 5642 { 5643 arrayvec[i] = array_ctor->expr; 5644 array_ctor = gfc_constructor_next (array_ctor); 5645 5646 if (mask_ctor) 5647 { 5648 if (!mask_ctor->expr->value.logical) 5649 arrayvec[i] = NULL; 5650 5651 mask_ctor = gfc_constructor_next (mask_ctor); 5652 } 5653 } 5654 5655 /* Same for the result expression. */ 5656 gfc_array_size (result, &size); 5657 resultsize = mpz_get_ui (size); 5658 mpz_clear (size); 5659 5660 resultvec = XCNEWVEC (gfc_expr*, resultsize); 5661 result_ctor = gfc_constructor_first (result->value.constructor); 5662 for (i = 0; i < resultsize; ++i) 5663 { 5664 resultvec[i] = result_ctor->expr; 5665 result_ctor = gfc_constructor_next (result_ctor); 5666 } 5667 5668 gfc_extract_int (dim, &dim_index); 5669 5670 dim_index -= 1; /* Zero-base index. */ 5671 dim_extent = 0; 5672 dim_stride = 0; 5673 5674 for (i = 0, n = 0; i < array->rank; ++i) 5675 { 5676 count[i] = 0; 5677 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 5678 if (i == dim_index) 5679 { 5680 dim_extent = mpz_get_si (array->shape[i]); 5681 dim_stride = tmpstride[i]; 5682 continue; 5683 } 5684 5685 extent[n] = mpz_get_si (array->shape[i]); 5686 sstride[n] = tmpstride[i]; 5687 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5688 n += 1; 5689 } 5690 5691 done = resultsize <= 0; 5692 base = arrayvec; 5693 dest = resultvec; 5694 while (!done) 5695 { 5696 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5697 { 5698 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) 5699 { 5700 mpz_set_si ((*dest)->value.integer, n + 1); 5701 if (!back_val) 5702 break; 5703 } 5704 } 5705 5706 count[0]++; 5707 base += sstride[0]; 5708 dest += dstride[0]; 5709 5710 n = 0; 5711 while (!done && count[n] == extent[n]) 5712 { 5713 count[n] = 0; 5714 base -= sstride[n] * extent[n]; 5715 dest -= dstride[n] * extent[n]; 5716 5717 n++; 5718 if (n < result->rank) 5719 { 5720 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5721 times, we'd warn for the last iteration, because the 5722 array index will have already been incremented to the 5723 array sizes, and we can't tell that this must make 5724 the test against result->rank false, because ranks 5725 must not exceed GFC_MAX_DIMENSIONS. */ 5726 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5727 count[n]++; 5728 base += sstride[n]; 5729 dest += dstride[n]; 5730 GCC_DIAGNOSTIC_POP 5731 } 5732 else 5733 done = true; 5734 } 5735 } 5736 5737 /* Place updated expression in result constructor. */ 5738 result_ctor = gfc_constructor_first (result->value.constructor); 5739 for (i = 0; i < resultsize; ++i) 5740 { 5741 result_ctor->expr = resultvec[i]; 5742 result_ctor = gfc_constructor_next (result_ctor); 5743 } 5744 5745 free (arrayvec); 5746 free (resultvec); 5747 return result; 5748} 5749 5750/* Simplify findloc. */ 5751 5752gfc_expr * 5753gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, 5754 gfc_expr *mask, gfc_expr *kind, gfc_expr *back) 5755{ 5756 gfc_expr *result; 5757 int ikind; 5758 bool back_val = false; 5759 5760 if (!is_constant_array_expr (array) 5761 || array->shape == NULL 5762 || !gfc_is_constant_expr (dim)) 5763 return NULL; 5764 5765 if (! gfc_is_constant_expr (value)) 5766 return 0; 5767 5768 if (mask 5769 && !is_constant_array_expr (mask) 5770 && mask->expr_type != EXPR_CONSTANT) 5771 return NULL; 5772 5773 if (kind) 5774 { 5775 if (gfc_extract_int (kind, &ikind, -1)) 5776 return NULL; 5777 } 5778 else 5779 ikind = gfc_default_integer_kind; 5780 5781 if (back) 5782 { 5783 if (back->expr_type != EXPR_CONSTANT) 5784 return NULL; 5785 5786 back_val = back->value.logical; 5787 } 5788 5789 if (dim) 5790 { 5791 result = transformational_result (array, dim, BT_INTEGER, 5792 ikind, &array->where); 5793 init_result_expr (result, 0, array); 5794 5795 if (array->rank == 1) 5796 return simplify_findloc_to_scalar (result, array, value, mask, 5797 back_val); 5798 else 5799 return simplify_findloc_to_array (result, array, value, dim, mask, 5800 back_val); 5801 } 5802 else 5803 { 5804 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5805 return simplify_findloc_nodim (result, value, array, mask, back_val); 5806 } 5807 return NULL; 5808} 5809 5810gfc_expr * 5811gfc_simplify_maxexponent (gfc_expr *x) 5812{ 5813 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5814 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5815 gfc_real_kinds[i].max_exponent); 5816} 5817 5818 5819gfc_expr * 5820gfc_simplify_minexponent (gfc_expr *x) 5821{ 5822 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5823 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5824 gfc_real_kinds[i].min_exponent); 5825} 5826 5827 5828gfc_expr * 5829gfc_simplify_mod (gfc_expr *a, gfc_expr *p) 5830{ 5831 gfc_expr *result; 5832 int kind; 5833 5834 /* First check p. */ 5835 if (p->expr_type != EXPR_CONSTANT) 5836 return NULL; 5837 5838 /* p shall not be 0. */ 5839 switch (p->ts.type) 5840 { 5841 case BT_INTEGER: 5842 if (mpz_cmp_ui (p->value.integer, 0) == 0) 5843 { 5844 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5845 "P", &p->where); 5846 return &gfc_bad_expr; 5847 } 5848 break; 5849 case BT_REAL: 5850 if (mpfr_cmp_ui (p->value.real, 0) == 0) 5851 { 5852 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5853 "P", &p->where); 5854 return &gfc_bad_expr; 5855 } 5856 break; 5857 default: 5858 gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); 5859 } 5860 5861 if (a->expr_type != EXPR_CONSTANT) 5862 return NULL; 5863 5864 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 5865 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 5866 5867 if (a->ts.type == BT_INTEGER) 5868 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); 5869 else 5870 { 5871 gfc_set_model_kind (kind); 5872 mpfr_fmod (result->value.real, a->value.real, p->value.real, 5873 GFC_RND_MODE); 5874 } 5875 5876 return range_check (result, "MOD"); 5877} 5878 5879 5880gfc_expr * 5881gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 5882{ 5883 gfc_expr *result; 5884 int kind; 5885 5886 /* First check p. */ 5887 if (p->expr_type != EXPR_CONSTANT) 5888 return NULL; 5889 5890 /* p shall not be 0. */ 5891 switch (p->ts.type) 5892 { 5893 case BT_INTEGER: 5894 if (mpz_cmp_ui (p->value.integer, 0) == 0) 5895 { 5896 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 5897 "P", &p->where); 5898 return &gfc_bad_expr; 5899 } 5900 break; 5901 case BT_REAL: 5902 if (mpfr_cmp_ui (p->value.real, 0) == 0) 5903 { 5904 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 5905 "P", &p->where); 5906 return &gfc_bad_expr; 5907 } 5908 break; 5909 default: 5910 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); 5911 } 5912 5913 if (a->expr_type != EXPR_CONSTANT) 5914 return NULL; 5915 5916 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 5917 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 5918 5919 if (a->ts.type == BT_INTEGER) 5920 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); 5921 else 5922 { 5923 gfc_set_model_kind (kind); 5924 mpfr_fmod (result->value.real, a->value.real, p->value.real, 5925 GFC_RND_MODE); 5926 if (mpfr_cmp_ui (result->value.real, 0) != 0) 5927 { 5928 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) 5929 mpfr_add (result->value.real, result->value.real, p->value.real, 5930 GFC_RND_MODE); 5931 } 5932 else 5933 mpfr_copysign (result->value.real, result->value.real, 5934 p->value.real, GFC_RND_MODE); 5935 } 5936 5937 return range_check (result, "MODULO"); 5938} 5939 5940 5941gfc_expr * 5942gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 5943{ 5944 gfc_expr *result; 5945 mpfr_exp_t emin, emax; 5946 int kind; 5947 5948 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 5949 return NULL; 5950 5951 result = gfc_copy_expr (x); 5952 5953 /* Save current values of emin and emax. */ 5954 emin = mpfr_get_emin (); 5955 emax = mpfr_get_emax (); 5956 5957 /* Set emin and emax for the current model number. */ 5958 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); 5959 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - 5960 mpfr_get_prec(result->value.real) + 1); 5961 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent); 5962 mpfr_check_range (result->value.real, 0, MPFR_RNDU); 5963 5964 if (mpfr_sgn (s->value.real) > 0) 5965 { 5966 mpfr_nextabove (result->value.real); 5967 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); 5968 } 5969 else 5970 { 5971 mpfr_nextbelow (result->value.real); 5972 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); 5973 } 5974 5975 mpfr_set_emin (emin); 5976 mpfr_set_emax (emax); 5977 5978 /* Only NaN can occur. Do not use range check as it gives an 5979 error for denormal numbers. */ 5980 if (mpfr_nan_p (result->value.real) && flag_range_check) 5981 { 5982 gfc_error ("Result of NEAREST is NaN at %L", &result->where); 5983 gfc_free_expr (result); 5984 return &gfc_bad_expr; 5985 } 5986 5987 return result; 5988} 5989 5990 5991static gfc_expr * 5992simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 5993{ 5994 gfc_expr *itrunc, *result; 5995 int kind; 5996 5997 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); 5998 if (kind == -1) 5999 return &gfc_bad_expr; 6000 6001 if (e->expr_type != EXPR_CONSTANT) 6002 return NULL; 6003 6004 itrunc = gfc_copy_expr (e); 6005 mpfr_round (itrunc->value.real, e->value.real); 6006 6007 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 6008 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); 6009 6010 gfc_free_expr (itrunc); 6011 6012 return range_check (result, name); 6013} 6014 6015 6016gfc_expr * 6017gfc_simplify_new_line (gfc_expr *e) 6018{ 6019 gfc_expr *result; 6020 6021 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); 6022 result->value.character.string[0] = '\n'; 6023 6024 return result; 6025} 6026 6027 6028gfc_expr * 6029gfc_simplify_nint (gfc_expr *e, gfc_expr *k) 6030{ 6031 return simplify_nint ("NINT", e, k); 6032} 6033 6034 6035gfc_expr * 6036gfc_simplify_idnint (gfc_expr *e) 6037{ 6038 return simplify_nint ("IDNINT", e, NULL); 6039} 6040 6041static int norm2_scale; 6042 6043static gfc_expr * 6044norm2_add_squared (gfc_expr *result, gfc_expr *e) 6045{ 6046 mpfr_t tmp; 6047 6048 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 6049 gcc_assert (result->ts.type == BT_REAL 6050 && result->expr_type == EXPR_CONSTANT); 6051 6052 gfc_set_model_kind (result->ts.kind); 6053 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); 6054 mpfr_exp_t exp; 6055 if (mpfr_regular_p (result->value.real)) 6056 { 6057 exp = mpfr_get_exp (result->value.real); 6058 /* If result is getting close to overflowing, scale down. */ 6059 if (exp >= gfc_real_kinds[index].max_exponent - 4 6060 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) 6061 { 6062 norm2_scale += 2; 6063 mpfr_div_ui (result->value.real, result->value.real, 16, 6064 GFC_RND_MODE); 6065 } 6066 } 6067 6068 mpfr_init (tmp); 6069 if (mpfr_regular_p (e->value.real)) 6070 { 6071 exp = mpfr_get_exp (e->value.real); 6072 /* If e**2 would overflow or close to overflowing, scale down. */ 6073 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) 6074 { 6075 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; 6076 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6077 mpfr_set_exp (tmp, new_scale - norm2_scale); 6078 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6079 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6080 norm2_scale = new_scale; 6081 } 6082 } 6083 if (norm2_scale) 6084 { 6085 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6086 mpfr_set_exp (tmp, norm2_scale); 6087 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE); 6088 } 6089 else 6090 mpfr_set (tmp, e->value.real, GFC_RND_MODE); 6091 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE); 6092 mpfr_add (result->value.real, result->value.real, tmp, 6093 GFC_RND_MODE); 6094 mpfr_clear (tmp); 6095 6096 return result; 6097} 6098 6099 6100static gfc_expr * 6101norm2_do_sqrt (gfc_expr *result, gfc_expr *e) 6102{ 6103 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 6104 gcc_assert (result->ts.type == BT_REAL 6105 && result->expr_type == EXPR_CONSTANT); 6106 6107 if (result != e) 6108 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); 6109 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 6110 if (norm2_scale && mpfr_regular_p (result->value.real)) 6111 { 6112 mpfr_t tmp; 6113 mpfr_init (tmp); 6114 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6115 mpfr_set_exp (tmp, norm2_scale); 6116 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6117 mpfr_clear (tmp); 6118 } 6119 norm2_scale = 0; 6120 6121 return result; 6122} 6123 6124 6125gfc_expr * 6126gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) 6127{ 6128 gfc_expr *result; 6129 bool size_zero; 6130 6131 size_zero = gfc_is_size_zero_array (e); 6132 6133 if (!(is_constant_array_expr (e) || size_zero) 6134 || (dim != NULL && !gfc_is_constant_expr (dim))) 6135 return NULL; 6136 6137 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); 6138 init_result_expr (result, 0, NULL); 6139 6140 if (size_zero) 6141 return result; 6142 6143 norm2_scale = 0; 6144 if (!dim || e->rank == 1) 6145 { 6146 result = simplify_transformation_to_scalar (result, e, NULL, 6147 norm2_add_squared); 6148 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 6149 if (norm2_scale && mpfr_regular_p (result->value.real)) 6150 { 6151 mpfr_t tmp; 6152 mpfr_init (tmp); 6153 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6154 mpfr_set_exp (tmp, norm2_scale); 6155 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6156 mpfr_clear (tmp); 6157 } 6158 norm2_scale = 0; 6159 } 6160 else 6161 result = simplify_transformation_to_array (result, e, dim, NULL, 6162 norm2_add_squared, 6163 norm2_do_sqrt); 6164 6165 return result; 6166} 6167 6168 6169gfc_expr * 6170gfc_simplify_not (gfc_expr *e) 6171{ 6172 gfc_expr *result; 6173 6174 if (e->expr_type != EXPR_CONSTANT) 6175 return NULL; 6176 6177 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6178 mpz_com (result->value.integer, e->value.integer); 6179 6180 return range_check (result, "NOT"); 6181} 6182 6183 6184gfc_expr * 6185gfc_simplify_null (gfc_expr *mold) 6186{ 6187 gfc_expr *result; 6188 6189 if (mold) 6190 { 6191 result = gfc_copy_expr (mold); 6192 result->expr_type = EXPR_NULL; 6193 } 6194 else 6195 result = gfc_get_null_expr (NULL); 6196 6197 return result; 6198} 6199 6200 6201gfc_expr * 6202gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) 6203{ 6204 gfc_expr *result; 6205 6206 if (flag_coarray == GFC_FCOARRAY_NONE) 6207 { 6208 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6209 return &gfc_bad_expr; 6210 } 6211 6212 if (flag_coarray != GFC_FCOARRAY_SINGLE) 6213 return NULL; 6214 6215 if (failed && failed->expr_type != EXPR_CONSTANT) 6216 return NULL; 6217 6218 /* FIXME: gfc_current_locus is wrong. */ 6219 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6220 &gfc_current_locus); 6221 6222 if (failed && failed->value.logical != 0) 6223 mpz_set_si (result->value.integer, 0); 6224 else 6225 mpz_set_si (result->value.integer, 1); 6226 6227 return result; 6228} 6229 6230 6231gfc_expr * 6232gfc_simplify_or (gfc_expr *x, gfc_expr *y) 6233{ 6234 gfc_expr *result; 6235 int kind; 6236 6237 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 6238 return NULL; 6239 6240 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 6241 6242 switch (x->ts.type) 6243 { 6244 case BT_INTEGER: 6245 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 6246 mpz_ior (result->value.integer, x->value.integer, y->value.integer); 6247 return range_check (result, "OR"); 6248 6249 case BT_LOGICAL: 6250 return gfc_get_logical_expr (kind, &x->where, 6251 x->value.logical || y->value.logical); 6252 default: 6253 gcc_unreachable(); 6254 } 6255} 6256 6257 6258gfc_expr * 6259gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 6260{ 6261 gfc_expr *result; 6262 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; 6263 6264 if (!is_constant_array_expr (array) 6265 || !is_constant_array_expr (vector) 6266 || (!gfc_is_constant_expr (mask) 6267 && !is_constant_array_expr (mask))) 6268 return NULL; 6269 6270 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 6271 if (array->ts.type == BT_DERIVED) 6272 result->ts.u.derived = array->ts.u.derived; 6273 6274 array_ctor = gfc_constructor_first (array->value.constructor); 6275 vector_ctor = vector 6276 ? gfc_constructor_first (vector->value.constructor) 6277 : NULL; 6278 6279 if (mask->expr_type == EXPR_CONSTANT 6280 && mask->value.logical) 6281 { 6282 /* Copy all elements of ARRAY to RESULT. */ 6283 while (array_ctor) 6284 { 6285 gfc_constructor_append_expr (&result->value.constructor, 6286 gfc_copy_expr (array_ctor->expr), 6287 NULL); 6288 6289 array_ctor = gfc_constructor_next (array_ctor); 6290 vector_ctor = gfc_constructor_next (vector_ctor); 6291 } 6292 } 6293 else if (mask->expr_type == EXPR_ARRAY) 6294 { 6295 /* Copy only those elements of ARRAY to RESULT whose 6296 MASK equals .TRUE.. */ 6297 mask_ctor = gfc_constructor_first (mask->value.constructor); 6298 while (mask_ctor && array_ctor) 6299 { 6300 if (mask_ctor->expr->value.logical) 6301 { 6302 gfc_constructor_append_expr (&result->value.constructor, 6303 gfc_copy_expr (array_ctor->expr), 6304 NULL); 6305 vector_ctor = gfc_constructor_next (vector_ctor); 6306 } 6307 6308 array_ctor = gfc_constructor_next (array_ctor); 6309 mask_ctor = gfc_constructor_next (mask_ctor); 6310 } 6311 } 6312 6313 /* Append any left-over elements from VECTOR to RESULT. */ 6314 while (vector_ctor) 6315 { 6316 gfc_constructor_append_expr (&result->value.constructor, 6317 gfc_copy_expr (vector_ctor->expr), 6318 NULL); 6319 vector_ctor = gfc_constructor_next (vector_ctor); 6320 } 6321 6322 result->shape = gfc_get_shape (1); 6323 gfc_array_size (result, &result->shape[0]); 6324 6325 if (array->ts.type == BT_CHARACTER) 6326 result->ts.u.cl = array->ts.u.cl; 6327 6328 return result; 6329} 6330 6331 6332static gfc_expr * 6333do_xor (gfc_expr *result, gfc_expr *e) 6334{ 6335 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); 6336 gcc_assert (result->ts.type == BT_LOGICAL 6337 && result->expr_type == EXPR_CONSTANT); 6338 6339 result->value.logical = result->value.logical != e->value.logical; 6340 return result; 6341} 6342 6343 6344gfc_expr * 6345gfc_simplify_is_contiguous (gfc_expr *array) 6346{ 6347 if (gfc_is_simply_contiguous (array, false, true)) 6348 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); 6349 6350 if (gfc_is_not_contiguous (array)) 6351 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); 6352 6353 return NULL; 6354} 6355 6356 6357gfc_expr * 6358gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) 6359{ 6360 return simplify_transformation (e, dim, NULL, 0, do_xor); 6361} 6362 6363 6364gfc_expr * 6365gfc_simplify_popcnt (gfc_expr *e) 6366{ 6367 int res, k; 6368 mpz_t x; 6369 6370 if (e->expr_type != EXPR_CONSTANT) 6371 return NULL; 6372 6373 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6374 6375 /* Convert argument to unsigned, then count the '1' bits. */ 6376 mpz_init_set (x, e->value.integer); 6377 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 6378 res = mpz_popcount (x); 6379 mpz_clear (x); 6380 6381 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); 6382} 6383 6384 6385gfc_expr * 6386gfc_simplify_poppar (gfc_expr *e) 6387{ 6388 gfc_expr *popcnt; 6389 int i; 6390 6391 if (e->expr_type != EXPR_CONSTANT) 6392 return NULL; 6393 6394 popcnt = gfc_simplify_popcnt (e); 6395 gcc_assert (popcnt); 6396 6397 bool fail = gfc_extract_int (popcnt, &i); 6398 gcc_assert (!fail); 6399 6400 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); 6401} 6402 6403 6404gfc_expr * 6405gfc_simplify_precision (gfc_expr *e) 6406{ 6407 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6408 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, 6409 gfc_real_kinds[i].precision); 6410} 6411 6412 6413gfc_expr * 6414gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 6415{ 6416 return simplify_transformation (array, dim, mask, 1, gfc_multiply); 6417} 6418 6419 6420gfc_expr * 6421gfc_simplify_radix (gfc_expr *e) 6422{ 6423 int i; 6424 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6425 6426 switch (e->ts.type) 6427 { 6428 case BT_INTEGER: 6429 i = gfc_integer_kinds[i].radix; 6430 break; 6431 6432 case BT_REAL: 6433 i = gfc_real_kinds[i].radix; 6434 break; 6435 6436 default: 6437 gcc_unreachable (); 6438 } 6439 6440 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 6441} 6442 6443 6444gfc_expr * 6445gfc_simplify_range (gfc_expr *e) 6446{ 6447 int i; 6448 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6449 6450 switch (e->ts.type) 6451 { 6452 case BT_INTEGER: 6453 i = gfc_integer_kinds[i].range; 6454 break; 6455 6456 case BT_REAL: 6457 case BT_COMPLEX: 6458 i = gfc_real_kinds[i].range; 6459 break; 6460 6461 default: 6462 gcc_unreachable (); 6463 } 6464 6465 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 6466} 6467 6468 6469gfc_expr * 6470gfc_simplify_rank (gfc_expr *e) 6471{ 6472 /* Assumed rank. */ 6473 if (e->rank == -1) 6474 return NULL; 6475 6476 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); 6477} 6478 6479 6480gfc_expr * 6481gfc_simplify_real (gfc_expr *e, gfc_expr *k) 6482{ 6483 gfc_expr *result = NULL; 6484 int kind, tmp1, tmp2; 6485 6486 /* Convert BOZ to real, and return without range checking. */ 6487 if (e->ts.type == BT_BOZ) 6488 { 6489 /* Determine kind for conversion of the BOZ. */ 6490 if (k) 6491 gfc_extract_int (k, &kind); 6492 else 6493 kind = gfc_default_real_kind; 6494 6495 if (!gfc_boz2real (e, kind)) 6496 return NULL; 6497 result = gfc_copy_expr (e); 6498 return result; 6499 } 6500 6501 if (e->ts.type == BT_COMPLEX) 6502 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); 6503 else 6504 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); 6505 6506 if (kind == -1) 6507 return &gfc_bad_expr; 6508 6509 if (e->expr_type != EXPR_CONSTANT) 6510 return NULL; 6511 6512 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 6513 warnings. */ 6514 tmp1 = warn_conversion; 6515 tmp2 = warn_conversion_extra; 6516 warn_conversion = warn_conversion_extra = 0; 6517 6518 result = gfc_convert_constant (e, BT_REAL, kind); 6519 6520 warn_conversion = tmp1; 6521 warn_conversion_extra = tmp2; 6522 6523 if (result == &gfc_bad_expr) 6524 return &gfc_bad_expr; 6525 6526 return range_check (result, "REAL"); 6527} 6528 6529 6530gfc_expr * 6531gfc_simplify_realpart (gfc_expr *e) 6532{ 6533 gfc_expr *result; 6534 6535 if (e->expr_type != EXPR_CONSTANT) 6536 return NULL; 6537 6538 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 6539 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); 6540 6541 return range_check (result, "REALPART"); 6542} 6543 6544gfc_expr * 6545gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) 6546{ 6547 gfc_expr *result; 6548 gfc_charlen_t len; 6549 mpz_t ncopies; 6550 bool have_length = false; 6551 6552 /* If NCOPIES isn't a constant, there's nothing we can do. */ 6553 if (n->expr_type != EXPR_CONSTANT) 6554 return NULL; 6555 6556 /* If NCOPIES is negative, it's an error. */ 6557 if (mpz_sgn (n->value.integer) < 0) 6558 { 6559 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", 6560 &n->where); 6561 return &gfc_bad_expr; 6562 } 6563 6564 /* If we don't know the character length, we can do no more. */ 6565 if (e->ts.u.cl && e->ts.u.cl->length 6566 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 6567 { 6568 len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); 6569 have_length = true; 6570 } 6571 else if (e->expr_type == EXPR_CONSTANT 6572 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 6573 { 6574 len = e->value.character.length; 6575 } 6576 else 6577 return NULL; 6578 6579 /* If the source length is 0, any value of NCOPIES is valid 6580 and everything behaves as if NCOPIES == 0. */ 6581 mpz_init (ncopies); 6582 if (len == 0) 6583 mpz_set_ui (ncopies, 0); 6584 else 6585 mpz_set (ncopies, n->value.integer); 6586 6587 /* Check that NCOPIES isn't too large. */ 6588 if (len) 6589 { 6590 mpz_t max, mlen; 6591 int i; 6592 6593 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ 6594 mpz_init (max); 6595 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 6596 6597 if (have_length) 6598 { 6599 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, 6600 e->ts.u.cl->length->value.integer); 6601 } 6602 else 6603 { 6604 mpz_init (mlen); 6605 gfc_mpz_set_hwi (mlen, len); 6606 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); 6607 mpz_clear (mlen); 6608 } 6609 6610 /* The check itself. */ 6611 if (mpz_cmp (ncopies, max) > 0) 6612 { 6613 mpz_clear (max); 6614 mpz_clear (ncopies); 6615 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", 6616 &n->where); 6617 return &gfc_bad_expr; 6618 } 6619 6620 mpz_clear (max); 6621 } 6622 mpz_clear (ncopies); 6623 6624 /* For further simplification, we need the character string to be 6625 constant. */ 6626 if (e->expr_type != EXPR_CONSTANT) 6627 return NULL; 6628 6629 HOST_WIDE_INT ncop; 6630 if (len || 6631 (e->ts.u.cl->length && 6632 mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) 6633 { 6634 bool fail = gfc_extract_hwi (n, &ncop); 6635 gcc_assert (!fail); 6636 } 6637 else 6638 ncop = 0; 6639 6640 if (ncop == 0) 6641 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); 6642 6643 len = e->value.character.length; 6644 gfc_charlen_t nlen = ncop * len; 6645 6646 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB 6647 (2**28 elements * 4 bytes (wide chars) per element) defer to 6648 runtime instead of consuming (unbounded) memory and CPU at 6649 compile time. */ 6650 if (nlen > 268435456) 6651 { 6652 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L" 6653 " deferred to runtime, expect bugs", &e->where); 6654 return NULL; 6655 } 6656 6657 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); 6658 for (size_t i = 0; i < (size_t) ncop; i++) 6659 for (size_t j = 0; j < (size_t) len; j++) 6660 result->value.character.string[j+i*len]= e->value.character.string[j]; 6661 6662 result->value.character.string[nlen] = '\0'; /* For debugger */ 6663 return result; 6664} 6665 6666 6667/* This one is a bear, but mainly has to do with shuffling elements. */ 6668 6669gfc_expr * 6670gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 6671 gfc_expr *pad, gfc_expr *order_exp) 6672{ 6673 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; 6674 int i, rank, npad, x[GFC_MAX_DIMENSIONS]; 6675 mpz_t index, size; 6676 unsigned long j; 6677 size_t nsource; 6678 gfc_expr *e, *result; 6679 6680 /* Check that argument expression types are OK. */ 6681 if (!is_constant_array_expr (source) 6682 || !is_constant_array_expr (shape_exp) 6683 || !is_constant_array_expr (pad) 6684 || !is_constant_array_expr (order_exp)) 6685 return NULL; 6686 6687 if (source->shape == NULL) 6688 return NULL; 6689 6690 /* Proceed with simplification, unpacking the array. */ 6691 6692 mpz_init (index); 6693 rank = 0; 6694 6695 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 6696 x[i] = 0; 6697 6698 for (;;) 6699 { 6700 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); 6701 if (e == NULL) 6702 break; 6703 6704 gfc_extract_int (e, &shape[rank]); 6705 6706 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); 6707 if (shape[rank] < 0) 6708 { 6709 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " 6710 "negative value %d for dimension %d", 6711 &shape_exp->where, shape[rank], rank+1); 6712 return &gfc_bad_expr; 6713 } 6714 6715 rank++; 6716 } 6717 6718 gcc_assert (rank > 0); 6719 6720 /* Now unpack the order array if present. */ 6721 if (order_exp == NULL) 6722 { 6723 for (i = 0; i < rank; i++) 6724 order[i] = i; 6725 } 6726 else 6727 { 6728 mpz_t size; 6729 int order_size, shape_size; 6730 6731 if (order_exp->rank != shape_exp->rank) 6732 { 6733 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", 6734 &order_exp->where, &shape_exp->where); 6735 return &gfc_bad_expr; 6736 } 6737 6738 gfc_array_size (shape_exp, &size); 6739 shape_size = mpz_get_ui (size); 6740 mpz_clear (size); 6741 gfc_array_size (order_exp, &size); 6742 order_size = mpz_get_ui (size); 6743 mpz_clear (size); 6744 if (order_size != shape_size) 6745 { 6746 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", 6747 &order_exp->where, &shape_exp->where); 6748 return &gfc_bad_expr; 6749 } 6750 6751 for (i = 0; i < rank; i++) 6752 { 6753 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); 6754 gcc_assert (e); 6755 6756 gfc_extract_int (e, &order[i]); 6757 6758 if (order[i] < 1 || order[i] > rank) 6759 { 6760 gfc_error ("Element with a value of %d in ORDER at %L must be " 6761 "in the range [1, ..., %d] for the RESHAPE intrinsic " 6762 "near %L", order[i], &order_exp->where, rank, 6763 &shape_exp->where); 6764 return &gfc_bad_expr; 6765 } 6766 6767 order[i]--; 6768 if (x[order[i]] != 0) 6769 { 6770 gfc_error ("ORDER at %L is not a permutation of the size of " 6771 "SHAPE at %L", &order_exp->where, &shape_exp->where); 6772 return &gfc_bad_expr; 6773 } 6774 x[order[i]] = 1; 6775 } 6776 } 6777 6778 /* Count the elements in the source and padding arrays. */ 6779 6780 npad = 0; 6781 if (pad != NULL) 6782 { 6783 gfc_array_size (pad, &size); 6784 npad = mpz_get_ui (size); 6785 mpz_clear (size); 6786 } 6787 6788 gfc_array_size (source, &size); 6789 nsource = mpz_get_ui (size); 6790 mpz_clear (size); 6791 6792 /* If it weren't for that pesky permutation we could just loop 6793 through the source and round out any shortage with pad elements. 6794 But no, someone just had to have the compiler do something the 6795 user should be doing. */ 6796 6797 for (i = 0; i < rank; i++) 6798 x[i] = 0; 6799 6800 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 6801 &source->where); 6802 if (source->ts.type == BT_DERIVED) 6803 result->ts.u.derived = source->ts.u.derived; 6804 result->rank = rank; 6805 result->shape = gfc_get_shape (rank); 6806 for (i = 0; i < rank; i++) 6807 mpz_init_set_ui (result->shape[i], shape[i]); 6808 6809 while (nsource > 0 || npad > 0) 6810 { 6811 /* Figure out which element to extract. */ 6812 mpz_set_ui (index, 0); 6813 6814 for (i = rank - 1; i >= 0; i--) 6815 { 6816 mpz_add_ui (index, index, x[order[i]]); 6817 if (i != 0) 6818 mpz_mul_ui (index, index, shape[order[i - 1]]); 6819 } 6820 6821 if (mpz_cmp_ui (index, INT_MAX) > 0) 6822 gfc_internal_error ("Reshaped array too large at %C"); 6823 6824 j = mpz_get_ui (index); 6825 6826 if (j < nsource) 6827 e = gfc_constructor_lookup_expr (source->value.constructor, j); 6828 else 6829 { 6830 if (npad <= 0) 6831 { 6832 mpz_clear (index); 6833 return NULL; 6834 } 6835 j = j - nsource; 6836 j = j % npad; 6837 e = gfc_constructor_lookup_expr (pad->value.constructor, j); 6838 } 6839 gcc_assert (e); 6840 6841 gfc_constructor_append_expr (&result->value.constructor, 6842 gfc_copy_expr (e), &e->where); 6843 6844 /* Calculate the next element. */ 6845 i = 0; 6846 6847inc: 6848 if (++x[i] < shape[i]) 6849 continue; 6850 x[i++] = 0; 6851 if (i < rank) 6852 goto inc; 6853 6854 break; 6855 } 6856 6857 mpz_clear (index); 6858 6859 return result; 6860} 6861 6862 6863gfc_expr * 6864gfc_simplify_rrspacing (gfc_expr *x) 6865{ 6866 gfc_expr *result; 6867 int i; 6868 long int e, p; 6869 6870 if (x->expr_type != EXPR_CONSTANT) 6871 return NULL; 6872 6873 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 6874 6875 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 6876 6877 /* RRSPACING(+/- 0.0) = 0.0 */ 6878 if (mpfr_zero_p (x->value.real)) 6879 { 6880 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 6881 return result; 6882 } 6883 6884 /* RRSPACING(inf) = NaN */ 6885 if (mpfr_inf_p (x->value.real)) 6886 { 6887 mpfr_set_nan (result->value.real); 6888 return result; 6889 } 6890 6891 /* RRSPACING(NaN) = same NaN */ 6892 if (mpfr_nan_p (x->value.real)) 6893 { 6894 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 6895 return result; 6896 } 6897 6898 /* | x * 2**(-e) | * 2**p. */ 6899 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); 6900 e = - (long int) mpfr_get_exp (x->value.real); 6901 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); 6902 6903 p = (long int) gfc_real_kinds[i].digits; 6904 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); 6905 6906 return range_check (result, "RRSPACING"); 6907} 6908 6909 6910gfc_expr * 6911gfc_simplify_scale (gfc_expr *x, gfc_expr *i) 6912{ 6913 int k, neg_flag, power, exp_range; 6914 mpfr_t scale, radix; 6915 gfc_expr *result; 6916 6917 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 6918 return NULL; 6919 6920 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 6921 6922 if (mpfr_zero_p (x->value.real)) 6923 { 6924 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 6925 return result; 6926 } 6927 6928 k = gfc_validate_kind (BT_REAL, x->ts.kind, false); 6929 6930 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; 6931 6932 /* This check filters out values of i that would overflow an int. */ 6933 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 6934 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) 6935 { 6936 gfc_error ("Result of SCALE overflows its kind at %L", &result->where); 6937 gfc_free_expr (result); 6938 return &gfc_bad_expr; 6939 } 6940 6941 /* Compute scale = radix ** power. */ 6942 power = mpz_get_si (i->value.integer); 6943 6944 if (power >= 0) 6945 neg_flag = 0; 6946 else 6947 { 6948 neg_flag = 1; 6949 power = -power; 6950 } 6951 6952 gfc_set_model_kind (x->ts.kind); 6953 mpfr_init (scale); 6954 mpfr_init (radix); 6955 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); 6956 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); 6957 6958 if (neg_flag) 6959 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); 6960 else 6961 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); 6962 6963 mpfr_clears (scale, radix, NULL); 6964 6965 return range_check (result, "SCALE"); 6966} 6967 6968 6969/* Variants of strspn and strcspn that operate on wide characters. */ 6970 6971static size_t 6972wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) 6973{ 6974 size_t i = 0; 6975 const gfc_char_t *c; 6976 6977 while (s1[i]) 6978 { 6979 for (c = s2; *c; c++) 6980 { 6981 if (s1[i] == *c) 6982 break; 6983 } 6984 if (*c == '\0') 6985 break; 6986 i++; 6987 } 6988 6989 return i; 6990} 6991 6992static size_t 6993wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) 6994{ 6995 size_t i = 0; 6996 const gfc_char_t *c; 6997 6998 while (s1[i]) 6999 { 7000 for (c = s2; *c; c++) 7001 { 7002 if (s1[i] == *c) 7003 break; 7004 } 7005 if (*c) 7006 break; 7007 i++; 7008 } 7009 7010 return i; 7011} 7012 7013 7014gfc_expr * 7015gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) 7016{ 7017 gfc_expr *result; 7018 int back; 7019 size_t i; 7020 size_t indx, len, lenc; 7021 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); 7022 7023 if (k == -1) 7024 return &gfc_bad_expr; 7025 7026 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT 7027 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 7028 return NULL; 7029 7030 if (b != NULL && b->value.logical != 0) 7031 back = 1; 7032 else 7033 back = 0; 7034 7035 len = e->value.character.length; 7036 lenc = c->value.character.length; 7037 7038 if (len == 0 || lenc == 0) 7039 { 7040 indx = 0; 7041 } 7042 else 7043 { 7044 if (back == 0) 7045 { 7046 indx = wide_strcspn (e->value.character.string, 7047 c->value.character.string) + 1; 7048 if (indx > len) 7049 indx = 0; 7050 } 7051 else 7052 for (indx = len; indx > 0; indx--) 7053 { 7054 for (i = 0; i < lenc; i++) 7055 { 7056 if (c->value.character.string[i] 7057 == e->value.character.string[indx - 1]) 7058 break; 7059 } 7060 if (i < lenc) 7061 break; 7062 } 7063 } 7064 7065 result = gfc_get_int_expr (k, &e->where, indx); 7066 return range_check (result, "SCAN"); 7067} 7068 7069 7070gfc_expr * 7071gfc_simplify_selected_char_kind (gfc_expr *e) 7072{ 7073 int kind; 7074 7075 if (e->expr_type != EXPR_CONSTANT) 7076 return NULL; 7077 7078 if (gfc_compare_with_Cstring (e, "ascii", false) == 0 7079 || gfc_compare_with_Cstring (e, "default", false) == 0) 7080 kind = 1; 7081 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) 7082 kind = 4; 7083 else 7084 kind = -1; 7085 7086 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 7087} 7088 7089 7090gfc_expr * 7091gfc_simplify_selected_int_kind (gfc_expr *e) 7092{ 7093 int i, kind, range; 7094 7095 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range)) 7096 return NULL; 7097 7098 kind = INT_MAX; 7099 7100 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 7101 if (gfc_integer_kinds[i].range >= range 7102 && gfc_integer_kinds[i].kind < kind) 7103 kind = gfc_integer_kinds[i].kind; 7104 7105 if (kind == INT_MAX) 7106 kind = -1; 7107 7108 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 7109} 7110 7111 7112gfc_expr * 7113gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) 7114{ 7115 int range, precision, radix, i, kind, found_precision, found_range, 7116 found_radix; 7117 locus *loc = &gfc_current_locus; 7118 7119 if (p == NULL) 7120 precision = 0; 7121 else 7122 { 7123 if (p->expr_type != EXPR_CONSTANT 7124 || gfc_extract_int (p, &precision)) 7125 return NULL; 7126 loc = &p->where; 7127 } 7128 7129 if (q == NULL) 7130 range = 0; 7131 else 7132 { 7133 if (q->expr_type != EXPR_CONSTANT 7134 || gfc_extract_int (q, &range)) 7135 return NULL; 7136 7137 if (!loc) 7138 loc = &q->where; 7139 } 7140 7141 if (rdx == NULL) 7142 radix = 0; 7143 else 7144 { 7145 if (rdx->expr_type != EXPR_CONSTANT 7146 || gfc_extract_int (rdx, &radix)) 7147 return NULL; 7148 7149 if (!loc) 7150 loc = &rdx->where; 7151 } 7152 7153 kind = INT_MAX; 7154 found_precision = 0; 7155 found_range = 0; 7156 found_radix = 0; 7157 7158 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 7159 { 7160 if (gfc_real_kinds[i].precision >= precision) 7161 found_precision = 1; 7162 7163 if (gfc_real_kinds[i].range >= range) 7164 found_range = 1; 7165 7166 if (radix == 0 || gfc_real_kinds[i].radix == radix) 7167 found_radix = 1; 7168 7169 if (gfc_real_kinds[i].precision >= precision 7170 && gfc_real_kinds[i].range >= range 7171 && (radix == 0 || gfc_real_kinds[i].radix == radix) 7172 && gfc_real_kinds[i].kind < kind) 7173 kind = gfc_real_kinds[i].kind; 7174 } 7175 7176 if (kind == INT_MAX) 7177 { 7178 if (found_radix && found_range && !found_precision) 7179 kind = -1; 7180 else if (found_radix && found_precision && !found_range) 7181 kind = -2; 7182 else if (found_radix && !found_precision && !found_range) 7183 kind = -3; 7184 else if (found_radix) 7185 kind = -4; 7186 else 7187 kind = -5; 7188 } 7189 7190 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); 7191} 7192 7193 7194gfc_expr * 7195gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) 7196{ 7197 gfc_expr *result; 7198 mpfr_t exp, absv, log2, pow2, frac; 7199 long exp2; 7200 7201 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 7202 return NULL; 7203 7204 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7205 7206 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 7207 SET_EXPONENT (NaN) = same NaN */ 7208 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) 7209 { 7210 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 7211 return result; 7212 } 7213 7214 /* SET_EXPONENT (inf) = NaN */ 7215 if (mpfr_inf_p (x->value.real)) 7216 { 7217 mpfr_set_nan (result->value.real); 7218 return result; 7219 } 7220 7221 gfc_set_model_kind (x->ts.kind); 7222 mpfr_init (absv); 7223 mpfr_init (log2); 7224 mpfr_init (exp); 7225 mpfr_init (pow2); 7226 mpfr_init (frac); 7227 7228 mpfr_abs (absv, x->value.real, GFC_RND_MODE); 7229 mpfr_log2 (log2, absv, GFC_RND_MODE); 7230 7231 mpfr_floor (log2, log2); 7232 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); 7233 7234 /* Old exponent value, and fraction. */ 7235 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); 7236 7237 mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE); 7238 7239 /* New exponent. */ 7240 exp2 = mpz_get_si (i->value.integer); 7241 mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE); 7242 7243 mpfr_clears (absv, log2, exp, pow2, frac, NULL); 7244 7245 return range_check (result, "SET_EXPONENT"); 7246} 7247 7248 7249gfc_expr * 7250gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) 7251{ 7252 mpz_t shape[GFC_MAX_DIMENSIONS]; 7253 gfc_expr *result, *e, *f; 7254 gfc_array_ref *ar; 7255 int n; 7256 bool t; 7257 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); 7258 7259 if (source->rank == -1) 7260 return NULL; 7261 7262 result = gfc_get_array_expr (BT_INTEGER, k, &source->where); 7263 result->shape = gfc_get_shape (1); 7264 mpz_init (result->shape[0]); 7265 7266 if (source->rank == 0) 7267 return result; 7268 7269 if (source->expr_type == EXPR_VARIABLE) 7270 { 7271 ar = gfc_find_array_ref (source); 7272 t = gfc_array_ref_shape (ar, shape); 7273 } 7274 else if (source->shape) 7275 { 7276 t = true; 7277 for (n = 0; n < source->rank; n++) 7278 { 7279 mpz_init (shape[n]); 7280 mpz_set (shape[n], source->shape[n]); 7281 } 7282 } 7283 else 7284 t = false; 7285 7286 for (n = 0; n < source->rank; n++) 7287 { 7288 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); 7289 7290 if (t) 7291 mpz_set (e->value.integer, shape[n]); 7292 else 7293 { 7294 mpz_set_ui (e->value.integer, n + 1); 7295 7296 f = simplify_size (source, e, k); 7297 gfc_free_expr (e); 7298 if (f == NULL) 7299 { 7300 gfc_free_expr (result); 7301 return NULL; 7302 } 7303 else 7304 e = f; 7305 } 7306 7307 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) 7308 { 7309 gfc_free_expr (result); 7310 if (t) 7311 gfc_clear_shape (shape, source->rank); 7312 return &gfc_bad_expr; 7313 } 7314 7315 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 7316 } 7317 7318 if (t) 7319 gfc_clear_shape (shape, source->rank); 7320 7321 mpz_set_si (result->shape[0], source->rank); 7322 7323 return result; 7324} 7325 7326 7327static gfc_expr * 7328simplify_size (gfc_expr *array, gfc_expr *dim, int k) 7329{ 7330 mpz_t size; 7331 gfc_expr *return_value; 7332 int d; 7333 gfc_ref *ref; 7334 7335 /* For unary operations, the size of the result is given by the size 7336 of the operand. For binary ones, it's the size of the first operand 7337 unless it is scalar, then it is the size of the second. */ 7338 if (array->expr_type == EXPR_OP && !array->value.op.uop) 7339 { 7340 gfc_expr* replacement; 7341 gfc_expr* simplified; 7342 7343 switch (array->value.op.op) 7344 { 7345 /* Unary operations. */ 7346 case INTRINSIC_NOT: 7347 case INTRINSIC_UPLUS: 7348 case INTRINSIC_UMINUS: 7349 case INTRINSIC_PARENTHESES: 7350 replacement = array->value.op.op1; 7351 break; 7352 7353 /* Binary operations. If any one of the operands is scalar, take 7354 the other one's size. If both of them are arrays, it does not 7355 matter -- try to find one with known shape, if possible. */ 7356 default: 7357 if (array->value.op.op1->rank == 0) 7358 replacement = array->value.op.op2; 7359 else if (array->value.op.op2->rank == 0) 7360 replacement = array->value.op.op1; 7361 else 7362 { 7363 simplified = simplify_size (array->value.op.op1, dim, k); 7364 if (simplified) 7365 return simplified; 7366 7367 replacement = array->value.op.op2; 7368 } 7369 break; 7370 } 7371 7372 /* Try to reduce it directly if possible. */ 7373 simplified = simplify_size (replacement, dim, k); 7374 7375 /* Otherwise, we build a new SIZE call. This is hopefully at least 7376 simpler than the original one. */ 7377 if (!simplified) 7378 { 7379 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); 7380 simplified = gfc_build_intrinsic_call (gfc_current_ns, 7381 GFC_ISYM_SIZE, "size", 7382 array->where, 3, 7383 gfc_copy_expr (replacement), 7384 gfc_copy_expr (dim), 7385 kind); 7386 } 7387 return simplified; 7388 } 7389 7390 for (ref = array->ref; ref; ref = ref->next) 7391 if (ref->type == REF_ARRAY && ref->u.ar.as 7392 && !gfc_resolve_array_spec (ref->u.ar.as, 0)) 7393 return NULL; 7394 7395 if (dim == NULL) 7396 { 7397 if (!gfc_array_size (array, &size)) 7398 return NULL; 7399 } 7400 else 7401 { 7402 if (dim->expr_type != EXPR_CONSTANT) 7403 return NULL; 7404 7405 d = mpz_get_ui (dim->value.integer) - 1; 7406 if (!gfc_array_dimen_size (array, d, &size)) 7407 return NULL; 7408 } 7409 7410 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 7411 mpz_set (return_value->value.integer, size); 7412 mpz_clear (size); 7413 7414 return return_value; 7415} 7416 7417 7418gfc_expr * 7419gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 7420{ 7421 gfc_expr *result; 7422 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); 7423 7424 if (k == -1) 7425 return &gfc_bad_expr; 7426 7427 result = simplify_size (array, dim, k); 7428 if (result == NULL || result == &gfc_bad_expr) 7429 return result; 7430 7431 return range_check (result, "SIZE"); 7432} 7433 7434 7435/* SIZEOF and C_SIZEOF return the size in bytes of an array element 7436 multiplied by the array size. */ 7437 7438gfc_expr * 7439gfc_simplify_sizeof (gfc_expr *x) 7440{ 7441 gfc_expr *result = NULL; 7442 mpz_t array_size; 7443 size_t res_size; 7444 7445 if (x->ts.type == BT_CLASS || x->ts.deferred) 7446 return NULL; 7447 7448 if (x->ts.type == BT_CHARACTER 7449 && (!x->ts.u.cl || !x->ts.u.cl->length 7450 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 7451 return NULL; 7452 7453 if (x->rank && x->expr_type != EXPR_ARRAY 7454 && !gfc_array_size (x, &array_size)) 7455 return NULL; 7456 7457 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 7458 &x->where); 7459 gfc_target_expr_size (x, &res_size); 7460 mpz_set_si (result->value.integer, res_size); 7461 7462 return result; 7463} 7464 7465 7466/* STORAGE_SIZE returns the size in bits of a single array element. */ 7467 7468gfc_expr * 7469gfc_simplify_storage_size (gfc_expr *x, 7470 gfc_expr *kind) 7471{ 7472 gfc_expr *result = NULL; 7473 int k; 7474 size_t siz; 7475 7476 if (x->ts.type == BT_CLASS || x->ts.deferred) 7477 return NULL; 7478 7479 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT 7480 && (!x->ts.u.cl || !x->ts.u.cl->length 7481 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 7482 return NULL; 7483 7484 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); 7485 if (k == -1) 7486 return &gfc_bad_expr; 7487 7488 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 7489 7490 gfc_element_size (x, &siz); 7491 mpz_set_si (result->value.integer, siz); 7492 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); 7493 7494 return range_check (result, "STORAGE_SIZE"); 7495} 7496 7497 7498gfc_expr * 7499gfc_simplify_sign (gfc_expr *x, gfc_expr *y) 7500{ 7501 gfc_expr *result; 7502 7503 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 7504 return NULL; 7505 7506 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7507 7508 switch (x->ts.type) 7509 { 7510 case BT_INTEGER: 7511 mpz_abs (result->value.integer, x->value.integer); 7512 if (mpz_sgn (y->value.integer) < 0) 7513 mpz_neg (result->value.integer, result->value.integer); 7514 break; 7515 7516 case BT_REAL: 7517 if (flag_sign_zero) 7518 mpfr_copysign (result->value.real, x->value.real, y->value.real, 7519 GFC_RND_MODE); 7520 else 7521 mpfr_setsign (result->value.real, x->value.real, 7522 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); 7523 break; 7524 7525 default: 7526 gfc_internal_error ("Bad type in gfc_simplify_sign"); 7527 } 7528 7529 return result; 7530} 7531 7532 7533gfc_expr * 7534gfc_simplify_sin (gfc_expr *x) 7535{ 7536 gfc_expr *result; 7537 7538 if (x->expr_type != EXPR_CONSTANT) 7539 return NULL; 7540 7541 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7542 7543 switch (x->ts.type) 7544 { 7545 case BT_REAL: 7546 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); 7547 break; 7548 7549 case BT_COMPLEX: 7550 gfc_set_model (x->value.real); 7551 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7552 break; 7553 7554 default: 7555 gfc_internal_error ("in gfc_simplify_sin(): Bad type"); 7556 } 7557 7558 return range_check (result, "SIN"); 7559} 7560 7561 7562gfc_expr * 7563gfc_simplify_sinh (gfc_expr *x) 7564{ 7565 gfc_expr *result; 7566 7567 if (x->expr_type != EXPR_CONSTANT) 7568 return NULL; 7569 7570 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7571 7572 switch (x->ts.type) 7573 { 7574 case BT_REAL: 7575 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); 7576 break; 7577 7578 case BT_COMPLEX: 7579 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7580 break; 7581 7582 default: 7583 gcc_unreachable (); 7584 } 7585 7586 return range_check (result, "SINH"); 7587} 7588 7589 7590/* The argument is always a double precision real that is converted to 7591 single precision. TODO: Rounding! */ 7592 7593gfc_expr * 7594gfc_simplify_sngl (gfc_expr *a) 7595{ 7596 gfc_expr *result; 7597 int tmp1, tmp2; 7598 7599 if (a->expr_type != EXPR_CONSTANT) 7600 return NULL; 7601 7602 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 7603 warnings. */ 7604 tmp1 = warn_conversion; 7605 tmp2 = warn_conversion_extra; 7606 warn_conversion = warn_conversion_extra = 0; 7607 7608 result = gfc_real2real (a, gfc_default_real_kind); 7609 7610 warn_conversion = tmp1; 7611 warn_conversion_extra = tmp2; 7612 7613 return range_check (result, "SNGL"); 7614} 7615 7616 7617gfc_expr * 7618gfc_simplify_spacing (gfc_expr *x) 7619{ 7620 gfc_expr *result; 7621 int i; 7622 long int en, ep; 7623 7624 if (x->expr_type != EXPR_CONSTANT) 7625 return NULL; 7626 7627 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 7628 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7629 7630 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ 7631 if (mpfr_zero_p (x->value.real)) 7632 { 7633 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 7634 return result; 7635 } 7636 7637 /* SPACING(inf) = NaN */ 7638 if (mpfr_inf_p (x->value.real)) 7639 { 7640 mpfr_set_nan (result->value.real); 7641 return result; 7642 } 7643 7644 /* SPACING(NaN) = same NaN */ 7645 if (mpfr_nan_p (x->value.real)) 7646 { 7647 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 7648 return result; 7649 } 7650 7651 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p 7652 are the radix, exponent of x, and precision. This excludes the 7653 possibility of subnormal numbers. Fortran 2003 states the result is 7654 b**max(e - p, emin - 1). */ 7655 7656 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; 7657 en = (long int) gfc_real_kinds[i].min_exponent - 1; 7658 en = en > ep ? en : ep; 7659 7660 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); 7661 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); 7662 7663 return range_check (result, "SPACING"); 7664} 7665 7666 7667gfc_expr * 7668gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) 7669{ 7670 gfc_expr *result = NULL; 7671 int nelem, i, j, dim, ncopies; 7672 mpz_t size; 7673 7674 if ((!gfc_is_constant_expr (source) 7675 && !is_constant_array_expr (source)) 7676 || !gfc_is_constant_expr (dim_expr) 7677 || !gfc_is_constant_expr (ncopies_expr)) 7678 return NULL; 7679 7680 gcc_assert (dim_expr->ts.type == BT_INTEGER); 7681 gfc_extract_int (dim_expr, &dim); 7682 dim -= 1; /* zero-base DIM */ 7683 7684 gcc_assert (ncopies_expr->ts.type == BT_INTEGER); 7685 gfc_extract_int (ncopies_expr, &ncopies); 7686 ncopies = MAX (ncopies, 0); 7687 7688 /* Do not allow the array size to exceed the limit for an array 7689 constructor. */ 7690 if (source->expr_type == EXPR_ARRAY) 7691 { 7692 if (!gfc_array_size (source, &size)) 7693 gfc_internal_error ("Failure getting length of a constant array."); 7694 } 7695 else 7696 mpz_init_set_ui (size, 1); 7697 7698 nelem = mpz_get_si (size) * ncopies; 7699 if (nelem > flag_max_array_constructor) 7700 { 7701 if (gfc_init_expr_flag) 7702 { 7703 gfc_error ("The number of elements (%d) in the array constructor " 7704 "at %L requires an increase of the allowed %d upper " 7705 "limit. See %<-fmax-array-constructor%> option.", 7706 nelem, &source->where, flag_max_array_constructor); 7707 return &gfc_bad_expr; 7708 } 7709 else 7710 return NULL; 7711 } 7712 7713 if (source->expr_type == EXPR_CONSTANT 7714 || source->expr_type == EXPR_STRUCTURE) 7715 { 7716 gcc_assert (dim == 0); 7717 7718 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 7719 &source->where); 7720 if (source->ts.type == BT_DERIVED) 7721 result->ts.u.derived = source->ts.u.derived; 7722 result->rank = 1; 7723 result->shape = gfc_get_shape (result->rank); 7724 mpz_init_set_si (result->shape[0], ncopies); 7725 7726 for (i = 0; i < ncopies; ++i) 7727 gfc_constructor_append_expr (&result->value.constructor, 7728 gfc_copy_expr (source), NULL); 7729 } 7730 else if (source->expr_type == EXPR_ARRAY) 7731 { 7732 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; 7733 gfc_constructor *source_ctor; 7734 7735 gcc_assert (source->rank < GFC_MAX_DIMENSIONS); 7736 gcc_assert (dim >= 0 && dim <= source->rank); 7737 7738 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 7739 &source->where); 7740 if (source->ts.type == BT_DERIVED) 7741 result->ts.u.derived = source->ts.u.derived; 7742 result->rank = source->rank + 1; 7743 result->shape = gfc_get_shape (result->rank); 7744 7745 for (i = 0, j = 0; i < result->rank; ++i) 7746 { 7747 if (i != dim) 7748 mpz_init_set (result->shape[i], source->shape[j++]); 7749 else 7750 mpz_init_set_si (result->shape[i], ncopies); 7751 7752 extent[i] = mpz_get_si (result->shape[i]); 7753 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; 7754 } 7755 7756 offset = 0; 7757 for (source_ctor = gfc_constructor_first (source->value.constructor); 7758 source_ctor; source_ctor = gfc_constructor_next (source_ctor)) 7759 { 7760 for (i = 0; i < ncopies; ++i) 7761 gfc_constructor_insert_expr (&result->value.constructor, 7762 gfc_copy_expr (source_ctor->expr), 7763 NULL, offset + i * rstride[dim]); 7764 7765 offset += (dim == 0 ? ncopies : 1); 7766 } 7767 } 7768 else 7769 { 7770 gfc_error ("Simplification of SPREAD at %C not yet implemented"); 7771 return &gfc_bad_expr; 7772 } 7773 7774 if (source->ts.type == BT_CHARACTER) 7775 result->ts.u.cl = source->ts.u.cl; 7776 7777 return result; 7778} 7779 7780 7781gfc_expr * 7782gfc_simplify_sqrt (gfc_expr *e) 7783{ 7784 gfc_expr *result = NULL; 7785 7786 if (e->expr_type != EXPR_CONSTANT) 7787 return NULL; 7788 7789 switch (e->ts.type) 7790 { 7791 case BT_REAL: 7792 if (mpfr_cmp_si (e->value.real, 0) < 0) 7793 { 7794 gfc_error ("Argument of SQRT at %L has a negative value", 7795 &e->where); 7796 return &gfc_bad_expr; 7797 } 7798 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 7799 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); 7800 break; 7801 7802 case BT_COMPLEX: 7803 gfc_set_model (e->value.real); 7804 7805 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 7806 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); 7807 break; 7808 7809 default: 7810 gfc_internal_error ("invalid argument of SQRT at %L", &e->where); 7811 } 7812 7813 return range_check (result, "SQRT"); 7814} 7815 7816 7817gfc_expr * 7818gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 7819{ 7820 return simplify_transformation (array, dim, mask, 0, gfc_add); 7821} 7822 7823 7824/* Simplify COTAN(X) where X has the unit of radian. */ 7825 7826gfc_expr * 7827gfc_simplify_cotan (gfc_expr *x) 7828{ 7829 gfc_expr *result; 7830 mpc_t swp, *val; 7831 7832 if (x->expr_type != EXPR_CONSTANT) 7833 return NULL; 7834 7835 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7836 7837 switch (x->ts.type) 7838 { 7839 case BT_REAL: 7840 mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE); 7841 break; 7842 7843 case BT_COMPLEX: 7844 /* There is no builtin mpc_cot, so compute cot = cos / sin. */ 7845 val = &result->value.complex; 7846 mpc_init2 (swp, mpfr_get_default_prec ()); 7847 mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE, 7848 GFC_MPC_RND_MODE); 7849 mpc_div (*val, swp, *val, GFC_MPC_RND_MODE); 7850 mpc_clear (swp); 7851 break; 7852 7853 default: 7854 gcc_unreachable (); 7855 } 7856 7857 return range_check (result, "COTAN"); 7858} 7859 7860 7861gfc_expr * 7862gfc_simplify_tan (gfc_expr *x) 7863{ 7864 gfc_expr *result; 7865 7866 if (x->expr_type != EXPR_CONSTANT) 7867 return NULL; 7868 7869 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7870 7871 switch (x->ts.type) 7872 { 7873 case BT_REAL: 7874 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); 7875 break; 7876 7877 case BT_COMPLEX: 7878 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7879 break; 7880 7881 default: 7882 gcc_unreachable (); 7883 } 7884 7885 return range_check (result, "TAN"); 7886} 7887 7888 7889gfc_expr * 7890gfc_simplify_tanh (gfc_expr *x) 7891{ 7892 gfc_expr *result; 7893 7894 if (x->expr_type != EXPR_CONSTANT) 7895 return NULL; 7896 7897 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7898 7899 switch (x->ts.type) 7900 { 7901 case BT_REAL: 7902 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); 7903 break; 7904 7905 case BT_COMPLEX: 7906 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7907 break; 7908 7909 default: 7910 gcc_unreachable (); 7911 } 7912 7913 return range_check (result, "TANH"); 7914} 7915 7916 7917gfc_expr * 7918gfc_simplify_tiny (gfc_expr *e) 7919{ 7920 gfc_expr *result; 7921 int i; 7922 7923 i = gfc_validate_kind (BT_REAL, e->ts.kind, false); 7924 7925 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 7926 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 7927 7928 return result; 7929} 7930 7931 7932gfc_expr * 7933gfc_simplify_trailz (gfc_expr *e) 7934{ 7935 unsigned long tz, bs; 7936 int i; 7937 7938 if (e->expr_type != EXPR_CONSTANT) 7939 return NULL; 7940 7941 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 7942 bs = gfc_integer_kinds[i].bit_size; 7943 tz = mpz_scan1 (e->value.integer, 0); 7944 7945 return gfc_get_int_expr (gfc_default_integer_kind, 7946 &e->where, MIN (tz, bs)); 7947} 7948 7949 7950gfc_expr * 7951gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 7952{ 7953 gfc_expr *result; 7954 gfc_expr *mold_element; 7955 size_t source_size; 7956 size_t result_size; 7957 size_t buffer_size; 7958 mpz_t tmp; 7959 unsigned char *buffer; 7960 size_t result_length; 7961 7962 if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size)) 7963 return NULL; 7964 7965 if (!gfc_resolve_expr (mold)) 7966 return NULL; 7967 if (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) 7968 return NULL; 7969 7970 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 7971 &result_size, &result_length)) 7972 return NULL; 7973 7974 /* Calculate the size of the source. */ 7975 if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) 7976 gfc_internal_error ("Failure getting length of a constant array."); 7977 7978 /* Create an empty new expression with the appropriate characteristics. */ 7979 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, 7980 &source->where); 7981 result->ts = mold->ts; 7982 7983 mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor) 7984 ? gfc_constructor_first (mold->value.constructor)->expr 7985 : mold; 7986 7987 /* Set result character length, if needed. Note that this needs to be 7988 set even for array expressions, in order to pass this information into 7989 gfc_target_interpret_expr. */ 7990 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) 7991 { 7992 result->value.character.length = mold_element->value.character.length; 7993 7994 /* Let the typespec of the result inherit the string length. 7995 This is crucial if a resulting array has size zero. */ 7996 if (mold_element->ts.u.cl->length) 7997 result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length); 7998 else 7999 result->ts.u.cl->length = 8000 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 8001 mold_element->value.character.length); 8002 } 8003 8004 /* Set the number of elements in the result, and determine its size. */ 8005 8006 if (mold->expr_type == EXPR_ARRAY || mold->rank || size) 8007 { 8008 result->expr_type = EXPR_ARRAY; 8009 result->rank = 1; 8010 result->shape = gfc_get_shape (1); 8011 mpz_init_set_ui (result->shape[0], result_length); 8012 } 8013 else 8014 result->rank = 0; 8015 8016 /* Allocate the buffer to store the binary version of the source. */ 8017 buffer_size = MAX (source_size, result_size); 8018 buffer = (unsigned char*)alloca (buffer_size); 8019 memset (buffer, 0, buffer_size); 8020 8021 /* Now write source to the buffer. */ 8022 gfc_target_encode_expr (source, buffer, buffer_size); 8023 8024 /* And read the buffer back into the new expression. */ 8025 gfc_target_interpret_expr (buffer, buffer_size, result, false); 8026 8027 return result; 8028} 8029 8030 8031gfc_expr * 8032gfc_simplify_transpose (gfc_expr *matrix) 8033{ 8034 int row, matrix_rows, col, matrix_cols; 8035 gfc_expr *result; 8036 8037 if (!is_constant_array_expr (matrix)) 8038 return NULL; 8039 8040 gcc_assert (matrix->rank == 2); 8041 8042 if (matrix->shape == NULL) 8043 return NULL; 8044 8045 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, 8046 &matrix->where); 8047 result->rank = 2; 8048 result->shape = gfc_get_shape (result->rank); 8049 mpz_init_set (result->shape[0], matrix->shape[1]); 8050 mpz_init_set (result->shape[1], matrix->shape[0]); 8051 8052 if (matrix->ts.type == BT_CHARACTER) 8053 result->ts.u.cl = matrix->ts.u.cl; 8054 else if (matrix->ts.type == BT_DERIVED) 8055 result->ts.u.derived = matrix->ts.u.derived; 8056 8057 matrix_rows = mpz_get_si (matrix->shape[0]); 8058 matrix_cols = mpz_get_si (matrix->shape[1]); 8059 for (row = 0; row < matrix_rows; ++row) 8060 for (col = 0; col < matrix_cols; ++col) 8061 { 8062 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, 8063 col * matrix_rows + row); 8064 gfc_constructor_insert_expr (&result->value.constructor, 8065 gfc_copy_expr (e), &matrix->where, 8066 row * matrix_cols + col); 8067 } 8068 8069 return result; 8070} 8071 8072 8073gfc_expr * 8074gfc_simplify_trim (gfc_expr *e) 8075{ 8076 gfc_expr *result; 8077 int count, i, len, lentrim; 8078 8079 if (e->expr_type != EXPR_CONSTANT) 8080 return NULL; 8081 8082 len = e->value.character.length; 8083 for (count = 0, i = 1; i <= len; ++i) 8084 { 8085 if (e->value.character.string[len - i] == ' ') 8086 count++; 8087 else 8088 break; 8089 } 8090 8091 lentrim = len - count; 8092 8093 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); 8094 for (i = 0; i < lentrim; i++) 8095 result->value.character.string[i] = e->value.character.string[i]; 8096 8097 return result; 8098} 8099 8100 8101gfc_expr * 8102gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) 8103{ 8104 gfc_expr *result; 8105 gfc_ref *ref; 8106 gfc_array_spec *as; 8107 gfc_constructor *sub_cons; 8108 bool first_image; 8109 int d; 8110 8111 if (!is_constant_array_expr (sub)) 8112 return NULL; 8113 8114 /* Follow any component references. */ 8115 as = coarray->symtree->n.sym->as; 8116 for (ref = coarray->ref; ref; ref = ref->next) 8117 if (ref->type == REF_COMPONENT) 8118 as = ref->u.ar.as; 8119 8120 if (as->type == AS_DEFERRED) 8121 return NULL; 8122 8123 /* "valid sequence of cosubscripts" are required; thus, return 0 unless 8124 the cosubscript addresses the first image. */ 8125 8126 sub_cons = gfc_constructor_first (sub->value.constructor); 8127 first_image = true; 8128 8129 for (d = 1; d <= as->corank; d++) 8130 { 8131 gfc_expr *ca_bound; 8132 int cmp; 8133 8134 gcc_assert (sub_cons != NULL); 8135 8136 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, 8137 NULL, true); 8138 if (ca_bound == NULL) 8139 return NULL; 8140 8141 if (ca_bound == &gfc_bad_expr) 8142 return ca_bound; 8143 8144 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); 8145 8146 if (cmp == 0) 8147 { 8148 gfc_free_expr (ca_bound); 8149 sub_cons = gfc_constructor_next (sub_cons); 8150 continue; 8151 } 8152 8153 first_image = false; 8154 8155 if (cmp > 0) 8156 { 8157 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 8158 "SUB has %ld and COARRAY lower bound is %ld)", 8159 &coarray->where, d, 8160 mpz_get_si (sub_cons->expr->value.integer), 8161 mpz_get_si (ca_bound->value.integer)); 8162 gfc_free_expr (ca_bound); 8163 return &gfc_bad_expr; 8164 } 8165 8166 gfc_free_expr (ca_bound); 8167 8168 /* Check whether upperbound is valid for the multi-images case. */ 8169 if (d < as->corank) 8170 { 8171 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, 8172 NULL, true); 8173 if (ca_bound == &gfc_bad_expr) 8174 return ca_bound; 8175 8176 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT 8177 && mpz_cmp (ca_bound->value.integer, 8178 sub_cons->expr->value.integer) < 0) 8179 { 8180 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 8181 "SUB has %ld and COARRAY upper bound is %ld)", 8182 &coarray->where, d, 8183 mpz_get_si (sub_cons->expr->value.integer), 8184 mpz_get_si (ca_bound->value.integer)); 8185 gfc_free_expr (ca_bound); 8186 return &gfc_bad_expr; 8187 } 8188 8189 if (ca_bound) 8190 gfc_free_expr (ca_bound); 8191 } 8192 8193 sub_cons = gfc_constructor_next (sub_cons); 8194 } 8195 8196 gcc_assert (sub_cons == NULL); 8197 8198 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image) 8199 return NULL; 8200 8201 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8202 &gfc_current_locus); 8203 if (first_image) 8204 mpz_set_si (result->value.integer, 1); 8205 else 8206 mpz_set_si (result->value.integer, 0); 8207 8208 return result; 8209} 8210 8211gfc_expr * 8212gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) 8213{ 8214 if (flag_coarray == GFC_FCOARRAY_NONE) 8215 { 8216 gfc_current_locus = *gfc_current_intrinsic_where; 8217 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 8218 return &gfc_bad_expr; 8219 } 8220 8221 /* Simplification is possible for fcoarray = single only. For all other modes 8222 the result depends on runtime conditions. */ 8223 if (flag_coarray != GFC_FCOARRAY_SINGLE) 8224 return NULL; 8225 8226 if (gfc_is_constant_expr (image)) 8227 { 8228 gfc_expr *result; 8229 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8230 &image->where); 8231 if (mpz_get_si (image->value.integer) == 1) 8232 mpz_set_si (result->value.integer, 0); 8233 else 8234 mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); 8235 return result; 8236 } 8237 else 8238 return NULL; 8239} 8240 8241 8242gfc_expr * 8243gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, 8244 gfc_expr *distance ATTRIBUTE_UNUSED) 8245{ 8246 if (flag_coarray != GFC_FCOARRAY_SINGLE) 8247 return NULL; 8248 8249 /* If no coarray argument has been passed or when the first argument 8250 is actually a distance argment. */ 8251 if (coarray == NULL || !gfc_is_coarray (coarray)) 8252 { 8253 gfc_expr *result; 8254 /* FIXME: gfc_current_locus is wrong. */ 8255 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8256 &gfc_current_locus); 8257 mpz_set_si (result->value.integer, 1); 8258 return result; 8259 } 8260 8261 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ 8262 return simplify_cobound (coarray, dim, NULL, 0); 8263} 8264 8265 8266gfc_expr * 8267gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 8268{ 8269 return simplify_bound (array, dim, kind, 1); 8270} 8271 8272gfc_expr * 8273gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 8274{ 8275 return simplify_cobound (array, dim, kind, 1); 8276} 8277 8278 8279gfc_expr * 8280gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 8281{ 8282 gfc_expr *result, *e; 8283 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; 8284 8285 if (!is_constant_array_expr (vector) 8286 || !is_constant_array_expr (mask) 8287 || (!gfc_is_constant_expr (field) 8288 && !is_constant_array_expr (field))) 8289 return NULL; 8290 8291 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, 8292 &vector->where); 8293 if (vector->ts.type == BT_DERIVED) 8294 result->ts.u.derived = vector->ts.u.derived; 8295 result->rank = mask->rank; 8296 result->shape = gfc_copy_shape (mask->shape, mask->rank); 8297 8298 if (vector->ts.type == BT_CHARACTER) 8299 result->ts.u.cl = vector->ts.u.cl; 8300 8301 vector_ctor = gfc_constructor_first (vector->value.constructor); 8302 mask_ctor = gfc_constructor_first (mask->value.constructor); 8303 field_ctor 8304 = field->expr_type == EXPR_ARRAY 8305 ? gfc_constructor_first (field->value.constructor) 8306 : NULL; 8307 8308 while (mask_ctor) 8309 { 8310 if (mask_ctor->expr->value.logical) 8311 { 8312 if (vector_ctor) 8313 { 8314 e = gfc_copy_expr (vector_ctor->expr); 8315 vector_ctor = gfc_constructor_next (vector_ctor); 8316 } 8317 else 8318 { 8319 gfc_free_expr (result); 8320 return NULL; 8321 } 8322 } 8323 else if (field->expr_type == EXPR_ARRAY) 8324 e = gfc_copy_expr (field_ctor->expr); 8325 else 8326 e = gfc_copy_expr (field); 8327 8328 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 8329 8330 mask_ctor = gfc_constructor_next (mask_ctor); 8331 field_ctor = gfc_constructor_next (field_ctor); 8332 } 8333 8334 return result; 8335} 8336 8337 8338gfc_expr * 8339gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) 8340{ 8341 gfc_expr *result; 8342 int back; 8343 size_t index, len, lenset; 8344 size_t i; 8345 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); 8346 8347 if (k == -1) 8348 return &gfc_bad_expr; 8349 8350 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT 8351 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 8352 return NULL; 8353 8354 if (b != NULL && b->value.logical != 0) 8355 back = 1; 8356 else 8357 back = 0; 8358 8359 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); 8360 8361 len = s->value.character.length; 8362 lenset = set->value.character.length; 8363 8364 if (len == 0) 8365 { 8366 mpz_set_ui (result->value.integer, 0); 8367 return result; 8368 } 8369 8370 if (back == 0) 8371 { 8372 if (lenset == 0) 8373 { 8374 mpz_set_ui (result->value.integer, 1); 8375 return result; 8376 } 8377 8378 index = wide_strspn (s->value.character.string, 8379 set->value.character.string) + 1; 8380 if (index > len) 8381 index = 0; 8382 8383 } 8384 else 8385 { 8386 if (lenset == 0) 8387 { 8388 mpz_set_ui (result->value.integer, len); 8389 return result; 8390 } 8391 for (index = len; index > 0; index --) 8392 { 8393 for (i = 0; i < lenset; i++) 8394 { 8395 if (s->value.character.string[index - 1] 8396 == set->value.character.string[i]) 8397 break; 8398 } 8399 if (i == lenset) 8400 break; 8401 } 8402 } 8403 8404 mpz_set_ui (result->value.integer, index); 8405 return result; 8406} 8407 8408 8409gfc_expr * 8410gfc_simplify_xor (gfc_expr *x, gfc_expr *y) 8411{ 8412 gfc_expr *result; 8413 int kind; 8414 8415 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 8416 return NULL; 8417 8418 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 8419 8420 switch (x->ts.type) 8421 { 8422 case BT_INTEGER: 8423 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 8424 mpz_xor (result->value.integer, x->value.integer, y->value.integer); 8425 return range_check (result, "XOR"); 8426 8427 case BT_LOGICAL: 8428 return gfc_get_logical_expr (kind, &x->where, 8429 (x->value.logical && !y->value.logical) 8430 || (!x->value.logical && y->value.logical)); 8431 8432 default: 8433 gcc_unreachable (); 8434 } 8435} 8436 8437 8438/****************** Constant simplification *****************/ 8439 8440/* Master function to convert one constant to another. While this is 8441 used as a simplification function, it requires the destination type 8442 and kind information which is supplied by a special case in 8443 do_simplify(). */ 8444 8445gfc_expr * 8446gfc_convert_constant (gfc_expr *e, bt type, int kind) 8447{ 8448 gfc_expr *result, *(*f) (gfc_expr *, int); 8449 gfc_constructor *c, *t; 8450 8451 switch (e->ts.type) 8452 { 8453 case BT_INTEGER: 8454 switch (type) 8455 { 8456 case BT_INTEGER: 8457 f = gfc_int2int; 8458 break; 8459 case BT_REAL: 8460 f = gfc_int2real; 8461 break; 8462 case BT_COMPLEX: 8463 f = gfc_int2complex; 8464 break; 8465 case BT_LOGICAL: 8466 f = gfc_int2log; 8467 break; 8468 default: 8469 goto oops; 8470 } 8471 break; 8472 8473 case BT_REAL: 8474 switch (type) 8475 { 8476 case BT_INTEGER: 8477 f = gfc_real2int; 8478 break; 8479 case BT_REAL: 8480 f = gfc_real2real; 8481 break; 8482 case BT_COMPLEX: 8483 f = gfc_real2complex; 8484 break; 8485 default: 8486 goto oops; 8487 } 8488 break; 8489 8490 case BT_COMPLEX: 8491 switch (type) 8492 { 8493 case BT_INTEGER: 8494 f = gfc_complex2int; 8495 break; 8496 case BT_REAL: 8497 f = gfc_complex2real; 8498 break; 8499 case BT_COMPLEX: 8500 f = gfc_complex2complex; 8501 break; 8502 8503 default: 8504 goto oops; 8505 } 8506 break; 8507 8508 case BT_LOGICAL: 8509 switch (type) 8510 { 8511 case BT_INTEGER: 8512 f = gfc_log2int; 8513 break; 8514 case BT_LOGICAL: 8515 f = gfc_log2log; 8516 break; 8517 default: 8518 goto oops; 8519 } 8520 break; 8521 8522 case BT_HOLLERITH: 8523 switch (type) 8524 { 8525 case BT_INTEGER: 8526 f = gfc_hollerith2int; 8527 break; 8528 8529 case BT_REAL: 8530 f = gfc_hollerith2real; 8531 break; 8532 8533 case BT_COMPLEX: 8534 f = gfc_hollerith2complex; 8535 break; 8536 8537 case BT_CHARACTER: 8538 f = gfc_hollerith2character; 8539 break; 8540 8541 case BT_LOGICAL: 8542 f = gfc_hollerith2logical; 8543 break; 8544 8545 default: 8546 goto oops; 8547 } 8548 break; 8549 8550 case BT_CHARACTER: 8551 switch (type) 8552 { 8553 case BT_INTEGER: 8554 f = gfc_character2int; 8555 break; 8556 8557 case BT_REAL: 8558 f = gfc_character2real; 8559 break; 8560 8561 case BT_COMPLEX: 8562 f = gfc_character2complex; 8563 break; 8564 8565 case BT_CHARACTER: 8566 f = gfc_character2character; 8567 break; 8568 8569 case BT_LOGICAL: 8570 f = gfc_character2logical; 8571 break; 8572 8573 default: 8574 goto oops; 8575 } 8576 break; 8577 8578 default: 8579 oops: 8580 return &gfc_bad_expr; 8581 } 8582 8583 result = NULL; 8584 8585 switch (e->expr_type) 8586 { 8587 case EXPR_CONSTANT: 8588 result = f (e, kind); 8589 if (result == NULL) 8590 return &gfc_bad_expr; 8591 break; 8592 8593 case EXPR_ARRAY: 8594 if (!gfc_is_constant_expr (e)) 8595 break; 8596 8597 result = gfc_get_array_expr (type, kind, &e->where); 8598 result->shape = gfc_copy_shape (e->shape, e->rank); 8599 result->rank = e->rank; 8600 8601 for (c = gfc_constructor_first (e->value.constructor); 8602 c; c = gfc_constructor_next (c)) 8603 { 8604 gfc_expr *tmp; 8605 if (c->iterator == NULL) 8606 { 8607 if (c->expr->expr_type == EXPR_ARRAY) 8608 tmp = gfc_convert_constant (c->expr, type, kind); 8609 else if (c->expr->expr_type == EXPR_OP) 8610 { 8611 if (!gfc_simplify_expr (c->expr, 1)) 8612 return &gfc_bad_expr; 8613 tmp = f (c->expr, kind); 8614 } 8615 else 8616 tmp = f (c->expr, kind); 8617 } 8618 else 8619 tmp = gfc_convert_constant (c->expr, type, kind); 8620 8621 if (tmp == NULL || tmp == &gfc_bad_expr) 8622 { 8623 gfc_free_expr (result); 8624 return NULL; 8625 } 8626 8627 t = gfc_constructor_append_expr (&result->value.constructor, 8628 tmp, &c->where); 8629 if (c->iterator) 8630 t->iterator = gfc_copy_iterator (c->iterator); 8631 } 8632 8633 break; 8634 8635 default: 8636 break; 8637 } 8638 8639 return result; 8640} 8641 8642 8643/* Function for converting character constants. */ 8644gfc_expr * 8645gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) 8646{ 8647 gfc_expr *result; 8648 int i; 8649 8650 if (!gfc_is_constant_expr (e)) 8651 return NULL; 8652 8653 if (e->expr_type == EXPR_CONSTANT) 8654 { 8655 /* Simple case of a scalar. */ 8656 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); 8657 if (result == NULL) 8658 return &gfc_bad_expr; 8659 8660 result->value.character.length = e->value.character.length; 8661 result->value.character.string 8662 = gfc_get_wide_string (e->value.character.length + 1); 8663 memcpy (result->value.character.string, e->value.character.string, 8664 (e->value.character.length + 1) * sizeof (gfc_char_t)); 8665 8666 /* Check we only have values representable in the destination kind. */ 8667 for (i = 0; i < result->value.character.length; i++) 8668 if (!gfc_check_character_range (result->value.character.string[i], 8669 kind)) 8670 { 8671 gfc_error ("Character %qs in string at %L cannot be converted " 8672 "into character kind %d", 8673 gfc_print_wide_char (result->value.character.string[i]), 8674 &e->where, kind); 8675 gfc_free_expr (result); 8676 return &gfc_bad_expr; 8677 } 8678 8679 return result; 8680 } 8681 else if (e->expr_type == EXPR_ARRAY) 8682 { 8683 /* For an array constructor, we convert each constructor element. */ 8684 gfc_constructor *c; 8685 8686 result = gfc_get_array_expr (type, kind, &e->where); 8687 result->shape = gfc_copy_shape (e->shape, e->rank); 8688 result->rank = e->rank; 8689 result->ts.u.cl = e->ts.u.cl; 8690 8691 for (c = gfc_constructor_first (e->value.constructor); 8692 c; c = gfc_constructor_next (c)) 8693 { 8694 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); 8695 if (tmp == &gfc_bad_expr) 8696 { 8697 gfc_free_expr (result); 8698 return &gfc_bad_expr; 8699 } 8700 8701 if (tmp == NULL) 8702 { 8703 gfc_free_expr (result); 8704 return NULL; 8705 } 8706 8707 gfc_constructor_append_expr (&result->value.constructor, 8708 tmp, &c->where); 8709 } 8710 8711 return result; 8712 } 8713 else 8714 return NULL; 8715} 8716 8717 8718gfc_expr * 8719gfc_simplify_compiler_options (void) 8720{ 8721 char *str; 8722 gfc_expr *result; 8723 8724 str = gfc_get_option_string (); 8725 result = gfc_get_character_expr (gfc_default_character_kind, 8726 &gfc_current_locus, str, strlen (str)); 8727 free (str); 8728 return result; 8729} 8730 8731 8732gfc_expr * 8733gfc_simplify_compiler_version (void) 8734{ 8735 char *buffer; 8736 size_t len; 8737 8738 len = strlen ("GCC version ") + strlen (version_string); 8739 buffer = XALLOCAVEC (char, len + 1); 8740 snprintf (buffer, len + 1, "GCC version %s", version_string); 8741 return gfc_get_character_expr (gfc_default_character_kind, 8742 &gfc_current_locus, buffer, len); 8743} 8744 8745/* Simplification routines for intrinsics of IEEE modules. */ 8746 8747gfc_expr * 8748simplify_ieee_selected_real_kind (gfc_expr *expr) 8749{ 8750 gfc_actual_arglist *arg; 8751 gfc_expr *p = NULL, *q = NULL, *rdx = NULL; 8752 8753 arg = expr->value.function.actual; 8754 p = arg->expr; 8755 if (arg->next) 8756 { 8757 q = arg->next->expr; 8758 if (arg->next->next) 8759 rdx = arg->next->next->expr; 8760 } 8761 8762 /* Currently, if IEEE is supported and this module is built, it means 8763 all our floating-point types conform to IEEE. Hence, we simply handle 8764 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */ 8765 return gfc_simplify_selected_real_kind (p, q, rdx); 8766} 8767 8768gfc_expr * 8769simplify_ieee_support (gfc_expr *expr) 8770{ 8771 /* We consider that if the IEEE modules are loaded, we have full support 8772 for flags, halting and rounding, which are the three functions 8773 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant 8774 expressions. One day, we will need libgfortran to detect support and 8775 communicate it back to us, allowing for partial support. */ 8776 8777 return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where, 8778 true); 8779} 8780 8781bool 8782matches_ieee_function_name (gfc_symbol *sym, const char *name) 8783{ 8784 int n = strlen(name); 8785 8786 if (!strncmp(sym->name, name, n)) 8787 return true; 8788 8789 /* If a generic was used and renamed, we need more work to find out. 8790 Compare the specific name. */ 8791 if (sym->generic && !strncmp(sym->generic->sym->name, name, n)) 8792 return true; 8793 8794 return false; 8795} 8796 8797gfc_expr * 8798gfc_simplify_ieee_functions (gfc_expr *expr) 8799{ 8800 gfc_symbol* sym = expr->symtree->n.sym; 8801 8802 if (matches_ieee_function_name(sym, "ieee_selected_real_kind")) 8803 return simplify_ieee_selected_real_kind (expr); 8804 else if (matches_ieee_function_name(sym, "ieee_support_flag") 8805 || matches_ieee_function_name(sym, "ieee_support_halting") 8806 || matches_ieee_function_name(sym, "ieee_support_rounding")) 8807 return simplify_ieee_support (expr); 8808 else 8809 return NULL; 8810} 8811