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