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 { 4530 if (e->symtree->n.sym->ts.type != BT_DERIVED 4531 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target 4532 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED 4533 && e->symtree->n.sym->assoc->target->symtree->n.sym 4534 && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)) 4535 /* The expression in assoc->target points to a ref to the _data 4536 component of the unlimited polymorphic entity. To get the _len 4537 component the last _data ref needs to be stripped and a ref to the 4538 _len component added. */ 4539 return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); 4540 else if (e->symtree->n.sym->ts.type == BT_DERIVED 4541 && e->ref && e->ref->type == REF_COMPONENT 4542 && e->ref->u.c.component->attr.pdt_string 4543 && e->ref->u.c.component->ts.type == BT_CHARACTER 4544 && e->ref->u.c.component->ts.u.cl->length) 4545 { 4546 if (gfc_init_expr_flag) 4547 { 4548 gfc_expr* tmp; 4549 tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym, 4550 e->ref->u.c 4551 .component->ts.u.cl 4552 ->length->symtree 4553 ->name); 4554 if (tmp) 4555 return tmp; 4556 } 4557 else 4558 { 4559 gfc_expr *len_expr = gfc_copy_expr (e); 4560 gfc_free_ref_list (len_expr->ref); 4561 len_expr->ref = NULL; 4562 gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref 4563 ->u.c.component->ts.u.cl->length->symtree 4564 ->name, 4565 false, true, &len_expr->ref); 4566 len_expr->ts = len_expr->ref->u.c.component->ts; 4567 return len_expr; 4568 } 4569 } 4570 } 4571 return NULL; 4572 } 4573 4574 4575 gfc_expr * 4576 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) 4577 { 4578 gfc_expr *result; 4579 size_t count, len, i; 4580 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); 4581 4582 if (k == -1) 4583 return &gfc_bad_expr; 4584 4585 if (e->expr_type != EXPR_CONSTANT) 4586 return NULL; 4587 4588 len = e->value.character.length; 4589 for (count = 0, i = 1; i <= len; i++) 4590 if (e->value.character.string[len - i] == ' ') 4591 count++; 4592 else 4593 break; 4594 4595 result = gfc_get_int_expr (k, &e->where, len - count); 4596 return range_check (result, "LEN_TRIM"); 4597 } 4598 4599 gfc_expr * 4600 gfc_simplify_lgamma (gfc_expr *x) 4601 { 4602 gfc_expr *result; 4603 int sg; 4604 4605 if (x->expr_type != EXPR_CONSTANT) 4606 return NULL; 4607 4608 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4609 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); 4610 4611 return range_check (result, "LGAMMA"); 4612 } 4613 4614 4615 gfc_expr * 4616 gfc_simplify_lge (gfc_expr *a, gfc_expr *b) 4617 { 4618 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4619 return NULL; 4620 4621 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4622 gfc_compare_string (a, b) >= 0); 4623 } 4624 4625 4626 gfc_expr * 4627 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) 4628 { 4629 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4630 return NULL; 4631 4632 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4633 gfc_compare_string (a, b) > 0); 4634 } 4635 4636 4637 gfc_expr * 4638 gfc_simplify_lle (gfc_expr *a, gfc_expr *b) 4639 { 4640 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4641 return NULL; 4642 4643 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4644 gfc_compare_string (a, b) <= 0); 4645 } 4646 4647 4648 gfc_expr * 4649 gfc_simplify_llt (gfc_expr *a, gfc_expr *b) 4650 { 4651 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4652 return NULL; 4653 4654 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4655 gfc_compare_string (a, b) < 0); 4656 } 4657 4658 4659 gfc_expr * 4660 gfc_simplify_log (gfc_expr *x) 4661 { 4662 gfc_expr *result; 4663 4664 if (x->expr_type != EXPR_CONSTANT) 4665 return NULL; 4666 4667 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4668 4669 switch (x->ts.type) 4670 { 4671 case BT_REAL: 4672 if (mpfr_sgn (x->value.real) <= 0) 4673 { 4674 gfc_error ("Argument of LOG at %L cannot be less than or equal " 4675 "to zero", &x->where); 4676 gfc_free_expr (result); 4677 return &gfc_bad_expr; 4678 } 4679 4680 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); 4681 break; 4682 4683 case BT_COMPLEX: 4684 if (mpfr_zero_p (mpc_realref (x->value.complex)) 4685 && mpfr_zero_p (mpc_imagref (x->value.complex))) 4686 { 4687 gfc_error ("Complex argument of LOG at %L cannot be zero", 4688 &x->where); 4689 gfc_free_expr (result); 4690 return &gfc_bad_expr; 4691 } 4692 4693 gfc_set_model_kind (x->ts.kind); 4694 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 4695 break; 4696 4697 default: 4698 gfc_internal_error ("gfc_simplify_log: bad type"); 4699 } 4700 4701 return range_check (result, "LOG"); 4702 } 4703 4704 4705 gfc_expr * 4706 gfc_simplify_log10 (gfc_expr *x) 4707 { 4708 gfc_expr *result; 4709 4710 if (x->expr_type != EXPR_CONSTANT) 4711 return NULL; 4712 4713 if (mpfr_sgn (x->value.real) <= 0) 4714 { 4715 gfc_error ("Argument of LOG10 at %L cannot be less than or equal " 4716 "to zero", &x->where); 4717 return &gfc_bad_expr; 4718 } 4719 4720 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4721 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); 4722 4723 return range_check (result, "LOG10"); 4724 } 4725 4726 4727 gfc_expr * 4728 gfc_simplify_logical (gfc_expr *e, gfc_expr *k) 4729 { 4730 int kind; 4731 4732 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); 4733 if (kind < 0) 4734 return &gfc_bad_expr; 4735 4736 if (e->expr_type != EXPR_CONSTANT) 4737 return NULL; 4738 4739 return gfc_get_logical_expr (kind, &e->where, e->value.logical); 4740 } 4741 4742 4743 gfc_expr* 4744 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 4745 { 4746 gfc_expr *result; 4747 int row, result_rows, col, result_columns; 4748 int stride_a, offset_a, stride_b, offset_b; 4749 4750 if (!is_constant_array_expr (matrix_a) 4751 || !is_constant_array_expr (matrix_b)) 4752 return NULL; 4753 4754 /* MATMUL should do mixed-mode arithmetic. Set the result type. */ 4755 if (matrix_a->ts.type != matrix_b->ts.type) 4756 { 4757 gfc_expr e; 4758 e.expr_type = EXPR_OP; 4759 gfc_clear_ts (&e.ts); 4760 e.value.op.op = INTRINSIC_NONE; 4761 e.value.op.op1 = matrix_a; 4762 e.value.op.op2 = matrix_b; 4763 gfc_type_convert_binary (&e, 1); 4764 result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); 4765 } 4766 else 4767 { 4768 result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind, 4769 &matrix_a->where); 4770 } 4771 4772 if (matrix_a->rank == 1 && matrix_b->rank == 2) 4773 { 4774 result_rows = 1; 4775 result_columns = mpz_get_si (matrix_b->shape[1]); 4776 stride_a = 1; 4777 stride_b = mpz_get_si (matrix_b->shape[0]); 4778 4779 result->rank = 1; 4780 result->shape = gfc_get_shape (result->rank); 4781 mpz_init_set_si (result->shape[0], result_columns); 4782 } 4783 else if (matrix_a->rank == 2 && matrix_b->rank == 1) 4784 { 4785 result_rows = mpz_get_si (matrix_a->shape[0]); 4786 result_columns = 1; 4787 stride_a = mpz_get_si (matrix_a->shape[0]); 4788 stride_b = 1; 4789 4790 result->rank = 1; 4791 result->shape = gfc_get_shape (result->rank); 4792 mpz_init_set_si (result->shape[0], result_rows); 4793 } 4794 else if (matrix_a->rank == 2 && matrix_b->rank == 2) 4795 { 4796 result_rows = mpz_get_si (matrix_a->shape[0]); 4797 result_columns = mpz_get_si (matrix_b->shape[1]); 4798 stride_a = mpz_get_si (matrix_a->shape[0]); 4799 stride_b = mpz_get_si (matrix_b->shape[0]); 4800 4801 result->rank = 2; 4802 result->shape = gfc_get_shape (result->rank); 4803 mpz_init_set_si (result->shape[0], result_rows); 4804 mpz_init_set_si (result->shape[1], result_columns); 4805 } 4806 else 4807 gcc_unreachable(); 4808 4809 offset_b = 0; 4810 for (col = 0; col < result_columns; ++col) 4811 { 4812 offset_a = 0; 4813 4814 for (row = 0; row < result_rows; ++row) 4815 { 4816 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, 4817 matrix_b, 1, offset_b, false); 4818 gfc_constructor_append_expr (&result->value.constructor, 4819 e, NULL); 4820 4821 offset_a += 1; 4822 } 4823 4824 offset_b += stride_b; 4825 } 4826 4827 return result; 4828 } 4829 4830 4831 gfc_expr * 4832 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) 4833 { 4834 gfc_expr *result; 4835 int kind, arg, k; 4836 4837 if (i->expr_type != EXPR_CONSTANT) 4838 return NULL; 4839 4840 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); 4841 if (kind == -1) 4842 return &gfc_bad_expr; 4843 k = gfc_validate_kind (BT_INTEGER, kind, false); 4844 4845 bool fail = gfc_extract_int (i, &arg); 4846 gcc_assert (!fail); 4847 4848 if (!gfc_check_mask (i, kind_arg)) 4849 return &gfc_bad_expr; 4850 4851 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4852 4853 /* MASKR(n) = 2^n - 1 */ 4854 mpz_set_ui (result->value.integer, 1); 4855 mpz_mul_2exp (result->value.integer, result->value.integer, arg); 4856 mpz_sub_ui (result->value.integer, result->value.integer, 1); 4857 4858 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4859 4860 return result; 4861 } 4862 4863 4864 gfc_expr * 4865 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) 4866 { 4867 gfc_expr *result; 4868 int kind, arg, k; 4869 mpz_t z; 4870 4871 if (i->expr_type != EXPR_CONSTANT) 4872 return NULL; 4873 4874 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); 4875 if (kind == -1) 4876 return &gfc_bad_expr; 4877 k = gfc_validate_kind (BT_INTEGER, kind, false); 4878 4879 bool fail = gfc_extract_int (i, &arg); 4880 gcc_assert (!fail); 4881 4882 if (!gfc_check_mask (i, kind_arg)) 4883 return &gfc_bad_expr; 4884 4885 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4886 4887 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ 4888 mpz_init_set_ui (z, 1); 4889 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); 4890 mpz_set_ui (result->value.integer, 1); 4891 mpz_mul_2exp (result->value.integer, result->value.integer, 4892 gfc_integer_kinds[k].bit_size - arg); 4893 mpz_sub (result->value.integer, z, result->value.integer); 4894 mpz_clear (z); 4895 4896 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4897 4898 return result; 4899 } 4900 4901 4902 gfc_expr * 4903 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 4904 { 4905 gfc_expr * result; 4906 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; 4907 4908 if (mask->expr_type == EXPR_CONSTANT) 4909 { 4910 result = gfc_copy_expr (mask->value.logical ? tsource : fsource); 4911 /* Parenthesis is needed to get lower bounds of 1. */ 4912 result = gfc_get_parentheses (result); 4913 gfc_simplify_expr (result, 1); 4914 return result; 4915 } 4916 4917 if (!mask->rank || !is_constant_array_expr (mask) 4918 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) 4919 return NULL; 4920 4921 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, 4922 &tsource->where); 4923 if (tsource->ts.type == BT_DERIVED) 4924 result->ts.u.derived = tsource->ts.u.derived; 4925 else if (tsource->ts.type == BT_CHARACTER) 4926 result->ts.u.cl = tsource->ts.u.cl; 4927 4928 tsource_ctor = gfc_constructor_first (tsource->value.constructor); 4929 fsource_ctor = gfc_constructor_first (fsource->value.constructor); 4930 mask_ctor = gfc_constructor_first (mask->value.constructor); 4931 4932 while (mask_ctor) 4933 { 4934 if (mask_ctor->expr->value.logical) 4935 gfc_constructor_append_expr (&result->value.constructor, 4936 gfc_copy_expr (tsource_ctor->expr), 4937 NULL); 4938 else 4939 gfc_constructor_append_expr (&result->value.constructor, 4940 gfc_copy_expr (fsource_ctor->expr), 4941 NULL); 4942 tsource_ctor = gfc_constructor_next (tsource_ctor); 4943 fsource_ctor = gfc_constructor_next (fsource_ctor); 4944 mask_ctor = gfc_constructor_next (mask_ctor); 4945 } 4946 4947 result->shape = gfc_get_shape (1); 4948 gfc_array_size (result, &result->shape[0]); 4949 4950 return result; 4951 } 4952 4953 4954 gfc_expr * 4955 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) 4956 { 4957 mpz_t arg1, arg2, mask; 4958 gfc_expr *result; 4959 4960 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT 4961 || mask_expr->expr_type != EXPR_CONSTANT) 4962 return NULL; 4963 4964 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); 4965 4966 /* Convert all argument to unsigned. */ 4967 mpz_init_set (arg1, i->value.integer); 4968 mpz_init_set (arg2, j->value.integer); 4969 mpz_init_set (mask, mask_expr->value.integer); 4970 4971 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ 4972 mpz_and (arg1, arg1, mask); 4973 mpz_com (mask, mask); 4974 mpz_and (arg2, arg2, mask); 4975 mpz_ior (result->value.integer, arg1, arg2); 4976 4977 mpz_clear (arg1); 4978 mpz_clear (arg2); 4979 mpz_clear (mask); 4980 4981 return result; 4982 } 4983 4984 4985 /* Selects between current value and extremum for simplify_min_max 4986 and simplify_minval_maxval. */ 4987 static int 4988 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) 4989 { 4990 int ret; 4991 4992 switch (arg->ts.type) 4993 { 4994 case BT_INTEGER: 4995 if (extremum->ts.kind < arg->ts.kind) 4996 extremum->ts.kind = arg->ts.kind; 4997 ret = mpz_cmp (arg->value.integer, 4998 extremum->value.integer) * sign; 4999 if (ret > 0) 5000 mpz_set (extremum->value.integer, arg->value.integer); 5001 break; 5002 5003 case BT_REAL: 5004 if (extremum->ts.kind < arg->ts.kind) 5005 extremum->ts.kind = arg->ts.kind; 5006 if (mpfr_nan_p (extremum->value.real)) 5007 { 5008 ret = 1; 5009 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); 5010 } 5011 else if (mpfr_nan_p (arg->value.real)) 5012 ret = -1; 5013 else 5014 { 5015 ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; 5016 if (ret > 0) 5017 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); 5018 } 5019 break; 5020 5021 case BT_CHARACTER: 5022 #define LENGTH(x) ((x)->value.character.length) 5023 #define STRING(x) ((x)->value.character.string) 5024 if (LENGTH (extremum) < LENGTH(arg)) 5025 { 5026 gfc_char_t *tmp = STRING(extremum); 5027 5028 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); 5029 memcpy (STRING(extremum), tmp, 5030 LENGTH(extremum) * sizeof (gfc_char_t)); 5031 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', 5032 LENGTH(arg) - LENGTH(extremum)); 5033 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ 5034 LENGTH(extremum) = LENGTH(arg); 5035 free (tmp); 5036 } 5037 ret = gfc_compare_string (arg, extremum) * sign; 5038 if (ret > 0) 5039 { 5040 free (STRING(extremum)); 5041 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); 5042 memcpy (STRING(extremum), STRING(arg), 5043 LENGTH(arg) * sizeof (gfc_char_t)); 5044 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', 5045 LENGTH(extremum) - LENGTH(arg)); 5046 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ 5047 } 5048 #undef LENGTH 5049 #undef STRING 5050 break; 5051 5052 default: 5053 gfc_internal_error ("simplify_min_max(): Bad type in arglist"); 5054 } 5055 if (back_val && ret == 0) 5056 ret = 1; 5057 5058 return ret; 5059 } 5060 5061 5062 /* This function is special since MAX() can take any number of 5063 arguments. The simplified expression is a rewritten version of the 5064 argument list containing at most one constant element. Other 5065 constant elements are deleted. Because the argument list has 5066 already been checked, this function always succeeds. sign is 1 for 5067 MAX(), -1 for MIN(). */ 5068 5069 static gfc_expr * 5070 simplify_min_max (gfc_expr *expr, int sign) 5071 { 5072 int tmp1, tmp2; 5073 gfc_actual_arglist *arg, *last, *extremum; 5074 gfc_expr *tmp, *ret; 5075 const char *fname; 5076 5077 last = NULL; 5078 extremum = NULL; 5079 5080 arg = expr->value.function.actual; 5081 5082 for (; arg; last = arg, arg = arg->next) 5083 { 5084 if (arg->expr->expr_type != EXPR_CONSTANT) 5085 continue; 5086 5087 if (extremum == NULL) 5088 { 5089 extremum = arg; 5090 continue; 5091 } 5092 5093 min_max_choose (arg->expr, extremum->expr, sign); 5094 5095 /* Delete the extra constant argument. */ 5096 last->next = arg->next; 5097 5098 arg->next = NULL; 5099 gfc_free_actual_arglist (arg); 5100 arg = last; 5101 } 5102 5103 /* If there is one value left, replace the function call with the 5104 expression. */ 5105 if (expr->value.function.actual->next != NULL) 5106 return NULL; 5107 5108 /* Handle special cases of specific functions (min|max)1 and 5109 a(min|max)0. */ 5110 5111 tmp = expr->value.function.actual->expr; 5112 fname = expr->value.function.isym->name; 5113 5114 if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind) 5115 && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) 5116 { 5117 /* Explicit conversion, turn off -Wconversion and -Wconversion-extra 5118 warnings. */ 5119 tmp1 = warn_conversion; 5120 tmp2 = warn_conversion_extra; 5121 warn_conversion = warn_conversion_extra = 0; 5122 5123 ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind); 5124 5125 warn_conversion = tmp1; 5126 warn_conversion_extra = tmp2; 5127 } 5128 else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind) 5129 && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) 5130 { 5131 ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind); 5132 } 5133 else 5134 ret = gfc_copy_expr (tmp); 5135 5136 return ret; 5137 5138 } 5139 5140 5141 gfc_expr * 5142 gfc_simplify_min (gfc_expr *e) 5143 { 5144 return simplify_min_max (e, -1); 5145 } 5146 5147 5148 gfc_expr * 5149 gfc_simplify_max (gfc_expr *e) 5150 { 5151 return simplify_min_max (e, 1); 5152 } 5153 5154 /* Helper function for gfc_simplify_minval. */ 5155 5156 static gfc_expr * 5157 gfc_min (gfc_expr *op1, gfc_expr *op2) 5158 { 5159 min_max_choose (op1, op2, -1); 5160 gfc_free_expr (op1); 5161 return op2; 5162 } 5163 5164 /* Simplify minval for constant arrays. */ 5165 5166 gfc_expr * 5167 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5168 { 5169 return simplify_transformation (array, dim, mask, INT_MAX, gfc_min); 5170 } 5171 5172 /* Helper function for gfc_simplify_maxval. */ 5173 5174 static gfc_expr * 5175 gfc_max (gfc_expr *op1, gfc_expr *op2) 5176 { 5177 min_max_choose (op1, op2, 1); 5178 gfc_free_expr (op1); 5179 return op2; 5180 } 5181 5182 5183 /* Simplify maxval for constant arrays. */ 5184 5185 gfc_expr * 5186 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5187 { 5188 return simplify_transformation (array, dim, mask, INT_MIN, gfc_max); 5189 } 5190 5191 5192 /* Transform minloc or maxloc of an array, according to MASK, 5193 to the scalar result. This code is mostly identical to 5194 simplify_transformation_to_scalar. */ 5195 5196 static gfc_expr * 5197 simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, 5198 gfc_expr *extremum, int sign, bool back_val) 5199 { 5200 gfc_expr *a, *m; 5201 gfc_constructor *array_ctor, *mask_ctor; 5202 mpz_t count; 5203 5204 mpz_set_si (result->value.integer, 0); 5205 5206 5207 /* Shortcut for constant .FALSE. MASK. */ 5208 if (mask 5209 && mask->expr_type == EXPR_CONSTANT 5210 && !mask->value.logical) 5211 return result; 5212 5213 array_ctor = gfc_constructor_first (array->value.constructor); 5214 if (mask && mask->expr_type == EXPR_ARRAY) 5215 mask_ctor = gfc_constructor_first (mask->value.constructor); 5216 else 5217 mask_ctor = NULL; 5218 5219 mpz_init_set_si (count, 0); 5220 while (array_ctor) 5221 { 5222 mpz_add_ui (count, count, 1); 5223 a = array_ctor->expr; 5224 array_ctor = gfc_constructor_next (array_ctor); 5225 /* A constant MASK equals .TRUE. here and can be ignored. */ 5226 if (mask_ctor) 5227 { 5228 m = mask_ctor->expr; 5229 mask_ctor = gfc_constructor_next (mask_ctor); 5230 if (!m->value.logical) 5231 continue; 5232 } 5233 if (min_max_choose (a, extremum, sign, back_val) > 0) 5234 mpz_set (result->value.integer, count); 5235 } 5236 mpz_clear (count); 5237 gfc_free_expr (extremum); 5238 return result; 5239 } 5240 5241 /* Simplify minloc / maxloc in the absence of a dim argument. */ 5242 5243 static gfc_expr * 5244 simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, 5245 gfc_expr *array, gfc_expr *mask, int sign, 5246 bool back_val) 5247 { 5248 ssize_t res[GFC_MAX_DIMENSIONS]; 5249 int i, n; 5250 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5251 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5252 sstride[GFC_MAX_DIMENSIONS]; 5253 gfc_expr *a, *m; 5254 bool continue_loop; 5255 bool ma; 5256 5257 for (i = 0; i<array->rank; i++) 5258 res[i] = -1; 5259 5260 /* Shortcut for constant .FALSE. MASK. */ 5261 if (mask 5262 && mask->expr_type == EXPR_CONSTANT 5263 && !mask->value.logical) 5264 goto finish; 5265 5266 if (array->shape == NULL) 5267 goto finish; 5268 5269 for (i = 0; i < array->rank; i++) 5270 { 5271 count[i] = 0; 5272 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); 5273 extent[i] = mpz_get_si (array->shape[i]); 5274 if (extent[i] <= 0) 5275 goto finish; 5276 } 5277 5278 continue_loop = true; 5279 array_ctor = gfc_constructor_first (array->value.constructor); 5280 if (mask && mask->rank > 0) 5281 mask_ctor = gfc_constructor_first (mask->value.constructor); 5282 else 5283 mask_ctor = NULL; 5284 5285 /* Loop over the array elements (and mask), keeping track of 5286 the indices to return. */ 5287 while (continue_loop) 5288 { 5289 do 5290 { 5291 a = array_ctor->expr; 5292 if (mask_ctor) 5293 { 5294 m = mask_ctor->expr; 5295 ma = m->value.logical; 5296 mask_ctor = gfc_constructor_next (mask_ctor); 5297 } 5298 else 5299 ma = true; 5300 5301 if (ma && min_max_choose (a, extremum, sign, back_val) > 0) 5302 { 5303 for (i = 0; i<array->rank; i++) 5304 res[i] = count[i]; 5305 } 5306 array_ctor = gfc_constructor_next (array_ctor); 5307 count[0] ++; 5308 } while (count[0] != extent[0]); 5309 n = 0; 5310 do 5311 { 5312 /* When we get to the end of a dimension, reset it and increment 5313 the next dimension. */ 5314 count[n] = 0; 5315 n++; 5316 if (n >= array->rank) 5317 { 5318 continue_loop = false; 5319 break; 5320 } 5321 else 5322 count[n] ++; 5323 } while (count[n] == extent[n]); 5324 } 5325 5326 finish: 5327 gfc_free_expr (extremum); 5328 result_ctor = gfc_constructor_first (result->value.constructor); 5329 for (i = 0; i<array->rank; i++) 5330 { 5331 gfc_expr *r_expr; 5332 r_expr = result_ctor->expr; 5333 mpz_set_si (r_expr->value.integer, res[i] + 1); 5334 result_ctor = gfc_constructor_next (result_ctor); 5335 } 5336 return result; 5337 } 5338 5339 /* Helper function for gfc_simplify_minmaxloc - build an array 5340 expression with n elements. */ 5341 5342 static gfc_expr * 5343 new_array (bt type, int kind, int n, locus *where) 5344 { 5345 gfc_expr *result; 5346 int i; 5347 5348 result = gfc_get_array_expr (type, kind, where); 5349 result->rank = 1; 5350 result->shape = gfc_get_shape(1); 5351 mpz_init_set_si (result->shape[0], n); 5352 for (i = 0; i < n; i++) 5353 { 5354 gfc_constructor_append_expr (&result->value.constructor, 5355 gfc_get_constant_expr (type, kind, where), 5356 NULL); 5357 } 5358 5359 return result; 5360 } 5361 5362 /* Simplify minloc and maxloc. This code is mostly identical to 5363 simplify_transformation_to_array. */ 5364 5365 static gfc_expr * 5366 simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, 5367 gfc_expr *dim, gfc_expr *mask, 5368 gfc_expr *extremum, int sign, bool back_val) 5369 { 5370 mpz_t size; 5371 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5372 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5373 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5374 5375 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5376 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 5377 tmpstride[GFC_MAX_DIMENSIONS]; 5378 5379 /* Shortcut for constant .FALSE. MASK. */ 5380 if (mask 5381 && mask->expr_type == EXPR_CONSTANT 5382 && !mask->value.logical) 5383 return result; 5384 5385 /* Build an indexed table for array element expressions to minimize 5386 linked-list traversal. Masked elements are set to NULL. */ 5387 gfc_array_size (array, &size); 5388 arraysize = mpz_get_ui (size); 5389 mpz_clear (size); 5390 5391 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 5392 5393 array_ctor = gfc_constructor_first (array->value.constructor); 5394 mask_ctor = NULL; 5395 if (mask && mask->expr_type == EXPR_ARRAY) 5396 mask_ctor = gfc_constructor_first (mask->value.constructor); 5397 5398 for (i = 0; i < arraysize; ++i) 5399 { 5400 arrayvec[i] = array_ctor->expr; 5401 array_ctor = gfc_constructor_next (array_ctor); 5402 5403 if (mask_ctor) 5404 { 5405 if (!mask_ctor->expr->value.logical) 5406 arrayvec[i] = NULL; 5407 5408 mask_ctor = gfc_constructor_next (mask_ctor); 5409 } 5410 } 5411 5412 /* Same for the result expression. */ 5413 gfc_array_size (result, &size); 5414 resultsize = mpz_get_ui (size); 5415 mpz_clear (size); 5416 5417 resultvec = XCNEWVEC (gfc_expr*, resultsize); 5418 result_ctor = gfc_constructor_first (result->value.constructor); 5419 for (i = 0; i < resultsize; ++i) 5420 { 5421 resultvec[i] = result_ctor->expr; 5422 result_ctor = gfc_constructor_next (result_ctor); 5423 } 5424 5425 gfc_extract_int (dim, &dim_index); 5426 dim_index -= 1; /* zero-base index */ 5427 dim_extent = 0; 5428 dim_stride = 0; 5429 5430 for (i = 0, n = 0; i < array->rank; ++i) 5431 { 5432 count[i] = 0; 5433 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 5434 if (i == dim_index) 5435 { 5436 dim_extent = mpz_get_si (array->shape[i]); 5437 dim_stride = tmpstride[i]; 5438 continue; 5439 } 5440 5441 extent[n] = mpz_get_si (array->shape[i]); 5442 sstride[n] = tmpstride[i]; 5443 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5444 n += 1; 5445 } 5446 5447 done = resultsize <= 0; 5448 base = arrayvec; 5449 dest = resultvec; 5450 while (!done) 5451 { 5452 gfc_expr *ex; 5453 ex = gfc_copy_expr (extremum); 5454 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5455 { 5456 if (*src && min_max_choose (*src, ex, sign, back_val) > 0) 5457 mpz_set_si ((*dest)->value.integer, n + 1); 5458 } 5459 5460 count[0]++; 5461 base += sstride[0]; 5462 dest += dstride[0]; 5463 gfc_free_expr (ex); 5464 5465 n = 0; 5466 while (!done && count[n] == extent[n]) 5467 { 5468 count[n] = 0; 5469 base -= sstride[n] * extent[n]; 5470 dest -= dstride[n] * extent[n]; 5471 5472 n++; 5473 if (n < result->rank) 5474 { 5475 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5476 times, we'd warn for the last iteration, because the 5477 array index will have already been incremented to the 5478 array sizes, and we can't tell that this must make 5479 the test against result->rank false, because ranks 5480 must not exceed GFC_MAX_DIMENSIONS. */ 5481 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5482 count[n]++; 5483 base += sstride[n]; 5484 dest += dstride[n]; 5485 GCC_DIAGNOSTIC_POP 5486 } 5487 else 5488 done = true; 5489 } 5490 } 5491 5492 /* Place updated expression in result constructor. */ 5493 result_ctor = gfc_constructor_first (result->value.constructor); 5494 for (i = 0; i < resultsize; ++i) 5495 { 5496 result_ctor->expr = resultvec[i]; 5497 result_ctor = gfc_constructor_next (result_ctor); 5498 } 5499 5500 free (arrayvec); 5501 free (resultvec); 5502 free (extremum); 5503 return result; 5504 } 5505 5506 /* Simplify minloc and maxloc for constant arrays. */ 5507 5508 static gfc_expr * 5509 gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 5510 gfc_expr *kind, gfc_expr *back, int sign) 5511 { 5512 gfc_expr *result; 5513 gfc_expr *extremum; 5514 int ikind; 5515 int init_val; 5516 bool back_val = false; 5517 5518 if (!is_constant_array_expr (array) 5519 || !gfc_is_constant_expr (dim)) 5520 return NULL; 5521 5522 if (mask 5523 && !is_constant_array_expr (mask) 5524 && mask->expr_type != EXPR_CONSTANT) 5525 return NULL; 5526 5527 if (kind) 5528 { 5529 if (gfc_extract_int (kind, &ikind, -1)) 5530 return NULL; 5531 } 5532 else 5533 ikind = gfc_default_integer_kind; 5534 5535 if (back) 5536 { 5537 if (back->expr_type != EXPR_CONSTANT) 5538 return NULL; 5539 5540 back_val = back->value.logical; 5541 } 5542 5543 if (sign < 0) 5544 init_val = INT_MAX; 5545 else if (sign > 0) 5546 init_val = INT_MIN; 5547 else 5548 gcc_unreachable(); 5549 5550 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); 5551 init_result_expr (extremum, init_val, array); 5552 5553 if (dim) 5554 { 5555 result = transformational_result (array, dim, BT_INTEGER, 5556 ikind, &array->where); 5557 init_result_expr (result, 0, array); 5558 5559 if (array->rank == 1) 5560 return simplify_minmaxloc_to_scalar (result, array, mask, extremum, 5561 sign, back_val); 5562 else 5563 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, 5564 sign, back_val); 5565 } 5566 else 5567 { 5568 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5569 return simplify_minmaxloc_nodim (result, extremum, array, mask, 5570 sign, back_val); 5571 } 5572 } 5573 5574 gfc_expr * 5575 gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5576 gfc_expr *back) 5577 { 5578 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); 5579 } 5580 5581 gfc_expr * 5582 gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5583 gfc_expr *back) 5584 { 5585 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); 5586 } 5587 5588 /* Simplify findloc to scalar. Similar to 5589 simplify_minmaxloc_to_scalar. */ 5590 5591 static gfc_expr * 5592 simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5593 gfc_expr *mask, int back_val) 5594 { 5595 gfc_expr *a, *m; 5596 gfc_constructor *array_ctor, *mask_ctor; 5597 mpz_t count; 5598 5599 mpz_set_si (result->value.integer, 0); 5600 5601 /* Shortcut for constant .FALSE. MASK. */ 5602 if (mask 5603 && mask->expr_type == EXPR_CONSTANT 5604 && !mask->value.logical) 5605 return result; 5606 5607 array_ctor = gfc_constructor_first (array->value.constructor); 5608 if (mask && mask->expr_type == EXPR_ARRAY) 5609 mask_ctor = gfc_constructor_first (mask->value.constructor); 5610 else 5611 mask_ctor = NULL; 5612 5613 mpz_init_set_si (count, 0); 5614 while (array_ctor) 5615 { 5616 mpz_add_ui (count, count, 1); 5617 a = array_ctor->expr; 5618 array_ctor = gfc_constructor_next (array_ctor); 5619 /* A constant MASK equals .TRUE. here and can be ignored. */ 5620 if (mask_ctor) 5621 { 5622 m = mask_ctor->expr; 5623 mask_ctor = gfc_constructor_next (mask_ctor); 5624 if (!m->value.logical) 5625 continue; 5626 } 5627 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5628 { 5629 /* We have a match. If BACK is true, continue so we find 5630 the last one. */ 5631 mpz_set (result->value.integer, count); 5632 if (!back_val) 5633 break; 5634 } 5635 } 5636 mpz_clear (count); 5637 return result; 5638 } 5639 5640 /* Simplify findloc in the absence of a dim argument. Similar to 5641 simplify_minmaxloc_nodim. */ 5642 5643 static gfc_expr * 5644 simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, 5645 gfc_expr *mask, bool back_val) 5646 { 5647 ssize_t res[GFC_MAX_DIMENSIONS]; 5648 int i, n; 5649 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5650 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5651 sstride[GFC_MAX_DIMENSIONS]; 5652 gfc_expr *a, *m; 5653 bool continue_loop; 5654 bool ma; 5655 5656 for (i = 0; i < array->rank; i++) 5657 res[i] = -1; 5658 5659 /* Shortcut for constant .FALSE. MASK. */ 5660 if (mask 5661 && mask->expr_type == EXPR_CONSTANT 5662 && !mask->value.logical) 5663 goto finish; 5664 5665 for (i = 0; i < array->rank; i++) 5666 { 5667 count[i] = 0; 5668 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); 5669 extent[i] = mpz_get_si (array->shape[i]); 5670 if (extent[i] <= 0) 5671 goto finish; 5672 } 5673 5674 continue_loop = true; 5675 array_ctor = gfc_constructor_first (array->value.constructor); 5676 if (mask && mask->rank > 0) 5677 mask_ctor = gfc_constructor_first (mask->value.constructor); 5678 else 5679 mask_ctor = NULL; 5680 5681 /* Loop over the array elements (and mask), keeping track of 5682 the indices to return. */ 5683 while (continue_loop) 5684 { 5685 do 5686 { 5687 a = array_ctor->expr; 5688 if (mask_ctor) 5689 { 5690 m = mask_ctor->expr; 5691 ma = m->value.logical; 5692 mask_ctor = gfc_constructor_next (mask_ctor); 5693 } 5694 else 5695 ma = true; 5696 5697 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5698 { 5699 for (i = 0; i < array->rank; i++) 5700 res[i] = count[i]; 5701 if (!back_val) 5702 goto finish; 5703 } 5704 array_ctor = gfc_constructor_next (array_ctor); 5705 count[0] ++; 5706 } while (count[0] != extent[0]); 5707 n = 0; 5708 do 5709 { 5710 /* When we get to the end of a dimension, reset it and increment 5711 the next dimension. */ 5712 count[n] = 0; 5713 n++; 5714 if (n >= array->rank) 5715 { 5716 continue_loop = false; 5717 break; 5718 } 5719 else 5720 count[n] ++; 5721 } while (count[n] == extent[n]); 5722 } 5723 5724 finish: 5725 result_ctor = gfc_constructor_first (result->value.constructor); 5726 for (i = 0; i < array->rank; i++) 5727 { 5728 gfc_expr *r_expr; 5729 r_expr = result_ctor->expr; 5730 mpz_set_si (r_expr->value.integer, res[i] + 1); 5731 result_ctor = gfc_constructor_next (result_ctor); 5732 } 5733 return result; 5734 } 5735 5736 5737 /* Simplify findloc to an array. Similar to 5738 simplify_minmaxloc_to_array. */ 5739 5740 static gfc_expr * 5741 simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5742 gfc_expr *dim, gfc_expr *mask, bool back_val) 5743 { 5744 mpz_t size; 5745 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5746 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5747 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5748 5749 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], 5750 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], 5751 tmpstride[GFC_MAX_DIMENSIONS]; 5752 5753 /* Shortcut for constant .FALSE. MASK. */ 5754 if (mask 5755 && mask->expr_type == EXPR_CONSTANT 5756 && !mask->value.logical) 5757 return result; 5758 5759 /* Build an indexed table for array element expressions to minimize 5760 linked-list traversal. Masked elements are set to NULL. */ 5761 gfc_array_size (array, &size); 5762 arraysize = mpz_get_ui (size); 5763 mpz_clear (size); 5764 5765 arrayvec = XCNEWVEC (gfc_expr*, arraysize); 5766 5767 array_ctor = gfc_constructor_first (array->value.constructor); 5768 mask_ctor = NULL; 5769 if (mask && mask->expr_type == EXPR_ARRAY) 5770 mask_ctor = gfc_constructor_first (mask->value.constructor); 5771 5772 for (i = 0; i < arraysize; ++i) 5773 { 5774 arrayvec[i] = array_ctor->expr; 5775 array_ctor = gfc_constructor_next (array_ctor); 5776 5777 if (mask_ctor) 5778 { 5779 if (!mask_ctor->expr->value.logical) 5780 arrayvec[i] = NULL; 5781 5782 mask_ctor = gfc_constructor_next (mask_ctor); 5783 } 5784 } 5785 5786 /* Same for the result expression. */ 5787 gfc_array_size (result, &size); 5788 resultsize = mpz_get_ui (size); 5789 mpz_clear (size); 5790 5791 resultvec = XCNEWVEC (gfc_expr*, resultsize); 5792 result_ctor = gfc_constructor_first (result->value.constructor); 5793 for (i = 0; i < resultsize; ++i) 5794 { 5795 resultvec[i] = result_ctor->expr; 5796 result_ctor = gfc_constructor_next (result_ctor); 5797 } 5798 5799 gfc_extract_int (dim, &dim_index); 5800 5801 dim_index -= 1; /* Zero-base index. */ 5802 dim_extent = 0; 5803 dim_stride = 0; 5804 5805 for (i = 0, n = 0; i < array->rank; ++i) 5806 { 5807 count[i] = 0; 5808 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); 5809 if (i == dim_index) 5810 { 5811 dim_extent = mpz_get_si (array->shape[i]); 5812 dim_stride = tmpstride[i]; 5813 continue; 5814 } 5815 5816 extent[n] = mpz_get_si (array->shape[i]); 5817 sstride[n] = tmpstride[i]; 5818 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5819 n += 1; 5820 } 5821 5822 done = resultsize <= 0; 5823 base = arrayvec; 5824 dest = resultvec; 5825 while (!done) 5826 { 5827 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5828 { 5829 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) 5830 { 5831 mpz_set_si ((*dest)->value.integer, n + 1); 5832 if (!back_val) 5833 break; 5834 } 5835 } 5836 5837 count[0]++; 5838 base += sstride[0]; 5839 dest += dstride[0]; 5840 5841 n = 0; 5842 while (!done && count[n] == extent[n]) 5843 { 5844 count[n] = 0; 5845 base -= sstride[n] * extent[n]; 5846 dest -= dstride[n] * extent[n]; 5847 5848 n++; 5849 if (n < result->rank) 5850 { 5851 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5852 times, we'd warn for the last iteration, because the 5853 array index will have already been incremented to the 5854 array sizes, and we can't tell that this must make 5855 the test against result->rank false, because ranks 5856 must not exceed GFC_MAX_DIMENSIONS. */ 5857 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5858 count[n]++; 5859 base += sstride[n]; 5860 dest += dstride[n]; 5861 GCC_DIAGNOSTIC_POP 5862 } 5863 else 5864 done = true; 5865 } 5866 } 5867 5868 /* Place updated expression in result constructor. */ 5869 result_ctor = gfc_constructor_first (result->value.constructor); 5870 for (i = 0; i < resultsize; ++i) 5871 { 5872 result_ctor->expr = resultvec[i]; 5873 result_ctor = gfc_constructor_next (result_ctor); 5874 } 5875 5876 free (arrayvec); 5877 free (resultvec); 5878 return result; 5879 } 5880 5881 /* Simplify findloc. */ 5882 5883 gfc_expr * 5884 gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, 5885 gfc_expr *mask, gfc_expr *kind, gfc_expr *back) 5886 { 5887 gfc_expr *result; 5888 int ikind; 5889 bool back_val = false; 5890 5891 if (!is_constant_array_expr (array) 5892 || array->shape == NULL 5893 || !gfc_is_constant_expr (dim)) 5894 return NULL; 5895 5896 if (! gfc_is_constant_expr (value)) 5897 return 0; 5898 5899 if (mask 5900 && !is_constant_array_expr (mask) 5901 && mask->expr_type != EXPR_CONSTANT) 5902 return NULL; 5903 5904 if (kind) 5905 { 5906 if (gfc_extract_int (kind, &ikind, -1)) 5907 return NULL; 5908 } 5909 else 5910 ikind = gfc_default_integer_kind; 5911 5912 if (back) 5913 { 5914 if (back->expr_type != EXPR_CONSTANT) 5915 return NULL; 5916 5917 back_val = back->value.logical; 5918 } 5919 5920 if (dim) 5921 { 5922 result = transformational_result (array, dim, BT_INTEGER, 5923 ikind, &array->where); 5924 init_result_expr (result, 0, array); 5925 5926 if (array->rank == 1) 5927 return simplify_findloc_to_scalar (result, array, value, mask, 5928 back_val); 5929 else 5930 return simplify_findloc_to_array (result, array, value, dim, mask, 5931 back_val); 5932 } 5933 else 5934 { 5935 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5936 return simplify_findloc_nodim (result, value, array, mask, back_val); 5937 } 5938 return NULL; 5939 } 5940 5941 gfc_expr * 5942 gfc_simplify_maxexponent (gfc_expr *x) 5943 { 5944 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5945 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5946 gfc_real_kinds[i].max_exponent); 5947 } 5948 5949 5950 gfc_expr * 5951 gfc_simplify_minexponent (gfc_expr *x) 5952 { 5953 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5954 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5955 gfc_real_kinds[i].min_exponent); 5956 } 5957 5958 5959 gfc_expr * 5960 gfc_simplify_mod (gfc_expr *a, gfc_expr *p) 5961 { 5962 gfc_expr *result; 5963 int kind; 5964 5965 /* First check p. */ 5966 if (p->expr_type != EXPR_CONSTANT) 5967 return NULL; 5968 5969 /* p shall not be 0. */ 5970 switch (p->ts.type) 5971 { 5972 case BT_INTEGER: 5973 if (mpz_cmp_ui (p->value.integer, 0) == 0) 5974 { 5975 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5976 "P", &p->where); 5977 return &gfc_bad_expr; 5978 } 5979 break; 5980 case BT_REAL: 5981 if (mpfr_cmp_ui (p->value.real, 0) == 0) 5982 { 5983 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5984 "P", &p->where); 5985 return &gfc_bad_expr; 5986 } 5987 break; 5988 default: 5989 gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); 5990 } 5991 5992 if (a->expr_type != EXPR_CONSTANT) 5993 return NULL; 5994 5995 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 5996 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 5997 5998 if (a->ts.type == BT_INTEGER) 5999 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); 6000 else 6001 { 6002 gfc_set_model_kind (kind); 6003 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6004 GFC_RND_MODE); 6005 } 6006 6007 return range_check (result, "MOD"); 6008 } 6009 6010 6011 gfc_expr * 6012 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 6013 { 6014 gfc_expr *result; 6015 int kind; 6016 6017 /* First check p. */ 6018 if (p->expr_type != EXPR_CONSTANT) 6019 return NULL; 6020 6021 /* p shall not be 0. */ 6022 switch (p->ts.type) 6023 { 6024 case BT_INTEGER: 6025 if (mpz_cmp_ui (p->value.integer, 0) == 0) 6026 { 6027 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6028 "P", &p->where); 6029 return &gfc_bad_expr; 6030 } 6031 break; 6032 case BT_REAL: 6033 if (mpfr_cmp_ui (p->value.real, 0) == 0) 6034 { 6035 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6036 "P", &p->where); 6037 return &gfc_bad_expr; 6038 } 6039 break; 6040 default: 6041 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); 6042 } 6043 6044 if (a->expr_type != EXPR_CONSTANT) 6045 return NULL; 6046 6047 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 6048 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 6049 6050 if (a->ts.type == BT_INTEGER) 6051 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); 6052 else 6053 { 6054 gfc_set_model_kind (kind); 6055 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6056 GFC_RND_MODE); 6057 if (mpfr_cmp_ui (result->value.real, 0) != 0) 6058 { 6059 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) 6060 mpfr_add (result->value.real, result->value.real, p->value.real, 6061 GFC_RND_MODE); 6062 } 6063 else 6064 mpfr_copysign (result->value.real, result->value.real, 6065 p->value.real, GFC_RND_MODE); 6066 } 6067 6068 return range_check (result, "MODULO"); 6069 } 6070 6071 6072 gfc_expr * 6073 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 6074 { 6075 gfc_expr *result; 6076 mpfr_exp_t emin, emax; 6077 int kind; 6078 6079 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 6080 return NULL; 6081 6082 result = gfc_copy_expr (x); 6083 6084 /* Save current values of emin and emax. */ 6085 emin = mpfr_get_emin (); 6086 emax = mpfr_get_emax (); 6087 6088 /* Set emin and emax for the current model number. */ 6089 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); 6090 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - 6091 mpfr_get_prec(result->value.real) + 1); 6092 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent); 6093 mpfr_check_range (result->value.real, 0, MPFR_RNDU); 6094 6095 if (mpfr_sgn (s->value.real) > 0) 6096 { 6097 mpfr_nextabove (result->value.real); 6098 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); 6099 } 6100 else 6101 { 6102 mpfr_nextbelow (result->value.real); 6103 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); 6104 } 6105 6106 mpfr_set_emin (emin); 6107 mpfr_set_emax (emax); 6108 6109 /* Only NaN can occur. Do not use range check as it gives an 6110 error for denormal numbers. */ 6111 if (mpfr_nan_p (result->value.real) && flag_range_check) 6112 { 6113 gfc_error ("Result of NEAREST is NaN at %L", &result->where); 6114 gfc_free_expr (result); 6115 return &gfc_bad_expr; 6116 } 6117 6118 return result; 6119 } 6120 6121 6122 static gfc_expr * 6123 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 6124 { 6125 gfc_expr *itrunc, *result; 6126 int kind; 6127 6128 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); 6129 if (kind == -1) 6130 return &gfc_bad_expr; 6131 6132 if (e->expr_type != EXPR_CONSTANT) 6133 return NULL; 6134 6135 itrunc = gfc_copy_expr (e); 6136 mpfr_round (itrunc->value.real, e->value.real); 6137 6138 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 6139 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); 6140 6141 gfc_free_expr (itrunc); 6142 6143 return range_check (result, name); 6144 } 6145 6146 6147 gfc_expr * 6148 gfc_simplify_new_line (gfc_expr *e) 6149 { 6150 gfc_expr *result; 6151 6152 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); 6153 result->value.character.string[0] = '\n'; 6154 6155 return result; 6156 } 6157 6158 6159 gfc_expr * 6160 gfc_simplify_nint (gfc_expr *e, gfc_expr *k) 6161 { 6162 return simplify_nint ("NINT", e, k); 6163 } 6164 6165 6166 gfc_expr * 6167 gfc_simplify_idnint (gfc_expr *e) 6168 { 6169 return simplify_nint ("IDNINT", e, NULL); 6170 } 6171 6172 static int norm2_scale; 6173 6174 static gfc_expr * 6175 norm2_add_squared (gfc_expr *result, gfc_expr *e) 6176 { 6177 mpfr_t tmp; 6178 6179 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 6180 gcc_assert (result->ts.type == BT_REAL 6181 && result->expr_type == EXPR_CONSTANT); 6182 6183 gfc_set_model_kind (result->ts.kind); 6184 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); 6185 mpfr_exp_t exp; 6186 if (mpfr_regular_p (result->value.real)) 6187 { 6188 exp = mpfr_get_exp (result->value.real); 6189 /* If result is getting close to overflowing, scale down. */ 6190 if (exp >= gfc_real_kinds[index].max_exponent - 4 6191 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) 6192 { 6193 norm2_scale += 2; 6194 mpfr_div_ui (result->value.real, result->value.real, 16, 6195 GFC_RND_MODE); 6196 } 6197 } 6198 6199 mpfr_init (tmp); 6200 if (mpfr_regular_p (e->value.real)) 6201 { 6202 exp = mpfr_get_exp (e->value.real); 6203 /* If e**2 would overflow or close to overflowing, scale down. */ 6204 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) 6205 { 6206 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; 6207 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6208 mpfr_set_exp (tmp, new_scale - norm2_scale); 6209 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6210 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6211 norm2_scale = new_scale; 6212 } 6213 } 6214 if (norm2_scale) 6215 { 6216 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6217 mpfr_set_exp (tmp, norm2_scale); 6218 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE); 6219 } 6220 else 6221 mpfr_set (tmp, e->value.real, GFC_RND_MODE); 6222 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE); 6223 mpfr_add (result->value.real, result->value.real, tmp, 6224 GFC_RND_MODE); 6225 mpfr_clear (tmp); 6226 6227 return result; 6228 } 6229 6230 6231 static gfc_expr * 6232 norm2_do_sqrt (gfc_expr *result, gfc_expr *e) 6233 { 6234 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); 6235 gcc_assert (result->ts.type == BT_REAL 6236 && result->expr_type == EXPR_CONSTANT); 6237 6238 if (result != e) 6239 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); 6240 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 6241 if (norm2_scale && mpfr_regular_p (result->value.real)) 6242 { 6243 mpfr_t tmp; 6244 mpfr_init (tmp); 6245 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6246 mpfr_set_exp (tmp, norm2_scale); 6247 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6248 mpfr_clear (tmp); 6249 } 6250 norm2_scale = 0; 6251 6252 return result; 6253 } 6254 6255 6256 gfc_expr * 6257 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) 6258 { 6259 gfc_expr *result; 6260 bool size_zero; 6261 6262 size_zero = gfc_is_size_zero_array (e); 6263 6264 if (!(is_constant_array_expr (e) || size_zero) 6265 || (dim != NULL && !gfc_is_constant_expr (dim))) 6266 return NULL; 6267 6268 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); 6269 init_result_expr (result, 0, NULL); 6270 6271 if (size_zero) 6272 return result; 6273 6274 norm2_scale = 0; 6275 if (!dim || e->rank == 1) 6276 { 6277 result = simplify_transformation_to_scalar (result, e, NULL, 6278 norm2_add_squared); 6279 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); 6280 if (norm2_scale && mpfr_regular_p (result->value.real)) 6281 { 6282 mpfr_t tmp; 6283 mpfr_init (tmp); 6284 mpfr_set_ui (tmp, 1, GFC_RND_MODE); 6285 mpfr_set_exp (tmp, norm2_scale); 6286 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); 6287 mpfr_clear (tmp); 6288 } 6289 norm2_scale = 0; 6290 } 6291 else 6292 result = simplify_transformation_to_array (result, e, dim, NULL, 6293 norm2_add_squared, 6294 norm2_do_sqrt); 6295 6296 return result; 6297 } 6298 6299 6300 gfc_expr * 6301 gfc_simplify_not (gfc_expr *e) 6302 { 6303 gfc_expr *result; 6304 6305 if (e->expr_type != EXPR_CONSTANT) 6306 return NULL; 6307 6308 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6309 mpz_com (result->value.integer, e->value.integer); 6310 6311 return range_check (result, "NOT"); 6312 } 6313 6314 6315 gfc_expr * 6316 gfc_simplify_null (gfc_expr *mold) 6317 { 6318 gfc_expr *result; 6319 6320 if (mold) 6321 { 6322 result = gfc_copy_expr (mold); 6323 result->expr_type = EXPR_NULL; 6324 } 6325 else 6326 result = gfc_get_null_expr (NULL); 6327 6328 return result; 6329 } 6330 6331 6332 gfc_expr * 6333 gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) 6334 { 6335 gfc_expr *result; 6336 6337 if (flag_coarray == GFC_FCOARRAY_NONE) 6338 { 6339 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6340 return &gfc_bad_expr; 6341 } 6342 6343 if (flag_coarray != GFC_FCOARRAY_SINGLE) 6344 return NULL; 6345 6346 if (failed && failed->expr_type != EXPR_CONSTANT) 6347 return NULL; 6348 6349 /* FIXME: gfc_current_locus is wrong. */ 6350 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6351 &gfc_current_locus); 6352 6353 if (failed && failed->value.logical != 0) 6354 mpz_set_si (result->value.integer, 0); 6355 else 6356 mpz_set_si (result->value.integer, 1); 6357 6358 return result; 6359 } 6360 6361 6362 gfc_expr * 6363 gfc_simplify_or (gfc_expr *x, gfc_expr *y) 6364 { 6365 gfc_expr *result; 6366 int kind; 6367 6368 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 6369 return NULL; 6370 6371 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 6372 6373 switch (x->ts.type) 6374 { 6375 case BT_INTEGER: 6376 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 6377 mpz_ior (result->value.integer, x->value.integer, y->value.integer); 6378 return range_check (result, "OR"); 6379 6380 case BT_LOGICAL: 6381 return gfc_get_logical_expr (kind, &x->where, 6382 x->value.logical || y->value.logical); 6383 default: 6384 gcc_unreachable(); 6385 } 6386 } 6387 6388 6389 gfc_expr * 6390 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 6391 { 6392 gfc_expr *result; 6393 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; 6394 6395 if (!is_constant_array_expr (array) 6396 || !is_constant_array_expr (vector) 6397 || (!gfc_is_constant_expr (mask) 6398 && !is_constant_array_expr (mask))) 6399 return NULL; 6400 6401 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 6402 if (array->ts.type == BT_DERIVED) 6403 result->ts.u.derived = array->ts.u.derived; 6404 6405 array_ctor = gfc_constructor_first (array->value.constructor); 6406 vector_ctor = vector 6407 ? gfc_constructor_first (vector->value.constructor) 6408 : NULL; 6409 6410 if (mask->expr_type == EXPR_CONSTANT 6411 && mask->value.logical) 6412 { 6413 /* Copy all elements of ARRAY to RESULT. */ 6414 while (array_ctor) 6415 { 6416 gfc_constructor_append_expr (&result->value.constructor, 6417 gfc_copy_expr (array_ctor->expr), 6418 NULL); 6419 6420 array_ctor = gfc_constructor_next (array_ctor); 6421 vector_ctor = gfc_constructor_next (vector_ctor); 6422 } 6423 } 6424 else if (mask->expr_type == EXPR_ARRAY) 6425 { 6426 /* Copy only those elements of ARRAY to RESULT whose 6427 MASK equals .TRUE.. */ 6428 mask_ctor = gfc_constructor_first (mask->value.constructor); 6429 while (mask_ctor && array_ctor) 6430 { 6431 if (mask_ctor->expr->value.logical) 6432 { 6433 gfc_constructor_append_expr (&result->value.constructor, 6434 gfc_copy_expr (array_ctor->expr), 6435 NULL); 6436 vector_ctor = gfc_constructor_next (vector_ctor); 6437 } 6438 6439 array_ctor = gfc_constructor_next (array_ctor); 6440 mask_ctor = gfc_constructor_next (mask_ctor); 6441 } 6442 } 6443 6444 /* Append any left-over elements from VECTOR to RESULT. */ 6445 while (vector_ctor) 6446 { 6447 gfc_constructor_append_expr (&result->value.constructor, 6448 gfc_copy_expr (vector_ctor->expr), 6449 NULL); 6450 vector_ctor = gfc_constructor_next (vector_ctor); 6451 } 6452 6453 result->shape = gfc_get_shape (1); 6454 gfc_array_size (result, &result->shape[0]); 6455 6456 if (array->ts.type == BT_CHARACTER) 6457 result->ts.u.cl = array->ts.u.cl; 6458 6459 return result; 6460 } 6461 6462 6463 static gfc_expr * 6464 do_xor (gfc_expr *result, gfc_expr *e) 6465 { 6466 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); 6467 gcc_assert (result->ts.type == BT_LOGICAL 6468 && result->expr_type == EXPR_CONSTANT); 6469 6470 result->value.logical = result->value.logical != e->value.logical; 6471 return result; 6472 } 6473 6474 6475 gfc_expr * 6476 gfc_simplify_is_contiguous (gfc_expr *array) 6477 { 6478 if (gfc_is_simply_contiguous (array, false, true)) 6479 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); 6480 6481 if (gfc_is_not_contiguous (array)) 6482 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); 6483 6484 return NULL; 6485 } 6486 6487 6488 gfc_expr * 6489 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) 6490 { 6491 return simplify_transformation (e, dim, NULL, 0, do_xor); 6492 } 6493 6494 6495 gfc_expr * 6496 gfc_simplify_popcnt (gfc_expr *e) 6497 { 6498 int res, k; 6499 mpz_t x; 6500 6501 if (e->expr_type != EXPR_CONSTANT) 6502 return NULL; 6503 6504 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6505 6506 /* Convert argument to unsigned, then count the '1' bits. */ 6507 mpz_init_set (x, e->value.integer); 6508 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 6509 res = mpz_popcount (x); 6510 mpz_clear (x); 6511 6512 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); 6513 } 6514 6515 6516 gfc_expr * 6517 gfc_simplify_poppar (gfc_expr *e) 6518 { 6519 gfc_expr *popcnt; 6520 int i; 6521 6522 if (e->expr_type != EXPR_CONSTANT) 6523 return NULL; 6524 6525 popcnt = gfc_simplify_popcnt (e); 6526 gcc_assert (popcnt); 6527 6528 bool fail = gfc_extract_int (popcnt, &i); 6529 gcc_assert (!fail); 6530 6531 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); 6532 } 6533 6534 6535 gfc_expr * 6536 gfc_simplify_precision (gfc_expr *e) 6537 { 6538 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6539 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, 6540 gfc_real_kinds[i].precision); 6541 } 6542 6543 6544 gfc_expr * 6545 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 6546 { 6547 return simplify_transformation (array, dim, mask, 1, gfc_multiply); 6548 } 6549 6550 6551 gfc_expr * 6552 gfc_simplify_radix (gfc_expr *e) 6553 { 6554 int i; 6555 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6556 6557 switch (e->ts.type) 6558 { 6559 case BT_INTEGER: 6560 i = gfc_integer_kinds[i].radix; 6561 break; 6562 6563 case BT_REAL: 6564 i = gfc_real_kinds[i].radix; 6565 break; 6566 6567 default: 6568 gcc_unreachable (); 6569 } 6570 6571 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 6572 } 6573 6574 6575 gfc_expr * 6576 gfc_simplify_range (gfc_expr *e) 6577 { 6578 int i; 6579 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 6580 6581 switch (e->ts.type) 6582 { 6583 case BT_INTEGER: 6584 i = gfc_integer_kinds[i].range; 6585 break; 6586 6587 case BT_REAL: 6588 case BT_COMPLEX: 6589 i = gfc_real_kinds[i].range; 6590 break; 6591 6592 default: 6593 gcc_unreachable (); 6594 } 6595 6596 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); 6597 } 6598 6599 6600 gfc_expr * 6601 gfc_simplify_rank (gfc_expr *e) 6602 { 6603 /* Assumed rank. */ 6604 if (e->rank == -1) 6605 return NULL; 6606 6607 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); 6608 } 6609 6610 6611 gfc_expr * 6612 gfc_simplify_real (gfc_expr *e, gfc_expr *k) 6613 { 6614 gfc_expr *result = NULL; 6615 int kind, tmp1, tmp2; 6616 6617 /* Convert BOZ to real, and return without range checking. */ 6618 if (e->ts.type == BT_BOZ) 6619 { 6620 /* Determine kind for conversion of the BOZ. */ 6621 if (k) 6622 gfc_extract_int (k, &kind); 6623 else 6624 kind = gfc_default_real_kind; 6625 6626 if (!gfc_boz2real (e, kind)) 6627 return NULL; 6628 result = gfc_copy_expr (e); 6629 return result; 6630 } 6631 6632 if (e->ts.type == BT_COMPLEX) 6633 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); 6634 else 6635 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); 6636 6637 if (kind == -1) 6638 return &gfc_bad_expr; 6639 6640 if (e->expr_type != EXPR_CONSTANT) 6641 return NULL; 6642 6643 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 6644 warnings. */ 6645 tmp1 = warn_conversion; 6646 tmp2 = warn_conversion_extra; 6647 warn_conversion = warn_conversion_extra = 0; 6648 6649 result = gfc_convert_constant (e, BT_REAL, kind); 6650 6651 warn_conversion = tmp1; 6652 warn_conversion_extra = tmp2; 6653 6654 if (result == &gfc_bad_expr) 6655 return &gfc_bad_expr; 6656 6657 return range_check (result, "REAL"); 6658 } 6659 6660 6661 gfc_expr * 6662 gfc_simplify_realpart (gfc_expr *e) 6663 { 6664 gfc_expr *result; 6665 6666 if (e->expr_type != EXPR_CONSTANT) 6667 return NULL; 6668 6669 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 6670 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); 6671 6672 return range_check (result, "REALPART"); 6673 } 6674 6675 gfc_expr * 6676 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) 6677 { 6678 gfc_expr *result; 6679 gfc_charlen_t len; 6680 mpz_t ncopies; 6681 bool have_length = false; 6682 6683 /* If NCOPIES isn't a constant, there's nothing we can do. */ 6684 if (n->expr_type != EXPR_CONSTANT) 6685 return NULL; 6686 6687 /* If NCOPIES is negative, it's an error. */ 6688 if (mpz_sgn (n->value.integer) < 0) 6689 { 6690 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", 6691 &n->where); 6692 return &gfc_bad_expr; 6693 } 6694 6695 /* If we don't know the character length, we can do no more. */ 6696 if (e->ts.u.cl && e->ts.u.cl->length 6697 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 6698 { 6699 len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); 6700 have_length = true; 6701 } 6702 else if (e->expr_type == EXPR_CONSTANT 6703 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 6704 { 6705 len = e->value.character.length; 6706 } 6707 else 6708 return NULL; 6709 6710 /* If the source length is 0, any value of NCOPIES is valid 6711 and everything behaves as if NCOPIES == 0. */ 6712 mpz_init (ncopies); 6713 if (len == 0) 6714 mpz_set_ui (ncopies, 0); 6715 else 6716 mpz_set (ncopies, n->value.integer); 6717 6718 /* Check that NCOPIES isn't too large. */ 6719 if (len) 6720 { 6721 mpz_t max, mlen; 6722 int i; 6723 6724 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ 6725 mpz_init (max); 6726 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 6727 6728 if (have_length) 6729 { 6730 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, 6731 e->ts.u.cl->length->value.integer); 6732 } 6733 else 6734 { 6735 mpz_init (mlen); 6736 gfc_mpz_set_hwi (mlen, len); 6737 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); 6738 mpz_clear (mlen); 6739 } 6740 6741 /* The check itself. */ 6742 if (mpz_cmp (ncopies, max) > 0) 6743 { 6744 mpz_clear (max); 6745 mpz_clear (ncopies); 6746 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", 6747 &n->where); 6748 return &gfc_bad_expr; 6749 } 6750 6751 mpz_clear (max); 6752 } 6753 mpz_clear (ncopies); 6754 6755 /* For further simplification, we need the character string to be 6756 constant. */ 6757 if (e->expr_type != EXPR_CONSTANT) 6758 return NULL; 6759 6760 HOST_WIDE_INT ncop; 6761 if (len || 6762 (e->ts.u.cl->length && 6763 mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) 6764 { 6765 bool fail = gfc_extract_hwi (n, &ncop); 6766 gcc_assert (!fail); 6767 } 6768 else 6769 ncop = 0; 6770 6771 if (ncop == 0) 6772 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); 6773 6774 len = e->value.character.length; 6775 gfc_charlen_t nlen = ncop * len; 6776 6777 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB 6778 (2**28 elements * 4 bytes (wide chars) per element) defer to 6779 runtime instead of consuming (unbounded) memory and CPU at 6780 compile time. */ 6781 if (nlen > 268435456) 6782 { 6783 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L" 6784 " deferred to runtime, expect bugs", &e->where); 6785 return NULL; 6786 } 6787 6788 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); 6789 for (size_t i = 0; i < (size_t) ncop; i++) 6790 for (size_t j = 0; j < (size_t) len; j++) 6791 result->value.character.string[j+i*len]= e->value.character.string[j]; 6792 6793 result->value.character.string[nlen] = '\0'; /* For debugger */ 6794 return result; 6795 } 6796 6797 6798 /* This one is a bear, but mainly has to do with shuffling elements. */ 6799 6800 gfc_expr * 6801 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 6802 gfc_expr *pad, gfc_expr *order_exp) 6803 { 6804 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; 6805 int i, rank, npad, x[GFC_MAX_DIMENSIONS]; 6806 mpz_t index, size; 6807 unsigned long j; 6808 size_t nsource; 6809 gfc_expr *e, *result; 6810 bool zerosize = false; 6811 6812 /* Check that argument expression types are OK. */ 6813 if (!is_constant_array_expr (source) 6814 || !is_constant_array_expr (shape_exp) 6815 || !is_constant_array_expr (pad) 6816 || !is_constant_array_expr (order_exp)) 6817 return NULL; 6818 6819 if (source->shape == NULL) 6820 return NULL; 6821 6822 /* Proceed with simplification, unpacking the array. */ 6823 6824 mpz_init (index); 6825 rank = 0; 6826 6827 for (i = 0; i < GFC_MAX_DIMENSIONS; i++) 6828 x[i] = 0; 6829 6830 for (;;) 6831 { 6832 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); 6833 if (e == NULL) 6834 break; 6835 6836 gfc_extract_int (e, &shape[rank]); 6837 6838 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); 6839 if (shape[rank] < 0) 6840 { 6841 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " 6842 "negative value %d for dimension %d", 6843 &shape_exp->where, shape[rank], rank+1); 6844 return &gfc_bad_expr; 6845 } 6846 6847 rank++; 6848 } 6849 6850 gcc_assert (rank > 0); 6851 6852 /* Now unpack the order array if present. */ 6853 if (order_exp == NULL) 6854 { 6855 for (i = 0; i < rank; i++) 6856 order[i] = i; 6857 } 6858 else 6859 { 6860 mpz_t size; 6861 int order_size, shape_size; 6862 6863 if (order_exp->rank != shape_exp->rank) 6864 { 6865 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", 6866 &order_exp->where, &shape_exp->where); 6867 return &gfc_bad_expr; 6868 } 6869 6870 gfc_array_size (shape_exp, &size); 6871 shape_size = mpz_get_ui (size); 6872 mpz_clear (size); 6873 gfc_array_size (order_exp, &size); 6874 order_size = mpz_get_ui (size); 6875 mpz_clear (size); 6876 if (order_size != shape_size) 6877 { 6878 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", 6879 &order_exp->where, &shape_exp->where); 6880 return &gfc_bad_expr; 6881 } 6882 6883 for (i = 0; i < rank; i++) 6884 { 6885 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); 6886 gcc_assert (e); 6887 6888 gfc_extract_int (e, &order[i]); 6889 6890 if (order[i] < 1 || order[i] > rank) 6891 { 6892 gfc_error ("Element with a value of %d in ORDER at %L must be " 6893 "in the range [1, ..., %d] for the RESHAPE intrinsic " 6894 "near %L", order[i], &order_exp->where, rank, 6895 &shape_exp->where); 6896 return &gfc_bad_expr; 6897 } 6898 6899 order[i]--; 6900 if (x[order[i]] != 0) 6901 { 6902 gfc_error ("ORDER at %L is not a permutation of the size of " 6903 "SHAPE at %L", &order_exp->where, &shape_exp->where); 6904 return &gfc_bad_expr; 6905 } 6906 x[order[i]] = 1; 6907 } 6908 } 6909 6910 /* Count the elements in the source and padding arrays. */ 6911 6912 npad = 0; 6913 if (pad != NULL) 6914 { 6915 gfc_array_size (pad, &size); 6916 npad = mpz_get_ui (size); 6917 mpz_clear (size); 6918 } 6919 6920 gfc_array_size (source, &size); 6921 nsource = mpz_get_ui (size); 6922 mpz_clear (size); 6923 6924 /* If it weren't for that pesky permutation we could just loop 6925 through the source and round out any shortage with pad elements. 6926 But no, someone just had to have the compiler do something the 6927 user should be doing. */ 6928 6929 for (i = 0; i < rank; i++) 6930 x[i] = 0; 6931 6932 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 6933 &source->where); 6934 if (source->ts.type == BT_DERIVED) 6935 result->ts.u.derived = source->ts.u.derived; 6936 if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL) 6937 result->ts = source->ts; 6938 result->rank = rank; 6939 result->shape = gfc_get_shape (rank); 6940 for (i = 0; i < rank; i++) 6941 { 6942 mpz_init_set_ui (result->shape[i], shape[i]); 6943 if (shape[i] == 0) 6944 zerosize = true; 6945 } 6946 6947 if (zerosize) 6948 goto sizezero; 6949 6950 while (nsource > 0 || npad > 0) 6951 { 6952 /* Figure out which element to extract. */ 6953 mpz_set_ui (index, 0); 6954 6955 for (i = rank - 1; i >= 0; i--) 6956 { 6957 mpz_add_ui (index, index, x[order[i]]); 6958 if (i != 0) 6959 mpz_mul_ui (index, index, shape[order[i - 1]]); 6960 } 6961 6962 if (mpz_cmp_ui (index, INT_MAX) > 0) 6963 gfc_internal_error ("Reshaped array too large at %C"); 6964 6965 j = mpz_get_ui (index); 6966 6967 if (j < nsource) 6968 e = gfc_constructor_lookup_expr (source->value.constructor, j); 6969 else 6970 { 6971 if (npad <= 0) 6972 { 6973 mpz_clear (index); 6974 return NULL; 6975 } 6976 j = j - nsource; 6977 j = j % npad; 6978 e = gfc_constructor_lookup_expr (pad->value.constructor, j); 6979 } 6980 gcc_assert (e); 6981 6982 gfc_constructor_append_expr (&result->value.constructor, 6983 gfc_copy_expr (e), &e->where); 6984 6985 /* Calculate the next element. */ 6986 i = 0; 6987 6988 inc: 6989 if (++x[i] < shape[i]) 6990 continue; 6991 x[i++] = 0; 6992 if (i < rank) 6993 goto inc; 6994 6995 break; 6996 } 6997 6998 sizezero: 6999 7000 mpz_clear (index); 7001 7002 return result; 7003 } 7004 7005 7006 gfc_expr * 7007 gfc_simplify_rrspacing (gfc_expr *x) 7008 { 7009 gfc_expr *result; 7010 int i; 7011 long int e, p; 7012 7013 if (x->expr_type != EXPR_CONSTANT) 7014 return NULL; 7015 7016 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 7017 7018 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7019 7020 /* RRSPACING(+/- 0.0) = 0.0 */ 7021 if (mpfr_zero_p (x->value.real)) 7022 { 7023 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 7024 return result; 7025 } 7026 7027 /* RRSPACING(inf) = NaN */ 7028 if (mpfr_inf_p (x->value.real)) 7029 { 7030 mpfr_set_nan (result->value.real); 7031 return result; 7032 } 7033 7034 /* RRSPACING(NaN) = same NaN */ 7035 if (mpfr_nan_p (x->value.real)) 7036 { 7037 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 7038 return result; 7039 } 7040 7041 /* | x * 2**(-e) | * 2**p. */ 7042 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); 7043 e = - (long int) mpfr_get_exp (x->value.real); 7044 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); 7045 7046 p = (long int) gfc_real_kinds[i].digits; 7047 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); 7048 7049 return range_check (result, "RRSPACING"); 7050 } 7051 7052 7053 gfc_expr * 7054 gfc_simplify_scale (gfc_expr *x, gfc_expr *i) 7055 { 7056 int k, neg_flag, power, exp_range; 7057 mpfr_t scale, radix; 7058 gfc_expr *result; 7059 7060 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 7061 return NULL; 7062 7063 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7064 7065 if (mpfr_zero_p (x->value.real)) 7066 { 7067 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); 7068 return result; 7069 } 7070 7071 k = gfc_validate_kind (BT_REAL, x->ts.kind, false); 7072 7073 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; 7074 7075 /* This check filters out values of i that would overflow an int. */ 7076 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 7077 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) 7078 { 7079 gfc_error ("Result of SCALE overflows its kind at %L", &result->where); 7080 gfc_free_expr (result); 7081 return &gfc_bad_expr; 7082 } 7083 7084 /* Compute scale = radix ** power. */ 7085 power = mpz_get_si (i->value.integer); 7086 7087 if (power >= 0) 7088 neg_flag = 0; 7089 else 7090 { 7091 neg_flag = 1; 7092 power = -power; 7093 } 7094 7095 gfc_set_model_kind (x->ts.kind); 7096 mpfr_init (scale); 7097 mpfr_init (radix); 7098 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); 7099 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); 7100 7101 if (neg_flag) 7102 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); 7103 else 7104 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); 7105 7106 mpfr_clears (scale, radix, NULL); 7107 7108 return range_check (result, "SCALE"); 7109 } 7110 7111 7112 /* Variants of strspn and strcspn that operate on wide characters. */ 7113 7114 static size_t 7115 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) 7116 { 7117 size_t i = 0; 7118 const gfc_char_t *c; 7119 7120 while (s1[i]) 7121 { 7122 for (c = s2; *c; c++) 7123 { 7124 if (s1[i] == *c) 7125 break; 7126 } 7127 if (*c == '\0') 7128 break; 7129 i++; 7130 } 7131 7132 return i; 7133 } 7134 7135 static size_t 7136 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) 7137 { 7138 size_t i = 0; 7139 const gfc_char_t *c; 7140 7141 while (s1[i]) 7142 { 7143 for (c = s2; *c; c++) 7144 { 7145 if (s1[i] == *c) 7146 break; 7147 } 7148 if (*c) 7149 break; 7150 i++; 7151 } 7152 7153 return i; 7154 } 7155 7156 7157 gfc_expr * 7158 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) 7159 { 7160 gfc_expr *result; 7161 int back; 7162 size_t i; 7163 size_t indx, len, lenc; 7164 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); 7165 7166 if (k == -1) 7167 return &gfc_bad_expr; 7168 7169 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT 7170 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 7171 return NULL; 7172 7173 if (b != NULL && b->value.logical != 0) 7174 back = 1; 7175 else 7176 back = 0; 7177 7178 len = e->value.character.length; 7179 lenc = c->value.character.length; 7180 7181 if (len == 0 || lenc == 0) 7182 { 7183 indx = 0; 7184 } 7185 else 7186 { 7187 if (back == 0) 7188 { 7189 indx = wide_strcspn (e->value.character.string, 7190 c->value.character.string) + 1; 7191 if (indx > len) 7192 indx = 0; 7193 } 7194 else 7195 for (indx = len; indx > 0; indx--) 7196 { 7197 for (i = 0; i < lenc; i++) 7198 { 7199 if (c->value.character.string[i] 7200 == e->value.character.string[indx - 1]) 7201 break; 7202 } 7203 if (i < lenc) 7204 break; 7205 } 7206 } 7207 7208 result = gfc_get_int_expr (k, &e->where, indx); 7209 return range_check (result, "SCAN"); 7210 } 7211 7212 7213 gfc_expr * 7214 gfc_simplify_selected_char_kind (gfc_expr *e) 7215 { 7216 int kind; 7217 7218 if (e->expr_type != EXPR_CONSTANT) 7219 return NULL; 7220 7221 if (gfc_compare_with_Cstring (e, "ascii", false) == 0 7222 || gfc_compare_with_Cstring (e, "default", false) == 0) 7223 kind = 1; 7224 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) 7225 kind = 4; 7226 else 7227 kind = -1; 7228 7229 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 7230 } 7231 7232 7233 gfc_expr * 7234 gfc_simplify_selected_int_kind (gfc_expr *e) 7235 { 7236 int i, kind, range; 7237 7238 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range)) 7239 return NULL; 7240 7241 kind = INT_MAX; 7242 7243 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 7244 if (gfc_integer_kinds[i].range >= range 7245 && gfc_integer_kinds[i].kind < kind) 7246 kind = gfc_integer_kinds[i].kind; 7247 7248 if (kind == INT_MAX) 7249 kind = -1; 7250 7251 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); 7252 } 7253 7254 7255 gfc_expr * 7256 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) 7257 { 7258 int range, precision, radix, i, kind, found_precision, found_range, 7259 found_radix; 7260 locus *loc = &gfc_current_locus; 7261 7262 if (p == NULL) 7263 precision = 0; 7264 else 7265 { 7266 if (p->expr_type != EXPR_CONSTANT 7267 || gfc_extract_int (p, &precision)) 7268 return NULL; 7269 loc = &p->where; 7270 } 7271 7272 if (q == NULL) 7273 range = 0; 7274 else 7275 { 7276 if (q->expr_type != EXPR_CONSTANT 7277 || gfc_extract_int (q, &range)) 7278 return NULL; 7279 7280 if (!loc) 7281 loc = &q->where; 7282 } 7283 7284 if (rdx == NULL) 7285 radix = 0; 7286 else 7287 { 7288 if (rdx->expr_type != EXPR_CONSTANT 7289 || gfc_extract_int (rdx, &radix)) 7290 return NULL; 7291 7292 if (!loc) 7293 loc = &rdx->where; 7294 } 7295 7296 kind = INT_MAX; 7297 found_precision = 0; 7298 found_range = 0; 7299 found_radix = 0; 7300 7301 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 7302 { 7303 if (gfc_real_kinds[i].precision >= precision) 7304 found_precision = 1; 7305 7306 if (gfc_real_kinds[i].range >= range) 7307 found_range = 1; 7308 7309 if (radix == 0 || gfc_real_kinds[i].radix == radix) 7310 found_radix = 1; 7311 7312 if (gfc_real_kinds[i].precision >= precision 7313 && gfc_real_kinds[i].range >= range 7314 && (radix == 0 || gfc_real_kinds[i].radix == radix) 7315 && gfc_real_kinds[i].kind < kind) 7316 kind = gfc_real_kinds[i].kind; 7317 } 7318 7319 if (kind == INT_MAX) 7320 { 7321 if (found_radix && found_range && !found_precision) 7322 kind = -1; 7323 else if (found_radix && found_precision && !found_range) 7324 kind = -2; 7325 else if (found_radix && !found_precision && !found_range) 7326 kind = -3; 7327 else if (found_radix) 7328 kind = -4; 7329 else 7330 kind = -5; 7331 } 7332 7333 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); 7334 } 7335 7336 7337 gfc_expr * 7338 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) 7339 { 7340 gfc_expr *result; 7341 mpfr_t exp, absv, log2, pow2, frac; 7342 long exp2; 7343 7344 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) 7345 return NULL; 7346 7347 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7348 7349 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 7350 SET_EXPONENT (NaN) = same NaN */ 7351 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) 7352 { 7353 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 7354 return result; 7355 } 7356 7357 /* SET_EXPONENT (inf) = NaN */ 7358 if (mpfr_inf_p (x->value.real)) 7359 { 7360 mpfr_set_nan (result->value.real); 7361 return result; 7362 } 7363 7364 gfc_set_model_kind (x->ts.kind); 7365 mpfr_init (absv); 7366 mpfr_init (log2); 7367 mpfr_init (exp); 7368 mpfr_init (pow2); 7369 mpfr_init (frac); 7370 7371 mpfr_abs (absv, x->value.real, GFC_RND_MODE); 7372 mpfr_log2 (log2, absv, GFC_RND_MODE); 7373 7374 mpfr_floor (log2, log2); 7375 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); 7376 7377 /* Old exponent value, and fraction. */ 7378 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); 7379 7380 mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE); 7381 7382 /* New exponent. */ 7383 exp2 = mpz_get_si (i->value.integer); 7384 mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE); 7385 7386 mpfr_clears (absv, log2, exp, pow2, frac, NULL); 7387 7388 return range_check (result, "SET_EXPONENT"); 7389 } 7390 7391 7392 gfc_expr * 7393 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) 7394 { 7395 mpz_t shape[GFC_MAX_DIMENSIONS]; 7396 gfc_expr *result, *e, *f; 7397 gfc_array_ref *ar; 7398 int n; 7399 bool t; 7400 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); 7401 7402 if (source->rank == -1) 7403 return NULL; 7404 7405 result = gfc_get_array_expr (BT_INTEGER, k, &source->where); 7406 result->shape = gfc_get_shape (1); 7407 mpz_init (result->shape[0]); 7408 7409 if (source->rank == 0) 7410 return result; 7411 7412 if (source->expr_type == EXPR_VARIABLE) 7413 { 7414 ar = gfc_find_array_ref (source); 7415 t = gfc_array_ref_shape (ar, shape); 7416 } 7417 else if (source->shape) 7418 { 7419 t = true; 7420 for (n = 0; n < source->rank; n++) 7421 { 7422 mpz_init (shape[n]); 7423 mpz_set (shape[n], source->shape[n]); 7424 } 7425 } 7426 else 7427 t = false; 7428 7429 for (n = 0; n < source->rank; n++) 7430 { 7431 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); 7432 7433 if (t) 7434 mpz_set (e->value.integer, shape[n]); 7435 else 7436 { 7437 mpz_set_ui (e->value.integer, n + 1); 7438 7439 f = simplify_size (source, e, k); 7440 gfc_free_expr (e); 7441 if (f == NULL) 7442 { 7443 gfc_free_expr (result); 7444 return NULL; 7445 } 7446 else 7447 e = f; 7448 } 7449 7450 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) 7451 { 7452 gfc_free_expr (result); 7453 if (t) 7454 gfc_clear_shape (shape, source->rank); 7455 return &gfc_bad_expr; 7456 } 7457 7458 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 7459 } 7460 7461 if (t) 7462 gfc_clear_shape (shape, source->rank); 7463 7464 mpz_set_si (result->shape[0], source->rank); 7465 7466 return result; 7467 } 7468 7469 7470 static gfc_expr * 7471 simplify_size (gfc_expr *array, gfc_expr *dim, int k) 7472 { 7473 mpz_t size; 7474 gfc_expr *return_value; 7475 int d; 7476 gfc_ref *ref; 7477 7478 /* For unary operations, the size of the result is given by the size 7479 of the operand. For binary ones, it's the size of the first operand 7480 unless it is scalar, then it is the size of the second. */ 7481 if (array->expr_type == EXPR_OP && !array->value.op.uop) 7482 { 7483 gfc_expr* replacement; 7484 gfc_expr* simplified; 7485 7486 switch (array->value.op.op) 7487 { 7488 /* Unary operations. */ 7489 case INTRINSIC_NOT: 7490 case INTRINSIC_UPLUS: 7491 case INTRINSIC_UMINUS: 7492 case INTRINSIC_PARENTHESES: 7493 replacement = array->value.op.op1; 7494 break; 7495 7496 /* Binary operations. If any one of the operands is scalar, take 7497 the other one's size. If both of them are arrays, it does not 7498 matter -- try to find one with known shape, if possible. */ 7499 default: 7500 if (array->value.op.op1->rank == 0) 7501 replacement = array->value.op.op2; 7502 else if (array->value.op.op2->rank == 0) 7503 replacement = array->value.op.op1; 7504 else 7505 { 7506 simplified = simplify_size (array->value.op.op1, dim, k); 7507 if (simplified) 7508 return simplified; 7509 7510 replacement = array->value.op.op2; 7511 } 7512 break; 7513 } 7514 7515 /* Try to reduce it directly if possible. */ 7516 simplified = simplify_size (replacement, dim, k); 7517 7518 /* Otherwise, we build a new SIZE call. This is hopefully at least 7519 simpler than the original one. */ 7520 if (!simplified) 7521 { 7522 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); 7523 simplified = gfc_build_intrinsic_call (gfc_current_ns, 7524 GFC_ISYM_SIZE, "size", 7525 array->where, 3, 7526 gfc_copy_expr (replacement), 7527 gfc_copy_expr (dim), 7528 kind); 7529 } 7530 return simplified; 7531 } 7532 7533 for (ref = array->ref; ref; ref = ref->next) 7534 if (ref->type == REF_ARRAY && ref->u.ar.as 7535 && !gfc_resolve_array_spec (ref->u.ar.as, 0)) 7536 return NULL; 7537 7538 if (dim == NULL) 7539 { 7540 if (!gfc_array_size (array, &size)) 7541 return NULL; 7542 } 7543 else 7544 { 7545 if (dim->expr_type != EXPR_CONSTANT) 7546 return NULL; 7547 7548 d = mpz_get_ui (dim->value.integer) - 1; 7549 if (!gfc_array_dimen_size (array, d, &size)) 7550 return NULL; 7551 } 7552 7553 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 7554 mpz_set (return_value->value.integer, size); 7555 mpz_clear (size); 7556 7557 return return_value; 7558 } 7559 7560 7561 gfc_expr * 7562 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 7563 { 7564 gfc_expr *result; 7565 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); 7566 7567 if (k == -1) 7568 return &gfc_bad_expr; 7569 7570 result = simplify_size (array, dim, k); 7571 if (result == NULL || result == &gfc_bad_expr) 7572 return result; 7573 7574 return range_check (result, "SIZE"); 7575 } 7576 7577 7578 /* SIZEOF and C_SIZEOF return the size in bytes of an array element 7579 multiplied by the array size. */ 7580 7581 gfc_expr * 7582 gfc_simplify_sizeof (gfc_expr *x) 7583 { 7584 gfc_expr *result = NULL; 7585 mpz_t array_size; 7586 size_t res_size; 7587 7588 if (x->ts.type == BT_CLASS || x->ts.deferred) 7589 return NULL; 7590 7591 if (x->ts.type == BT_CHARACTER 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 if (x->rank && x->expr_type != EXPR_ARRAY 7597 && !gfc_array_size (x, &array_size)) 7598 return NULL; 7599 7600 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 7601 &x->where); 7602 gfc_target_expr_size (x, &res_size); 7603 mpz_set_si (result->value.integer, res_size); 7604 7605 return result; 7606 } 7607 7608 7609 /* STORAGE_SIZE returns the size in bits of a single array element. */ 7610 7611 gfc_expr * 7612 gfc_simplify_storage_size (gfc_expr *x, 7613 gfc_expr *kind) 7614 { 7615 gfc_expr *result = NULL; 7616 int k; 7617 size_t siz; 7618 7619 if (x->ts.type == BT_CLASS || x->ts.deferred) 7620 return NULL; 7621 7622 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT 7623 && (!x->ts.u.cl || !x->ts.u.cl->length 7624 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 7625 return NULL; 7626 7627 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); 7628 if (k == -1) 7629 return &gfc_bad_expr; 7630 7631 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 7632 7633 gfc_element_size (x, &siz); 7634 mpz_set_si (result->value.integer, siz); 7635 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); 7636 7637 return range_check (result, "STORAGE_SIZE"); 7638 } 7639 7640 7641 gfc_expr * 7642 gfc_simplify_sign (gfc_expr *x, gfc_expr *y) 7643 { 7644 gfc_expr *result; 7645 7646 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 7647 return NULL; 7648 7649 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7650 7651 switch (x->ts.type) 7652 { 7653 case BT_INTEGER: 7654 mpz_abs (result->value.integer, x->value.integer); 7655 if (mpz_sgn (y->value.integer) < 0) 7656 mpz_neg (result->value.integer, result->value.integer); 7657 break; 7658 7659 case BT_REAL: 7660 if (flag_sign_zero) 7661 mpfr_copysign (result->value.real, x->value.real, y->value.real, 7662 GFC_RND_MODE); 7663 else 7664 mpfr_setsign (result->value.real, x->value.real, 7665 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); 7666 break; 7667 7668 default: 7669 gfc_internal_error ("Bad type in gfc_simplify_sign"); 7670 } 7671 7672 return result; 7673 } 7674 7675 7676 gfc_expr * 7677 gfc_simplify_sin (gfc_expr *x) 7678 { 7679 gfc_expr *result; 7680 7681 if (x->expr_type != EXPR_CONSTANT) 7682 return NULL; 7683 7684 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7685 7686 switch (x->ts.type) 7687 { 7688 case BT_REAL: 7689 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); 7690 break; 7691 7692 case BT_COMPLEX: 7693 gfc_set_model (x->value.real); 7694 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7695 break; 7696 7697 default: 7698 gfc_internal_error ("in gfc_simplify_sin(): Bad type"); 7699 } 7700 7701 return range_check (result, "SIN"); 7702 } 7703 7704 7705 gfc_expr * 7706 gfc_simplify_sinh (gfc_expr *x) 7707 { 7708 gfc_expr *result; 7709 7710 if (x->expr_type != EXPR_CONSTANT) 7711 return NULL; 7712 7713 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7714 7715 switch (x->ts.type) 7716 { 7717 case BT_REAL: 7718 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); 7719 break; 7720 7721 case BT_COMPLEX: 7722 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 7723 break; 7724 7725 default: 7726 gcc_unreachable (); 7727 } 7728 7729 return range_check (result, "SINH"); 7730 } 7731 7732 7733 /* The argument is always a double precision real that is converted to 7734 single precision. TODO: Rounding! */ 7735 7736 gfc_expr * 7737 gfc_simplify_sngl (gfc_expr *a) 7738 { 7739 gfc_expr *result; 7740 int tmp1, tmp2; 7741 7742 if (a->expr_type != EXPR_CONSTANT) 7743 return NULL; 7744 7745 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 7746 warnings. */ 7747 tmp1 = warn_conversion; 7748 tmp2 = warn_conversion_extra; 7749 warn_conversion = warn_conversion_extra = 0; 7750 7751 result = gfc_real2real (a, gfc_default_real_kind); 7752 7753 warn_conversion = tmp1; 7754 warn_conversion_extra = tmp2; 7755 7756 return range_check (result, "SNGL"); 7757 } 7758 7759 7760 gfc_expr * 7761 gfc_simplify_spacing (gfc_expr *x) 7762 { 7763 gfc_expr *result; 7764 int i; 7765 long int en, ep; 7766 7767 if (x->expr_type != EXPR_CONSTANT) 7768 return NULL; 7769 7770 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 7771 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 7772 7773 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ 7774 if (mpfr_zero_p (x->value.real)) 7775 { 7776 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 7777 return result; 7778 } 7779 7780 /* SPACING(inf) = NaN */ 7781 if (mpfr_inf_p (x->value.real)) 7782 { 7783 mpfr_set_nan (result->value.real); 7784 return result; 7785 } 7786 7787 /* SPACING(NaN) = same NaN */ 7788 if (mpfr_nan_p (x->value.real)) 7789 { 7790 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); 7791 return result; 7792 } 7793 7794 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p 7795 are the radix, exponent of x, and precision. This excludes the 7796 possibility of subnormal numbers. Fortran 2003 states the result is 7797 b**max(e - p, emin - 1). */ 7798 7799 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; 7800 en = (long int) gfc_real_kinds[i].min_exponent - 1; 7801 en = en > ep ? en : ep; 7802 7803 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); 7804 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); 7805 7806 return range_check (result, "SPACING"); 7807 } 7808 7809 7810 gfc_expr * 7811 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) 7812 { 7813 gfc_expr *result = NULL; 7814 int nelem, i, j, dim, ncopies; 7815 mpz_t size; 7816 7817 if ((!gfc_is_constant_expr (source) 7818 && !is_constant_array_expr (source)) 7819 || !gfc_is_constant_expr (dim_expr) 7820 || !gfc_is_constant_expr (ncopies_expr)) 7821 return NULL; 7822 7823 gcc_assert (dim_expr->ts.type == BT_INTEGER); 7824 gfc_extract_int (dim_expr, &dim); 7825 dim -= 1; /* zero-base DIM */ 7826 7827 gcc_assert (ncopies_expr->ts.type == BT_INTEGER); 7828 gfc_extract_int (ncopies_expr, &ncopies); 7829 ncopies = MAX (ncopies, 0); 7830 7831 /* Do not allow the array size to exceed the limit for an array 7832 constructor. */ 7833 if (source->expr_type == EXPR_ARRAY) 7834 { 7835 if (!gfc_array_size (source, &size)) 7836 gfc_internal_error ("Failure getting length of a constant array."); 7837 } 7838 else 7839 mpz_init_set_ui (size, 1); 7840 7841 nelem = mpz_get_si (size) * ncopies; 7842 if (nelem > flag_max_array_constructor) 7843 { 7844 if (gfc_init_expr_flag) 7845 { 7846 gfc_error ("The number of elements (%d) in the array constructor " 7847 "at %L requires an increase of the allowed %d upper " 7848 "limit. See %<-fmax-array-constructor%> option.", 7849 nelem, &source->where, flag_max_array_constructor); 7850 return &gfc_bad_expr; 7851 } 7852 else 7853 return NULL; 7854 } 7855 7856 if (source->expr_type == EXPR_CONSTANT 7857 || source->expr_type == EXPR_STRUCTURE) 7858 { 7859 gcc_assert (dim == 0); 7860 7861 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 7862 &source->where); 7863 if (source->ts.type == BT_DERIVED) 7864 result->ts.u.derived = source->ts.u.derived; 7865 result->rank = 1; 7866 result->shape = gfc_get_shape (result->rank); 7867 mpz_init_set_si (result->shape[0], ncopies); 7868 7869 for (i = 0; i < ncopies; ++i) 7870 gfc_constructor_append_expr (&result->value.constructor, 7871 gfc_copy_expr (source), NULL); 7872 } 7873 else if (source->expr_type == EXPR_ARRAY) 7874 { 7875 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; 7876 gfc_constructor *source_ctor; 7877 7878 gcc_assert (source->rank < GFC_MAX_DIMENSIONS); 7879 gcc_assert (dim >= 0 && dim <= source->rank); 7880 7881 result = gfc_get_array_expr (source->ts.type, source->ts.kind, 7882 &source->where); 7883 if (source->ts.type == BT_DERIVED) 7884 result->ts.u.derived = source->ts.u.derived; 7885 result->rank = source->rank + 1; 7886 result->shape = gfc_get_shape (result->rank); 7887 7888 for (i = 0, j = 0; i < result->rank; ++i) 7889 { 7890 if (i != dim) 7891 mpz_init_set (result->shape[i], source->shape[j++]); 7892 else 7893 mpz_init_set_si (result->shape[i], ncopies); 7894 7895 extent[i] = mpz_get_si (result->shape[i]); 7896 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; 7897 } 7898 7899 offset = 0; 7900 for (source_ctor = gfc_constructor_first (source->value.constructor); 7901 source_ctor; source_ctor = gfc_constructor_next (source_ctor)) 7902 { 7903 for (i = 0; i < ncopies; ++i) 7904 gfc_constructor_insert_expr (&result->value.constructor, 7905 gfc_copy_expr (source_ctor->expr), 7906 NULL, offset + i * rstride[dim]); 7907 7908 offset += (dim == 0 ? ncopies : 1); 7909 } 7910 } 7911 else 7912 { 7913 gfc_error ("Simplification of SPREAD at %C not yet implemented"); 7914 return &gfc_bad_expr; 7915 } 7916 7917 if (source->ts.type == BT_CHARACTER) 7918 result->ts.u.cl = source->ts.u.cl; 7919 7920 return result; 7921 } 7922 7923 7924 gfc_expr * 7925 gfc_simplify_sqrt (gfc_expr *e) 7926 { 7927 gfc_expr *result = NULL; 7928 7929 if (e->expr_type != EXPR_CONSTANT) 7930 return NULL; 7931 7932 switch (e->ts.type) 7933 { 7934 case BT_REAL: 7935 if (mpfr_cmp_si (e->value.real, 0) < 0) 7936 { 7937 gfc_error ("Argument of SQRT at %L has a negative value", 7938 &e->where); 7939 return &gfc_bad_expr; 7940 } 7941 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 7942 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); 7943 break; 7944 7945 case BT_COMPLEX: 7946 gfc_set_model (e->value.real); 7947 7948 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 7949 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); 7950 break; 7951 7952 default: 7953 gfc_internal_error ("invalid argument of SQRT at %L", &e->where); 7954 } 7955 7956 return range_check (result, "SQRT"); 7957 } 7958 7959 7960 gfc_expr * 7961 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 7962 { 7963 return simplify_transformation (array, dim, mask, 0, gfc_add); 7964 } 7965 7966 7967 /* Simplify COTAN(X) where X has the unit of radian. */ 7968 7969 gfc_expr * 7970 gfc_simplify_cotan (gfc_expr *x) 7971 { 7972 gfc_expr *result; 7973 mpc_t swp, *val; 7974 7975 if (x->expr_type != EXPR_CONSTANT) 7976 return NULL; 7977 7978 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 7979 7980 switch (x->ts.type) 7981 { 7982 case BT_REAL: 7983 mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE); 7984 break; 7985 7986 case BT_COMPLEX: 7987 /* There is no builtin mpc_cot, so compute cot = cos / sin. */ 7988 val = &result->value.complex; 7989 mpc_init2 (swp, mpfr_get_default_prec ()); 7990 mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE, 7991 GFC_MPC_RND_MODE); 7992 mpc_div (*val, swp, *val, GFC_MPC_RND_MODE); 7993 mpc_clear (swp); 7994 break; 7995 7996 default: 7997 gcc_unreachable (); 7998 } 7999 8000 return range_check (result, "COTAN"); 8001 } 8002 8003 8004 gfc_expr * 8005 gfc_simplify_tan (gfc_expr *x) 8006 { 8007 gfc_expr *result; 8008 8009 if (x->expr_type != EXPR_CONSTANT) 8010 return NULL; 8011 8012 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 8013 8014 switch (x->ts.type) 8015 { 8016 case BT_REAL: 8017 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); 8018 break; 8019 8020 case BT_COMPLEX: 8021 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 8022 break; 8023 8024 default: 8025 gcc_unreachable (); 8026 } 8027 8028 return range_check (result, "TAN"); 8029 } 8030 8031 8032 gfc_expr * 8033 gfc_simplify_tanh (gfc_expr *x) 8034 { 8035 gfc_expr *result; 8036 8037 if (x->expr_type != EXPR_CONSTANT) 8038 return NULL; 8039 8040 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 8041 8042 switch (x->ts.type) 8043 { 8044 case BT_REAL: 8045 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); 8046 break; 8047 8048 case BT_COMPLEX: 8049 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); 8050 break; 8051 8052 default: 8053 gcc_unreachable (); 8054 } 8055 8056 return range_check (result, "TANH"); 8057 } 8058 8059 8060 gfc_expr * 8061 gfc_simplify_tiny (gfc_expr *e) 8062 { 8063 gfc_expr *result; 8064 int i; 8065 8066 i = gfc_validate_kind (BT_REAL, e->ts.kind, false); 8067 8068 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 8069 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); 8070 8071 return result; 8072 } 8073 8074 8075 gfc_expr * 8076 gfc_simplify_trailz (gfc_expr *e) 8077 { 8078 unsigned long tz, bs; 8079 int i; 8080 8081 if (e->expr_type != EXPR_CONSTANT) 8082 return NULL; 8083 8084 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 8085 bs = gfc_integer_kinds[i].bit_size; 8086 tz = mpz_scan1 (e->value.integer, 0); 8087 8088 return gfc_get_int_expr (gfc_default_integer_kind, 8089 &e->where, MIN (tz, bs)); 8090 } 8091 8092 8093 gfc_expr * 8094 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 8095 { 8096 gfc_expr *result; 8097 gfc_expr *mold_element; 8098 size_t source_size; 8099 size_t result_size; 8100 size_t buffer_size; 8101 mpz_t tmp; 8102 unsigned char *buffer; 8103 size_t result_length; 8104 8105 if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size)) 8106 return NULL; 8107 8108 if (!gfc_resolve_expr (mold)) 8109 return NULL; 8110 if (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) 8111 return NULL; 8112 8113 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 8114 &result_size, &result_length)) 8115 return NULL; 8116 8117 /* Calculate the size of the source. */ 8118 if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) 8119 gfc_internal_error ("Failure getting length of a constant array."); 8120 8121 /* Create an empty new expression with the appropriate characteristics. */ 8122 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, 8123 &source->where); 8124 result->ts = mold->ts; 8125 8126 mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor) 8127 ? gfc_constructor_first (mold->value.constructor)->expr 8128 : mold; 8129 8130 /* Set result character length, if needed. Note that this needs to be 8131 set even for array expressions, in order to pass this information into 8132 gfc_target_interpret_expr. */ 8133 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) 8134 { 8135 result->value.character.length = mold_element->value.character.length; 8136 8137 /* Let the typespec of the result inherit the string length. 8138 This is crucial if a resulting array has size zero. */ 8139 if (mold_element->ts.u.cl->length) 8140 result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length); 8141 else 8142 result->ts.u.cl->length = 8143 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 8144 mold_element->value.character.length); 8145 } 8146 8147 /* Set the number of elements in the result, and determine its size. */ 8148 8149 if (mold->expr_type == EXPR_ARRAY || mold->rank || size) 8150 { 8151 result->expr_type = EXPR_ARRAY; 8152 result->rank = 1; 8153 result->shape = gfc_get_shape (1); 8154 mpz_init_set_ui (result->shape[0], result_length); 8155 } 8156 else 8157 result->rank = 0; 8158 8159 /* Allocate the buffer to store the binary version of the source. */ 8160 buffer_size = MAX (source_size, result_size); 8161 buffer = (unsigned char*)alloca (buffer_size); 8162 memset (buffer, 0, buffer_size); 8163 8164 /* Now write source to the buffer. */ 8165 gfc_target_encode_expr (source, buffer, buffer_size); 8166 8167 /* And read the buffer back into the new expression. */ 8168 gfc_target_interpret_expr (buffer, buffer_size, result, false); 8169 8170 return result; 8171 } 8172 8173 8174 gfc_expr * 8175 gfc_simplify_transpose (gfc_expr *matrix) 8176 { 8177 int row, matrix_rows, col, matrix_cols; 8178 gfc_expr *result; 8179 8180 if (!is_constant_array_expr (matrix)) 8181 return NULL; 8182 8183 gcc_assert (matrix->rank == 2); 8184 8185 if (matrix->shape == NULL) 8186 return NULL; 8187 8188 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, 8189 &matrix->where); 8190 result->rank = 2; 8191 result->shape = gfc_get_shape (result->rank); 8192 mpz_init_set (result->shape[0], matrix->shape[1]); 8193 mpz_init_set (result->shape[1], matrix->shape[0]); 8194 8195 if (matrix->ts.type == BT_CHARACTER) 8196 result->ts.u.cl = matrix->ts.u.cl; 8197 else if (matrix->ts.type == BT_DERIVED) 8198 result->ts.u.derived = matrix->ts.u.derived; 8199 8200 matrix_rows = mpz_get_si (matrix->shape[0]); 8201 matrix_cols = mpz_get_si (matrix->shape[1]); 8202 for (row = 0; row < matrix_rows; ++row) 8203 for (col = 0; col < matrix_cols; ++col) 8204 { 8205 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, 8206 col * matrix_rows + row); 8207 gfc_constructor_insert_expr (&result->value.constructor, 8208 gfc_copy_expr (e), &matrix->where, 8209 row * matrix_cols + col); 8210 } 8211 8212 return result; 8213 } 8214 8215 8216 gfc_expr * 8217 gfc_simplify_trim (gfc_expr *e) 8218 { 8219 gfc_expr *result; 8220 int count, i, len, lentrim; 8221 8222 if (e->expr_type != EXPR_CONSTANT) 8223 return NULL; 8224 8225 len = e->value.character.length; 8226 for (count = 0, i = 1; i <= len; ++i) 8227 { 8228 if (e->value.character.string[len - i] == ' ') 8229 count++; 8230 else 8231 break; 8232 } 8233 8234 lentrim = len - count; 8235 8236 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); 8237 for (i = 0; i < lentrim; i++) 8238 result->value.character.string[i] = e->value.character.string[i]; 8239 8240 return result; 8241 } 8242 8243 8244 gfc_expr * 8245 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) 8246 { 8247 gfc_expr *result; 8248 gfc_ref *ref; 8249 gfc_array_spec *as; 8250 gfc_constructor *sub_cons; 8251 bool first_image; 8252 int d; 8253 8254 if (!is_constant_array_expr (sub)) 8255 return NULL; 8256 8257 /* Follow any component references. */ 8258 as = coarray->symtree->n.sym->as; 8259 for (ref = coarray->ref; ref; ref = ref->next) 8260 if (ref->type == REF_COMPONENT) 8261 as = ref->u.ar.as; 8262 8263 if (as->type == AS_DEFERRED) 8264 return NULL; 8265 8266 /* "valid sequence of cosubscripts" are required; thus, return 0 unless 8267 the cosubscript addresses the first image. */ 8268 8269 sub_cons = gfc_constructor_first (sub->value.constructor); 8270 first_image = true; 8271 8272 for (d = 1; d <= as->corank; d++) 8273 { 8274 gfc_expr *ca_bound; 8275 int cmp; 8276 8277 gcc_assert (sub_cons != NULL); 8278 8279 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, 8280 NULL, true); 8281 if (ca_bound == NULL) 8282 return NULL; 8283 8284 if (ca_bound == &gfc_bad_expr) 8285 return ca_bound; 8286 8287 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); 8288 8289 if (cmp == 0) 8290 { 8291 gfc_free_expr (ca_bound); 8292 sub_cons = gfc_constructor_next (sub_cons); 8293 continue; 8294 } 8295 8296 first_image = false; 8297 8298 if (cmp > 0) 8299 { 8300 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 8301 "SUB has %ld and COARRAY lower bound is %ld)", 8302 &coarray->where, d, 8303 mpz_get_si (sub_cons->expr->value.integer), 8304 mpz_get_si (ca_bound->value.integer)); 8305 gfc_free_expr (ca_bound); 8306 return &gfc_bad_expr; 8307 } 8308 8309 gfc_free_expr (ca_bound); 8310 8311 /* Check whether upperbound is valid for the multi-images case. */ 8312 if (d < as->corank) 8313 { 8314 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, 8315 NULL, true); 8316 if (ca_bound == &gfc_bad_expr) 8317 return ca_bound; 8318 8319 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT 8320 && mpz_cmp (ca_bound->value.integer, 8321 sub_cons->expr->value.integer) < 0) 8322 { 8323 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " 8324 "SUB has %ld and COARRAY upper bound is %ld)", 8325 &coarray->where, d, 8326 mpz_get_si (sub_cons->expr->value.integer), 8327 mpz_get_si (ca_bound->value.integer)); 8328 gfc_free_expr (ca_bound); 8329 return &gfc_bad_expr; 8330 } 8331 8332 if (ca_bound) 8333 gfc_free_expr (ca_bound); 8334 } 8335 8336 sub_cons = gfc_constructor_next (sub_cons); 8337 } 8338 8339 gcc_assert (sub_cons == NULL); 8340 8341 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image) 8342 return NULL; 8343 8344 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8345 &gfc_current_locus); 8346 if (first_image) 8347 mpz_set_si (result->value.integer, 1); 8348 else 8349 mpz_set_si (result->value.integer, 0); 8350 8351 return result; 8352 } 8353 8354 gfc_expr * 8355 gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) 8356 { 8357 if (flag_coarray == GFC_FCOARRAY_NONE) 8358 { 8359 gfc_current_locus = *gfc_current_intrinsic_where; 8360 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 8361 return &gfc_bad_expr; 8362 } 8363 8364 /* Simplification is possible for fcoarray = single only. For all other modes 8365 the result depends on runtime conditions. */ 8366 if (flag_coarray != GFC_FCOARRAY_SINGLE) 8367 return NULL; 8368 8369 if (gfc_is_constant_expr (image)) 8370 { 8371 gfc_expr *result; 8372 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8373 &image->where); 8374 if (mpz_get_si (image->value.integer) == 1) 8375 mpz_set_si (result->value.integer, 0); 8376 else 8377 mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); 8378 return result; 8379 } 8380 else 8381 return NULL; 8382 } 8383 8384 8385 gfc_expr * 8386 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, 8387 gfc_expr *distance ATTRIBUTE_UNUSED) 8388 { 8389 if (flag_coarray != GFC_FCOARRAY_SINGLE) 8390 return NULL; 8391 8392 /* If no coarray argument has been passed or when the first argument 8393 is actually a distance argument. */ 8394 if (coarray == NULL || !gfc_is_coarray (coarray)) 8395 { 8396 gfc_expr *result; 8397 /* FIXME: gfc_current_locus is wrong. */ 8398 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 8399 &gfc_current_locus); 8400 mpz_set_si (result->value.integer, 1); 8401 return result; 8402 } 8403 8404 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ 8405 return simplify_cobound (coarray, dim, NULL, 0); 8406 } 8407 8408 8409 gfc_expr * 8410 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 8411 { 8412 return simplify_bound (array, dim, kind, 1); 8413 } 8414 8415 gfc_expr * 8416 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 8417 { 8418 return simplify_cobound (array, dim, kind, 1); 8419 } 8420 8421 8422 gfc_expr * 8423 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 8424 { 8425 gfc_expr *result, *e; 8426 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; 8427 8428 if (!is_constant_array_expr (vector) 8429 || !is_constant_array_expr (mask) 8430 || (!gfc_is_constant_expr (field) 8431 && !is_constant_array_expr (field))) 8432 return NULL; 8433 8434 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, 8435 &vector->where); 8436 if (vector->ts.type == BT_DERIVED) 8437 result->ts.u.derived = vector->ts.u.derived; 8438 result->rank = mask->rank; 8439 result->shape = gfc_copy_shape (mask->shape, mask->rank); 8440 8441 if (vector->ts.type == BT_CHARACTER) 8442 result->ts.u.cl = vector->ts.u.cl; 8443 8444 vector_ctor = gfc_constructor_first (vector->value.constructor); 8445 mask_ctor = gfc_constructor_first (mask->value.constructor); 8446 field_ctor 8447 = field->expr_type == EXPR_ARRAY 8448 ? gfc_constructor_first (field->value.constructor) 8449 : NULL; 8450 8451 while (mask_ctor) 8452 { 8453 if (mask_ctor->expr->value.logical) 8454 { 8455 if (vector_ctor) 8456 { 8457 e = gfc_copy_expr (vector_ctor->expr); 8458 vector_ctor = gfc_constructor_next (vector_ctor); 8459 } 8460 else 8461 { 8462 gfc_free_expr (result); 8463 return NULL; 8464 } 8465 } 8466 else if (field->expr_type == EXPR_ARRAY) 8467 e = gfc_copy_expr (field_ctor->expr); 8468 else 8469 e = gfc_copy_expr (field); 8470 8471 gfc_constructor_append_expr (&result->value.constructor, e, NULL); 8472 8473 mask_ctor = gfc_constructor_next (mask_ctor); 8474 field_ctor = gfc_constructor_next (field_ctor); 8475 } 8476 8477 return result; 8478 } 8479 8480 8481 gfc_expr * 8482 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) 8483 { 8484 gfc_expr *result; 8485 int back; 8486 size_t index, len, lenset; 8487 size_t i; 8488 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); 8489 8490 if (k == -1) 8491 return &gfc_bad_expr; 8492 8493 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT 8494 || ( b != NULL && b->expr_type != EXPR_CONSTANT)) 8495 return NULL; 8496 8497 if (b != NULL && b->value.logical != 0) 8498 back = 1; 8499 else 8500 back = 0; 8501 8502 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); 8503 8504 len = s->value.character.length; 8505 lenset = set->value.character.length; 8506 8507 if (len == 0) 8508 { 8509 mpz_set_ui (result->value.integer, 0); 8510 return result; 8511 } 8512 8513 if (back == 0) 8514 { 8515 if (lenset == 0) 8516 { 8517 mpz_set_ui (result->value.integer, 1); 8518 return result; 8519 } 8520 8521 index = wide_strspn (s->value.character.string, 8522 set->value.character.string) + 1; 8523 if (index > len) 8524 index = 0; 8525 8526 } 8527 else 8528 { 8529 if (lenset == 0) 8530 { 8531 mpz_set_ui (result->value.integer, len); 8532 return result; 8533 } 8534 for (index = len; index > 0; index --) 8535 { 8536 for (i = 0; i < lenset; i++) 8537 { 8538 if (s->value.character.string[index - 1] 8539 == set->value.character.string[i]) 8540 break; 8541 } 8542 if (i == lenset) 8543 break; 8544 } 8545 } 8546 8547 mpz_set_ui (result->value.integer, index); 8548 return result; 8549 } 8550 8551 8552 gfc_expr * 8553 gfc_simplify_xor (gfc_expr *x, gfc_expr *y) 8554 { 8555 gfc_expr *result; 8556 int kind; 8557 8558 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 8559 return NULL; 8560 8561 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 8562 8563 switch (x->ts.type) 8564 { 8565 case BT_INTEGER: 8566 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 8567 mpz_xor (result->value.integer, x->value.integer, y->value.integer); 8568 return range_check (result, "XOR"); 8569 8570 case BT_LOGICAL: 8571 return gfc_get_logical_expr (kind, &x->where, 8572 (x->value.logical && !y->value.logical) 8573 || (!x->value.logical && y->value.logical)); 8574 8575 default: 8576 gcc_unreachable (); 8577 } 8578 } 8579 8580 8581 /****************** Constant simplification *****************/ 8582 8583 /* Master function to convert one constant to another. While this is 8584 used as a simplification function, it requires the destination type 8585 and kind information which is supplied by a special case in 8586 do_simplify(). */ 8587 8588 gfc_expr * 8589 gfc_convert_constant (gfc_expr *e, bt type, int kind) 8590 { 8591 gfc_expr *result, *(*f) (gfc_expr *, int); 8592 gfc_constructor *c, *t; 8593 8594 switch (e->ts.type) 8595 { 8596 case BT_INTEGER: 8597 switch (type) 8598 { 8599 case BT_INTEGER: 8600 f = gfc_int2int; 8601 break; 8602 case BT_REAL: 8603 f = gfc_int2real; 8604 break; 8605 case BT_COMPLEX: 8606 f = gfc_int2complex; 8607 break; 8608 case BT_LOGICAL: 8609 f = gfc_int2log; 8610 break; 8611 default: 8612 goto oops; 8613 } 8614 break; 8615 8616 case BT_REAL: 8617 switch (type) 8618 { 8619 case BT_INTEGER: 8620 f = gfc_real2int; 8621 break; 8622 case BT_REAL: 8623 f = gfc_real2real; 8624 break; 8625 case BT_COMPLEX: 8626 f = gfc_real2complex; 8627 break; 8628 default: 8629 goto oops; 8630 } 8631 break; 8632 8633 case BT_COMPLEX: 8634 switch (type) 8635 { 8636 case BT_INTEGER: 8637 f = gfc_complex2int; 8638 break; 8639 case BT_REAL: 8640 f = gfc_complex2real; 8641 break; 8642 case BT_COMPLEX: 8643 f = gfc_complex2complex; 8644 break; 8645 8646 default: 8647 goto oops; 8648 } 8649 break; 8650 8651 case BT_LOGICAL: 8652 switch (type) 8653 { 8654 case BT_INTEGER: 8655 f = gfc_log2int; 8656 break; 8657 case BT_LOGICAL: 8658 f = gfc_log2log; 8659 break; 8660 default: 8661 goto oops; 8662 } 8663 break; 8664 8665 case BT_HOLLERITH: 8666 switch (type) 8667 { 8668 case BT_INTEGER: 8669 f = gfc_hollerith2int; 8670 break; 8671 8672 case BT_REAL: 8673 f = gfc_hollerith2real; 8674 break; 8675 8676 case BT_COMPLEX: 8677 f = gfc_hollerith2complex; 8678 break; 8679 8680 case BT_CHARACTER: 8681 f = gfc_hollerith2character; 8682 break; 8683 8684 case BT_LOGICAL: 8685 f = gfc_hollerith2logical; 8686 break; 8687 8688 default: 8689 goto oops; 8690 } 8691 break; 8692 8693 case BT_CHARACTER: 8694 switch (type) 8695 { 8696 case BT_INTEGER: 8697 f = gfc_character2int; 8698 break; 8699 8700 case BT_REAL: 8701 f = gfc_character2real; 8702 break; 8703 8704 case BT_COMPLEX: 8705 f = gfc_character2complex; 8706 break; 8707 8708 case BT_CHARACTER: 8709 f = gfc_character2character; 8710 break; 8711 8712 case BT_LOGICAL: 8713 f = gfc_character2logical; 8714 break; 8715 8716 default: 8717 goto oops; 8718 } 8719 break; 8720 8721 default: 8722 oops: 8723 return &gfc_bad_expr; 8724 } 8725 8726 result = NULL; 8727 8728 switch (e->expr_type) 8729 { 8730 case EXPR_CONSTANT: 8731 result = f (e, kind); 8732 if (result == NULL) 8733 return &gfc_bad_expr; 8734 break; 8735 8736 case EXPR_ARRAY: 8737 if (!gfc_is_constant_expr (e)) 8738 break; 8739 8740 result = gfc_get_array_expr (type, kind, &e->where); 8741 result->shape = gfc_copy_shape (e->shape, e->rank); 8742 result->rank = e->rank; 8743 8744 for (c = gfc_constructor_first (e->value.constructor); 8745 c; c = gfc_constructor_next (c)) 8746 { 8747 gfc_expr *tmp; 8748 if (c->iterator == NULL) 8749 { 8750 if (c->expr->expr_type == EXPR_ARRAY) 8751 tmp = gfc_convert_constant (c->expr, type, kind); 8752 else if (c->expr->expr_type == EXPR_OP) 8753 { 8754 if (!gfc_simplify_expr (c->expr, 1)) 8755 return &gfc_bad_expr; 8756 tmp = f (c->expr, kind); 8757 } 8758 else 8759 tmp = f (c->expr, kind); 8760 } 8761 else 8762 tmp = gfc_convert_constant (c->expr, type, kind); 8763 8764 if (tmp == NULL || tmp == &gfc_bad_expr) 8765 { 8766 gfc_free_expr (result); 8767 return NULL; 8768 } 8769 8770 t = gfc_constructor_append_expr (&result->value.constructor, 8771 tmp, &c->where); 8772 if (c->iterator) 8773 t->iterator = gfc_copy_iterator (c->iterator); 8774 } 8775 8776 break; 8777 8778 default: 8779 break; 8780 } 8781 8782 return result; 8783 } 8784 8785 8786 /* Function for converting character constants. */ 8787 gfc_expr * 8788 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) 8789 { 8790 gfc_expr *result; 8791 int i; 8792 8793 if (!gfc_is_constant_expr (e)) 8794 return NULL; 8795 8796 if (e->expr_type == EXPR_CONSTANT) 8797 { 8798 /* Simple case of a scalar. */ 8799 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); 8800 if (result == NULL) 8801 return &gfc_bad_expr; 8802 8803 result->value.character.length = e->value.character.length; 8804 result->value.character.string 8805 = gfc_get_wide_string (e->value.character.length + 1); 8806 memcpy (result->value.character.string, e->value.character.string, 8807 (e->value.character.length + 1) * sizeof (gfc_char_t)); 8808 8809 /* Check we only have values representable in the destination kind. */ 8810 for (i = 0; i < result->value.character.length; i++) 8811 if (!gfc_check_character_range (result->value.character.string[i], 8812 kind)) 8813 { 8814 gfc_error ("Character %qs in string at %L cannot be converted " 8815 "into character kind %d", 8816 gfc_print_wide_char (result->value.character.string[i]), 8817 &e->where, kind); 8818 gfc_free_expr (result); 8819 return &gfc_bad_expr; 8820 } 8821 8822 return result; 8823 } 8824 else if (e->expr_type == EXPR_ARRAY) 8825 { 8826 /* For an array constructor, we convert each constructor element. */ 8827 gfc_constructor *c; 8828 8829 result = gfc_get_array_expr (type, kind, &e->where); 8830 result->shape = gfc_copy_shape (e->shape, e->rank); 8831 result->rank = e->rank; 8832 result->ts.u.cl = e->ts.u.cl; 8833 8834 for (c = gfc_constructor_first (e->value.constructor); 8835 c; c = gfc_constructor_next (c)) 8836 { 8837 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); 8838 if (tmp == &gfc_bad_expr) 8839 { 8840 gfc_free_expr (result); 8841 return &gfc_bad_expr; 8842 } 8843 8844 if (tmp == NULL) 8845 { 8846 gfc_free_expr (result); 8847 return NULL; 8848 } 8849 8850 gfc_constructor_append_expr (&result->value.constructor, 8851 tmp, &c->where); 8852 } 8853 8854 return result; 8855 } 8856 else 8857 return NULL; 8858 } 8859 8860 8861 gfc_expr * 8862 gfc_simplify_compiler_options (void) 8863 { 8864 char *str; 8865 gfc_expr *result; 8866 8867 str = gfc_get_option_string (); 8868 result = gfc_get_character_expr (gfc_default_character_kind, 8869 &gfc_current_locus, str, strlen (str)); 8870 free (str); 8871 return result; 8872 } 8873 8874 8875 gfc_expr * 8876 gfc_simplify_compiler_version (void) 8877 { 8878 char *buffer; 8879 size_t len; 8880 8881 len = strlen ("GCC version ") + strlen (version_string); 8882 buffer = XALLOCAVEC (char, len + 1); 8883 snprintf (buffer, len + 1, "GCC version %s", version_string); 8884 return gfc_get_character_expr (gfc_default_character_kind, 8885 &gfc_current_locus, buffer, len); 8886 } 8887 8888 /* Simplification routines for intrinsics of IEEE modules. */ 8889 8890 gfc_expr * 8891 simplify_ieee_selected_real_kind (gfc_expr *expr) 8892 { 8893 gfc_actual_arglist *arg; 8894 gfc_expr *p = NULL, *q = NULL, *rdx = NULL; 8895 8896 arg = expr->value.function.actual; 8897 p = arg->expr; 8898 if (arg->next) 8899 { 8900 q = arg->next->expr; 8901 if (arg->next->next) 8902 rdx = arg->next->next->expr; 8903 } 8904 8905 /* Currently, if IEEE is supported and this module is built, it means 8906 all our floating-point types conform to IEEE. Hence, we simply handle 8907 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */ 8908 return gfc_simplify_selected_real_kind (p, q, rdx); 8909 } 8910 8911 gfc_expr * 8912 simplify_ieee_support (gfc_expr *expr) 8913 { 8914 /* We consider that if the IEEE modules are loaded, we have full support 8915 for flags, halting and rounding, which are the three functions 8916 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant 8917 expressions. One day, we will need libgfortran to detect support and 8918 communicate it back to us, allowing for partial support. */ 8919 8920 return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where, 8921 true); 8922 } 8923 8924 bool 8925 matches_ieee_function_name (gfc_symbol *sym, const char *name) 8926 { 8927 int n = strlen(name); 8928 8929 if (!strncmp(sym->name, name, n)) 8930 return true; 8931 8932 /* If a generic was used and renamed, we need more work to find out. 8933 Compare the specific name. */ 8934 if (sym->generic && !strncmp(sym->generic->sym->name, name, n)) 8935 return true; 8936 8937 return false; 8938 } 8939 8940 gfc_expr * 8941 gfc_simplify_ieee_functions (gfc_expr *expr) 8942 { 8943 gfc_symbol* sym = expr->symtree->n.sym; 8944 8945 if (matches_ieee_function_name(sym, "ieee_selected_real_kind")) 8946 return simplify_ieee_selected_real_kind (expr); 8947 else if (matches_ieee_function_name(sym, "ieee_support_flag") 8948 || matches_ieee_function_name(sym, "ieee_support_halting") 8949 || matches_ieee_function_name(sym, "ieee_support_rounding")) 8950 return simplify_ieee_support (expr); 8951 else 8952 return NULL; 8953 } 8954