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