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