check.cc revision 1.1
1 /* Check functions 2 Copyright (C) 2002-2022 Free Software Foundation, Inc. 3 Contributed by Andy Vaught & Katherine Holcomb 4 5 This file is part of GCC. 6 7 GCC is free software; you can redistribute it and/or modify it under 8 the terms of the GNU General Public License as published by the Free 9 Software Foundation; either version 3, or (at your option) any later 10 version. 11 12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13 WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GCC; see the file COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 22 /* These functions check to see if an argument list is compatible with 23 a particular intrinsic function or subroutine. Presence of 24 required arguments has already been established, the argument list 25 has been sorted into the right order and has NULL arguments in the 26 correct places for missing optional arguments. */ 27 28 #include "config.h" 29 #include "system.h" 30 #include "coretypes.h" 31 #include "options.h" 32 #include "gfortran.h" 33 #include "intrinsic.h" 34 #include "constructor.h" 35 #include "target-memory.h" 36 37 38 /* Reset a BOZ to a zero value. This is used to prevent run-on errors 39 from resolve.cc(resolve_function). */ 40 41 static void 42 reset_boz (gfc_expr *x) 43 { 44 /* Clear boz info. */ 45 x->boz.rdx = 0; 46 x->boz.len = 0; 47 free (x->boz.str); 48 49 x->ts.type = BT_INTEGER; 50 x->ts.kind = gfc_default_integer_kind; 51 mpz_init (x->value.integer); 52 mpz_set_ui (x->value.integer, 0); 53 } 54 55 /* A BOZ literal constant can appear in a limited number of contexts. 56 gfc_invalid_boz() is a helper function to simplify error/warning 57 generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran 58 allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz 59 is used, then issue a warning; otherwise issue an error. */ 60 61 bool 62 gfc_invalid_boz (const char *msg, locus *loc) 63 { 64 if (flag_allow_invalid_boz) 65 { 66 gfc_warning (0, msg, loc); 67 return false; 68 } 69 70 const char *hint = _(" [see %<-fno-allow-invalid-boz%>]"); 71 size_t len = strlen (msg) + strlen (hint) + 1; 72 char *msg2 = (char *) alloca (len); 73 strcpy (msg2, msg); 74 strcat (msg2, hint); 75 gfc_error (msg2, loc); 76 return true; 77 } 78 79 80 /* Issue an error for an illegal BOZ argument. */ 81 82 static bool 83 illegal_boz_arg (gfc_expr *x) 84 { 85 if (x->ts.type == BT_BOZ) 86 { 87 gfc_error ("BOZ literal constant at %L cannot be an actual argument " 88 "to %qs", &x->where, gfc_current_intrinsic); 89 reset_boz (x); 90 return true; 91 } 92 93 return false; 94 } 95 96 /* Some precedures take two arguments such that both cannot be BOZ. */ 97 98 static bool 99 boz_args_check(gfc_expr *i, gfc_expr *j) 100 { 101 if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) 102 { 103 gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " 104 "literal constants", gfc_current_intrinsic, &i->where, 105 &j->where); 106 reset_boz (i); 107 reset_boz (j); 108 return false; 109 110 } 111 112 return true; 113 } 114 115 116 /* Check that a BOZ is a constant. */ 117 118 static bool 119 is_boz_constant (gfc_expr *a) 120 { 121 if (a->expr_type != EXPR_CONSTANT) 122 { 123 gfc_error ("Invalid use of BOZ literal constant at %L", &a->where); 124 return false; 125 } 126 127 return true; 128 } 129 130 131 /* Convert a octal string into a binary string. This is used in the 132 fallback conversion of an octal string to a REAL. */ 133 134 static char * 135 oct2bin(int nbits, char *oct) 136 { 137 const char bits[8][5] = { 138 "000", "001", "010", "011", "100", "101", "110", "111"}; 139 140 char *buf, *bufp; 141 int i, j, n; 142 143 j = nbits + 1; 144 if (nbits == 64) j++; 145 146 bufp = buf = XCNEWVEC (char, j + 1); 147 memset (bufp, 0, j + 1); 148 149 n = strlen (oct); 150 for (i = 0; i < n; i++, oct++) 151 { 152 j = *oct - 48; 153 strcpy (bufp, &bits[j][0]); 154 bufp += 3; 155 } 156 157 bufp = XCNEWVEC (char, nbits + 1); 158 if (nbits == 64) 159 strcpy (bufp, buf + 2); 160 else 161 strcpy (bufp, buf + 1); 162 163 free (buf); 164 165 return bufp; 166 } 167 168 169 /* Convert a hexidecimal string into a binary string. This is used in the 170 fallback conversion of a hexidecimal string to a REAL. */ 171 172 static char * 173 hex2bin(int nbits, char *hex) 174 { 175 const char bits[16][5] = { 176 "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", 177 "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"}; 178 179 char *buf, *bufp; 180 int i, j, n; 181 182 bufp = buf = XCNEWVEC (char, nbits + 1); 183 memset (bufp, 0, nbits + 1); 184 185 n = strlen (hex); 186 for (i = 0; i < n; i++, hex++) 187 { 188 j = *hex; 189 if (j > 47 && j < 58) 190 j -= 48; 191 else if (j > 64 && j < 71) 192 j -= 55; 193 else if (j > 96 && j < 103) 194 j -= 87; 195 else 196 gcc_unreachable (); 197 198 strcpy (bufp, &bits[j][0]); 199 bufp += 4; 200 } 201 202 return buf; 203 } 204 205 206 /* Fallback conversion of a BOZ string to REAL. */ 207 208 static void 209 bin2real (gfc_expr *x, int kind) 210 { 211 char buf[114], *sp; 212 int b, i, ie, t, w; 213 bool sgn; 214 mpz_t em; 215 216 i = gfc_validate_kind (BT_REAL, kind, false); 217 t = gfc_real_kinds[i].digits - 1; 218 219 /* Number of bits in the exponent. */ 220 if (gfc_real_kinds[i].max_exponent == 16384) 221 w = 15; 222 else if (gfc_real_kinds[i].max_exponent == 1024) 223 w = 11; 224 else 225 w = 8; 226 227 if (x->boz.rdx == 16) 228 sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str); 229 else if (x->boz.rdx == 8) 230 sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str); 231 else 232 sp = x->boz.str; 233 234 /* Extract sign bit. */ 235 sgn = *sp != '0'; 236 237 /* Extract biased exponent. */ 238 memset (buf, 0, 114); 239 strncpy (buf, ++sp, w); 240 mpz_init (em); 241 mpz_set_str (em, buf, 2); 242 ie = mpz_get_si (em); 243 244 mpfr_init2 (x->value.real, t + 1); 245 x->ts.type = BT_REAL; 246 x->ts.kind = kind; 247 248 sp += w; /* Set to first digit in significand. */ 249 b = (1 << w) - 1; 250 if ((i == 0 && ie == b) || (i == 1 && ie == b) 251 || ((i == 2 || i == 3) && ie == b)) 252 { 253 bool zeros = true; 254 if (i == 2) sp++; 255 for (; *sp; sp++) 256 { 257 if (*sp != '0') 258 { 259 zeros = false; 260 break; 261 } 262 } 263 264 if (zeros) 265 mpfr_set_inf (x->value.real, 1); 266 else 267 mpfr_set_nan (x->value.real); 268 } 269 else 270 { 271 if (i == 2) 272 strncpy (buf, sp, t + 1); 273 else 274 { 275 /* Significand with hidden bit. */ 276 buf[0] = '1'; 277 strncpy (&buf[1], sp, t); 278 } 279 280 /* Convert to significand to integer. */ 281 mpz_set_str (em, buf, 2); 282 ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */ 283 mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE); 284 } 285 286 if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE); 287 288 mpz_clear (em); 289 } 290 291 292 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real () 293 converts the string into a REAL of the appropriate kind. The treatment 294 of the sign bit is processor dependent. */ 295 296 bool 297 gfc_boz2real (gfc_expr *x, int kind) 298 { 299 extern int gfc_max_integer_kind; 300 gfc_typespec ts; 301 int len; 302 char *buf, *str; 303 304 if (!is_boz_constant (x)) 305 return false; 306 307 /* Determine the length of the required string. */ 308 len = 8 * kind; 309 if (x->boz.rdx == 16) len /= 4; 310 if (x->boz.rdx == 8) len = len / 3 + 1; 311 buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ 312 313 if (x->boz.len >= len) /* Truncate if necessary. */ 314 { 315 str = x->boz.str + (x->boz.len - len); 316 strcpy(buf, str); 317 } 318 else /* Copy and pad. */ 319 { 320 memset (buf, 48, len); 321 str = buf + (len - x->boz.len); 322 strcpy (str, x->boz.str); 323 } 324 325 /* Need to adjust leading bits in an octal string. */ 326 if (x->boz.rdx == 8) 327 { 328 /* Clear first bit. */ 329 if (kind == 4 || kind == 10 || kind == 16) 330 { 331 if (buf[0] == '4') 332 buf[0] = '0'; 333 else if (buf[0] == '5') 334 buf[0] = '1'; 335 else if (buf[0] == '6') 336 buf[0] = '2'; 337 else if (buf[0] == '7') 338 buf[0] = '3'; 339 } 340 /* Clear first two bits. */ 341 else 342 { 343 if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') 344 buf[0] = '0'; 345 else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') 346 buf[0] = '1'; 347 } 348 } 349 350 /* Reset BOZ string to the truncated or padded version. */ 351 free (x->boz.str); 352 x->boz.len = len; 353 x->boz.str = XCNEWVEC (char, len + 1); 354 strncpy (x->boz.str, buf, len); 355 356 /* For some targets, the largest INTEGER in terms of bits is smaller than 357 the bits needed to hold the REAL. Fortunately, the kind type parameter 358 indicates the number of bytes required to an INTEGER and a REAL. */ 359 if (gfc_max_integer_kind < kind) 360 { 361 bin2real (x, kind); 362 } 363 else 364 { 365 /* Convert to widest possible integer. */ 366 gfc_boz2int (x, gfc_max_integer_kind); 367 ts.type = BT_REAL; 368 ts.kind = kind; 369 if (!gfc_convert_boz (x, &ts)) 370 { 371 gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where); 372 return false; 373 } 374 } 375 376 return true; 377 } 378 379 380 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int () 381 converts the string into an INTEGER of the appropriate kind. The 382 treatment of the sign bit is processor dependent. If the converted 383 value exceeds the range of the type, then wrap-around semantics are 384 applied. */ 385 386 bool 387 gfc_boz2int (gfc_expr *x, int kind) 388 { 389 int i, len; 390 char *buf, *str; 391 mpz_t tmp1; 392 393 if (!is_boz_constant (x)) 394 return false; 395 396 i = gfc_validate_kind (BT_INTEGER, kind, false); 397 len = gfc_integer_kinds[i].bit_size; 398 if (x->boz.rdx == 16) len /= 4; 399 if (x->boz.rdx == 8) len = len / 3 + 1; 400 buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ 401 402 if (x->boz.len >= len) /* Truncate if necessary. */ 403 { 404 str = x->boz.str + (x->boz.len - len); 405 strcpy(buf, str); 406 } 407 else /* Copy and pad. */ 408 { 409 memset (buf, 48, len); 410 str = buf + (len - x->boz.len); 411 strcpy (str, x->boz.str); 412 } 413 414 /* Need to adjust leading bits in an octal string. */ 415 if (x->boz.rdx == 8) 416 { 417 /* Clear first bit. */ 418 if (kind == 1 || kind == 4 || kind == 16) 419 { 420 if (buf[0] == '4') 421 buf[0] = '0'; 422 else if (buf[0] == '5') 423 buf[0] = '1'; 424 else if (buf[0] == '6') 425 buf[0] = '2'; 426 else if (buf[0] == '7') 427 buf[0] = '3'; 428 } 429 /* Clear first two bits. */ 430 else 431 { 432 if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') 433 buf[0] = '0'; 434 else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') 435 buf[0] = '1'; 436 } 437 } 438 439 /* Convert as-if unsigned integer. */ 440 mpz_init (tmp1); 441 mpz_set_str (tmp1, buf, x->boz.rdx); 442 443 /* Check for wrap-around. */ 444 if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0) 445 { 446 mpz_t tmp2; 447 mpz_init (tmp2); 448 mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1); 449 mpz_mod (tmp1, tmp1, tmp2); 450 mpz_sub (tmp1, tmp1, tmp2); 451 mpz_clear (tmp2); 452 } 453 454 /* Clear boz info. */ 455 x->boz.rdx = 0; 456 x->boz.len = 0; 457 free (x->boz.str); 458 459 mpz_init (x->value.integer); 460 mpz_set (x->value.integer, tmp1); 461 x->ts.type = BT_INTEGER; 462 x->ts.kind = kind; 463 mpz_clear (tmp1); 464 465 return true; 466 } 467 468 469 /* Make sure an expression is a scalar. */ 470 471 static bool 472 scalar_check (gfc_expr *e, int n) 473 { 474 if (e->rank == 0) 475 return true; 476 477 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", 478 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 479 &e->where); 480 481 return false; 482 } 483 484 485 /* Check the type of an expression. */ 486 487 static bool 488 type_check (gfc_expr *e, int n, bt type) 489 { 490 if (e->ts.type == type) 491 return true; 492 493 gfc_error ("%qs argument of %qs intrinsic at %L must be %s", 494 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 495 &e->where, gfc_basic_typename (type)); 496 497 return false; 498 } 499 500 501 /* Check that the expression is a numeric type. */ 502 503 static bool 504 numeric_check (gfc_expr *e, int n) 505 { 506 /* Users sometime use a subroutine designator as an actual argument to 507 an intrinsic subprogram that expects an argument with a numeric type. */ 508 if (e->symtree && e->symtree->n.sym->attr.subroutine) 509 goto error; 510 511 if (gfc_numeric_ts (&e->ts)) 512 return true; 513 514 /* If the expression has not got a type, check if its namespace can 515 offer a default type. */ 516 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) 517 && e->symtree->n.sym->ts.type == BT_UNKNOWN 518 && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) 519 && gfc_numeric_ts (&e->symtree->n.sym->ts)) 520 { 521 e->ts = e->symtree->n.sym->ts; 522 return true; 523 } 524 525 error: 526 527 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type", 528 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 529 &e->where); 530 531 return false; 532 } 533 534 535 /* Check that an expression is integer or real. */ 536 537 static bool 538 int_or_real_check (gfc_expr *e, int n) 539 { 540 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) 541 { 542 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 543 "or REAL", gfc_current_intrinsic_arg[n]->name, 544 gfc_current_intrinsic, &e->where); 545 return false; 546 } 547 548 return true; 549 } 550 551 /* Check that an expression is integer or real; allow character for 552 F2003 or later. */ 553 554 static bool 555 int_or_real_or_char_check_f2003 (gfc_expr *e, int n) 556 { 557 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) 558 { 559 if (e->ts.type == BT_CHARACTER) 560 return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for " 561 "%qs argument of %qs intrinsic at %L", 562 gfc_current_intrinsic_arg[n]->name, 563 gfc_current_intrinsic, &e->where); 564 else 565 { 566 if (gfc_option.allow_std & GFC_STD_F2003) 567 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 568 "or REAL or CHARACTER", 569 gfc_current_intrinsic_arg[n]->name, 570 gfc_current_intrinsic, &e->where); 571 else 572 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 573 "or REAL", gfc_current_intrinsic_arg[n]->name, 574 gfc_current_intrinsic, &e->where); 575 } 576 return false; 577 } 578 579 return true; 580 } 581 582 /* Check that an expression is an intrinsic type. */ 583 static bool 584 intrinsic_type_check (gfc_expr *e, int n) 585 { 586 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL 587 && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER 588 && e->ts.type != BT_LOGICAL) 589 { 590 gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type", 591 gfc_current_intrinsic_arg[n]->name, 592 gfc_current_intrinsic, &e->where); 593 return false; 594 } 595 return true; 596 } 597 598 /* Check that an expression is real or complex. */ 599 600 static bool 601 real_or_complex_check (gfc_expr *e, int n) 602 { 603 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) 604 { 605 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " 606 "or COMPLEX", gfc_current_intrinsic_arg[n]->name, 607 gfc_current_intrinsic, &e->where); 608 return false; 609 } 610 611 return true; 612 } 613 614 615 /* Check that an expression is INTEGER or PROCEDURE. */ 616 617 static bool 618 int_or_proc_check (gfc_expr *e, int n) 619 { 620 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) 621 { 622 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 623 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, 624 gfc_current_intrinsic, &e->where); 625 return false; 626 } 627 628 return true; 629 } 630 631 632 /* Check that the expression is an optional constant integer 633 and that it specifies a valid kind for that type. */ 634 635 static bool 636 kind_check (gfc_expr *k, int n, bt type) 637 { 638 int kind; 639 640 if (k == NULL) 641 return true; 642 643 if (!type_check (k, n, BT_INTEGER)) 644 return false; 645 646 if (!scalar_check (k, n)) 647 return false; 648 649 if (!gfc_check_init_expr (k)) 650 { 651 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", 652 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 653 &k->where); 654 return false; 655 } 656 657 if (gfc_extract_int (k, &kind) 658 || gfc_validate_kind (type, kind, true) < 0) 659 { 660 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), 661 &k->where); 662 return false; 663 } 664 665 return true; 666 } 667 668 669 /* Make sure the expression is a double precision real. */ 670 671 static bool 672 double_check (gfc_expr *d, int n) 673 { 674 if (!type_check (d, n, BT_REAL)) 675 return false; 676 677 if (d->ts.kind != gfc_default_double_kind) 678 { 679 gfc_error ("%qs argument of %qs intrinsic at %L must be double " 680 "precision", gfc_current_intrinsic_arg[n]->name, 681 gfc_current_intrinsic, &d->where); 682 return false; 683 } 684 685 return true; 686 } 687 688 689 static bool 690 coarray_check (gfc_expr *e, int n) 691 { 692 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok 693 && CLASS_DATA (e)->attr.codimension 694 && CLASS_DATA (e)->as->corank) 695 { 696 gfc_add_class_array_ref (e); 697 return true; 698 } 699 700 if (!gfc_is_coarray (e)) 701 { 702 gfc_error ("Expected coarray variable as %qs argument to the %s " 703 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, 704 gfc_current_intrinsic, &e->where); 705 return false; 706 } 707 708 return true; 709 } 710 711 712 /* Make sure the expression is a logical array. */ 713 714 static bool 715 logical_array_check (gfc_expr *array, int n) 716 { 717 if (array->ts.type != BT_LOGICAL || array->rank == 0) 718 { 719 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " 720 "array", gfc_current_intrinsic_arg[n]->name, 721 gfc_current_intrinsic, &array->where); 722 return false; 723 } 724 725 return true; 726 } 727 728 729 /* Make sure an expression is an array. */ 730 731 static bool 732 array_check (gfc_expr *e, int n) 733 { 734 if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok 735 && CLASS_DATA (e)->attr.dimension 736 && CLASS_DATA (e)->as->rank) 737 { 738 gfc_add_class_array_ref (e); 739 } 740 741 if (e->rank != 0 && e->ts.type != BT_PROCEDURE) 742 return true; 743 744 gfc_error ("%qs argument of %qs intrinsic at %L must be an array", 745 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 746 &e->where); 747 748 return false; 749 } 750 751 752 /* If expr is a constant, then check to ensure that it is greater than 753 of equal to zero. */ 754 755 static bool 756 nonnegative_check (const char *arg, gfc_expr *expr) 757 { 758 int i; 759 760 if (expr->expr_type == EXPR_CONSTANT) 761 { 762 gfc_extract_int (expr, &i); 763 if (i < 0) 764 { 765 gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); 766 return false; 767 } 768 } 769 770 return true; 771 } 772 773 774 /* If expr is a constant, then check to ensure that it is greater than zero. */ 775 776 static bool 777 positive_check (int n, gfc_expr *expr) 778 { 779 int i; 780 781 if (expr->expr_type == EXPR_CONSTANT) 782 { 783 gfc_extract_int (expr, &i); 784 if (i <= 0) 785 { 786 gfc_error ("%qs argument of %qs intrinsic at %L must be positive", 787 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 788 &expr->where); 789 return false; 790 } 791 } 792 793 return true; 794 } 795 796 797 /* If expr2 is constant, then check that the value is less than 798 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ 799 800 static bool 801 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, 802 gfc_expr *expr2, bool or_equal) 803 { 804 int i2, i3; 805 806 if (expr2->expr_type == EXPR_CONSTANT) 807 { 808 gfc_extract_int (expr2, &i2); 809 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); 810 811 /* For ISHFT[C], check that |shift| <= bit_size(i). */ 812 if (arg2 == NULL) 813 { 814 if (i2 < 0) 815 i2 = -i2; 816 817 if (i2 > gfc_integer_kinds[i3].bit_size) 818 { 819 gfc_error ("The absolute value of SHIFT at %L must be less " 820 "than or equal to BIT_SIZE(%qs)", 821 &expr2->where, arg1); 822 return false; 823 } 824 } 825 826 if (or_equal) 827 { 828 if (i2 > gfc_integer_kinds[i3].bit_size) 829 { 830 gfc_error ("%qs at %L must be less than " 831 "or equal to BIT_SIZE(%qs)", 832 arg2, &expr2->where, arg1); 833 return false; 834 } 835 } 836 else 837 { 838 if (i2 >= gfc_integer_kinds[i3].bit_size) 839 { 840 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", 841 arg2, &expr2->where, arg1); 842 return false; 843 } 844 } 845 } 846 847 return true; 848 } 849 850 851 /* If expr is constant, then check that the value is less than or equal 852 to the bit_size of the kind k. */ 853 854 static bool 855 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) 856 { 857 int i, val; 858 859 if (expr->expr_type != EXPR_CONSTANT) 860 return true; 861 862 i = gfc_validate_kind (BT_INTEGER, k, false); 863 gfc_extract_int (expr, &val); 864 865 if (val > gfc_integer_kinds[i].bit_size) 866 { 867 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " 868 "INTEGER(KIND=%d)", arg, &expr->where, k); 869 return false; 870 } 871 872 return true; 873 } 874 875 876 /* If expr2 and expr3 are constants, then check that the value is less than 877 or equal to bit_size(expr1). */ 878 879 static bool 880 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, 881 gfc_expr *expr2, const char *arg3, gfc_expr *expr3) 882 { 883 int i2, i3; 884 885 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) 886 { 887 gfc_extract_int (expr2, &i2); 888 gfc_extract_int (expr3, &i3); 889 i2 += i3; 890 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); 891 if (i2 > gfc_integer_kinds[i3].bit_size) 892 { 893 gfc_error ("%<%s + %s%> at %L must be less than or equal " 894 "to BIT_SIZE(%qs)", 895 arg2, arg3, &expr2->where, arg1); 896 return false; 897 } 898 } 899 900 return true; 901 } 902 903 /* Make sure two expressions have the same type. */ 904 905 static bool 906 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false) 907 { 908 gfc_typespec *ets = &e->ts; 909 gfc_typespec *fts = &f->ts; 910 911 if (assoc) 912 { 913 /* Procedure pointer component expressions have the type of the interface 914 procedure. If they are being tested for association with a procedure 915 pointer (ie. not a component), the type of the procedure must be 916 determined. */ 917 if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) 918 ets = &e->symtree->n.sym->ts; 919 if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) 920 fts = &f->symtree->n.sym->ts; 921 } 922 923 if (gfc_compare_types (ets, fts)) 924 return true; 925 926 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " 927 "and kind as %qs", gfc_current_intrinsic_arg[m]->name, 928 gfc_current_intrinsic, &f->where, 929 gfc_current_intrinsic_arg[n]->name); 930 931 return false; 932 } 933 934 935 /* Make sure that an expression has a certain (nonzero) rank. */ 936 937 static bool 938 rank_check (gfc_expr *e, int n, int rank) 939 { 940 if (e->rank == rank) 941 return true; 942 943 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", 944 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 945 &e->where, rank); 946 947 return false; 948 } 949 950 951 /* Make sure a variable expression is not an optional dummy argument. */ 952 953 static bool 954 nonoptional_check (gfc_expr *e, int n) 955 { 956 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) 957 { 958 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", 959 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 960 &e->where); 961 } 962 963 /* TODO: Recursive check on nonoptional variables? */ 964 965 return true; 966 } 967 968 969 /* Check for ALLOCATABLE attribute. */ 970 971 static bool 972 allocatable_check (gfc_expr *e, int n) 973 { 974 symbol_attribute attr; 975 976 attr = gfc_variable_attr (e, NULL); 977 if (!attr.allocatable 978 || (attr.associate_var && !attr.select_rank_temporary)) 979 { 980 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", 981 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 982 &e->where); 983 return false; 984 } 985 986 return true; 987 } 988 989 990 /* Check that an expression has a particular kind. */ 991 992 static bool 993 kind_value_check (gfc_expr *e, int n, int k) 994 { 995 if (e->ts.kind == k) 996 return true; 997 998 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", 999 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 1000 &e->where, k); 1001 1002 return false; 1003 } 1004 1005 1006 /* Make sure an expression is a variable. */ 1007 1008 static bool 1009 variable_check (gfc_expr *e, int n, bool allow_proc) 1010 { 1011 if (e->expr_type == EXPR_VARIABLE 1012 && e->symtree->n.sym->attr.intent == INTENT_IN 1013 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT 1014 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT) 1015 && !gfc_check_vardef_context (e, false, true, false, NULL)) 1016 { 1017 gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)", 1018 gfc_current_intrinsic_arg[n]->name, 1019 gfc_current_intrinsic, &e->where); 1020 return false; 1021 } 1022 1023 if (e->expr_type == EXPR_VARIABLE 1024 && e->symtree->n.sym->attr.flavor != FL_PARAMETER 1025 && (allow_proc || !e->symtree->n.sym->attr.function)) 1026 return true; 1027 1028 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function 1029 && e->symtree->n.sym == e->symtree->n.sym->result) 1030 { 1031 gfc_namespace *ns; 1032 for (ns = gfc_current_ns; ns; ns = ns->parent) 1033 if (ns->proc_name == e->symtree->n.sym) 1034 return true; 1035 } 1036 1037 /* F2018:R902: function reference having a data pointer result. */ 1038 if (e->expr_type == EXPR_FUNCTION 1039 && e->symtree->n.sym->attr.flavor == FL_PROCEDURE 1040 && e->symtree->n.sym->attr.function 1041 && e->symtree->n.sym->attr.pointer) 1042 return true; 1043 1044 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", 1045 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); 1046 1047 return false; 1048 } 1049 1050 1051 /* Check the common DIM parameter for correctness. */ 1052 1053 static bool 1054 dim_check (gfc_expr *dim, int n, bool optional) 1055 { 1056 if (dim == NULL) 1057 return true; 1058 1059 if (!type_check (dim, n, BT_INTEGER)) 1060 return false; 1061 1062 if (!scalar_check (dim, n)) 1063 return false; 1064 1065 if (!optional && !nonoptional_check (dim, n)) 1066 return false; 1067 1068 return true; 1069 } 1070 1071 1072 /* If a coarray DIM parameter is a constant, make sure that it is greater than 1073 zero and less than or equal to the corank of the given array. */ 1074 1075 static bool 1076 dim_corank_check (gfc_expr *dim, gfc_expr *array) 1077 { 1078 int corank; 1079 1080 gcc_assert (array->expr_type == EXPR_VARIABLE); 1081 1082 if (dim->expr_type != EXPR_CONSTANT) 1083 return true; 1084 1085 if (array->ts.type == BT_CLASS) 1086 return true; 1087 1088 corank = gfc_get_corank (array); 1089 1090 if (mpz_cmp_ui (dim->value.integer, 1) < 0 1091 || mpz_cmp_ui (dim->value.integer, corank) > 0) 1092 { 1093 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " 1094 "codimension index", gfc_current_intrinsic, &dim->where); 1095 1096 return false; 1097 } 1098 1099 return true; 1100 } 1101 1102 1103 /* If a DIM parameter is a constant, make sure that it is greater than 1104 zero and less than or equal to the rank of the given array. If 1105 allow_assumed is zero then dim must be less than the rank of the array 1106 for assumed size arrays. */ 1107 1108 static bool 1109 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) 1110 { 1111 gfc_array_ref *ar; 1112 int rank; 1113 1114 if (dim == NULL) 1115 return true; 1116 1117 if (dim->expr_type != EXPR_CONSTANT) 1118 return true; 1119 1120 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym 1121 && array->value.function.isym->id == GFC_ISYM_SPREAD) 1122 rank = array->rank + 1; 1123 else 1124 rank = array->rank; 1125 1126 /* Assumed-rank array. */ 1127 if (rank == -1) 1128 rank = GFC_MAX_DIMENSIONS; 1129 1130 if (array->expr_type == EXPR_VARIABLE) 1131 { 1132 ar = gfc_find_array_ref (array, true); 1133 if (!ar) 1134 return false; 1135 if (ar->as->type == AS_ASSUMED_SIZE 1136 && !allow_assumed 1137 && ar->type != AR_ELEMENT 1138 && ar->type != AR_SECTION) 1139 rank--; 1140 } 1141 1142 if (mpz_cmp_ui (dim->value.integer, 1) < 0 1143 || mpz_cmp_ui (dim->value.integer, rank) > 0) 1144 { 1145 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " 1146 "dimension index", gfc_current_intrinsic, &dim->where); 1147 1148 return false; 1149 } 1150 1151 return true; 1152 } 1153 1154 1155 /* Compare the size of a along dimension ai with the size of b along 1156 dimension bi, returning 0 if they are known not to be identical, 1157 and 1 if they are identical, or if this cannot be determined. */ 1158 1159 static int 1160 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) 1161 { 1162 mpz_t a_size, b_size; 1163 int ret; 1164 1165 gcc_assert (a->rank > ai); 1166 gcc_assert (b->rank > bi); 1167 1168 ret = 1; 1169 1170 if (gfc_array_dimen_size (a, ai, &a_size)) 1171 { 1172 if (gfc_array_dimen_size (b, bi, &b_size)) 1173 { 1174 if (mpz_cmp (a_size, b_size) != 0) 1175 ret = 0; 1176 1177 mpz_clear (b_size); 1178 } 1179 mpz_clear (a_size); 1180 } 1181 return ret; 1182 } 1183 1184 /* Calculate the length of a character variable, including substrings. 1185 Strip away parentheses if necessary. Return -1 if no length could 1186 be determined. */ 1187 1188 static long 1189 gfc_var_strlen (const gfc_expr *a) 1190 { 1191 gfc_ref *ra; 1192 1193 while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) 1194 a = a->value.op.op1; 1195 1196 for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) 1197 ; 1198 1199 if (ra) 1200 { 1201 long start_a, end_a; 1202 1203 if (!ra->u.ss.end) 1204 return -1; 1205 1206 if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT) 1207 && ra->u.ss.end->expr_type == EXPR_CONSTANT) 1208 { 1209 start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer) 1210 : 1; 1211 end_a = mpz_get_si (ra->u.ss.end->value.integer); 1212 return (end_a < start_a) ? 0 : end_a - start_a + 1; 1213 } 1214 else if (ra->u.ss.start 1215 && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) 1216 return 1; 1217 else 1218 return -1; 1219 } 1220 1221 if (a->ts.u.cl && a->ts.u.cl->length 1222 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) 1223 return mpz_get_si (a->ts.u.cl->length->value.integer); 1224 else if (a->expr_type == EXPR_CONSTANT 1225 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) 1226 return a->value.character.length; 1227 else 1228 return -1; 1229 1230 } 1231 1232 /* Check whether two character expressions have the same length; 1233 returns true if they have or if the length cannot be determined, 1234 otherwise return false and raise a gfc_error. */ 1235 1236 bool 1237 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) 1238 { 1239 long len_a, len_b; 1240 1241 len_a = gfc_var_strlen(a); 1242 len_b = gfc_var_strlen(b); 1243 1244 if (len_a == -1 || len_b == -1 || len_a == len_b) 1245 return true; 1246 else 1247 { 1248 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", 1249 len_a, len_b, name, &a->where); 1250 return false; 1251 } 1252 } 1253 1254 1255 /***** Check functions *****/ 1256 1257 /* Check subroutine suitable for intrinsics taking a real argument and 1258 a kind argument for the result. */ 1259 1260 static bool 1261 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) 1262 { 1263 if (!type_check (a, 0, BT_REAL)) 1264 return false; 1265 if (!kind_check (kind, 1, type)) 1266 return false; 1267 1268 return true; 1269 } 1270 1271 1272 /* Check subroutine suitable for ceiling, floor and nint. */ 1273 1274 bool 1275 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) 1276 { 1277 return check_a_kind (a, kind, BT_INTEGER); 1278 } 1279 1280 1281 /* Check subroutine suitable for aint, anint. */ 1282 1283 bool 1284 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) 1285 { 1286 return check_a_kind (a, kind, BT_REAL); 1287 } 1288 1289 1290 bool 1291 gfc_check_abs (gfc_expr *a) 1292 { 1293 if (!numeric_check (a, 0)) 1294 return false; 1295 1296 return true; 1297 } 1298 1299 1300 bool 1301 gfc_check_achar (gfc_expr *a, gfc_expr *kind) 1302 { 1303 if (a->ts.type == BT_BOZ) 1304 { 1305 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " 1306 "ACHAR intrinsic subprogram"), &a->where)) 1307 return false; 1308 1309 if (!gfc_boz2int (a, gfc_default_integer_kind)) 1310 return false; 1311 } 1312 1313 if (!type_check (a, 0, BT_INTEGER)) 1314 return false; 1315 1316 if (!kind_check (kind, 1, BT_CHARACTER)) 1317 return false; 1318 1319 return true; 1320 } 1321 1322 1323 bool 1324 gfc_check_access_func (gfc_expr *name, gfc_expr *mode) 1325 { 1326 if (!type_check (name, 0, BT_CHARACTER) 1327 || !scalar_check (name, 0)) 1328 return false; 1329 if (!kind_value_check (name, 0, gfc_default_character_kind)) 1330 return false; 1331 1332 if (!type_check (mode, 1, BT_CHARACTER) 1333 || !scalar_check (mode, 1)) 1334 return false; 1335 if (!kind_value_check (mode, 1, gfc_default_character_kind)) 1336 return false; 1337 1338 return true; 1339 } 1340 1341 1342 bool 1343 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) 1344 { 1345 if (!logical_array_check (mask, 0)) 1346 return false; 1347 1348 if (!dim_check (dim, 1, false)) 1349 return false; 1350 1351 if (!dim_rank_check (dim, mask, 0)) 1352 return false; 1353 1354 return true; 1355 } 1356 1357 1358 /* Limited checking for ALLOCATED intrinsic. Additional checking 1359 is performed in intrinsic.cc(sort_actual), because ALLOCATED 1360 has two mutually exclusive non-optional arguments. */ 1361 1362 bool 1363 gfc_check_allocated (gfc_expr *array) 1364 { 1365 /* Tests on allocated components of coarrays need to detour the check to 1366 argument of the _caf_get. */ 1367 if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION 1368 && array->value.function.isym 1369 && array->value.function.isym->id == GFC_ISYM_CAF_GET) 1370 { 1371 array = array->value.function.actual->expr; 1372 if (!array->ref) 1373 return false; 1374 } 1375 1376 if (!variable_check (array, 0, false)) 1377 return false; 1378 if (!allocatable_check (array, 0)) 1379 return false; 1380 1381 return true; 1382 } 1383 1384 1385 /* Common check function where the first argument must be real or 1386 integer and the second argument must be the same as the first. */ 1387 1388 bool 1389 gfc_check_a_p (gfc_expr *a, gfc_expr *p) 1390 { 1391 if (!int_or_real_check (a, 0)) 1392 return false; 1393 1394 if (a->ts.type != p->ts.type) 1395 { 1396 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " 1397 "have the same type", gfc_current_intrinsic_arg[0]->name, 1398 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1399 &p->where); 1400 return false; 1401 } 1402 1403 if (a->ts.kind != p->ts.kind) 1404 { 1405 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 1406 &p->where)) 1407 return false; 1408 } 1409 1410 return true; 1411 } 1412 1413 1414 bool 1415 gfc_check_x_yd (gfc_expr *x, gfc_expr *y) 1416 { 1417 if (!double_check (x, 0) || !double_check (y, 1)) 1418 return false; 1419 1420 return true; 1421 } 1422 1423 bool 1424 gfc_invalid_null_arg (gfc_expr *x) 1425 { 1426 if (x->expr_type == EXPR_NULL) 1427 { 1428 gfc_error ("NULL at %L is not permitted as actual argument " 1429 "to %qs intrinsic function", &x->where, 1430 gfc_current_intrinsic); 1431 return true; 1432 } 1433 return false; 1434 } 1435 1436 bool 1437 gfc_check_associated (gfc_expr *pointer, gfc_expr *target) 1438 { 1439 symbol_attribute attr1, attr2; 1440 int i; 1441 bool t; 1442 1443 if (gfc_invalid_null_arg (pointer)) 1444 return false; 1445 1446 attr1 = gfc_expr_attr (pointer); 1447 1448 if (!attr1.pointer && !attr1.proc_pointer) 1449 { 1450 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", 1451 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 1452 &pointer->where); 1453 return false; 1454 } 1455 1456 /* F2008, C1242. */ 1457 if (attr1.pointer && gfc_is_coindexed (pointer)) 1458 { 1459 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 1460 "coindexed", gfc_current_intrinsic_arg[0]->name, 1461 gfc_current_intrinsic, &pointer->where); 1462 return false; 1463 } 1464 1465 /* Target argument is optional. */ 1466 if (target == NULL) 1467 return true; 1468 1469 if (gfc_invalid_null_arg (target)) 1470 return false; 1471 1472 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) 1473 attr2 = gfc_expr_attr (target); 1474 else 1475 { 1476 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " 1477 "or target VARIABLE or FUNCTION", 1478 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1479 &target->where); 1480 return false; 1481 } 1482 1483 if (attr1.pointer && !attr2.pointer && !attr2.target) 1484 { 1485 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " 1486 "or a TARGET", gfc_current_intrinsic_arg[1]->name, 1487 gfc_current_intrinsic, &target->where); 1488 return false; 1489 } 1490 1491 /* F2008, C1242. */ 1492 if (attr1.pointer && gfc_is_coindexed (target)) 1493 { 1494 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 1495 "coindexed", gfc_current_intrinsic_arg[1]->name, 1496 gfc_current_intrinsic, &target->where); 1497 return false; 1498 } 1499 1500 t = true; 1501 if (!same_type_check (pointer, 0, target, 1, true)) 1502 t = false; 1503 /* F2018 C838 explicitly allows an assumed-rank variable as the first 1504 argument of intrinsic inquiry functions. */ 1505 if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) 1506 t = false; 1507 if (target->rank > 0 && target->ref) 1508 { 1509 for (i = 0; i < target->rank; i++) 1510 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 1511 { 1512 gfc_error ("Array section with a vector subscript at %L shall not " 1513 "be the target of a pointer", 1514 &target->where); 1515 t = false; 1516 break; 1517 } 1518 } 1519 return t; 1520 } 1521 1522 1523 bool 1524 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) 1525 { 1526 /* gfc_notify_std would be a waste of time as the return value 1527 is seemingly used only for the generic resolution. The error 1528 will be: Too many arguments. */ 1529 if ((gfc_option.allow_std & GFC_STD_F2008) == 0) 1530 return false; 1531 1532 return gfc_check_atan2 (y, x); 1533 } 1534 1535 1536 bool 1537 gfc_check_atan2 (gfc_expr *y, gfc_expr *x) 1538 { 1539 if (!type_check (y, 0, BT_REAL)) 1540 return false; 1541 if (!same_type_check (y, 0, x, 1)) 1542 return false; 1543 1544 return true; 1545 } 1546 1547 1548 static bool 1549 gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, 1550 gfc_expr *stat, int stat_no) 1551 { 1552 if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) 1553 return false; 1554 1555 if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) 1556 && !(atom->ts.type == BT_LOGICAL 1557 && atom->ts.kind == gfc_atomic_logical_kind)) 1558 { 1559 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " 1560 "integer of ATOMIC_INT_KIND or a logical of " 1561 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic); 1562 return false; 1563 } 1564 1565 if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom)) 1566 { 1567 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " 1568 "coarray or coindexed", &atom->where, gfc_current_intrinsic); 1569 return false; 1570 } 1571 1572 if (atom->ts.type != value->ts.type) 1573 { 1574 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same " 1575 "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name, 1576 gfc_current_intrinsic, &value->where, 1577 gfc_current_intrinsic_arg[atom_no]->name, &atom->where); 1578 return false; 1579 } 1580 1581 if (stat != NULL) 1582 { 1583 if (!type_check (stat, stat_no, BT_INTEGER)) 1584 return false; 1585 if (!scalar_check (stat, stat_no)) 1586 return false; 1587 if (!variable_check (stat, stat_no, false)) 1588 return false; 1589 if (!kind_value_check (stat, stat_no, gfc_default_integer_kind)) 1590 return false; 1591 1592 if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", 1593 gfc_current_intrinsic, &stat->where)) 1594 return false; 1595 } 1596 1597 return true; 1598 } 1599 1600 1601 bool 1602 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) 1603 { 1604 if (atom->expr_type == EXPR_FUNCTION 1605 && atom->value.function.isym 1606 && atom->value.function.isym->id == GFC_ISYM_CAF_GET) 1607 atom = atom->value.function.actual->expr; 1608 1609 if (!gfc_check_vardef_context (atom, false, false, false, NULL)) 1610 { 1611 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " 1612 "definable", gfc_current_intrinsic, &atom->where); 1613 return false; 1614 } 1615 1616 return gfc_check_atomic (atom, 0, value, 1, stat, 2); 1617 } 1618 1619 1620 bool 1621 gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) 1622 { 1623 if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) 1624 { 1625 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " 1626 "integer of ATOMIC_INT_KIND", &atom->where, 1627 gfc_current_intrinsic); 1628 return false; 1629 } 1630 1631 return gfc_check_atomic_def (atom, value, stat); 1632 } 1633 1634 1635 bool 1636 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) 1637 { 1638 if (atom->expr_type == EXPR_FUNCTION 1639 && atom->value.function.isym 1640 && atom->value.function.isym->id == GFC_ISYM_CAF_GET) 1641 atom = atom->value.function.actual->expr; 1642 1643 if (!gfc_check_vardef_context (value, false, false, false, NULL)) 1644 { 1645 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " 1646 "definable", gfc_current_intrinsic, &value->where); 1647 return false; 1648 } 1649 1650 return gfc_check_atomic (atom, 1, value, 0, stat, 2); 1651 } 1652 1653 1654 bool 1655 gfc_check_image_status (gfc_expr *image, gfc_expr *team) 1656 { 1657 /* IMAGE has to be a positive, scalar integer. */ 1658 if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0) 1659 || !positive_check (0, image)) 1660 return false; 1661 1662 if (team) 1663 { 1664 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", 1665 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1666 &team->where); 1667 return false; 1668 } 1669 return true; 1670 } 1671 1672 1673 bool 1674 gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) 1675 { 1676 if (team) 1677 { 1678 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", 1679 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 1680 &team->where); 1681 return false; 1682 } 1683 1684 if (kind) 1685 { 1686 int k; 1687 1688 if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1) 1689 || !positive_check (1, kind)) 1690 return false; 1691 1692 /* Get the kind, reporting error on non-constant or overflow. */ 1693 gfc_current_locus = kind->where; 1694 if (gfc_extract_int (kind, &k, 1)) 1695 return false; 1696 if (gfc_validate_kind (BT_INTEGER, k, true) == -1) 1697 { 1698 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a " 1699 "valid integer kind", gfc_current_intrinsic_arg[1]->name, 1700 gfc_current_intrinsic, &kind->where); 1701 return false; 1702 } 1703 } 1704 return true; 1705 } 1706 1707 1708 bool 1709 gfc_check_get_team (gfc_expr *level) 1710 { 1711 if (level) 1712 { 1713 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", 1714 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 1715 &level->where); 1716 return false; 1717 } 1718 return true; 1719 } 1720 1721 1722 bool 1723 gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, 1724 gfc_expr *new_val, gfc_expr *stat) 1725 { 1726 if (atom->expr_type == EXPR_FUNCTION 1727 && atom->value.function.isym 1728 && atom->value.function.isym->id == GFC_ISYM_CAF_GET) 1729 atom = atom->value.function.actual->expr; 1730 1731 if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4)) 1732 return false; 1733 1734 if (!scalar_check (old, 1) || !scalar_check (compare, 2)) 1735 return false; 1736 1737 if (!same_type_check (atom, 0, old, 1)) 1738 return false; 1739 1740 if (!same_type_check (atom, 0, compare, 2)) 1741 return false; 1742 1743 if (!gfc_check_vardef_context (atom, false, false, false, NULL)) 1744 { 1745 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " 1746 "definable", gfc_current_intrinsic, &atom->where); 1747 return false; 1748 } 1749 1750 if (!gfc_check_vardef_context (old, false, false, false, NULL)) 1751 { 1752 gfc_error ("OLD argument of the %s intrinsic function at %L shall be " 1753 "definable", gfc_current_intrinsic, &old->where); 1754 return false; 1755 } 1756 1757 return true; 1758 } 1759 1760 bool 1761 gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat) 1762 { 1763 if (event->ts.type != BT_DERIVED 1764 || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV 1765 || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE) 1766 { 1767 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY " 1768 "shall be of type EVENT_TYPE", &event->where); 1769 return false; 1770 } 1771 1772 if (!scalar_check (event, 0)) 1773 return false; 1774 1775 if (!gfc_check_vardef_context (count, false, false, false, NULL)) 1776 { 1777 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " 1778 "shall be definable", &count->where); 1779 return false; 1780 } 1781 1782 if (!type_check (count, 1, BT_INTEGER)) 1783 return false; 1784 1785 int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false); 1786 int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); 1787 1788 if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) 1789 { 1790 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " 1791 "shall have at least the range of the default integer", 1792 &count->where); 1793 return false; 1794 } 1795 1796 if (stat != NULL) 1797 { 1798 if (!type_check (stat, 2, BT_INTEGER)) 1799 return false; 1800 if (!scalar_check (stat, 2)) 1801 return false; 1802 if (!variable_check (stat, 2, false)) 1803 return false; 1804 1805 if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", 1806 gfc_current_intrinsic, &stat->where)) 1807 return false; 1808 } 1809 1810 return true; 1811 } 1812 1813 1814 bool 1815 gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, 1816 gfc_expr *stat) 1817 { 1818 if (atom->expr_type == EXPR_FUNCTION 1819 && atom->value.function.isym 1820 && atom->value.function.isym->id == GFC_ISYM_CAF_GET) 1821 atom = atom->value.function.actual->expr; 1822 1823 if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) 1824 { 1825 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " 1826 "integer of ATOMIC_INT_KIND", &atom->where, 1827 gfc_current_intrinsic); 1828 return false; 1829 } 1830 1831 if (!gfc_check_atomic (atom, 0, value, 1, stat, 3)) 1832 return false; 1833 1834 if (!scalar_check (old, 2)) 1835 return false; 1836 1837 if (!same_type_check (atom, 0, old, 2)) 1838 return false; 1839 1840 if (!gfc_check_vardef_context (atom, false, false, false, NULL)) 1841 { 1842 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " 1843 "definable", gfc_current_intrinsic, &atom->where); 1844 return false; 1845 } 1846 1847 if (!gfc_check_vardef_context (old, false, false, false, NULL)) 1848 { 1849 gfc_error ("OLD argument of the %s intrinsic function at %L shall be " 1850 "definable", gfc_current_intrinsic, &old->where); 1851 return false; 1852 } 1853 1854 return true; 1855 } 1856 1857 1858 /* BESJN and BESYN functions. */ 1859 1860 bool 1861 gfc_check_besn (gfc_expr *n, gfc_expr *x) 1862 { 1863 if (!type_check (n, 0, BT_INTEGER)) 1864 return false; 1865 if (n->expr_type == EXPR_CONSTANT) 1866 { 1867 int i; 1868 gfc_extract_int (n, &i); 1869 if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " 1870 "N at %L", &n->where)) 1871 return false; 1872 } 1873 1874 if (!type_check (x, 1, BT_REAL)) 1875 return false; 1876 1877 return true; 1878 } 1879 1880 1881 /* Transformational version of the Bessel JN and YN functions. */ 1882 1883 bool 1884 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) 1885 { 1886 if (!type_check (n1, 0, BT_INTEGER)) 1887 return false; 1888 if (!scalar_check (n1, 0)) 1889 return false; 1890 if (!nonnegative_check ("N1", n1)) 1891 return false; 1892 1893 if (!type_check (n2, 1, BT_INTEGER)) 1894 return false; 1895 if (!scalar_check (n2, 1)) 1896 return false; 1897 if (!nonnegative_check ("N2", n2)) 1898 return false; 1899 1900 if (!type_check (x, 2, BT_REAL)) 1901 return false; 1902 if (!scalar_check (x, 2)) 1903 return false; 1904 1905 return true; 1906 } 1907 1908 1909 bool 1910 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) 1911 { 1912 extern int gfc_max_integer_kind; 1913 1914 /* If i and j are both BOZ, convert to widest INTEGER. */ 1915 if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) 1916 { 1917 if (!gfc_boz2int (i, gfc_max_integer_kind)) 1918 return false; 1919 if (!gfc_boz2int (j, gfc_max_integer_kind)) 1920 return false; 1921 } 1922 1923 /* If i is BOZ and j is integer, convert i to type of j. */ 1924 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER 1925 && !gfc_boz2int (i, j->ts.kind)) 1926 return false; 1927 1928 /* If j is BOZ and i is integer, convert j to type of i. */ 1929 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER 1930 && !gfc_boz2int (j, i->ts.kind)) 1931 return false; 1932 1933 if (!type_check (i, 0, BT_INTEGER)) 1934 return false; 1935 1936 if (!type_check (j, 1, BT_INTEGER)) 1937 return false; 1938 1939 return true; 1940 } 1941 1942 1943 bool 1944 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) 1945 { 1946 if (!type_check (i, 0, BT_INTEGER)) 1947 return false; 1948 1949 if (!type_check (pos, 1, BT_INTEGER)) 1950 return false; 1951 1952 if (!nonnegative_check ("pos", pos)) 1953 return false; 1954 1955 if (!less_than_bitsize1 ("i", i, "pos", pos, false)) 1956 return false; 1957 1958 return true; 1959 } 1960 1961 1962 bool 1963 gfc_check_char (gfc_expr *i, gfc_expr *kind) 1964 { 1965 if (i->ts.type == BT_BOZ) 1966 { 1967 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " 1968 "CHAR intrinsic subprogram"), &i->where)) 1969 return false; 1970 1971 if (!gfc_boz2int (i, gfc_default_integer_kind)) 1972 return false; 1973 } 1974 1975 if (!type_check (i, 0, BT_INTEGER)) 1976 return false; 1977 1978 if (!kind_check (kind, 1, BT_CHARACTER)) 1979 return false; 1980 1981 return true; 1982 } 1983 1984 1985 bool 1986 gfc_check_chdir (gfc_expr *dir) 1987 { 1988 if (!type_check (dir, 0, BT_CHARACTER)) 1989 return false; 1990 if (!kind_value_check (dir, 0, gfc_default_character_kind)) 1991 return false; 1992 1993 return true; 1994 } 1995 1996 1997 bool 1998 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) 1999 { 2000 if (!type_check (dir, 0, BT_CHARACTER)) 2001 return false; 2002 if (!kind_value_check (dir, 0, gfc_default_character_kind)) 2003 return false; 2004 2005 if (status == NULL) 2006 return true; 2007 2008 if (!type_check (status, 1, BT_INTEGER)) 2009 return false; 2010 if (!scalar_check (status, 1)) 2011 return false; 2012 2013 return true; 2014 } 2015 2016 2017 bool 2018 gfc_check_chmod (gfc_expr *name, gfc_expr *mode) 2019 { 2020 if (!type_check (name, 0, BT_CHARACTER)) 2021 return false; 2022 if (!kind_value_check (name, 0, gfc_default_character_kind)) 2023 return false; 2024 2025 if (!type_check (mode, 1, BT_CHARACTER)) 2026 return false; 2027 if (!kind_value_check (mode, 1, gfc_default_character_kind)) 2028 return false; 2029 2030 return true; 2031 } 2032 2033 2034 bool 2035 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) 2036 { 2037 if (!type_check (name, 0, BT_CHARACTER)) 2038 return false; 2039 if (!kind_value_check (name, 0, gfc_default_character_kind)) 2040 return false; 2041 2042 if (!type_check (mode, 1, BT_CHARACTER)) 2043 return false; 2044 if (!kind_value_check (mode, 1, gfc_default_character_kind)) 2045 return false; 2046 2047 if (status == NULL) 2048 return true; 2049 2050 if (!type_check (status, 2, BT_INTEGER)) 2051 return false; 2052 2053 if (!scalar_check (status, 2)) 2054 return false; 2055 2056 return true; 2057 } 2058 2059 2060 bool 2061 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) 2062 { 2063 int k; 2064 2065 /* Check kind first, because it may be needed in conversion of a BOZ. */ 2066 if (kind) 2067 { 2068 if (!kind_check (kind, 2, BT_COMPLEX)) 2069 return false; 2070 gfc_extract_int (kind, &k); 2071 } 2072 else 2073 k = gfc_default_complex_kind; 2074 2075 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k)) 2076 return false; 2077 2078 if (!numeric_check (x, 0)) 2079 return false; 2080 2081 if (y != NULL) 2082 { 2083 if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k)) 2084 return false; 2085 2086 if (!numeric_check (y, 1)) 2087 return false; 2088 2089 if (x->ts.type == BT_COMPLEX) 2090 { 2091 gfc_error ("%qs argument of %qs intrinsic at %L must not be " 2092 "present if %<x%> is COMPLEX", 2093 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2094 &y->where); 2095 return false; 2096 } 2097 2098 if (y->ts.type == BT_COMPLEX) 2099 { 2100 gfc_error ("%qs argument of %qs intrinsic at %L must have a type " 2101 "of either REAL or INTEGER", 2102 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2103 &y->where); 2104 return false; 2105 } 2106 } 2107 2108 if (!kind && warn_conversion 2109 && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) 2110 gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " 2111 "COMPLEX(%d) at %L might lose precision, consider using " 2112 "the KIND argument", gfc_typename (&x->ts), 2113 gfc_default_real_kind, &x->where); 2114 else if (y && !kind && warn_conversion 2115 && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) 2116 gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " 2117 "COMPLEX(%d) at %L might lose precision, consider using " 2118 "the KIND argument", gfc_typename (&y->ts), 2119 gfc_default_real_kind, &y->where); 2120 return true; 2121 } 2122 2123 2124 static bool 2125 check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, 2126 gfc_expr *errmsg, bool co_reduce) 2127 { 2128 if (!variable_check (a, 0, false)) 2129 return false; 2130 2131 if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with " 2132 "INTENT(INOUT)")) 2133 return false; 2134 2135 /* Fortran 2008, 12.5.2.4, paragraph 18. */ 2136 if (gfc_has_vector_subscript (a)) 2137 { 2138 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic " 2139 "subroutine %s shall not have a vector subscript", 2140 &a->where, gfc_current_intrinsic); 2141 return false; 2142 } 2143 2144 if (gfc_is_coindexed (a)) 2145 { 2146 gfc_error ("The A argument at %L to the intrinsic %s shall not be " 2147 "coindexed", &a->where, gfc_current_intrinsic); 2148 return false; 2149 } 2150 2151 if (image_idx != NULL) 2152 { 2153 if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) 2154 return false; 2155 if (!scalar_check (image_idx, co_reduce ? 2 : 1)) 2156 return false; 2157 } 2158 2159 if (stat != NULL) 2160 { 2161 if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) 2162 return false; 2163 if (!scalar_check (stat, co_reduce ? 3 : 2)) 2164 return false; 2165 if (!variable_check (stat, co_reduce ? 3 : 2, false)) 2166 return false; 2167 if (stat->ts.kind != 4) 2168 { 2169 gfc_error ("The stat= argument at %L must be a kind=4 integer " 2170 "variable", &stat->where); 2171 return false; 2172 } 2173 } 2174 2175 if (errmsg != NULL) 2176 { 2177 if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) 2178 return false; 2179 if (!scalar_check (errmsg, co_reduce ? 4 : 3)) 2180 return false; 2181 if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) 2182 return false; 2183 if (errmsg->ts.kind != 1) 2184 { 2185 gfc_error ("The errmsg= argument at %L must be a default-kind " 2186 "character variable", &errmsg->where); 2187 return false; 2188 } 2189 } 2190 2191 if (flag_coarray == GFC_FCOARRAY_NONE) 2192 { 2193 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", 2194 &a->where); 2195 return false; 2196 } 2197 2198 return true; 2199 } 2200 2201 2202 bool 2203 gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, 2204 gfc_expr *errmsg) 2205 { 2206 if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) 2207 { 2208 gfc_error ("Support for the A argument at %L which is polymorphic A " 2209 "argument or has allocatable components is not yet " 2210 "implemented", &a->where); 2211 return false; 2212 } 2213 return check_co_collective (a, source_image, stat, errmsg, false); 2214 } 2215 2216 2217 bool 2218 gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, 2219 gfc_expr *stat, gfc_expr *errmsg) 2220 { 2221 symbol_attribute attr; 2222 gfc_formal_arglist *formal; 2223 gfc_symbol *sym; 2224 2225 if (a->ts.type == BT_CLASS) 2226 { 2227 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", 2228 &a->where); 2229 return false; 2230 } 2231 2232 if (gfc_expr_attr (a).alloc_comp) 2233 { 2234 gfc_error ("Support for the A argument at %L with allocatable components" 2235 " is not yet implemented", &a->where); 2236 return false; 2237 } 2238 2239 if (!check_co_collective (a, result_image, stat, errmsg, true)) 2240 return false; 2241 2242 if (!gfc_resolve_expr (op)) 2243 return false; 2244 2245 attr = gfc_expr_attr (op); 2246 if (!attr.pure || !attr.function) 2247 { 2248 gfc_error ("OPERATION argument at %L must be a PURE function", 2249 &op->where); 2250 return false; 2251 } 2252 2253 if (attr.intrinsic) 2254 { 2255 /* None of the intrinsics fulfills the criteria of taking two arguments, 2256 returning the same type and kind as the arguments and being permitted 2257 as actual argument. */ 2258 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE", 2259 op->symtree->n.sym->name, &op->where); 2260 return false; 2261 } 2262 2263 if (gfc_is_proc_ptr_comp (op)) 2264 { 2265 gfc_component *comp = gfc_get_proc_ptr_comp (op); 2266 sym = comp->ts.interface; 2267 } 2268 else 2269 sym = op->symtree->n.sym; 2270 2271 formal = sym->formal; 2272 2273 if (!formal || !formal->next || formal->next->next) 2274 { 2275 gfc_error ("The function passed as OPERATION at %L shall have two " 2276 "arguments", &op->where); 2277 return false; 2278 } 2279 2280 if (sym->result->ts.type == BT_UNKNOWN) 2281 gfc_set_default_type (sym->result, 0, NULL); 2282 2283 if (!gfc_compare_types (&a->ts, &sym->result->ts)) 2284 { 2285 gfc_error ("The A argument at %L has type %s but the function passed as " 2286 "OPERATION at %L returns %s", 2287 &a->where, gfc_typename (a), &op->where, 2288 gfc_typename (&sym->result->ts)); 2289 return false; 2290 } 2291 if (!gfc_compare_types (&a->ts, &formal->sym->ts) 2292 || !gfc_compare_types (&a->ts, &formal->next->sym->ts)) 2293 { 2294 gfc_error ("The function passed as OPERATION at %L has arguments of type " 2295 "%s and %s but shall have type %s", &op->where, 2296 gfc_typename (&formal->sym->ts), 2297 gfc_typename (&formal->next->sym->ts), gfc_typename (a)); 2298 return false; 2299 } 2300 if (op->rank || attr.allocatable || attr.pointer || formal->sym->as 2301 || formal->next->sym->as || formal->sym->attr.allocatable 2302 || formal->next->sym->attr.allocatable || formal->sym->attr.pointer 2303 || formal->next->sym->attr.pointer) 2304 { 2305 gfc_error ("The function passed as OPERATION at %L shall have scalar " 2306 "nonallocatable nonpointer arguments and return a " 2307 "nonallocatable nonpointer scalar", &op->where); 2308 return false; 2309 } 2310 2311 if (formal->sym->attr.value != formal->next->sym->attr.value) 2312 { 2313 gfc_error ("The function passed as OPERATION at %L shall have the VALUE " 2314 "attribute either for none or both arguments", &op->where); 2315 return false; 2316 } 2317 2318 if (formal->sym->attr.target != formal->next->sym->attr.target) 2319 { 2320 gfc_error ("The function passed as OPERATION at %L shall have the TARGET " 2321 "attribute either for none or both arguments", &op->where); 2322 return false; 2323 } 2324 2325 if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous) 2326 { 2327 gfc_error ("The function passed as OPERATION at %L shall have the " 2328 "ASYNCHRONOUS attribute either for none or both arguments", 2329 &op->where); 2330 return false; 2331 } 2332 2333 if (formal->sym->attr.optional || formal->next->sym->attr.optional) 2334 { 2335 gfc_error ("The function passed as OPERATION at %L shall not have the " 2336 "OPTIONAL attribute for either of the arguments", &op->where); 2337 return false; 2338 } 2339 2340 if (a->ts.type == BT_CHARACTER) 2341 { 2342 gfc_charlen *cl; 2343 unsigned long actual_size, formal_size1, formal_size2, result_size; 2344 2345 cl = a->ts.u.cl; 2346 actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT 2347 ? mpz_get_ui (cl->length->value.integer) : 0; 2348 2349 cl = formal->sym->ts.u.cl; 2350 formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT 2351 ? mpz_get_ui (cl->length->value.integer) : 0; 2352 2353 cl = formal->next->sym->ts.u.cl; 2354 formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT 2355 ? mpz_get_ui (cl->length->value.integer) : 0; 2356 2357 cl = sym->ts.u.cl; 2358 result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT 2359 ? mpz_get_ui (cl->length->value.integer) : 0; 2360 2361 if (actual_size 2362 && ((formal_size1 && actual_size != formal_size1) 2363 || (formal_size2 && actual_size != formal_size2))) 2364 { 2365 gfc_error ("The character length of the A argument at %L and of the " 2366 "arguments of the OPERATION at %L shall be the same", 2367 &a->where, &op->where); 2368 return false; 2369 } 2370 if (actual_size && result_size && actual_size != result_size) 2371 { 2372 gfc_error ("The character length of the A argument at %L and of the " 2373 "function result of the OPERATION at %L shall be the same", 2374 &a->where, &op->where); 2375 return false; 2376 } 2377 } 2378 2379 return true; 2380 } 2381 2382 2383 bool 2384 gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, 2385 gfc_expr *errmsg) 2386 { 2387 if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL 2388 && a->ts.type != BT_CHARACTER) 2389 { 2390 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " 2391 "integer, real or character", 2392 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 2393 &a->where); 2394 return false; 2395 } 2396 return check_co_collective (a, result_image, stat, errmsg, false); 2397 } 2398 2399 2400 bool 2401 gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, 2402 gfc_expr *errmsg) 2403 { 2404 if (!numeric_check (a, 0)) 2405 return false; 2406 return check_co_collective (a, result_image, stat, errmsg, false); 2407 } 2408 2409 2410 bool 2411 gfc_check_complex (gfc_expr *x, gfc_expr *y) 2412 { 2413 if (!boz_args_check (x, y)) 2414 return false; 2415 2416 if (x->ts.type == BT_BOZ) 2417 { 2418 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" 2419 " intrinsic subprogram"), &x->where)) 2420 { 2421 reset_boz (x); 2422 return false; 2423 } 2424 if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind)) 2425 return false; 2426 if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind)) 2427 return false; 2428 } 2429 2430 if (y->ts.type == BT_BOZ) 2431 { 2432 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" 2433 " intrinsic subprogram"), &y->where)) 2434 { 2435 reset_boz (y); 2436 return false; 2437 } 2438 if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind)) 2439 return false; 2440 if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind)) 2441 return false; 2442 } 2443 2444 if (!int_or_real_check (x, 0)) 2445 return false; 2446 if (!scalar_check (x, 0)) 2447 return false; 2448 2449 if (!int_or_real_check (y, 1)) 2450 return false; 2451 if (!scalar_check (y, 1)) 2452 return false; 2453 2454 return true; 2455 } 2456 2457 2458 bool 2459 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 2460 { 2461 if (!logical_array_check (mask, 0)) 2462 return false; 2463 if (!dim_check (dim, 1, false)) 2464 return false; 2465 if (!dim_rank_check (dim, mask, 0)) 2466 return false; 2467 if (!kind_check (kind, 2, BT_INTEGER)) 2468 return false; 2469 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2470 "with KIND argument at %L", 2471 gfc_current_intrinsic, &kind->where)) 2472 return false; 2473 2474 return true; 2475 } 2476 2477 2478 bool 2479 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) 2480 { 2481 if (!array_check (array, 0)) 2482 return false; 2483 2484 if (!type_check (shift, 1, BT_INTEGER)) 2485 return false; 2486 2487 if (!dim_check (dim, 2, true)) 2488 return false; 2489 2490 if (!dim_rank_check (dim, array, false)) 2491 return false; 2492 2493 if (array->rank == 1 || shift->rank == 0) 2494 { 2495 if (!scalar_check (shift, 1)) 2496 return false; 2497 } 2498 else if (shift->rank == array->rank - 1) 2499 { 2500 int d; 2501 if (!dim) 2502 d = 1; 2503 else if (dim->expr_type == EXPR_CONSTANT) 2504 gfc_extract_int (dim, &d); 2505 else 2506 d = -1; 2507 2508 if (d > 0) 2509 { 2510 int i, j; 2511 for (i = 0, j = 0; i < array->rank; i++) 2512 if (i != d - 1) 2513 { 2514 if (!identical_dimen_shape (array, i, shift, j)) 2515 { 2516 gfc_error ("%qs argument of %qs intrinsic at %L has " 2517 "invalid shape in dimension %d (%ld/%ld)", 2518 gfc_current_intrinsic_arg[1]->name, 2519 gfc_current_intrinsic, &shift->where, i + 1, 2520 mpz_get_si (array->shape[i]), 2521 mpz_get_si (shift->shape[j])); 2522 return false; 2523 } 2524 2525 j += 1; 2526 } 2527 } 2528 } 2529 else 2530 { 2531 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " 2532 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, 2533 gfc_current_intrinsic, &shift->where, array->rank - 1); 2534 return false; 2535 } 2536 2537 return true; 2538 } 2539 2540 2541 bool 2542 gfc_check_ctime (gfc_expr *time) 2543 { 2544 if (!scalar_check (time, 0)) 2545 return false; 2546 2547 if (!type_check (time, 0, BT_INTEGER)) 2548 return false; 2549 2550 return true; 2551 } 2552 2553 2554 bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) 2555 { 2556 if (!double_check (y, 0) || !double_check (x, 1)) 2557 return false; 2558 2559 return true; 2560 } 2561 2562 bool 2563 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) 2564 { 2565 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) 2566 return false; 2567 2568 if (!numeric_check (x, 0)) 2569 return false; 2570 2571 if (y != NULL) 2572 { 2573 if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind)) 2574 return false; 2575 2576 if (!numeric_check (y, 1)) 2577 return false; 2578 2579 if (x->ts.type == BT_COMPLEX) 2580 { 2581 gfc_error ("%qs argument of %qs intrinsic at %L must not be " 2582 "present if %<x%> is COMPLEX", 2583 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2584 &y->where); 2585 return false; 2586 } 2587 2588 if (y->ts.type == BT_COMPLEX) 2589 { 2590 gfc_error ("%qs argument of %qs intrinsic at %L must have a type " 2591 "of either REAL or INTEGER", 2592 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2593 &y->where); 2594 return false; 2595 } 2596 } 2597 2598 return true; 2599 } 2600 2601 2602 bool 2603 gfc_check_dble (gfc_expr *x) 2604 { 2605 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) 2606 return false; 2607 2608 if (!numeric_check (x, 0)) 2609 return false; 2610 2611 return true; 2612 } 2613 2614 2615 bool 2616 gfc_check_digits (gfc_expr *x) 2617 { 2618 if (!int_or_real_check (x, 0)) 2619 return false; 2620 2621 return true; 2622 } 2623 2624 2625 bool 2626 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) 2627 { 2628 switch (vector_a->ts.type) 2629 { 2630 case BT_LOGICAL: 2631 if (!type_check (vector_b, 1, BT_LOGICAL)) 2632 return false; 2633 break; 2634 2635 case BT_INTEGER: 2636 case BT_REAL: 2637 case BT_COMPLEX: 2638 if (!numeric_check (vector_b, 1)) 2639 return false; 2640 break; 2641 2642 default: 2643 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 2644 "or LOGICAL", gfc_current_intrinsic_arg[0]->name, 2645 gfc_current_intrinsic, &vector_a->where); 2646 return false; 2647 } 2648 2649 if (!rank_check (vector_a, 0, 1)) 2650 return false; 2651 2652 if (!rank_check (vector_b, 1, 1)) 2653 return false; 2654 2655 if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) 2656 { 2657 gfc_error ("Different shape for arguments %qs and %qs at %L for " 2658 "intrinsic %<dot_product%>", 2659 gfc_current_intrinsic_arg[0]->name, 2660 gfc_current_intrinsic_arg[1]->name, &vector_a->where); 2661 return false; 2662 } 2663 2664 return true; 2665 } 2666 2667 2668 bool 2669 gfc_check_dprod (gfc_expr *x, gfc_expr *y) 2670 { 2671 if (!type_check (x, 0, BT_REAL) 2672 || !type_check (y, 1, BT_REAL)) 2673 return false; 2674 2675 if (x->ts.kind != gfc_default_real_kind) 2676 { 2677 gfc_error ("%qs argument of %qs intrinsic at %L must be default " 2678 "real", gfc_current_intrinsic_arg[0]->name, 2679 gfc_current_intrinsic, &x->where); 2680 return false; 2681 } 2682 2683 if (y->ts.kind != gfc_default_real_kind) 2684 { 2685 gfc_error ("%qs argument of %qs intrinsic at %L must be default " 2686 "real", gfc_current_intrinsic_arg[1]->name, 2687 gfc_current_intrinsic, &y->where); 2688 return false; 2689 } 2690 2691 return true; 2692 } 2693 2694 bool 2695 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) 2696 { 2697 /* i and j cannot both be BOZ literal constants. */ 2698 if (!boz_args_check (i, j)) 2699 return false; 2700 2701 /* If i is BOZ and j is integer, convert i to type of j. If j is not 2702 an integer, clear the BOZ; otherwise, check that i is an integer. */ 2703 if (i->ts.type == BT_BOZ) 2704 { 2705 if (j->ts.type != BT_INTEGER) 2706 reset_boz (i); 2707 else if (!gfc_boz2int (i, j->ts.kind)) 2708 return false; 2709 } 2710 else if (!type_check (i, 0, BT_INTEGER)) 2711 { 2712 if (j->ts.type == BT_BOZ) 2713 reset_boz (j); 2714 return false; 2715 } 2716 2717 /* If j is BOZ and i is integer, convert j to type of i. If i is not 2718 an integer, clear the BOZ; otherwise, check that i is an integer. */ 2719 if (j->ts.type == BT_BOZ) 2720 { 2721 if (i->ts.type != BT_INTEGER) 2722 reset_boz (j); 2723 else if (!gfc_boz2int (j, i->ts.kind)) 2724 return false; 2725 } 2726 else if (!type_check (j, 1, BT_INTEGER)) 2727 return false; 2728 2729 if (!same_type_check (i, 0, j, 1)) 2730 return false; 2731 2732 if (!type_check (shift, 2, BT_INTEGER)) 2733 return false; 2734 2735 if (!nonnegative_check ("SHIFT", shift)) 2736 return false; 2737 2738 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) 2739 return false; 2740 2741 return true; 2742 } 2743 2744 2745 bool 2746 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, 2747 gfc_expr *dim) 2748 { 2749 int d; 2750 2751 if (!array_check (array, 0)) 2752 return false; 2753 2754 if (!type_check (shift, 1, BT_INTEGER)) 2755 return false; 2756 2757 if (!dim_check (dim, 3, true)) 2758 return false; 2759 2760 if (!dim_rank_check (dim, array, false)) 2761 return false; 2762 2763 if (!dim) 2764 d = 1; 2765 else if (dim->expr_type == EXPR_CONSTANT) 2766 gfc_extract_int (dim, &d); 2767 else 2768 d = -1; 2769 2770 if (array->rank == 1 || shift->rank == 0) 2771 { 2772 if (!scalar_check (shift, 1)) 2773 return false; 2774 } 2775 else if (shift->rank == array->rank - 1) 2776 { 2777 if (d > 0) 2778 { 2779 int i, j; 2780 for (i = 0, j = 0; i < array->rank; i++) 2781 if (i != d - 1) 2782 { 2783 if (!identical_dimen_shape (array, i, shift, j)) 2784 { 2785 gfc_error ("%qs argument of %qs intrinsic at %L has " 2786 "invalid shape in dimension %d (%ld/%ld)", 2787 gfc_current_intrinsic_arg[1]->name, 2788 gfc_current_intrinsic, &shift->where, i + 1, 2789 mpz_get_si (array->shape[i]), 2790 mpz_get_si (shift->shape[j])); 2791 return false; 2792 } 2793 2794 j += 1; 2795 } 2796 } 2797 } 2798 else 2799 { 2800 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " 2801 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, 2802 gfc_current_intrinsic, &shift->where, array->rank - 1); 2803 return false; 2804 } 2805 2806 if (boundary != NULL) 2807 { 2808 if (!same_type_check (array, 0, boundary, 2)) 2809 return false; 2810 2811 /* Reject unequal string lengths and emit a better error message than 2812 gfc_check_same_strlen would. */ 2813 if (array->ts.type == BT_CHARACTER) 2814 { 2815 ssize_t len_a, len_b; 2816 2817 len_a = gfc_var_strlen (array); 2818 len_b = gfc_var_strlen (boundary); 2819 if (len_a != -1 && len_b != -1 && len_a != len_b) 2820 { 2821 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", 2822 gfc_current_intrinsic_arg[2]->name, 2823 gfc_current_intrinsic_arg[0]->name, 2824 &boundary->where, gfc_current_intrinsic); 2825 return false; 2826 } 2827 } 2828 2829 if (array->rank == 1 || boundary->rank == 0) 2830 { 2831 if (!scalar_check (boundary, 2)) 2832 return false; 2833 } 2834 else if (boundary->rank == array->rank - 1) 2835 { 2836 if (d > 0) 2837 { 2838 int i,j; 2839 for (i = 0, j = 0; i < array->rank; i++) 2840 { 2841 if (i != d - 1) 2842 { 2843 if (!identical_dimen_shape (array, i, boundary, j)) 2844 { 2845 gfc_error ("%qs argument of %qs intrinsic at %L has " 2846 "invalid shape in dimension %d (%ld/%ld)", 2847 gfc_current_intrinsic_arg[2]->name, 2848 gfc_current_intrinsic, &shift->where, i+1, 2849 mpz_get_si (array->shape[i]), 2850 mpz_get_si (boundary->shape[j])); 2851 return false; 2852 } 2853 j += 1; 2854 } 2855 } 2856 } 2857 } 2858 else 2859 { 2860 gfc_error ("%qs argument of intrinsic %qs at %L of must have " 2861 "rank %d or be a scalar", 2862 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2863 &shift->where, array->rank - 1); 2864 return false; 2865 } 2866 } 2867 else 2868 { 2869 switch (array->ts.type) 2870 { 2871 case BT_INTEGER: 2872 case BT_LOGICAL: 2873 case BT_REAL: 2874 case BT_COMPLEX: 2875 case BT_CHARACTER: 2876 break; 2877 2878 default: 2879 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs " 2880 "of type %qs", gfc_current_intrinsic_arg[2]->name, 2881 gfc_current_intrinsic, &array->where, 2882 gfc_current_intrinsic_arg[0]->name, 2883 gfc_typename (array)); 2884 return false; 2885 } 2886 } 2887 2888 return true; 2889 } 2890 2891 2892 bool 2893 gfc_check_float (gfc_expr *a) 2894 { 2895 if (a->ts.type == BT_BOZ) 2896 { 2897 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the" 2898 " FLOAT intrinsic subprogram"), &a->where)) 2899 { 2900 reset_boz (a); 2901 return false; 2902 } 2903 if (!gfc_boz2int (a, gfc_default_integer_kind)) 2904 return false; 2905 } 2906 2907 if (!type_check (a, 0, BT_INTEGER)) 2908 return false; 2909 2910 if ((a->ts.kind != gfc_default_integer_kind) 2911 && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " 2912 "kind argument to %s intrinsic at %L", 2913 gfc_current_intrinsic, &a->where)) 2914 return false; 2915 2916 return true; 2917 } 2918 2919 /* A single complex argument. */ 2920 2921 bool 2922 gfc_check_fn_c (gfc_expr *a) 2923 { 2924 if (!type_check (a, 0, BT_COMPLEX)) 2925 return false; 2926 2927 return true; 2928 } 2929 2930 2931 /* A single real argument. */ 2932 2933 bool 2934 gfc_check_fn_r (gfc_expr *a) 2935 { 2936 if (!type_check (a, 0, BT_REAL)) 2937 return false; 2938 2939 return true; 2940 } 2941 2942 /* A single double argument. */ 2943 2944 bool 2945 gfc_check_fn_d (gfc_expr *a) 2946 { 2947 if (!double_check (a, 0)) 2948 return false; 2949 2950 return true; 2951 } 2952 2953 /* A single real or complex argument. */ 2954 2955 bool 2956 gfc_check_fn_rc (gfc_expr *a) 2957 { 2958 if (!real_or_complex_check (a, 0)) 2959 return false; 2960 2961 return true; 2962 } 2963 2964 2965 bool 2966 gfc_check_fn_rc2008 (gfc_expr *a) 2967 { 2968 if (!real_or_complex_check (a, 0)) 2969 return false; 2970 2971 if (a->ts.type == BT_COMPLEX 2972 && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs " 2973 "of %qs intrinsic at %L", 2974 gfc_current_intrinsic_arg[0]->name, 2975 gfc_current_intrinsic, &a->where)) 2976 return false; 2977 2978 return true; 2979 } 2980 2981 2982 bool 2983 gfc_check_fnum (gfc_expr *unit) 2984 { 2985 if (!type_check (unit, 0, BT_INTEGER)) 2986 return false; 2987 2988 if (!scalar_check (unit, 0)) 2989 return false; 2990 2991 return true; 2992 } 2993 2994 2995 bool 2996 gfc_check_huge (gfc_expr *x) 2997 { 2998 if (!int_or_real_check (x, 0)) 2999 return false; 3000 3001 return true; 3002 } 3003 3004 3005 bool 3006 gfc_check_hypot (gfc_expr *x, gfc_expr *y) 3007 { 3008 if (!type_check (x, 0, BT_REAL)) 3009 return false; 3010 if (!same_type_check (x, 0, y, 1)) 3011 return false; 3012 3013 return true; 3014 } 3015 3016 3017 /* Check that the single argument is an integer. */ 3018 3019 bool 3020 gfc_check_i (gfc_expr *i) 3021 { 3022 if (!type_check (i, 0, BT_INTEGER)) 3023 return false; 3024 3025 return true; 3026 } 3027 3028 3029 bool 3030 gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) 3031 { 3032 /* i and j cannot both be BOZ literal constants. */ 3033 if (!boz_args_check (i, j)) 3034 return false; 3035 3036 /* If i is BOZ and j is integer, convert i to type of j. */ 3037 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER 3038 && !gfc_boz2int (i, j->ts.kind)) 3039 return false; 3040 3041 /* If j is BOZ and i is integer, convert j to type of i. */ 3042 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER 3043 && !gfc_boz2int (j, i->ts.kind)) 3044 return false; 3045 3046 if (!type_check (i, 0, BT_INTEGER)) 3047 return false; 3048 3049 if (!type_check (j, 1, BT_INTEGER)) 3050 return false; 3051 3052 if (i->ts.kind != j->ts.kind) 3053 { 3054 gfc_error ("Arguments of %qs have different kind type parameters " 3055 "at %L", gfc_current_intrinsic, &i->where); 3056 return false; 3057 } 3058 3059 return true; 3060 } 3061 3062 3063 bool 3064 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) 3065 { 3066 if (!type_check (i, 0, BT_INTEGER)) 3067 return false; 3068 3069 if (!type_check (pos, 1, BT_INTEGER)) 3070 return false; 3071 3072 if (!type_check (len, 2, BT_INTEGER)) 3073 return false; 3074 3075 if (!nonnegative_check ("pos", pos)) 3076 return false; 3077 3078 if (!nonnegative_check ("len", len)) 3079 return false; 3080 3081 if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) 3082 return false; 3083 3084 return true; 3085 } 3086 3087 3088 bool 3089 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) 3090 { 3091 int i; 3092 3093 if (!type_check (c, 0, BT_CHARACTER)) 3094 return false; 3095 3096 if (!kind_check (kind, 1, BT_INTEGER)) 3097 return false; 3098 3099 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3100 "with KIND argument at %L", 3101 gfc_current_intrinsic, &kind->where)) 3102 return false; 3103 3104 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) 3105 { 3106 gfc_expr *start; 3107 gfc_expr *end; 3108 gfc_ref *ref; 3109 3110 /* Substring references don't have the charlength set. */ 3111 ref = c->ref; 3112 while (ref && ref->type != REF_SUBSTRING) 3113 ref = ref->next; 3114 3115 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); 3116 3117 if (!ref) 3118 { 3119 /* Check that the argument is length one. Non-constant lengths 3120 can't be checked here, so assume they are ok. */ 3121 if (c->ts.u.cl && c->ts.u.cl->length) 3122 { 3123 /* If we already have a length for this expression then use it. */ 3124 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) 3125 return true; 3126 i = mpz_get_si (c->ts.u.cl->length->value.integer); 3127 } 3128 else 3129 return true; 3130 } 3131 else 3132 { 3133 start = ref->u.ss.start; 3134 end = ref->u.ss.end; 3135 3136 gcc_assert (start); 3137 if (end == NULL || end->expr_type != EXPR_CONSTANT 3138 || start->expr_type != EXPR_CONSTANT) 3139 return true; 3140 3141 i = mpz_get_si (end->value.integer) + 1 3142 - mpz_get_si (start->value.integer); 3143 } 3144 } 3145 else 3146 return true; 3147 3148 if (i != 1) 3149 { 3150 gfc_error ("Argument of %s at %L must be of length one", 3151 gfc_current_intrinsic, &c->where); 3152 return false; 3153 } 3154 3155 return true; 3156 } 3157 3158 3159 bool 3160 gfc_check_idnint (gfc_expr *a) 3161 { 3162 if (!double_check (a, 0)) 3163 return false; 3164 3165 return true; 3166 } 3167 3168 3169 bool 3170 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, 3171 gfc_expr *kind) 3172 { 3173 if (!type_check (string, 0, BT_CHARACTER) 3174 || !type_check (substring, 1, BT_CHARACTER)) 3175 return false; 3176 3177 if (back != NULL && !type_check (back, 2, BT_LOGICAL)) 3178 return false; 3179 3180 if (!kind_check (kind, 3, BT_INTEGER)) 3181 return false; 3182 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3183 "with KIND argument at %L", 3184 gfc_current_intrinsic, &kind->where)) 3185 return false; 3186 3187 if (string->ts.kind != substring->ts.kind) 3188 { 3189 gfc_error ("%qs argument of %qs intrinsic at %L must be the same " 3190 "kind as %qs", gfc_current_intrinsic_arg[1]->name, 3191 gfc_current_intrinsic, &substring->where, 3192 gfc_current_intrinsic_arg[0]->name); 3193 return false; 3194 } 3195 3196 return true; 3197 } 3198 3199 3200 bool 3201 gfc_check_int (gfc_expr *x, gfc_expr *kind) 3202 { 3203 /* BOZ is dealt within simplify_int*. */ 3204 if (x->ts.type == BT_BOZ) 3205 return true; 3206 3207 if (!numeric_check (x, 0)) 3208 return false; 3209 3210 if (!kind_check (kind, 1, BT_INTEGER)) 3211 return false; 3212 3213 return true; 3214 } 3215 3216 3217 bool 3218 gfc_check_intconv (gfc_expr *x) 3219 { 3220 if (strcmp (gfc_current_intrinsic, "short") == 0 3221 || strcmp (gfc_current_intrinsic, "long") == 0) 3222 { 3223 gfc_error ("%qs intrinsic subprogram at %L has been removed. " 3224 "Use INT intrinsic subprogram.", gfc_current_intrinsic, 3225 &x->where); 3226 return false; 3227 } 3228 3229 /* BOZ is dealt within simplify_int*. */ 3230 if (x->ts.type == BT_BOZ) 3231 return true; 3232 3233 if (!numeric_check (x, 0)) 3234 return false; 3235 3236 return true; 3237 } 3238 3239 bool 3240 gfc_check_ishft (gfc_expr *i, gfc_expr *shift) 3241 { 3242 if (!type_check (i, 0, BT_INTEGER) 3243 || !type_check (shift, 1, BT_INTEGER)) 3244 return false; 3245 3246 if (!less_than_bitsize1 ("I", i, NULL, shift, true)) 3247 return false; 3248 3249 return true; 3250 } 3251 3252 3253 bool 3254 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) 3255 { 3256 if (!type_check (i, 0, BT_INTEGER) 3257 || !type_check (shift, 1, BT_INTEGER)) 3258 return false; 3259 3260 if (size != NULL) 3261 { 3262 int i2, i3; 3263 3264 if (!type_check (size, 2, BT_INTEGER)) 3265 return false; 3266 3267 if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) 3268 return false; 3269 3270 if (size->expr_type == EXPR_CONSTANT) 3271 { 3272 gfc_extract_int (size, &i3); 3273 if (i3 <= 0) 3274 { 3275 gfc_error ("SIZE at %L must be positive", &size->where); 3276 return false; 3277 } 3278 3279 if (shift->expr_type == EXPR_CONSTANT) 3280 { 3281 gfc_extract_int (shift, &i2); 3282 if (i2 < 0) 3283 i2 = -i2; 3284 3285 if (i2 > i3) 3286 { 3287 gfc_error ("The absolute value of SHIFT at %L must be less " 3288 "than or equal to SIZE at %L", &shift->where, 3289 &size->where); 3290 return false; 3291 } 3292 } 3293 } 3294 } 3295 else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) 3296 return false; 3297 3298 return true; 3299 } 3300 3301 3302 bool 3303 gfc_check_kill (gfc_expr *pid, gfc_expr *sig) 3304 { 3305 if (!type_check (pid, 0, BT_INTEGER)) 3306 return false; 3307 3308 if (!scalar_check (pid, 0)) 3309 return false; 3310 3311 if (!type_check (sig, 1, BT_INTEGER)) 3312 return false; 3313 3314 if (!scalar_check (sig, 1)) 3315 return false; 3316 3317 return true; 3318 } 3319 3320 3321 bool 3322 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) 3323 { 3324 if (!type_check (pid, 0, BT_INTEGER)) 3325 return false; 3326 3327 if (!scalar_check (pid, 0)) 3328 return false; 3329 3330 if (!type_check (sig, 1, BT_INTEGER)) 3331 return false; 3332 3333 if (!scalar_check (sig, 1)) 3334 return false; 3335 3336 if (status) 3337 { 3338 if (!type_check (status, 2, BT_INTEGER)) 3339 return false; 3340 3341 if (!scalar_check (status, 2)) 3342 return false; 3343 3344 if (status->expr_type != EXPR_VARIABLE) 3345 { 3346 gfc_error ("STATUS at %L shall be an INTENT(OUT) variable", 3347 &status->where); 3348 return false; 3349 } 3350 3351 if (status->expr_type == EXPR_VARIABLE 3352 && status->symtree && status->symtree->n.sym 3353 && status->symtree->n.sym->attr.intent == INTENT_IN) 3354 { 3355 gfc_error ("%qs at %L shall be an INTENT(OUT) variable", 3356 status->symtree->name, &status->where); 3357 return false; 3358 } 3359 } 3360 3361 return true; 3362 } 3363 3364 3365 bool 3366 gfc_check_kind (gfc_expr *x) 3367 { 3368 if (gfc_invalid_null_arg (x)) 3369 return false; 3370 3371 if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) 3372 { 3373 gfc_error ("%qs argument of %qs intrinsic at %L must be of " 3374 "intrinsic type", gfc_current_intrinsic_arg[0]->name, 3375 gfc_current_intrinsic, &x->where); 3376 return false; 3377 } 3378 if (x->ts.type == BT_PROCEDURE) 3379 { 3380 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity", 3381 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 3382 &x->where); 3383 return false; 3384 } 3385 3386 return true; 3387 } 3388 3389 3390 bool 3391 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 3392 { 3393 if (!array_check (array, 0)) 3394 return false; 3395 3396 if (!dim_check (dim, 1, false)) 3397 return false; 3398 3399 if (!dim_rank_check (dim, array, 1)) 3400 return false; 3401 3402 if (!kind_check (kind, 2, BT_INTEGER)) 3403 return false; 3404 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3405 "with KIND argument at %L", 3406 gfc_current_intrinsic, &kind->where)) 3407 return false; 3408 3409 return true; 3410 } 3411 3412 3413 bool 3414 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) 3415 { 3416 if (flag_coarray == GFC_FCOARRAY_NONE) 3417 { 3418 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 3419 return false; 3420 } 3421 3422 if (!coarray_check (coarray, 0)) 3423 return false; 3424 3425 if (dim != NULL) 3426 { 3427 if (!dim_check (dim, 1, false)) 3428 return false; 3429 3430 if (!dim_corank_check (dim, coarray)) 3431 return false; 3432 } 3433 3434 if (!kind_check (kind, 2, BT_INTEGER)) 3435 return false; 3436 3437 return true; 3438 } 3439 3440 3441 bool 3442 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) 3443 { 3444 if (!type_check (s, 0, BT_CHARACTER)) 3445 return false; 3446 3447 if (gfc_invalid_null_arg (s)) 3448 return false; 3449 3450 if (!kind_check (kind, 1, BT_INTEGER)) 3451 return false; 3452 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3453 "with KIND argument at %L", 3454 gfc_current_intrinsic, &kind->where)) 3455 return false; 3456 3457 return true; 3458 } 3459 3460 3461 bool 3462 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) 3463 { 3464 if (!type_check (a, 0, BT_CHARACTER)) 3465 return false; 3466 if (!kind_value_check (a, 0, gfc_default_character_kind)) 3467 return false; 3468 3469 if (!type_check (b, 1, BT_CHARACTER)) 3470 return false; 3471 if (!kind_value_check (b, 1, gfc_default_character_kind)) 3472 return false; 3473 3474 return true; 3475 } 3476 3477 3478 bool 3479 gfc_check_link (gfc_expr *path1, gfc_expr *path2) 3480 { 3481 if (!type_check (path1, 0, BT_CHARACTER)) 3482 return false; 3483 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 3484 return false; 3485 3486 if (!type_check (path2, 1, BT_CHARACTER)) 3487 return false; 3488 if (!kind_value_check (path2, 1, gfc_default_character_kind)) 3489 return false; 3490 3491 return true; 3492 } 3493 3494 3495 bool 3496 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 3497 { 3498 if (!type_check (path1, 0, BT_CHARACTER)) 3499 return false; 3500 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 3501 return false; 3502 3503 if (!type_check (path2, 1, BT_CHARACTER)) 3504 return false; 3505 if (!kind_value_check (path2, 0, gfc_default_character_kind)) 3506 return false; 3507 3508 if (status == NULL) 3509 return true; 3510 3511 if (!type_check (status, 2, BT_INTEGER)) 3512 return false; 3513 3514 if (!scalar_check (status, 2)) 3515 return false; 3516 3517 return true; 3518 } 3519 3520 3521 bool 3522 gfc_check_loc (gfc_expr *expr) 3523 { 3524 return variable_check (expr, 0, true); 3525 } 3526 3527 3528 bool 3529 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) 3530 { 3531 if (!type_check (path1, 0, BT_CHARACTER)) 3532 return false; 3533 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 3534 return false; 3535 3536 if (!type_check (path2, 1, BT_CHARACTER)) 3537 return false; 3538 if (!kind_value_check (path2, 1, gfc_default_character_kind)) 3539 return false; 3540 3541 return true; 3542 } 3543 3544 3545 bool 3546 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 3547 { 3548 if (!type_check (path1, 0, BT_CHARACTER)) 3549 return false; 3550 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 3551 return false; 3552 3553 if (!type_check (path2, 1, BT_CHARACTER)) 3554 return false; 3555 if (!kind_value_check (path2, 1, gfc_default_character_kind)) 3556 return false; 3557 3558 if (status == NULL) 3559 return true; 3560 3561 if (!type_check (status, 2, BT_INTEGER)) 3562 return false; 3563 3564 if (!scalar_check (status, 2)) 3565 return false; 3566 3567 return true; 3568 } 3569 3570 3571 bool 3572 gfc_check_logical (gfc_expr *a, gfc_expr *kind) 3573 { 3574 if (!type_check (a, 0, BT_LOGICAL)) 3575 return false; 3576 if (!kind_check (kind, 1, BT_LOGICAL)) 3577 return false; 3578 3579 return true; 3580 } 3581 3582 3583 /* Min/max family. */ 3584 3585 static bool 3586 min_max_args (gfc_actual_arglist *args) 3587 { 3588 gfc_actual_arglist *arg; 3589 int i, j, nargs, *nlabels, nlabelless; 3590 bool a1 = false, a2 = false; 3591 3592 if (args == NULL || args->next == NULL) 3593 { 3594 gfc_error ("Intrinsic %qs at %L must have at least two arguments", 3595 gfc_current_intrinsic, gfc_current_intrinsic_where); 3596 return false; 3597 } 3598 3599 if (!args->name) 3600 a1 = true; 3601 3602 if (!args->next->name) 3603 a2 = true; 3604 3605 nargs = 0; 3606 for (arg = args; arg; arg = arg->next) 3607 if (arg->name) 3608 nargs++; 3609 3610 if (nargs == 0) 3611 return true; 3612 3613 /* Note: Having a keywordless argument after an "arg=" is checked before. */ 3614 nlabelless = 0; 3615 nlabels = XALLOCAVEC (int, nargs); 3616 for (arg = args, i = 0; arg; arg = arg->next, i++) 3617 if (arg->name) 3618 { 3619 int n; 3620 char *endp; 3621 3622 if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9') 3623 goto unknown; 3624 n = strtol (&arg->name[1], &endp, 10); 3625 if (endp[0] != '\0') 3626 goto unknown; 3627 if (n <= 0) 3628 goto unknown; 3629 if (n <= nlabelless) 3630 goto duplicate; 3631 nlabels[i] = n; 3632 if (n == 1) 3633 a1 = true; 3634 if (n == 2) 3635 a2 = true; 3636 } 3637 else 3638 nlabelless++; 3639 3640 if (!a1 || !a2) 3641 { 3642 gfc_error ("Missing %qs argument to the %s intrinsic at %L", 3643 !a1 ? "a1" : "a2", gfc_current_intrinsic, 3644 gfc_current_intrinsic_where); 3645 return false; 3646 } 3647 3648 /* Check for duplicates. */ 3649 for (i = 0; i < nargs; i++) 3650 for (j = i + 1; j < nargs; j++) 3651 if (nlabels[i] == nlabels[j]) 3652 goto duplicate; 3653 3654 return true; 3655 3656 duplicate: 3657 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, 3658 &arg->expr->where, gfc_current_intrinsic); 3659 return false; 3660 3661 unknown: 3662 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, 3663 &arg->expr->where, gfc_current_intrinsic); 3664 return false; 3665 } 3666 3667 3668 static bool 3669 check_rest (bt type, int kind, gfc_actual_arglist *arglist) 3670 { 3671 gfc_actual_arglist *arg, *tmp; 3672 gfc_expr *x; 3673 int m, n; 3674 3675 if (!min_max_args (arglist)) 3676 return false; 3677 3678 for (arg = arglist, n=1; arg; arg = arg->next, n++) 3679 { 3680 x = arg->expr; 3681 if (x->ts.type != type || x->ts.kind != kind) 3682 { 3683 if (x->ts.type == type) 3684 { 3685 if (x->ts.type == BT_CHARACTER) 3686 { 3687 gfc_error ("Different character kinds at %L", &x->where); 3688 return false; 3689 } 3690 if (!gfc_notify_std (GFC_STD_GNU, "Different type " 3691 "kinds at %L", &x->where)) 3692 return false; 3693 } 3694 else 3695 { 3696 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be " 3697 "%s(%d)", n, gfc_current_intrinsic, &x->where, 3698 gfc_basic_typename (type), kind); 3699 return false; 3700 } 3701 } 3702 3703 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) 3704 if (!gfc_check_conformance (tmp->expr, x, 3705 _("arguments 'a%d' and 'a%d' for " 3706 "intrinsic '%s'"), m, n, 3707 gfc_current_intrinsic)) 3708 return false; 3709 } 3710 3711 return true; 3712 } 3713 3714 3715 bool 3716 gfc_check_min_max (gfc_actual_arglist *arg) 3717 { 3718 gfc_expr *x; 3719 3720 if (!min_max_args (arg)) 3721 return false; 3722 3723 x = arg->expr; 3724 3725 if (x->ts.type == BT_CHARACTER) 3726 { 3727 if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3728 "with CHARACTER argument at %L", 3729 gfc_current_intrinsic, &x->where)) 3730 return false; 3731 } 3732 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) 3733 { 3734 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, " 3735 "REAL or CHARACTER", gfc_current_intrinsic, &x->where); 3736 return false; 3737 } 3738 3739 return check_rest (x->ts.type, x->ts.kind, arg); 3740 } 3741 3742 3743 bool 3744 gfc_check_min_max_integer (gfc_actual_arglist *arg) 3745 { 3746 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); 3747 } 3748 3749 3750 bool 3751 gfc_check_min_max_real (gfc_actual_arglist *arg) 3752 { 3753 return check_rest (BT_REAL, gfc_default_real_kind, arg); 3754 } 3755 3756 3757 bool 3758 gfc_check_min_max_double (gfc_actual_arglist *arg) 3759 { 3760 return check_rest (BT_REAL, gfc_default_double_kind, arg); 3761 } 3762 3763 3764 /* End of min/max family. */ 3765 3766 bool 3767 gfc_check_malloc (gfc_expr *size) 3768 { 3769 if (!type_check (size, 0, BT_INTEGER)) 3770 return false; 3771 3772 if (!scalar_check (size, 0)) 3773 return false; 3774 3775 return true; 3776 } 3777 3778 3779 bool 3780 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 3781 { 3782 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) 3783 { 3784 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 3785 "or LOGICAL", gfc_current_intrinsic_arg[0]->name, 3786 gfc_current_intrinsic, &matrix_a->where); 3787 return false; 3788 } 3789 3790 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) 3791 { 3792 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 3793 "or LOGICAL", gfc_current_intrinsic_arg[1]->name, 3794 gfc_current_intrinsic, &matrix_b->where); 3795 return false; 3796 } 3797 3798 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) 3799 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) 3800 { 3801 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", 3802 gfc_current_intrinsic, &matrix_a->where, 3803 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); 3804 return false; 3805 } 3806 3807 switch (matrix_a->rank) 3808 { 3809 case 1: 3810 if (!rank_check (matrix_b, 1, 2)) 3811 return false; 3812 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ 3813 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) 3814 { 3815 gfc_error ("Different shape on dimension 1 for arguments %qs " 3816 "and %qs at %L for intrinsic matmul", 3817 gfc_current_intrinsic_arg[0]->name, 3818 gfc_current_intrinsic_arg[1]->name, &matrix_a->where); 3819 return false; 3820 } 3821 break; 3822 3823 case 2: 3824 if (matrix_b->rank != 2) 3825 { 3826 if (!rank_check (matrix_b, 1, 1)) 3827 return false; 3828 } 3829 /* matrix_b has rank 1 or 2 here. Common check for the cases 3830 - matrix_a has shape (n,m) and matrix_b has shape (m, k) 3831 - matrix_a has shape (n,m) and matrix_b has shape (m). */ 3832 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) 3833 { 3834 gfc_error ("Different shape on dimension 2 for argument %qs and " 3835 "dimension 1 for argument %qs at %L for intrinsic " 3836 "matmul", gfc_current_intrinsic_arg[0]->name, 3837 gfc_current_intrinsic_arg[1]->name, &matrix_a->where); 3838 return false; 3839 } 3840 break; 3841 3842 default: 3843 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " 3844 "1 or 2", gfc_current_intrinsic_arg[0]->name, 3845 gfc_current_intrinsic, &matrix_a->where); 3846 return false; 3847 } 3848 3849 return true; 3850 } 3851 3852 3853 /* Whoever came up with this interface was probably on something. 3854 The possibilities for the occupation of the second and third 3855 parameters are: 3856 3857 Arg #2 Arg #3 3858 NULL NULL 3859 DIM NULL 3860 MASK NULL 3861 NULL MASK minloc(array, mask=m) 3862 DIM MASK 3863 3864 I.e. in the case of minloc(array,mask), mask will be in the second 3865 position of the argument list and we'll have to fix that up. Also, 3866 add the BACK argument if that isn't present. */ 3867 3868 bool 3869 gfc_check_minloc_maxloc (gfc_actual_arglist *ap) 3870 { 3871 gfc_expr *a, *m, *d, *k, *b; 3872 3873 a = ap->expr; 3874 if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0)) 3875 return false; 3876 3877 d = ap->next->expr; 3878 m = ap->next->next->expr; 3879 k = ap->next->next->next->expr; 3880 b = ap->next->next->next->next->expr; 3881 3882 if (b) 3883 { 3884 if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4)) 3885 return false; 3886 } 3887 else 3888 { 3889 b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); 3890 ap->next->next->next->next->expr = b; 3891 ap->next->next->next->next->name = gfc_get_string ("back"); 3892 } 3893 3894 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL 3895 && ap->next->name == NULL) 3896 { 3897 m = d; 3898 d = NULL; 3899 ap->next->expr = NULL; 3900 ap->next->next->expr = m; 3901 } 3902 3903 if (!dim_check (d, 1, false)) 3904 return false; 3905 3906 if (!dim_rank_check (d, a, 0)) 3907 return false; 3908 3909 if (m != NULL && !type_check (m, 2, BT_LOGICAL)) 3910 return false; 3911 3912 if (m != NULL 3913 && !gfc_check_conformance (a, m, 3914 _("arguments '%s' and '%s' for intrinsic %s"), 3915 gfc_current_intrinsic_arg[0]->name, 3916 gfc_current_intrinsic_arg[2]->name, 3917 gfc_current_intrinsic)) 3918 return false; 3919 3920 if (!kind_check (k, 1, BT_INTEGER)) 3921 return false; 3922 3923 return true; 3924 } 3925 3926 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc 3927 above, with the additional "value" argument. */ 3928 3929 bool 3930 gfc_check_findloc (gfc_actual_arglist *ap) 3931 { 3932 gfc_expr *a, *v, *m, *d, *k, *b; 3933 bool a1, v1; 3934 3935 a = ap->expr; 3936 if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) 3937 return false; 3938 3939 v = ap->next->expr; 3940 if (!intrinsic_type_check (v, 1) || !scalar_check (v,1)) 3941 return false; 3942 3943 /* Check if the type are both logical. */ 3944 a1 = a->ts.type == BT_LOGICAL; 3945 v1 = v->ts.type == BT_LOGICAL; 3946 if ((a1 && !v1) || (!a1 && v1)) 3947 goto incompat; 3948 3949 /* Check if the type are both character. */ 3950 a1 = a->ts.type == BT_CHARACTER; 3951 v1 = v->ts.type == BT_CHARACTER; 3952 if ((a1 && !v1) || (!a1 && v1)) 3953 goto incompat; 3954 3955 /* Check the kind of the characters argument match. */ 3956 if (a1 && v1 && a->ts.kind != v->ts.kind) 3957 goto incompat; 3958 3959 d = ap->next->next->expr; 3960 m = ap->next->next->next->expr; 3961 k = ap->next->next->next->next->expr; 3962 b = ap->next->next->next->next->next->expr; 3963 3964 if (b) 3965 { 3966 if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4)) 3967 return false; 3968 } 3969 else 3970 { 3971 b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); 3972 ap->next->next->next->next->next->expr = b; 3973 ap->next->next->next->next->next->name = gfc_get_string ("back"); 3974 } 3975 3976 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL 3977 && ap->next->name == NULL) 3978 { 3979 m = d; 3980 d = NULL; 3981 ap->next->next->expr = NULL; 3982 ap->next->next->next->expr = m; 3983 } 3984 3985 if (!dim_check (d, 2, false)) 3986 return false; 3987 3988 if (!dim_rank_check (d, a, 0)) 3989 return false; 3990 3991 if (m != NULL && !type_check (m, 3, BT_LOGICAL)) 3992 return false; 3993 3994 if (m != NULL 3995 && !gfc_check_conformance (a, m, 3996 _("arguments '%s' and '%s' for intrinsic %s"), 3997 gfc_current_intrinsic_arg[0]->name, 3998 gfc_current_intrinsic_arg[3]->name, 3999 gfc_current_intrinsic)) 4000 return false; 4001 4002 if (!kind_check (k, 1, BT_INTEGER)) 4003 return false; 4004 4005 return true; 4006 4007 incompat: 4008 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " 4009 "conformance to argument %qs at %L", 4010 gfc_current_intrinsic_arg[0]->name, 4011 gfc_current_intrinsic, &a->where, 4012 gfc_current_intrinsic_arg[1]->name, &v->where); 4013 return false; 4014 } 4015 4016 4017 /* Similar to minloc/maxloc, the argument list might need to be 4018 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The 4019 difference is that MINLOC/MAXLOC take an additional KIND argument. 4020 The possibilities are: 4021 4022 Arg #2 Arg #3 4023 NULL NULL 4024 DIM NULL 4025 MASK NULL 4026 NULL MASK minval(array, mask=m) 4027 DIM MASK 4028 4029 I.e. in the case of minval(array,mask), mask will be in the second 4030 position of the argument list and we'll have to fix that up. */ 4031 4032 static bool 4033 check_reduction (gfc_actual_arglist *ap) 4034 { 4035 gfc_expr *a, *m, *d; 4036 4037 a = ap->expr; 4038 d = ap->next->expr; 4039 m = ap->next->next->expr; 4040 4041 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL 4042 && ap->next->name == NULL) 4043 { 4044 m = d; 4045 d = NULL; 4046 ap->next->expr = NULL; 4047 ap->next->next->expr = m; 4048 } 4049 4050 if (!dim_check (d, 1, false)) 4051 return false; 4052 4053 if (!dim_rank_check (d, a, 0)) 4054 return false; 4055 4056 if (m != NULL && !type_check (m, 2, BT_LOGICAL)) 4057 return false; 4058 4059 if (m != NULL 4060 && !gfc_check_conformance (a, m, 4061 _("arguments '%s' and '%s' for intrinsic %s"), 4062 gfc_current_intrinsic_arg[0]->name, 4063 gfc_current_intrinsic_arg[2]->name, 4064 gfc_current_intrinsic)) 4065 return false; 4066 4067 return true; 4068 } 4069 4070 4071 bool 4072 gfc_check_minval_maxval (gfc_actual_arglist *ap) 4073 { 4074 if (!int_or_real_or_char_check_f2003 (ap->expr, 0) 4075 || !array_check (ap->expr, 0)) 4076 return false; 4077 4078 return check_reduction (ap); 4079 } 4080 4081 4082 bool 4083 gfc_check_product_sum (gfc_actual_arglist *ap) 4084 { 4085 if (!numeric_check (ap->expr, 0) 4086 || !array_check (ap->expr, 0)) 4087 return false; 4088 4089 return check_reduction (ap); 4090 } 4091 4092 4093 /* For IANY, IALL and IPARITY. */ 4094 4095 bool 4096 gfc_check_mask (gfc_expr *i, gfc_expr *kind) 4097 { 4098 int k; 4099 4100 if (!type_check (i, 0, BT_INTEGER)) 4101 return false; 4102 4103 if (!nonnegative_check ("I", i)) 4104 return false; 4105 4106 if (!kind_check (kind, 1, BT_INTEGER)) 4107 return false; 4108 4109 if (kind) 4110 gfc_extract_int (kind, &k); 4111 else 4112 k = gfc_default_integer_kind; 4113 4114 if (!less_than_bitsizekind ("I", i, k)) 4115 return false; 4116 4117 return true; 4118 } 4119 4120 4121 bool 4122 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) 4123 { 4124 if (ap->expr->ts.type != BT_INTEGER) 4125 { 4126 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", 4127 gfc_current_intrinsic_arg[0]->name, 4128 gfc_current_intrinsic, &ap->expr->where); 4129 return false; 4130 } 4131 4132 if (!array_check (ap->expr, 0)) 4133 return false; 4134 4135 return check_reduction (ap); 4136 } 4137 4138 4139 bool 4140 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 4141 { 4142 if (gfc_invalid_null_arg (tsource)) 4143 return false; 4144 4145 if (gfc_invalid_null_arg (fsource)) 4146 return false; 4147 4148 if (!same_type_check (tsource, 0, fsource, 1)) 4149 return false; 4150 4151 if (!type_check (mask, 2, BT_LOGICAL)) 4152 return false; 4153 4154 if (tsource->ts.type == BT_CHARACTER) 4155 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); 4156 4157 return true; 4158 } 4159 4160 4161 bool 4162 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) 4163 { 4164 /* i and j cannot both be BOZ literal constants. */ 4165 if (!boz_args_check (i, j)) 4166 return false; 4167 4168 /* If i is BOZ and j is integer, convert i to type of j. */ 4169 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER 4170 && !gfc_boz2int (i, j->ts.kind)) 4171 return false; 4172 4173 /* If j is BOZ and i is integer, convert j to type of i. */ 4174 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER 4175 && !gfc_boz2int (j, i->ts.kind)) 4176 return false; 4177 4178 if (!type_check (i, 0, BT_INTEGER)) 4179 return false; 4180 4181 if (!type_check (j, 1, BT_INTEGER)) 4182 return false; 4183 4184 if (!same_type_check (i, 0, j, 1)) 4185 return false; 4186 4187 if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind)) 4188 return false; 4189 4190 if (!type_check (mask, 2, BT_INTEGER)) 4191 return false; 4192 4193 if (!same_type_check (i, 0, mask, 2)) 4194 return false; 4195 4196 return true; 4197 } 4198 4199 4200 bool 4201 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) 4202 { 4203 if (!variable_check (from, 0, false)) 4204 return false; 4205 if (!allocatable_check (from, 0)) 4206 return false; 4207 if (gfc_is_coindexed (from)) 4208 { 4209 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be " 4210 "coindexed", &from->where); 4211 return false; 4212 } 4213 4214 if (!variable_check (to, 1, false)) 4215 return false; 4216 if (!allocatable_check (to, 1)) 4217 return false; 4218 if (gfc_is_coindexed (to)) 4219 { 4220 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be " 4221 "coindexed", &to->where); 4222 return false; 4223 } 4224 4225 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) 4226 { 4227 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " 4228 "polymorphic if FROM is polymorphic", 4229 &to->where); 4230 return false; 4231 } 4232 4233 if (!same_type_check (to, 1, from, 0)) 4234 return false; 4235 4236 if (to->rank != from->rank) 4237 { 4238 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " 4239 "must have the same rank %d/%d", &to->where, from->rank, 4240 to->rank); 4241 return false; 4242 } 4243 4244 /* IR F08/0040; cf. 12-006A. */ 4245 if (gfc_get_corank (to) != gfc_get_corank (from)) 4246 { 4247 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " 4248 "must have the same corank %d/%d", &to->where, 4249 gfc_get_corank (from), gfc_get_corank (to)); 4250 return false; 4251 } 4252 4253 /* This is based losely on F2003 12.4.1.7. It is intended to prevent 4254 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1 4255 and cmp2 are allocatable. After the allocation is transferred, 4256 the 'to' chain is broken by the nullification of the 'from'. A bit 4257 of reflection reveals that this can only occur for derived types 4258 with recursive allocatable components. */ 4259 if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE 4260 && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name)) 4261 { 4262 gfc_ref *to_ref, *from_ref; 4263 to_ref = to->ref; 4264 from_ref = from->ref; 4265 bool aliasing = true; 4266 4267 for (; from_ref && to_ref; 4268 from_ref = from_ref->next, to_ref = to_ref->next) 4269 { 4270 if (to_ref->type != from->ref->type) 4271 aliasing = false; 4272 else if (to_ref->type == REF_ARRAY 4273 && to_ref->u.ar.type != AR_FULL 4274 && from_ref->u.ar.type != AR_FULL) 4275 /* Play safe; assume sections and elements are different. */ 4276 aliasing = false; 4277 else if (to_ref->type == REF_COMPONENT 4278 && to_ref->u.c.component != from_ref->u.c.component) 4279 aliasing = false; 4280 4281 if (!aliasing) 4282 break; 4283 } 4284 4285 if (aliasing) 4286 { 4287 gfc_error ("The FROM and TO arguments at %L violate aliasing " 4288 "restrictions (F2003 12.4.1.7)", &to->where); 4289 return false; 4290 } 4291 } 4292 4293 /* CLASS arguments: Make sure the vtab of from is present. */ 4294 if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) 4295 gfc_find_vtab (&from->ts); 4296 4297 return true; 4298 } 4299 4300 4301 bool 4302 gfc_check_nearest (gfc_expr *x, gfc_expr *s) 4303 { 4304 if (!type_check (x, 0, BT_REAL)) 4305 return false; 4306 4307 if (!type_check (s, 1, BT_REAL)) 4308 return false; 4309 4310 if (s->expr_type == EXPR_CONSTANT) 4311 { 4312 if (mpfr_sgn (s->value.real) == 0) 4313 { 4314 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero", 4315 &s->where); 4316 return false; 4317 } 4318 } 4319 4320 return true; 4321 } 4322 4323 4324 bool 4325 gfc_check_new_line (gfc_expr *a) 4326 { 4327 if (!type_check (a, 0, BT_CHARACTER)) 4328 return false; 4329 4330 return true; 4331 } 4332 4333 4334 bool 4335 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) 4336 { 4337 if (!type_check (array, 0, BT_REAL)) 4338 return false; 4339 4340 if (!array_check (array, 0)) 4341 return false; 4342 4343 if (!dim_check (dim, 1, false)) 4344 return false; 4345 4346 if (!dim_rank_check (dim, array, false)) 4347 return false; 4348 4349 return true; 4350 } 4351 4352 bool 4353 gfc_check_null (gfc_expr *mold) 4354 { 4355 symbol_attribute attr; 4356 4357 if (mold == NULL) 4358 return true; 4359 4360 if (!variable_check (mold, 0, true)) 4361 return false; 4362 4363 attr = gfc_variable_attr (mold, NULL); 4364 4365 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) 4366 { 4367 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " 4368 "ALLOCATABLE or procedure pointer", 4369 gfc_current_intrinsic_arg[0]->name, 4370 gfc_current_intrinsic, &mold->where); 4371 return false; 4372 } 4373 4374 if (attr.allocatable 4375 && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " 4376 "allocatable MOLD at %L", &mold->where)) 4377 return false; 4378 4379 /* F2008, C1242. */ 4380 if (gfc_is_coindexed (mold)) 4381 { 4382 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 4383 "coindexed", gfc_current_intrinsic_arg[0]->name, 4384 gfc_current_intrinsic, &mold->where); 4385 return false; 4386 } 4387 4388 return true; 4389 } 4390 4391 4392 bool 4393 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 4394 { 4395 if (!array_check (array, 0)) 4396 return false; 4397 4398 if (!type_check (mask, 1, BT_LOGICAL)) 4399 return false; 4400 4401 if (!gfc_check_conformance (array, mask, 4402 _("arguments '%s' and '%s' for intrinsic '%s'"), 4403 gfc_current_intrinsic_arg[0]->name, 4404 gfc_current_intrinsic_arg[1]->name, 4405 gfc_current_intrinsic)) 4406 return false; 4407 4408 if (vector != NULL) 4409 { 4410 mpz_t array_size, vector_size; 4411 bool have_array_size, have_vector_size; 4412 4413 if (!same_type_check (array, 0, vector, 2)) 4414 return false; 4415 4416 if (!rank_check (vector, 2, 1)) 4417 return false; 4418 4419 /* VECTOR requires at least as many elements as MASK 4420 has .TRUE. values. */ 4421 have_array_size = gfc_array_size(array, &array_size); 4422 have_vector_size = gfc_array_size(vector, &vector_size); 4423 4424 if (have_vector_size 4425 && (mask->expr_type == EXPR_ARRAY 4426 || (mask->expr_type == EXPR_CONSTANT 4427 && have_array_size))) 4428 { 4429 int mask_true_values = 0; 4430 4431 if (mask->expr_type == EXPR_ARRAY) 4432 { 4433 gfc_constructor *mask_ctor; 4434 mask_ctor = gfc_constructor_first (mask->value.constructor); 4435 while (mask_ctor) 4436 { 4437 if (mask_ctor->expr->expr_type != EXPR_CONSTANT) 4438 { 4439 mask_true_values = 0; 4440 break; 4441 } 4442 4443 if (mask_ctor->expr->value.logical) 4444 mask_true_values++; 4445 4446 mask_ctor = gfc_constructor_next (mask_ctor); 4447 } 4448 } 4449 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) 4450 mask_true_values = mpz_get_si (array_size); 4451 4452 if (mpz_get_si (vector_size) < mask_true_values) 4453 { 4454 gfc_error ("%qs argument of %qs intrinsic at %L must " 4455 "provide at least as many elements as there " 4456 "are .TRUE. values in %qs (%ld/%d)", 4457 gfc_current_intrinsic_arg[2]->name, 4458 gfc_current_intrinsic, &vector->where, 4459 gfc_current_intrinsic_arg[1]->name, 4460 mpz_get_si (vector_size), mask_true_values); 4461 return false; 4462 } 4463 } 4464 4465 if (have_array_size) 4466 mpz_clear (array_size); 4467 if (have_vector_size) 4468 mpz_clear (vector_size); 4469 } 4470 4471 return true; 4472 } 4473 4474 4475 bool 4476 gfc_check_parity (gfc_expr *mask, gfc_expr *dim) 4477 { 4478 if (!type_check (mask, 0, BT_LOGICAL)) 4479 return false; 4480 4481 if (!array_check (mask, 0)) 4482 return false; 4483 4484 if (!dim_check (dim, 1, false)) 4485 return false; 4486 4487 if (!dim_rank_check (dim, mask, false)) 4488 return false; 4489 4490 return true; 4491 } 4492 4493 4494 bool 4495 gfc_check_precision (gfc_expr *x) 4496 { 4497 if (!real_or_complex_check (x, 0)) 4498 return false; 4499 4500 return true; 4501 } 4502 4503 4504 bool 4505 gfc_check_present (gfc_expr *a) 4506 { 4507 gfc_symbol *sym; 4508 4509 if (!variable_check (a, 0, true)) 4510 return false; 4511 4512 sym = a->symtree->n.sym; 4513 if (!sym->attr.dummy) 4514 { 4515 gfc_error ("%qs argument of %qs intrinsic at %L must be of a " 4516 "dummy variable", gfc_current_intrinsic_arg[0]->name, 4517 gfc_current_intrinsic, &a->where); 4518 return false; 4519 } 4520 4521 /* For CLASS, the optional attribute might be set at either location. */ 4522 if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional) 4523 && !sym->attr.optional) 4524 { 4525 gfc_error ("%qs argument of %qs intrinsic at %L must be of " 4526 "an OPTIONAL dummy variable", 4527 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4528 &a->where); 4529 return false; 4530 } 4531 4532 /* 13.14.82 PRESENT(A) 4533 ...... 4534 Argument. A shall be the name of an optional dummy argument that is 4535 accessible in the subprogram in which the PRESENT function reference 4536 appears... */ 4537 4538 if (a->ref != NULL 4539 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY 4540 && (a->ref->u.ar.type == AR_FULL 4541 || (a->ref->u.ar.type == AR_ELEMENT 4542 && a->ref->u.ar.as->rank == 0)))) 4543 { 4544 gfc_error ("%qs argument of %qs intrinsic at %L must not be a " 4545 "subobject of %qs", gfc_current_intrinsic_arg[0]->name, 4546 gfc_current_intrinsic, &a->where, sym->name); 4547 return false; 4548 } 4549 4550 return true; 4551 } 4552 4553 4554 bool 4555 gfc_check_radix (gfc_expr *x) 4556 { 4557 if (!int_or_real_check (x, 0)) 4558 return false; 4559 4560 return true; 4561 } 4562 4563 4564 bool 4565 gfc_check_range (gfc_expr *x) 4566 { 4567 if (!numeric_check (x, 0)) 4568 return false; 4569 4570 return true; 4571 } 4572 4573 4574 bool 4575 gfc_check_rank (gfc_expr *a) 4576 { 4577 /* Any data object is allowed; a "data object" is a "constant (4.1.3), 4578 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */ 4579 4580 bool is_variable = true; 4581 4582 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ 4583 if (a->expr_type == EXPR_FUNCTION) 4584 is_variable = a->value.function.esym 4585 ? a->value.function.esym->result->attr.pointer 4586 : a->symtree->n.sym->result->attr.pointer; 4587 4588 if (a->expr_type == EXPR_OP 4589 || a->expr_type == EXPR_NULL 4590 || a->expr_type == EXPR_COMPCALL 4591 || a->expr_type == EXPR_PPC 4592 || a->ts.type == BT_PROCEDURE 4593 || !is_variable) 4594 { 4595 gfc_error ("The argument of the RANK intrinsic at %L must be a data " 4596 "object", &a->where); 4597 return false; 4598 } 4599 4600 return true; 4601 } 4602 4603 4604 bool 4605 gfc_check_real (gfc_expr *a, gfc_expr *kind) 4606 { 4607 if (!kind_check (kind, 1, BT_REAL)) 4608 return false; 4609 4610 /* BOZ is dealt with in gfc_simplify_real. */ 4611 if (a->ts.type == BT_BOZ) 4612 return true; 4613 4614 if (!numeric_check (a, 0)) 4615 return false; 4616 4617 return true; 4618 } 4619 4620 4621 bool 4622 gfc_check_rename (gfc_expr *path1, gfc_expr *path2) 4623 { 4624 if (!type_check (path1, 0, BT_CHARACTER)) 4625 return false; 4626 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 4627 return false; 4628 4629 if (!type_check (path2, 1, BT_CHARACTER)) 4630 return false; 4631 if (!kind_value_check (path2, 1, gfc_default_character_kind)) 4632 return false; 4633 4634 return true; 4635 } 4636 4637 4638 bool 4639 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 4640 { 4641 if (!type_check (path1, 0, BT_CHARACTER)) 4642 return false; 4643 if (!kind_value_check (path1, 0, gfc_default_character_kind)) 4644 return false; 4645 4646 if (!type_check (path2, 1, BT_CHARACTER)) 4647 return false; 4648 if (!kind_value_check (path2, 1, gfc_default_character_kind)) 4649 return false; 4650 4651 if (status == NULL) 4652 return true; 4653 4654 if (!type_check (status, 2, BT_INTEGER)) 4655 return false; 4656 4657 if (!scalar_check (status, 2)) 4658 return false; 4659 4660 return true; 4661 } 4662 4663 4664 bool 4665 gfc_check_repeat (gfc_expr *x, gfc_expr *y) 4666 { 4667 if (!type_check (x, 0, BT_CHARACTER)) 4668 return false; 4669 4670 if (!scalar_check (x, 0)) 4671 return false; 4672 4673 if (!type_check (y, 0, BT_INTEGER)) 4674 return false; 4675 4676 if (!scalar_check (y, 1)) 4677 return false; 4678 4679 return true; 4680 } 4681 4682 4683 bool 4684 gfc_check_reshape (gfc_expr *source, gfc_expr *shape, 4685 gfc_expr *pad, gfc_expr *order) 4686 { 4687 mpz_t size; 4688 mpz_t nelems; 4689 int shape_size; 4690 bool shape_is_const; 4691 4692 if (!array_check (source, 0)) 4693 return false; 4694 4695 if (!rank_check (shape, 1, 1)) 4696 return false; 4697 4698 if (!type_check (shape, 1, BT_INTEGER)) 4699 return false; 4700 4701 if (!gfc_array_size (shape, &size)) 4702 { 4703 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an " 4704 "array of constant size", &shape->where); 4705 return false; 4706 } 4707 4708 shape_size = mpz_get_ui (size); 4709 mpz_clear (size); 4710 4711 if (shape_size <= 0) 4712 { 4713 gfc_error ("%qs argument of %qs intrinsic at %L is empty", 4714 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 4715 &shape->where); 4716 return false; 4717 } 4718 else if (shape_size > GFC_MAX_DIMENSIONS) 4719 { 4720 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more " 4721 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); 4722 return false; 4723 } 4724 4725 gfc_simplify_expr (shape, 0); 4726 shape_is_const = gfc_is_constant_expr (shape); 4727 4728 if (shape->expr_type == EXPR_ARRAY && shape_is_const) 4729 { 4730 gfc_expr *e; 4731 int i, extent; 4732 for (i = 0; i < shape_size; ++i) 4733 { 4734 e = gfc_constructor_lookup_expr (shape->value.constructor, i); 4735 if (e->expr_type != EXPR_CONSTANT) 4736 continue; 4737 4738 gfc_extract_int (e, &extent); 4739 if (extent < 0) 4740 { 4741 gfc_error ("%qs argument of %qs intrinsic at %L has " 4742 "negative element (%d)", 4743 gfc_current_intrinsic_arg[1]->name, 4744 gfc_current_intrinsic, &shape->where, extent); 4745 return false; 4746 } 4747 } 4748 } 4749 4750 if (pad != NULL) 4751 { 4752 if (!same_type_check (source, 0, pad, 2)) 4753 return false; 4754 4755 if (!array_check (pad, 2)) 4756 return false; 4757 } 4758 4759 if (order != NULL) 4760 { 4761 if (!array_check (order, 3)) 4762 return false; 4763 4764 if (!type_check (order, 3, BT_INTEGER)) 4765 return false; 4766 4767 if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order)) 4768 { 4769 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; 4770 gfc_expr *e; 4771 4772 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i) 4773 perm[i] = 0; 4774 4775 gfc_array_size (order, &size); 4776 order_size = mpz_get_ui (size); 4777 mpz_clear (size); 4778 4779 if (order_size != shape_size) 4780 { 4781 gfc_error ("%qs argument of %qs intrinsic at %L " 4782 "has wrong number of elements (%d/%d)", 4783 gfc_current_intrinsic_arg[3]->name, 4784 gfc_current_intrinsic, &order->where, 4785 order_size, shape_size); 4786 return false; 4787 } 4788 4789 for (i = 1; i <= order_size; ++i) 4790 { 4791 e = gfc_constructor_lookup_expr (order->value.constructor, i-1); 4792 if (e->expr_type != EXPR_CONSTANT) 4793 continue; 4794 4795 gfc_extract_int (e, &dim); 4796 4797 if (dim < 1 || dim > order_size) 4798 { 4799 gfc_error ("%qs argument of %qs intrinsic at %L " 4800 "has out-of-range dimension (%d)", 4801 gfc_current_intrinsic_arg[3]->name, 4802 gfc_current_intrinsic, &e->where, dim); 4803 return false; 4804 } 4805 4806 if (perm[dim-1] != 0) 4807 { 4808 gfc_error ("%qs argument of %qs intrinsic at %L has " 4809 "invalid permutation of dimensions (dimension " 4810 "%qd duplicated)", 4811 gfc_current_intrinsic_arg[3]->name, 4812 gfc_current_intrinsic, &e->where, dim); 4813 return false; 4814 } 4815 4816 perm[dim-1] = 1; 4817 } 4818 } 4819 } 4820 4821 if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const 4822 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as 4823 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) 4824 { 4825 /* Check the match in size between source and destination. */ 4826 if (gfc_array_size (source, &nelems)) 4827 { 4828 gfc_constructor *c; 4829 bool test; 4830 4831 4832 mpz_init_set_ui (size, 1); 4833 for (c = gfc_constructor_first (shape->value.constructor); 4834 c; c = gfc_constructor_next (c)) 4835 mpz_mul (size, size, c->expr->value.integer); 4836 4837 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; 4838 mpz_clear (nelems); 4839 mpz_clear (size); 4840 4841 if (test) 4842 { 4843 gfc_error ("Without padding, there are not enough elements " 4844 "in the intrinsic RESHAPE source at %L to match " 4845 "the shape", &source->where); 4846 return false; 4847 } 4848 } 4849 } 4850 4851 return true; 4852 } 4853 4854 4855 bool 4856 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) 4857 { 4858 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) 4859 { 4860 gfc_error ("%qs argument of %qs intrinsic at %L " 4861 "cannot be of type %s", 4862 gfc_current_intrinsic_arg[0]->name, 4863 gfc_current_intrinsic, 4864 &a->where, gfc_typename (a)); 4865 return false; 4866 } 4867 4868 if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) 4869 { 4870 gfc_error ("%qs argument of %qs intrinsic at %L " 4871 "must be of an extensible type", 4872 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4873 &a->where); 4874 return false; 4875 } 4876 4877 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) 4878 { 4879 gfc_error ("%qs argument of %qs intrinsic at %L " 4880 "cannot be of type %s", 4881 gfc_current_intrinsic_arg[0]->name, 4882 gfc_current_intrinsic, 4883 &b->where, gfc_typename (b)); 4884 return false; 4885 } 4886 4887 if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) 4888 { 4889 gfc_error ("%qs argument of %qs intrinsic at %L " 4890 "must be of an extensible type", 4891 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 4892 &b->where); 4893 return false; 4894 } 4895 4896 return true; 4897 } 4898 4899 4900 bool 4901 gfc_check_scale (gfc_expr *x, gfc_expr *i) 4902 { 4903 if (!type_check (x, 0, BT_REAL)) 4904 return false; 4905 4906 if (!type_check (i, 1, BT_INTEGER)) 4907 return false; 4908 4909 return true; 4910 } 4911 4912 4913 bool 4914 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) 4915 { 4916 if (!type_check (x, 0, BT_CHARACTER)) 4917 return false; 4918 4919 if (!type_check (y, 1, BT_CHARACTER)) 4920 return false; 4921 4922 if (z != NULL && !type_check (z, 2, BT_LOGICAL)) 4923 return false; 4924 4925 if (!kind_check (kind, 3, BT_INTEGER)) 4926 return false; 4927 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 4928 "with KIND argument at %L", 4929 gfc_current_intrinsic, &kind->where)) 4930 return false; 4931 4932 if (!same_type_check (x, 0, y, 1)) 4933 return false; 4934 4935 return true; 4936 } 4937 4938 4939 bool 4940 gfc_check_secnds (gfc_expr *r) 4941 { 4942 if (!type_check (r, 0, BT_REAL)) 4943 return false; 4944 4945 if (!kind_value_check (r, 0, 4)) 4946 return false; 4947 4948 if (!scalar_check (r, 0)) 4949 return false; 4950 4951 return true; 4952 } 4953 4954 4955 bool 4956 gfc_check_selected_char_kind (gfc_expr *name) 4957 { 4958 if (!type_check (name, 0, BT_CHARACTER)) 4959 return false; 4960 4961 if (!kind_value_check (name, 0, gfc_default_character_kind)) 4962 return false; 4963 4964 if (!scalar_check (name, 0)) 4965 return false; 4966 4967 return true; 4968 } 4969 4970 4971 bool 4972 gfc_check_selected_int_kind (gfc_expr *r) 4973 { 4974 if (!type_check (r, 0, BT_INTEGER)) 4975 return false; 4976 4977 if (!scalar_check (r, 0)) 4978 return false; 4979 4980 return true; 4981 } 4982 4983 4984 bool 4985 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) 4986 { 4987 if (p == NULL && r == NULL 4988 && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" 4989 " neither %<P%> nor %<R%> argument at %L", 4990 gfc_current_intrinsic_where)) 4991 return false; 4992 4993 if (p) 4994 { 4995 if (!type_check (p, 0, BT_INTEGER)) 4996 return false; 4997 4998 if (!scalar_check (p, 0)) 4999 return false; 5000 } 5001 5002 if (r) 5003 { 5004 if (!type_check (r, 1, BT_INTEGER)) 5005 return false; 5006 5007 if (!scalar_check (r, 1)) 5008 return false; 5009 } 5010 5011 if (radix) 5012 { 5013 if (!type_check (radix, 1, BT_INTEGER)) 5014 return false; 5015 5016 if (!scalar_check (radix, 1)) 5017 return false; 5018 5019 if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with " 5020 "RADIX argument at %L", gfc_current_intrinsic, 5021 &radix->where)) 5022 return false; 5023 } 5024 5025 return true; 5026 } 5027 5028 5029 bool 5030 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) 5031 { 5032 if (!type_check (x, 0, BT_REAL)) 5033 return false; 5034 5035 if (!type_check (i, 1, BT_INTEGER)) 5036 return false; 5037 5038 return true; 5039 } 5040 5041 5042 bool 5043 gfc_check_shape (gfc_expr *source, gfc_expr *kind) 5044 { 5045 gfc_array_ref *ar; 5046 5047 if (gfc_invalid_null_arg (source)) 5048 return false; 5049 5050 if (!kind_check (kind, 1, BT_INTEGER)) 5051 return false; 5052 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 5053 "with KIND argument at %L", 5054 gfc_current_intrinsic, &kind->where)) 5055 return false; 5056 5057 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) 5058 return true; 5059 5060 if (source->ref == NULL) 5061 return false; 5062 5063 ar = gfc_find_array_ref (source); 5064 5065 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL) 5066 { 5067 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be " 5068 "an assumed size array", &source->where); 5069 return false; 5070 } 5071 5072 return true; 5073 } 5074 5075 5076 bool 5077 gfc_check_shift (gfc_expr *i, gfc_expr *shift) 5078 { 5079 if (!type_check (i, 0, BT_INTEGER)) 5080 return false; 5081 5082 if (!type_check (shift, 0, BT_INTEGER)) 5083 return false; 5084 5085 if (!nonnegative_check ("SHIFT", shift)) 5086 return false; 5087 5088 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) 5089 return false; 5090 5091 return true; 5092 } 5093 5094 5095 bool 5096 gfc_check_sign (gfc_expr *a, gfc_expr *b) 5097 { 5098 if (!int_or_real_check (a, 0)) 5099 return false; 5100 5101 if (!same_type_check (a, 0, b, 1)) 5102 return false; 5103 5104 return true; 5105 } 5106 5107 5108 bool 5109 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 5110 { 5111 if (!array_check (array, 0)) 5112 return false; 5113 5114 if (!dim_check (dim, 1, true)) 5115 return false; 5116 5117 if (!dim_rank_check (dim, array, 0)) 5118 return false; 5119 5120 if (!kind_check (kind, 2, BT_INTEGER)) 5121 return false; 5122 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 5123 "with KIND argument at %L", 5124 gfc_current_intrinsic, &kind->where)) 5125 return false; 5126 5127 5128 return true; 5129 } 5130 5131 5132 bool 5133 gfc_check_sizeof (gfc_expr *arg) 5134 { 5135 if (gfc_invalid_null_arg (arg)) 5136 return false; 5137 5138 if (arg->ts.type == BT_PROCEDURE) 5139 { 5140 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", 5141 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5142 &arg->where); 5143 return false; 5144 } 5145 5146 if (illegal_boz_arg (arg)) 5147 return false; 5148 5149 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */ 5150 if (arg->ts.type == BT_ASSUMED 5151 && (arg->symtree->n.sym->as == NULL 5152 || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE 5153 && arg->symtree->n.sym->as->type != AS_DEFERRED 5154 && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) 5155 { 5156 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", 5157 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5158 &arg->where); 5159 return false; 5160 } 5161 5162 if (arg->rank && arg->expr_type == EXPR_VARIABLE 5163 && arg->symtree->n.sym->as != NULL 5164 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref 5165 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) 5166 { 5167 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " 5168 "assumed-size array", gfc_current_intrinsic_arg[0]->name, 5169 gfc_current_intrinsic, &arg->where); 5170 return false; 5171 } 5172 5173 return true; 5174 } 5175 5176 5177 /* Check whether an expression is interoperable. When returning false, 5178 msg is set to a string telling why the expression is not interoperable, 5179 otherwise, it is set to NULL. The msg string can be used in diagnostics. 5180 If c_loc is true, character with len > 1 are allowed (cf. Fortran 5181 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape 5182 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays 5183 are permitted. */ 5184 5185 static bool 5186 is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) 5187 { 5188 *msg = NULL; 5189 5190 if (expr->expr_type == EXPR_NULL) 5191 { 5192 *msg = "NULL() is not interoperable"; 5193 return false; 5194 } 5195 5196 if (expr->ts.type == BT_BOZ) 5197 { 5198 *msg = "BOZ literal constant"; 5199 return false; 5200 } 5201 5202 if (expr->ts.type == BT_CLASS) 5203 { 5204 *msg = "Expression is polymorphic"; 5205 return false; 5206 } 5207 5208 if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c 5209 && !expr->ts.u.derived->ts.is_iso_c) 5210 { 5211 *msg = "Expression is a noninteroperable derived type"; 5212 return false; 5213 } 5214 5215 if (expr->ts.type == BT_PROCEDURE) 5216 { 5217 *msg = "Procedure unexpected as argument"; 5218 return false; 5219 } 5220 5221 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL) 5222 { 5223 int i; 5224 for (i = 0; gfc_logical_kinds[i].kind; i++) 5225 if (gfc_logical_kinds[i].kind == expr->ts.kind) 5226 return true; 5227 *msg = "Extension to use a non-C_Bool-kind LOGICAL"; 5228 return false; 5229 } 5230 5231 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER 5232 && expr->ts.kind != 1) 5233 { 5234 *msg = "Extension to use a non-C_CHAR-kind CHARACTER"; 5235 return false; 5236 } 5237 5238 if (expr->ts.type == BT_CHARACTER) { 5239 if (expr->ts.deferred) 5240 { 5241 /* TS 29113 allows deferred-length strings as dummy arguments, 5242 but it is not an interoperable type. */ 5243 *msg = "Expression shall not be a deferred-length string"; 5244 return false; 5245 } 5246 5247 if (expr->ts.u.cl && expr->ts.u.cl->length 5248 && !gfc_simplify_expr (expr->ts.u.cl->length, 0)) 5249 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); 5250 5251 if (!c_loc && expr->ts.u.cl 5252 && (!expr->ts.u.cl->length 5253 || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT 5254 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) 5255 { 5256 *msg = "Type shall have a character length of 1"; 5257 return false; 5258 } 5259 } 5260 5261 /* Note: The following checks are about interoperatable variables, Fortran 5262 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more 5263 is allowed, e.g. assumed-shape arrays with TS 29113. */ 5264 5265 if (gfc_is_coarray (expr)) 5266 { 5267 *msg = "Coarrays are not interoperable"; 5268 return false; 5269 } 5270 5271 if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) 5272 { 5273 gfc_array_ref *ar = gfc_find_array_ref (expr); 5274 if (ar->type != AR_FULL) 5275 { 5276 *msg = "Only whole-arrays are interoperable"; 5277 return false; 5278 } 5279 if (!c_f_ptr && ar->as->type != AS_EXPLICIT 5280 && ar->as->type != AS_ASSUMED_SIZE) 5281 { 5282 *msg = "Only explicit-size and assumed-size arrays are interoperable"; 5283 return false; 5284 } 5285 } 5286 5287 return true; 5288 } 5289 5290 5291 bool 5292 gfc_check_c_sizeof (gfc_expr *arg) 5293 { 5294 const char *msg; 5295 5296 if (!is_c_interoperable (arg, &msg, false, false)) 5297 { 5298 gfc_error ("%qs argument of %qs intrinsic at %L must be an " 5299 "interoperable data entity: %s", 5300 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5301 &arg->where, msg); 5302 return false; 5303 } 5304 5305 if (arg->ts.type == BT_ASSUMED) 5306 { 5307 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 5308 "TYPE(*)", 5309 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5310 &arg->where); 5311 return false; 5312 } 5313 5314 if (arg->rank && arg->expr_type == EXPR_VARIABLE 5315 && arg->symtree->n.sym->as != NULL 5316 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref 5317 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) 5318 { 5319 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " 5320 "assumed-size array", gfc_current_intrinsic_arg[0]->name, 5321 gfc_current_intrinsic, &arg->where); 5322 return false; 5323 } 5324 5325 return true; 5326 } 5327 5328 5329 bool 5330 gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) 5331 { 5332 if (c_ptr_1->ts.type != BT_DERIVED 5333 || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING 5334 || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR 5335 && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) 5336 { 5337 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " 5338 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); 5339 return false; 5340 } 5341 5342 if (!scalar_check (c_ptr_1, 0)) 5343 return false; 5344 5345 if (c_ptr_2 5346 && (c_ptr_2->ts.type != BT_DERIVED 5347 || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING 5348 || (c_ptr_1->ts.u.derived->intmod_sym_id 5349 != c_ptr_2->ts.u.derived->intmod_sym_id))) 5350 { 5351 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " 5352 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, 5353 gfc_typename (&c_ptr_1->ts), 5354 gfc_typename (&c_ptr_2->ts)); 5355 return false; 5356 } 5357 5358 if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) 5359 return false; 5360 5361 return true; 5362 } 5363 5364 5365 bool 5366 gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) 5367 { 5368 symbol_attribute attr; 5369 const char *msg; 5370 5371 if (cptr->ts.type != BT_DERIVED 5372 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING 5373 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR) 5374 { 5375 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the " 5376 "type TYPE(C_PTR)", &cptr->where); 5377 return false; 5378 } 5379 5380 if (!scalar_check (cptr, 0)) 5381 return false; 5382 5383 attr = gfc_expr_attr (fptr); 5384 5385 if (!attr.pointer) 5386 { 5387 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer", 5388 &fptr->where); 5389 return false; 5390 } 5391 5392 if (fptr->ts.type == BT_CLASS) 5393 { 5394 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic", 5395 &fptr->where); 5396 return false; 5397 } 5398 5399 if (gfc_is_coindexed (fptr)) 5400 { 5401 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be " 5402 "coindexed", &fptr->where); 5403 return false; 5404 } 5405 5406 if (fptr->rank == 0 && shape) 5407 { 5408 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar " 5409 "FPTR", &fptr->where); 5410 return false; 5411 } 5412 else if (fptr->rank && !shape) 5413 { 5414 gfc_error ("Expected SHAPE argument to C_F_POINTER with array " 5415 "FPTR at %L", &fptr->where); 5416 return false; 5417 } 5418 5419 if (shape && !rank_check (shape, 2, 1)) 5420 return false; 5421 5422 if (shape && !type_check (shape, 2, BT_INTEGER)) 5423 return false; 5424 5425 if (shape) 5426 { 5427 mpz_t size; 5428 if (gfc_array_size (shape, &size)) 5429 { 5430 if (mpz_cmp_ui (size, fptr->rank) != 0) 5431 { 5432 mpz_clear (size); 5433 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same " 5434 "size as the RANK of FPTR", &shape->where); 5435 return false; 5436 } 5437 mpz_clear (size); 5438 } 5439 } 5440 5441 if (fptr->ts.type == BT_CLASS) 5442 { 5443 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); 5444 return false; 5445 } 5446 5447 if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true)) 5448 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR " 5449 "at %L to C_F_POINTER: %s", &fptr->where, msg); 5450 5451 return true; 5452 } 5453 5454 5455 bool 5456 gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) 5457 { 5458 symbol_attribute attr; 5459 5460 if (cptr->ts.type != BT_DERIVED 5461 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING 5462 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR) 5463 { 5464 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the " 5465 "type TYPE(C_FUNPTR)", &cptr->where); 5466 return false; 5467 } 5468 5469 if (!scalar_check (cptr, 0)) 5470 return false; 5471 5472 attr = gfc_expr_attr (fptr); 5473 5474 if (!attr.proc_pointer) 5475 { 5476 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure " 5477 "pointer", &fptr->where); 5478 return false; 5479 } 5480 5481 if (gfc_is_coindexed (fptr)) 5482 { 5483 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be " 5484 "coindexed", &fptr->where); 5485 return false; 5486 } 5487 5488 if (!attr.is_bind_c) 5489 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " 5490 "pointer at %L to C_F_PROCPOINTER", &fptr->where); 5491 5492 return true; 5493 } 5494 5495 5496 bool 5497 gfc_check_c_funloc (gfc_expr *x) 5498 { 5499 symbol_attribute attr; 5500 5501 if (gfc_is_coindexed (x)) 5502 { 5503 gfc_error ("Argument X at %L to C_FUNLOC shall not be " 5504 "coindexed", &x->where); 5505 return false; 5506 } 5507 5508 attr = gfc_expr_attr (x); 5509 5510 if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE 5511 && x->symtree->n.sym == x->symtree->n.sym->result) 5512 for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent) 5513 if (x->symtree->n.sym == ns->proc_name) 5514 { 5515 gfc_error ("Function result %qs at %L is invalid as X argument " 5516 "to C_FUNLOC", x->symtree->n.sym->name, &x->where); 5517 return false; 5518 } 5519 5520 if (attr.flavor != FL_PROCEDURE) 5521 { 5522 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure " 5523 "or a procedure pointer", &x->where); 5524 return false; 5525 } 5526 5527 if (!attr.is_bind_c) 5528 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " 5529 "at %L to C_FUNLOC", &x->where); 5530 return true; 5531 } 5532 5533 5534 bool 5535 gfc_check_c_loc (gfc_expr *x) 5536 { 5537 symbol_attribute attr; 5538 const char *msg; 5539 5540 if (gfc_is_coindexed (x)) 5541 { 5542 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where); 5543 return false; 5544 } 5545 5546 if (x->ts.type == BT_CLASS) 5547 { 5548 gfc_error ("X argument at %L to C_LOC shall not be polymorphic", 5549 &x->where); 5550 return false; 5551 } 5552 5553 attr = gfc_expr_attr (x); 5554 5555 if (!attr.pointer 5556 && (x->expr_type != EXPR_VARIABLE || !attr.target 5557 || attr.flavor == FL_PARAMETER)) 5558 { 5559 gfc_error ("Argument X at %L to C_LOC shall have either " 5560 "the POINTER or the TARGET attribute", &x->where); 5561 return false; 5562 } 5563 5564 if (x->ts.type == BT_CHARACTER 5565 && gfc_var_strlen (x) == 0) 5566 { 5567 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized " 5568 "string", &x->where); 5569 return false; 5570 } 5571 5572 if (!is_c_interoperable (x, &msg, true, false)) 5573 { 5574 if (x->ts.type == BT_CLASS) 5575 { 5576 gfc_error ("Argument at %L to C_LOC shall not be polymorphic", 5577 &x->where); 5578 return false; 5579 } 5580 5581 if (x->rank 5582 && !gfc_notify_std (GFC_STD_F2018, 5583 "Noninteroperable array at %L as" 5584 " argument to C_LOC: %s", &x->where, msg)) 5585 return false; 5586 } 5587 else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008)) 5588 { 5589 gfc_array_ref *ar = gfc_find_array_ref (x); 5590 5591 if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE 5592 && !attr.allocatable 5593 && !gfc_notify_std (GFC_STD_F2008, 5594 "Array of interoperable type at %L " 5595 "to C_LOC which is nonallocatable and neither " 5596 "assumed size nor explicit size", &x->where)) 5597 return false; 5598 else if (ar->type != AR_FULL 5599 && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " 5600 "to C_LOC", &x->where)) 5601 return false; 5602 } 5603 5604 return true; 5605 } 5606 5607 5608 bool 5609 gfc_check_sleep_sub (gfc_expr *seconds) 5610 { 5611 if (!type_check (seconds, 0, BT_INTEGER)) 5612 return false; 5613 5614 if (!scalar_check (seconds, 0)) 5615 return false; 5616 5617 return true; 5618 } 5619 5620 bool 5621 gfc_check_sngl (gfc_expr *a) 5622 { 5623 if (!type_check (a, 0, BT_REAL)) 5624 return false; 5625 5626 if ((a->ts.kind != gfc_default_double_kind) 5627 && !gfc_notify_std (GFC_STD_GNU, "non double precision " 5628 "REAL argument to %s intrinsic at %L", 5629 gfc_current_intrinsic, &a->where)) 5630 return false; 5631 5632 return true; 5633 } 5634 5635 bool 5636 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) 5637 { 5638 if (gfc_invalid_null_arg (source)) 5639 return false; 5640 5641 if (source->rank >= GFC_MAX_DIMENSIONS) 5642 { 5643 gfc_error ("%qs argument of %qs intrinsic at %L must be less " 5644 "than rank %d", gfc_current_intrinsic_arg[0]->name, 5645 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); 5646 5647 return false; 5648 } 5649 5650 if (dim == NULL) 5651 return false; 5652 5653 if (!dim_check (dim, 1, false)) 5654 return false; 5655 5656 /* dim_rank_check() does not apply here. */ 5657 if (dim 5658 && dim->expr_type == EXPR_CONSTANT 5659 && (mpz_cmp_ui (dim->value.integer, 1) < 0 5660 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) 5661 { 5662 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " 5663 "dimension index", gfc_current_intrinsic_arg[1]->name, 5664 gfc_current_intrinsic, &dim->where); 5665 return false; 5666 } 5667 5668 if (!type_check (ncopies, 2, BT_INTEGER)) 5669 return false; 5670 5671 if (!scalar_check (ncopies, 2)) 5672 return false; 5673 5674 return true; 5675 } 5676 5677 5678 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and 5679 functions). */ 5680 5681 bool 5682 arg_strlen_is_zero (gfc_expr *c, int n) 5683 { 5684 if (gfc_var_strlen (c) == 0) 5685 { 5686 gfc_error ("%qs argument of %qs intrinsic at %L must have " 5687 "length at least 1", gfc_current_intrinsic_arg[n]->name, 5688 gfc_current_intrinsic, &c->where); 5689 return true; 5690 } 5691 return false; 5692 } 5693 5694 bool 5695 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) 5696 { 5697 if (!type_check (unit, 0, BT_INTEGER)) 5698 return false; 5699 5700 if (!scalar_check (unit, 0)) 5701 return false; 5702 5703 if (!type_check (c, 1, BT_CHARACTER)) 5704 return false; 5705 if (!kind_value_check (c, 1, gfc_default_character_kind)) 5706 return false; 5707 if (strcmp (gfc_current_intrinsic, "fgetc") == 0 5708 && !variable_check (c, 1, false)) 5709 return false; 5710 if (arg_strlen_is_zero (c, 1)) 5711 return false; 5712 5713 if (status == NULL) 5714 return true; 5715 5716 if (!type_check (status, 2, BT_INTEGER) 5717 || !kind_value_check (status, 2, gfc_default_integer_kind) 5718 || !scalar_check (status, 2) 5719 || !variable_check (status, 2, false)) 5720 return false; 5721 5722 return true; 5723 } 5724 5725 5726 bool 5727 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) 5728 { 5729 return gfc_check_fgetputc_sub (unit, c, NULL); 5730 } 5731 5732 5733 bool 5734 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) 5735 { 5736 if (!type_check (c, 0, BT_CHARACTER)) 5737 return false; 5738 if (!kind_value_check (c, 0, gfc_default_character_kind)) 5739 return false; 5740 if (strcmp (gfc_current_intrinsic, "fget") == 0 5741 && !variable_check (c, 0, false)) 5742 return false; 5743 if (arg_strlen_is_zero (c, 0)) 5744 return false; 5745 5746 if (status == NULL) 5747 return true; 5748 5749 if (!type_check (status, 1, BT_INTEGER) 5750 || !kind_value_check (status, 1, gfc_default_integer_kind) 5751 || !scalar_check (status, 1) 5752 || !variable_check (status, 1, false)) 5753 return false; 5754 5755 return true; 5756 } 5757 5758 5759 bool 5760 gfc_check_fgetput (gfc_expr *c) 5761 { 5762 return gfc_check_fgetput_sub (c, NULL); 5763 } 5764 5765 5766 bool 5767 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) 5768 { 5769 if (!type_check (unit, 0, BT_INTEGER)) 5770 return false; 5771 5772 if (!scalar_check (unit, 0)) 5773 return false; 5774 5775 if (!type_check (offset, 1, BT_INTEGER)) 5776 return false; 5777 5778 if (!scalar_check (offset, 1)) 5779 return false; 5780 5781 if (!type_check (whence, 2, BT_INTEGER)) 5782 return false; 5783 5784 if (!scalar_check (whence, 2)) 5785 return false; 5786 5787 if (status == NULL) 5788 return true; 5789 5790 if (!type_check (status, 3, BT_INTEGER)) 5791 return false; 5792 5793 if (!kind_value_check (status, 3, 4)) 5794 return false; 5795 5796 if (!scalar_check (status, 3)) 5797 return false; 5798 5799 return true; 5800 } 5801 5802 5803 5804 bool 5805 gfc_check_fstat (gfc_expr *unit, gfc_expr *array) 5806 { 5807 if (!type_check (unit, 0, BT_INTEGER)) 5808 return false; 5809 5810 if (!scalar_check (unit, 0)) 5811 return false; 5812 5813 if (!type_check (array, 1, BT_INTEGER) 5814 || !kind_value_check (unit, 0, gfc_default_integer_kind)) 5815 return false; 5816 5817 if (!array_check (array, 1)) 5818 return false; 5819 5820 return true; 5821 } 5822 5823 5824 bool 5825 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) 5826 { 5827 if (!type_check (unit, 0, BT_INTEGER)) 5828 return false; 5829 5830 if (!scalar_check (unit, 0)) 5831 return false; 5832 5833 if (!type_check (array, 1, BT_INTEGER) 5834 || !kind_value_check (array, 1, gfc_default_integer_kind)) 5835 return false; 5836 5837 if (!array_check (array, 1)) 5838 return false; 5839 5840 if (status == NULL) 5841 return true; 5842 5843 if (!type_check (status, 2, BT_INTEGER) 5844 || !kind_value_check (status, 2, gfc_default_integer_kind)) 5845 return false; 5846 5847 if (!scalar_check (status, 2)) 5848 return false; 5849 5850 return true; 5851 } 5852 5853 5854 bool 5855 gfc_check_ftell (gfc_expr *unit) 5856 { 5857 if (!type_check (unit, 0, BT_INTEGER)) 5858 return false; 5859 5860 if (!scalar_check (unit, 0)) 5861 return false; 5862 5863 return true; 5864 } 5865 5866 5867 bool 5868 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) 5869 { 5870 if (!type_check (unit, 0, BT_INTEGER)) 5871 return false; 5872 5873 if (!scalar_check (unit, 0)) 5874 return false; 5875 5876 if (!type_check (offset, 1, BT_INTEGER)) 5877 return false; 5878 5879 if (!scalar_check (offset, 1)) 5880 return false; 5881 5882 return true; 5883 } 5884 5885 5886 bool 5887 gfc_check_stat (gfc_expr *name, gfc_expr *array) 5888 { 5889 if (!type_check (name, 0, BT_CHARACTER)) 5890 return false; 5891 if (!kind_value_check (name, 0, gfc_default_character_kind)) 5892 return false; 5893 5894 if (!type_check (array, 1, BT_INTEGER) 5895 || !kind_value_check (array, 1, gfc_default_integer_kind)) 5896 return false; 5897 5898 if (!array_check (array, 1)) 5899 return false; 5900 5901 return true; 5902 } 5903 5904 5905 bool 5906 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) 5907 { 5908 if (!type_check (name, 0, BT_CHARACTER)) 5909 return false; 5910 if (!kind_value_check (name, 0, gfc_default_character_kind)) 5911 return false; 5912 5913 if (!type_check (array, 1, BT_INTEGER) 5914 || !kind_value_check (array, 1, gfc_default_integer_kind)) 5915 return false; 5916 5917 if (!array_check (array, 1)) 5918 return false; 5919 5920 if (status == NULL) 5921 return true; 5922 5923 if (!type_check (status, 2, BT_INTEGER) 5924 || !kind_value_check (array, 1, gfc_default_integer_kind)) 5925 return false; 5926 5927 if (!scalar_check (status, 2)) 5928 return false; 5929 5930 return true; 5931 } 5932 5933 5934 bool 5935 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) 5936 { 5937 mpz_t nelems; 5938 5939 if (flag_coarray == GFC_FCOARRAY_NONE) 5940 { 5941 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 5942 return false; 5943 } 5944 5945 if (!coarray_check (coarray, 0)) 5946 return false; 5947 5948 if (sub->rank != 1) 5949 { 5950 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", 5951 gfc_current_intrinsic_arg[1]->name, &sub->where); 5952 return false; 5953 } 5954 5955 if (sub->ts.type != BT_INTEGER) 5956 { 5957 gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", 5958 gfc_current_intrinsic_arg[1]->name, &sub->where); 5959 return false; 5960 } 5961 5962 if (gfc_array_size (sub, &nelems)) 5963 { 5964 int corank = gfc_get_corank (coarray); 5965 5966 if (mpz_cmp_ui (nelems, corank) != 0) 5967 { 5968 gfc_error ("The number of array elements of the SUB argument to " 5969 "IMAGE_INDEX at %L shall be %d (corank) not %d", 5970 &sub->where, corank, (int) mpz_get_si (nelems)); 5971 mpz_clear (nelems); 5972 return false; 5973 } 5974 mpz_clear (nelems); 5975 } 5976 5977 return true; 5978 } 5979 5980 5981 bool 5982 gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) 5983 { 5984 if (flag_coarray == GFC_FCOARRAY_NONE) 5985 { 5986 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 5987 return false; 5988 } 5989 5990 if (distance) 5991 { 5992 if (!type_check (distance, 0, BT_INTEGER)) 5993 return false; 5994 5995 if (!nonnegative_check ("DISTANCE", distance)) 5996 return false; 5997 5998 if (!scalar_check (distance, 0)) 5999 return false; 6000 6001 if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " 6002 "NUM_IMAGES at %L", &distance->where)) 6003 return false; 6004 } 6005 6006 if (failed) 6007 { 6008 if (!type_check (failed, 1, BT_LOGICAL)) 6009 return false; 6010 6011 if (!scalar_check (failed, 1)) 6012 return false; 6013 6014 if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " 6015 "NUM_IMAGES at %L", &failed->where)) 6016 return false; 6017 } 6018 6019 return true; 6020 } 6021 6022 6023 bool 6024 gfc_check_team_number (gfc_expr *team) 6025 { 6026 if (flag_coarray == GFC_FCOARRAY_NONE) 6027 { 6028 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6029 return false; 6030 } 6031 6032 if (team) 6033 { 6034 if (team->ts.type != BT_DERIVED 6035 || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV 6036 || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) 6037 { 6038 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " 6039 "shall be of type TEAM_TYPE", &team->where); 6040 return false; 6041 } 6042 } 6043 else 6044 return true; 6045 6046 return true; 6047 } 6048 6049 6050 bool 6051 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) 6052 { 6053 if (flag_coarray == GFC_FCOARRAY_NONE) 6054 { 6055 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6056 return false; 6057 } 6058 6059 if (coarray == NULL && dim == NULL && distance == NULL) 6060 return true; 6061 6062 if (dim != NULL && coarray == NULL) 6063 { 6064 gfc_error ("DIM argument without COARRAY argument not allowed for " 6065 "THIS_IMAGE intrinsic at %L", &dim->where); 6066 return false; 6067 } 6068 6069 if (distance && (coarray || dim)) 6070 { 6071 gfc_error ("The DISTANCE argument may not be specified together with the " 6072 "COARRAY or DIM argument in intrinsic at %L", 6073 &distance->where); 6074 return false; 6075 } 6076 6077 /* Assume that we have "this_image (distance)". */ 6078 if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) 6079 { 6080 if (dim) 6081 { 6082 gfc_error ("Unexpected DIM argument with noncoarray argument at %L", 6083 &coarray->where); 6084 return false; 6085 } 6086 distance = coarray; 6087 } 6088 6089 if (distance) 6090 { 6091 if (!type_check (distance, 2, BT_INTEGER)) 6092 return false; 6093 6094 if (!nonnegative_check ("DISTANCE", distance)) 6095 return false; 6096 6097 if (!scalar_check (distance, 2)) 6098 return false; 6099 6100 if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " 6101 "THIS_IMAGE at %L", &distance->where)) 6102 return false; 6103 6104 return true; 6105 } 6106 6107 if (!coarray_check (coarray, 0)) 6108 return false; 6109 6110 if (dim != NULL) 6111 { 6112 if (!dim_check (dim, 1, false)) 6113 return false; 6114 6115 if (!dim_corank_check (dim, coarray)) 6116 return false; 6117 } 6118 6119 return true; 6120 } 6121 6122 /* Calculate the sizes for transfer, used by gfc_check_transfer and also 6123 by gfc_simplify_transfer. Return false if we cannot do so. */ 6124 6125 bool 6126 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, 6127 size_t *source_size, size_t *result_size, 6128 size_t *result_length_p) 6129 { 6130 size_t result_elt_size; 6131 6132 if (source->expr_type == EXPR_FUNCTION) 6133 return false; 6134 6135 if (size && size->expr_type != EXPR_CONSTANT) 6136 return false; 6137 6138 /* Calculate the size of the source. */ 6139 if (!gfc_target_expr_size (source, source_size)) 6140 return false; 6141 6142 /* Determine the size of the element. */ 6143 if (!gfc_element_size (mold, &result_elt_size)) 6144 return false; 6145 6146 /* If the storage size of SOURCE is greater than zero and MOLD is an array, 6147 * a scalar with the type and type parameters of MOLD shall not have a 6148 * storage size equal to zero. 6149 * If MOLD is a scalar and SIZE is absent, the result is a scalar. 6150 * If MOLD is an array and SIZE is absent, the result is an array and of 6151 * rank one. Its size is as small as possible such that its physical 6152 * representation is not shorter than that of SOURCE. 6153 * If SIZE is present, the result is an array of rank one and size SIZE. 6154 */ 6155 if (result_elt_size == 0 && *source_size > 0 6156 && (mold->expr_type == EXPR_ARRAY || mold->rank)) 6157 { 6158 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an " 6159 "array and shall not have storage size 0 when %<SOURCE%> " 6160 "argument has size greater than 0", &mold->where); 6161 return false; 6162 } 6163 6164 if (result_elt_size == 0 && *source_size == 0 && !size) 6165 { 6166 *result_size = 0; 6167 if (result_length_p) 6168 *result_length_p = 0; 6169 return true; 6170 } 6171 6172 if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank)) 6173 || size) 6174 { 6175 int result_length; 6176 6177 if (size) 6178 result_length = (size_t)mpz_get_ui (size->value.integer); 6179 else 6180 { 6181 result_length = *source_size / result_elt_size; 6182 if (result_length * result_elt_size < *source_size) 6183 result_length += 1; 6184 } 6185 6186 *result_size = result_length * result_elt_size; 6187 if (result_length_p) 6188 *result_length_p = result_length; 6189 } 6190 else 6191 *result_size = result_elt_size; 6192 6193 return true; 6194 } 6195 6196 6197 bool 6198 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 6199 { 6200 size_t source_size; 6201 size_t result_size; 6202 6203 if (gfc_invalid_null_arg (source)) 6204 return false; 6205 6206 /* SOURCE shall be a scalar or array of any type. */ 6207 if (source->ts.type == BT_PROCEDURE 6208 && source->symtree->n.sym->attr.subroutine == 1) 6209 { 6210 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L " 6211 "must not be a %s", &source->where, 6212 gfc_basic_typename (source->ts.type)); 6213 return false; 6214 } 6215 6216 if (source->ts.type == BT_BOZ && illegal_boz_arg (source)) 6217 return false; 6218 6219 if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold)) 6220 return false; 6221 6222 if (gfc_invalid_null_arg (mold)) 6223 return false; 6224 6225 /* MOLD shall be a scalar or array of any type. */ 6226 if (mold->ts.type == BT_PROCEDURE 6227 && mold->symtree->n.sym->attr.subroutine == 1) 6228 { 6229 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L " 6230 "must not be a %s", &mold->where, 6231 gfc_basic_typename (mold->ts.type)); 6232 return false; 6233 } 6234 6235 if (mold->ts.type == BT_HOLLERITH) 6236 { 6237 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be" 6238 " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); 6239 return false; 6240 } 6241 6242 /* SIZE (optional) shall be an integer scalar. The corresponding actual 6243 argument shall not be an optional dummy argument. */ 6244 if (size != NULL) 6245 { 6246 if (!type_check (size, 2, BT_INTEGER)) 6247 { 6248 if (size->ts.type == BT_BOZ) 6249 reset_boz (size); 6250 return false; 6251 } 6252 6253 if (!scalar_check (size, 2)) 6254 return false; 6255 6256 if (!nonoptional_check (size, 2)) 6257 return false; 6258 } 6259 6260 if (!warn_surprising) 6261 return true; 6262 6263 /* If we can't calculate the sizes, we cannot check any more. 6264 Return true for that case. */ 6265 6266 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 6267 &result_size, NULL)) 6268 return true; 6269 6270 if (source_size < result_size) 6271 gfc_warning (OPT_Wsurprising, 6272 "Intrinsic TRANSFER at %L has partly undefined result: " 6273 "source size %ld < result size %ld", &source->where, 6274 (long) source_size, (long) result_size); 6275 6276 return true; 6277 } 6278 6279 6280 bool 6281 gfc_check_transpose (gfc_expr *matrix) 6282 { 6283 if (!rank_check (matrix, 0, 2)) 6284 return false; 6285 6286 return true; 6287 } 6288 6289 6290 bool 6291 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 6292 { 6293 if (!array_check (array, 0)) 6294 return false; 6295 6296 if (!dim_check (dim, 1, false)) 6297 return false; 6298 6299 if (!dim_rank_check (dim, array, 0)) 6300 return false; 6301 6302 if (!kind_check (kind, 2, BT_INTEGER)) 6303 return false; 6304 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 6305 "with KIND argument at %L", 6306 gfc_current_intrinsic, &kind->where)) 6307 return false; 6308 6309 return true; 6310 } 6311 6312 6313 bool 6314 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) 6315 { 6316 if (flag_coarray == GFC_FCOARRAY_NONE) 6317 { 6318 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6319 return false; 6320 } 6321 6322 if (!coarray_check (coarray, 0)) 6323 return false; 6324 6325 if (dim != NULL) 6326 { 6327 if (!dim_check (dim, 1, false)) 6328 return false; 6329 6330 if (!dim_corank_check (dim, coarray)) 6331 return false; 6332 } 6333 6334 if (!kind_check (kind, 2, BT_INTEGER)) 6335 return false; 6336 6337 return true; 6338 } 6339 6340 6341 bool 6342 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 6343 { 6344 mpz_t vector_size; 6345 6346 if (!rank_check (vector, 0, 1)) 6347 return false; 6348 6349 if (!array_check (mask, 1)) 6350 return false; 6351 6352 if (!type_check (mask, 1, BT_LOGICAL)) 6353 return false; 6354 6355 if (!same_type_check (vector, 0, field, 2)) 6356 return false; 6357 6358 gfc_simplify_expr (mask, 0); 6359 6360 if (mask->expr_type == EXPR_ARRAY 6361 && gfc_array_size (vector, &vector_size)) 6362 { 6363 int mask_true_count = 0; 6364 gfc_constructor *mask_ctor; 6365 mask_ctor = gfc_constructor_first (mask->value.constructor); 6366 while (mask_ctor) 6367 { 6368 if (mask_ctor->expr->expr_type != EXPR_CONSTANT) 6369 { 6370 mask_true_count = 0; 6371 break; 6372 } 6373 6374 if (mask_ctor->expr->value.logical) 6375 mask_true_count++; 6376 6377 mask_ctor = gfc_constructor_next (mask_ctor); 6378 } 6379 6380 if (mpz_get_si (vector_size) < mask_true_count) 6381 { 6382 gfc_error ("%qs argument of %qs intrinsic at %L must " 6383 "provide at least as many elements as there " 6384 "are .TRUE. values in %qs (%ld/%d)", 6385 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 6386 &vector->where, gfc_current_intrinsic_arg[1]->name, 6387 mpz_get_si (vector_size), mask_true_count); 6388 return false; 6389 } 6390 6391 mpz_clear (vector_size); 6392 } 6393 6394 if (mask->rank != field->rank && field->rank != 0) 6395 { 6396 gfc_error ("%qs argument of %qs intrinsic at %L must have " 6397 "the same rank as %qs or be a scalar", 6398 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, 6399 &field->where, gfc_current_intrinsic_arg[1]->name); 6400 return false; 6401 } 6402 6403 if (mask->rank == field->rank) 6404 { 6405 int i; 6406 for (i = 0; i < field->rank; i++) 6407 if (! identical_dimen_shape (mask, i, field, i)) 6408 { 6409 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " 6410 "must have identical shape.", 6411 gfc_current_intrinsic_arg[2]->name, 6412 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 6413 &field->where); 6414 } 6415 } 6416 6417 return true; 6418 } 6419 6420 6421 bool 6422 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) 6423 { 6424 if (!type_check (x, 0, BT_CHARACTER)) 6425 return false; 6426 6427 if (!same_type_check (x, 0, y, 1)) 6428 return false; 6429 6430 if (z != NULL && !type_check (z, 2, BT_LOGICAL)) 6431 return false; 6432 6433 if (!kind_check (kind, 3, BT_INTEGER)) 6434 return false; 6435 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 6436 "with KIND argument at %L", 6437 gfc_current_intrinsic, &kind->where)) 6438 return false; 6439 6440 return true; 6441 } 6442 6443 6444 bool 6445 gfc_check_trim (gfc_expr *x) 6446 { 6447 if (!type_check (x, 0, BT_CHARACTER)) 6448 return false; 6449 6450 if (gfc_invalid_null_arg (x)) 6451 return false; 6452 6453 if (!scalar_check (x, 0)) 6454 return false; 6455 6456 return true; 6457 } 6458 6459 6460 bool 6461 gfc_check_ttynam (gfc_expr *unit) 6462 { 6463 if (!scalar_check (unit, 0)) 6464 return false; 6465 6466 if (!type_check (unit, 0, BT_INTEGER)) 6467 return false; 6468 6469 return true; 6470 } 6471 6472 6473 /************* Check functions for intrinsic subroutines *************/ 6474 6475 bool 6476 gfc_check_cpu_time (gfc_expr *time) 6477 { 6478 if (!scalar_check (time, 0)) 6479 return false; 6480 6481 if (!type_check (time, 0, BT_REAL)) 6482 return false; 6483 6484 if (!variable_check (time, 0, false)) 6485 return false; 6486 6487 return true; 6488 } 6489 6490 6491 bool 6492 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, 6493 gfc_expr *zone, gfc_expr *values) 6494 { 6495 if (date != NULL) 6496 { 6497 if (!type_check (date, 0, BT_CHARACTER)) 6498 return false; 6499 if (!kind_value_check (date, 0, gfc_default_character_kind)) 6500 return false; 6501 if (!scalar_check (date, 0)) 6502 return false; 6503 if (!variable_check (date, 0, false)) 6504 return false; 6505 } 6506 6507 if (time != NULL) 6508 { 6509 if (!type_check (time, 1, BT_CHARACTER)) 6510 return false; 6511 if (!kind_value_check (time, 1, gfc_default_character_kind)) 6512 return false; 6513 if (!scalar_check (time, 1)) 6514 return false; 6515 if (!variable_check (time, 1, false)) 6516 return false; 6517 } 6518 6519 if (zone != NULL) 6520 { 6521 if (!type_check (zone, 2, BT_CHARACTER)) 6522 return false; 6523 if (!kind_value_check (zone, 2, gfc_default_character_kind)) 6524 return false; 6525 if (!scalar_check (zone, 2)) 6526 return false; 6527 if (!variable_check (zone, 2, false)) 6528 return false; 6529 } 6530 6531 if (values != NULL) 6532 { 6533 if (!type_check (values, 3, BT_INTEGER)) 6534 return false; 6535 if (!array_check (values, 3)) 6536 return false; 6537 if (!rank_check (values, 3, 1)) 6538 return false; 6539 if (!variable_check (values, 3, false)) 6540 return false; 6541 } 6542 6543 return true; 6544 } 6545 6546 6547 bool 6548 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, 6549 gfc_expr *to, gfc_expr *topos) 6550 { 6551 if (!type_check (from, 0, BT_INTEGER)) 6552 return false; 6553 6554 if (!type_check (frompos, 1, BT_INTEGER)) 6555 return false; 6556 6557 if (!type_check (len, 2, BT_INTEGER)) 6558 return false; 6559 6560 if (!same_type_check (from, 0, to, 3)) 6561 return false; 6562 6563 if (!variable_check (to, 3, false)) 6564 return false; 6565 6566 if (!type_check (topos, 4, BT_INTEGER)) 6567 return false; 6568 6569 if (!nonnegative_check ("frompos", frompos)) 6570 return false; 6571 6572 if (!nonnegative_check ("topos", topos)) 6573 return false; 6574 6575 if (!nonnegative_check ("len", len)) 6576 return false; 6577 6578 if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) 6579 return false; 6580 6581 if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) 6582 return false; 6583 6584 return true; 6585 } 6586 6587 6588 /* Check the arguments for RANDOM_INIT. */ 6589 6590 bool 6591 gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct) 6592 { 6593 if (!type_check (repeatable, 0, BT_LOGICAL)) 6594 return false; 6595 6596 if (!scalar_check (repeatable, 0)) 6597 return false; 6598 6599 if (!type_check (image_distinct, 1, BT_LOGICAL)) 6600 return false; 6601 6602 if (!scalar_check (image_distinct, 1)) 6603 return false; 6604 6605 return true; 6606 } 6607 6608 6609 bool 6610 gfc_check_random_number (gfc_expr *harvest) 6611 { 6612 if (!type_check (harvest, 0, BT_REAL)) 6613 return false; 6614 6615 if (!variable_check (harvest, 0, false)) 6616 return false; 6617 6618 return true; 6619 } 6620 6621 6622 bool 6623 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) 6624 { 6625 unsigned int nargs = 0, seed_size; 6626 locus *where = NULL; 6627 mpz_t put_size, get_size; 6628 6629 /* Keep the number of bytes in sync with master_state in 6630 libgfortran/intrinsics/random.c. */ 6631 seed_size = 32 / gfc_default_integer_kind; 6632 6633 if (size != NULL) 6634 { 6635 if (size->expr_type != EXPR_VARIABLE 6636 || !size->symtree->n.sym->attr.optional) 6637 nargs++; 6638 6639 if (!scalar_check (size, 0)) 6640 return false; 6641 6642 if (!type_check (size, 0, BT_INTEGER)) 6643 return false; 6644 6645 if (!variable_check (size, 0, false)) 6646 return false; 6647 6648 if (!kind_value_check (size, 0, gfc_default_integer_kind)) 6649 return false; 6650 } 6651 6652 if (put != NULL) 6653 { 6654 if (put->expr_type != EXPR_VARIABLE 6655 || !put->symtree->n.sym->attr.optional) 6656 { 6657 nargs++; 6658 where = &put->where; 6659 } 6660 6661 if (!array_check (put, 1)) 6662 return false; 6663 6664 if (!rank_check (put, 1, 1)) 6665 return false; 6666 6667 if (!type_check (put, 1, BT_INTEGER)) 6668 return false; 6669 6670 if (!kind_value_check (put, 1, gfc_default_integer_kind)) 6671 return false; 6672 6673 if (gfc_array_size (put, &put_size) 6674 && mpz_get_ui (put_size) < seed_size) 6675 gfc_error ("Size of %qs argument of %qs intrinsic at %L " 6676 "too small (%i/%i)", 6677 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 6678 &put->where, (int) mpz_get_ui (put_size), seed_size); 6679 } 6680 6681 if (get != NULL) 6682 { 6683 if (get->expr_type != EXPR_VARIABLE 6684 || !get->symtree->n.sym->attr.optional) 6685 { 6686 nargs++; 6687 where = &get->where; 6688 } 6689 6690 if (!array_check (get, 2)) 6691 return false; 6692 6693 if (!rank_check (get, 2, 1)) 6694 return false; 6695 6696 if (!type_check (get, 2, BT_INTEGER)) 6697 return false; 6698 6699 if (!variable_check (get, 2, false)) 6700 return false; 6701 6702 if (!kind_value_check (get, 2, gfc_default_integer_kind)) 6703 return false; 6704 6705 if (gfc_array_size (get, &get_size) 6706 && mpz_get_ui (get_size) < seed_size) 6707 gfc_error ("Size of %qs argument of %qs intrinsic at %L " 6708 "too small (%i/%i)", 6709 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, 6710 &get->where, (int) mpz_get_ui (get_size), seed_size); 6711 } 6712 6713 /* RANDOM_SEED may not have more than one non-optional argument. */ 6714 if (nargs > 1) 6715 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where); 6716 6717 return true; 6718 } 6719 6720 bool 6721 gfc_check_fe_runtime_error (gfc_actual_arglist *a) 6722 { 6723 gfc_expr *e; 6724 size_t len, i; 6725 int num_percent, nargs; 6726 6727 e = a->expr; 6728 if (e->expr_type != EXPR_CONSTANT) 6729 return true; 6730 6731 len = e->value.character.length; 6732 if (e->value.character.string[len-1] != '\0') 6733 gfc_internal_error ("fe_runtime_error string must be null terminated"); 6734 6735 num_percent = 0; 6736 for (i=0; i<len-1; i++) 6737 if (e->value.character.string[i] == '%') 6738 num_percent ++; 6739 6740 nargs = 0; 6741 for (; a; a = a->next) 6742 nargs ++; 6743 6744 if (nargs -1 != num_percent) 6745 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)", 6746 nargs, num_percent++); 6747 6748 return true; 6749 } 6750 6751 bool 6752 gfc_check_second_sub (gfc_expr *time) 6753 { 6754 if (!scalar_check (time, 0)) 6755 return false; 6756 6757 if (!type_check (time, 0, BT_REAL)) 6758 return false; 6759 6760 if (!kind_value_check (time, 0, 4)) 6761 return false; 6762 6763 return true; 6764 } 6765 6766 6767 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer 6768 variables in Fortran 95. In Fortran 2003 and later, they can be of any 6769 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and 6770 count_max are all optional arguments */ 6771 6772 bool 6773 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, 6774 gfc_expr *count_max) 6775 { 6776 if (count != NULL) 6777 { 6778 if (!scalar_check (count, 0)) 6779 return false; 6780 6781 if (!type_check (count, 0, BT_INTEGER)) 6782 return false; 6783 6784 if (count->ts.kind != gfc_default_integer_kind 6785 && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to " 6786 "SYSTEM_CLOCK at %L has non-default kind", 6787 &count->where)) 6788 return false; 6789 6790 if (!variable_check (count, 0, false)) 6791 return false; 6792 } 6793 6794 if (count_rate != NULL) 6795 { 6796 if (!scalar_check (count_rate, 1)) 6797 return false; 6798 6799 if (!variable_check (count_rate, 1, false)) 6800 return false; 6801 6802 if (count_rate->ts.type == BT_REAL) 6803 { 6804 if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to " 6805 "SYSTEM_CLOCK at %L", &count_rate->where)) 6806 return false; 6807 } 6808 else 6809 { 6810 if (!type_check (count_rate, 1, BT_INTEGER)) 6811 return false; 6812 6813 if (count_rate->ts.kind != gfc_default_integer_kind 6814 && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to " 6815 "SYSTEM_CLOCK at %L has non-default kind", 6816 &count_rate->where)) 6817 return false; 6818 } 6819 6820 } 6821 6822 if (count_max != NULL) 6823 { 6824 if (!scalar_check (count_max, 2)) 6825 return false; 6826 6827 if (!type_check (count_max, 2, BT_INTEGER)) 6828 return false; 6829 6830 if (count_max->ts.kind != gfc_default_integer_kind 6831 && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to " 6832 "SYSTEM_CLOCK at %L has non-default kind", 6833 &count_max->where)) 6834 return false; 6835 6836 if (!variable_check (count_max, 2, false)) 6837 return false; 6838 } 6839 6840 return true; 6841 } 6842 6843 6844 bool 6845 gfc_check_irand (gfc_expr *x) 6846 { 6847 if (x == NULL) 6848 return true; 6849 6850 if (!scalar_check (x, 0)) 6851 return false; 6852 6853 if (!type_check (x, 0, BT_INTEGER)) 6854 return false; 6855 6856 if (!kind_value_check (x, 0, 4)) 6857 return false; 6858 6859 return true; 6860 } 6861 6862 6863 bool 6864 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) 6865 { 6866 if (!scalar_check (seconds, 0)) 6867 return false; 6868 if (!type_check (seconds, 0, BT_INTEGER)) 6869 return false; 6870 6871 if (!int_or_proc_check (handler, 1)) 6872 return false; 6873 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 6874 return false; 6875 6876 if (status == NULL) 6877 return true; 6878 6879 if (!scalar_check (status, 2)) 6880 return false; 6881 if (!type_check (status, 2, BT_INTEGER)) 6882 return false; 6883 if (!kind_value_check (status, 2, gfc_default_integer_kind)) 6884 return false; 6885 6886 return true; 6887 } 6888 6889 6890 bool 6891 gfc_check_rand (gfc_expr *x) 6892 { 6893 if (x == NULL) 6894 return true; 6895 6896 if (!scalar_check (x, 0)) 6897 return false; 6898 6899 if (!type_check (x, 0, BT_INTEGER)) 6900 return false; 6901 6902 if (!kind_value_check (x, 0, 4)) 6903 return false; 6904 6905 return true; 6906 } 6907 6908 6909 bool 6910 gfc_check_srand (gfc_expr *x) 6911 { 6912 if (!scalar_check (x, 0)) 6913 return false; 6914 6915 if (!type_check (x, 0, BT_INTEGER)) 6916 return false; 6917 6918 if (!kind_value_check (x, 0, 4)) 6919 return false; 6920 6921 return true; 6922 } 6923 6924 6925 bool 6926 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) 6927 { 6928 if (!scalar_check (time, 0)) 6929 return false; 6930 if (!type_check (time, 0, BT_INTEGER)) 6931 return false; 6932 6933 if (!type_check (result, 1, BT_CHARACTER)) 6934 return false; 6935 if (!kind_value_check (result, 1, gfc_default_character_kind)) 6936 return false; 6937 6938 return true; 6939 } 6940 6941 6942 bool 6943 gfc_check_dtime_etime (gfc_expr *x) 6944 { 6945 if (!array_check (x, 0)) 6946 return false; 6947 6948 if (!rank_check (x, 0, 1)) 6949 return false; 6950 6951 if (!variable_check (x, 0, false)) 6952 return false; 6953 6954 if (!type_check (x, 0, BT_REAL)) 6955 return false; 6956 6957 if (!kind_value_check (x, 0, 4)) 6958 return false; 6959 6960 return true; 6961 } 6962 6963 6964 bool 6965 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) 6966 { 6967 if (!array_check (values, 0)) 6968 return false; 6969 6970 if (!rank_check (values, 0, 1)) 6971 return false; 6972 6973 if (!variable_check (values, 0, false)) 6974 return false; 6975 6976 if (!type_check (values, 0, BT_REAL)) 6977 return false; 6978 6979 if (!kind_value_check (values, 0, 4)) 6980 return false; 6981 6982 if (!scalar_check (time, 1)) 6983 return false; 6984 6985 if (!type_check (time, 1, BT_REAL)) 6986 return false; 6987 6988 if (!kind_value_check (time, 1, 4)) 6989 return false; 6990 6991 return true; 6992 } 6993 6994 6995 bool 6996 gfc_check_fdate_sub (gfc_expr *date) 6997 { 6998 if (!type_check (date, 0, BT_CHARACTER)) 6999 return false; 7000 if (!kind_value_check (date, 0, gfc_default_character_kind)) 7001 return false; 7002 7003 return true; 7004 } 7005 7006 7007 bool 7008 gfc_check_gerror (gfc_expr *msg) 7009 { 7010 if (!type_check (msg, 0, BT_CHARACTER)) 7011 return false; 7012 if (!kind_value_check (msg, 0, gfc_default_character_kind)) 7013 return false; 7014 7015 return true; 7016 } 7017 7018 7019 bool 7020 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) 7021 { 7022 if (!type_check (cwd, 0, BT_CHARACTER)) 7023 return false; 7024 if (!kind_value_check (cwd, 0, gfc_default_character_kind)) 7025 return false; 7026 7027 if (status == NULL) 7028 return true; 7029 7030 if (!scalar_check (status, 1)) 7031 return false; 7032 7033 if (!type_check (status, 1, BT_INTEGER)) 7034 return false; 7035 7036 return true; 7037 } 7038 7039 7040 bool 7041 gfc_check_getarg (gfc_expr *pos, gfc_expr *value) 7042 { 7043 if (!type_check (pos, 0, BT_INTEGER)) 7044 return false; 7045 7046 if (pos->ts.kind > gfc_default_integer_kind) 7047 { 7048 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " 7049 "not wider than the default kind (%d)", 7050 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 7051 &pos->where, gfc_default_integer_kind); 7052 return false; 7053 } 7054 7055 if (!type_check (value, 1, BT_CHARACTER)) 7056 return false; 7057 if (!kind_value_check (value, 1, gfc_default_character_kind)) 7058 return false; 7059 7060 return true; 7061 } 7062 7063 7064 bool 7065 gfc_check_getlog (gfc_expr *msg) 7066 { 7067 if (!type_check (msg, 0, BT_CHARACTER)) 7068 return false; 7069 if (!kind_value_check (msg, 0, gfc_default_character_kind)) 7070 return false; 7071 7072 return true; 7073 } 7074 7075 7076 bool 7077 gfc_check_exit (gfc_expr *status) 7078 { 7079 if (status == NULL) 7080 return true; 7081 7082 if (!type_check (status, 0, BT_INTEGER)) 7083 return false; 7084 7085 if (!scalar_check (status, 0)) 7086 return false; 7087 7088 return true; 7089 } 7090 7091 7092 bool 7093 gfc_check_flush (gfc_expr *unit) 7094 { 7095 if (unit == NULL) 7096 return true; 7097 7098 if (!type_check (unit, 0, BT_INTEGER)) 7099 return false; 7100 7101 if (!scalar_check (unit, 0)) 7102 return false; 7103 7104 return true; 7105 } 7106 7107 7108 bool 7109 gfc_check_free (gfc_expr *i) 7110 { 7111 if (!type_check (i, 0, BT_INTEGER)) 7112 return false; 7113 7114 if (!scalar_check (i, 0)) 7115 return false; 7116 7117 return true; 7118 } 7119 7120 7121 bool 7122 gfc_check_hostnm (gfc_expr *name) 7123 { 7124 if (!type_check (name, 0, BT_CHARACTER)) 7125 return false; 7126 if (!kind_value_check (name, 0, gfc_default_character_kind)) 7127 return false; 7128 7129 return true; 7130 } 7131 7132 7133 bool 7134 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) 7135 { 7136 if (!type_check (name, 0, BT_CHARACTER)) 7137 return false; 7138 if (!kind_value_check (name, 0, gfc_default_character_kind)) 7139 return false; 7140 7141 if (status == NULL) 7142 return true; 7143 7144 if (!scalar_check (status, 1)) 7145 return false; 7146 7147 if (!type_check (status, 1, BT_INTEGER)) 7148 return false; 7149 7150 return true; 7151 } 7152 7153 7154 bool 7155 gfc_check_itime_idate (gfc_expr *values) 7156 { 7157 if (!array_check (values, 0)) 7158 return false; 7159 7160 if (!rank_check (values, 0, 1)) 7161 return false; 7162 7163 if (!variable_check (values, 0, false)) 7164 return false; 7165 7166 if (!type_check (values, 0, BT_INTEGER)) 7167 return false; 7168 7169 if (!kind_value_check (values, 0, gfc_default_integer_kind)) 7170 return false; 7171 7172 return true; 7173 } 7174 7175 7176 bool 7177 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) 7178 { 7179 if (!type_check (time, 0, BT_INTEGER)) 7180 return false; 7181 7182 if (!kind_value_check (time, 0, gfc_default_integer_kind)) 7183 return false; 7184 7185 if (!scalar_check (time, 0)) 7186 return false; 7187 7188 if (!array_check (values, 1)) 7189 return false; 7190 7191 if (!rank_check (values, 1, 1)) 7192 return false; 7193 7194 if (!variable_check (values, 1, false)) 7195 return false; 7196 7197 if (!type_check (values, 1, BT_INTEGER)) 7198 return false; 7199 7200 if (!kind_value_check (values, 1, gfc_default_integer_kind)) 7201 return false; 7202 7203 return true; 7204 } 7205 7206 7207 bool 7208 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) 7209 { 7210 if (!scalar_check (unit, 0)) 7211 return false; 7212 7213 if (!type_check (unit, 0, BT_INTEGER)) 7214 return false; 7215 7216 if (!type_check (name, 1, BT_CHARACTER)) 7217 return false; 7218 if (!kind_value_check (name, 1, gfc_default_character_kind)) 7219 return false; 7220 7221 return true; 7222 } 7223 7224 7225 bool 7226 gfc_check_is_contiguous (gfc_expr *array) 7227 { 7228 if (array->expr_type == EXPR_NULL) 7229 { 7230 gfc_error ("Actual argument at %L of %qs intrinsic shall be an " 7231 "associated pointer", &array->where, gfc_current_intrinsic); 7232 return false; 7233 } 7234 7235 if (!array_check (array, 0)) 7236 return false; 7237 7238 return true; 7239 } 7240 7241 7242 bool 7243 gfc_check_isatty (gfc_expr *unit) 7244 { 7245 if (unit == NULL) 7246 return false; 7247 7248 if (!type_check (unit, 0, BT_INTEGER)) 7249 return false; 7250 7251 if (!scalar_check (unit, 0)) 7252 return false; 7253 7254 return true; 7255 } 7256 7257 7258 bool 7259 gfc_check_isnan (gfc_expr *x) 7260 { 7261 if (!type_check (x, 0, BT_REAL)) 7262 return false; 7263 7264 return true; 7265 } 7266 7267 7268 bool 7269 gfc_check_perror (gfc_expr *string) 7270 { 7271 if (!type_check (string, 0, BT_CHARACTER)) 7272 return false; 7273 if (!kind_value_check (string, 0, gfc_default_character_kind)) 7274 return false; 7275 7276 return true; 7277 } 7278 7279 7280 bool 7281 gfc_check_umask (gfc_expr *mask) 7282 { 7283 if (!type_check (mask, 0, BT_INTEGER)) 7284 return false; 7285 7286 if (!scalar_check (mask, 0)) 7287 return false; 7288 7289 return true; 7290 } 7291 7292 7293 bool 7294 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) 7295 { 7296 if (!type_check (mask, 0, BT_INTEGER)) 7297 return false; 7298 7299 if (!scalar_check (mask, 0)) 7300 return false; 7301 7302 if (old == NULL) 7303 return true; 7304 7305 if (!scalar_check (old, 1)) 7306 return false; 7307 7308 if (!type_check (old, 1, BT_INTEGER)) 7309 return false; 7310 7311 return true; 7312 } 7313 7314 7315 bool 7316 gfc_check_unlink (gfc_expr *name) 7317 { 7318 if (!type_check (name, 0, BT_CHARACTER)) 7319 return false; 7320 if (!kind_value_check (name, 0, gfc_default_character_kind)) 7321 return false; 7322 7323 return true; 7324 } 7325 7326 7327 bool 7328 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) 7329 { 7330 if (!type_check (name, 0, BT_CHARACTER)) 7331 return false; 7332 if (!kind_value_check (name, 0, gfc_default_character_kind)) 7333 return false; 7334 7335 if (status == NULL) 7336 return true; 7337 7338 if (!scalar_check (status, 1)) 7339 return false; 7340 7341 if (!type_check (status, 1, BT_INTEGER)) 7342 return false; 7343 7344 return true; 7345 } 7346 7347 7348 bool 7349 gfc_check_signal (gfc_expr *number, gfc_expr *handler) 7350 { 7351 if (!scalar_check (number, 0)) 7352 return false; 7353 if (!type_check (number, 0, BT_INTEGER)) 7354 return false; 7355 7356 if (!int_or_proc_check (handler, 1)) 7357 return false; 7358 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 7359 return false; 7360 7361 return true; 7362 } 7363 7364 7365 bool 7366 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) 7367 { 7368 if (!scalar_check (number, 0)) 7369 return false; 7370 if (!type_check (number, 0, BT_INTEGER)) 7371 return false; 7372 7373 if (!int_or_proc_check (handler, 1)) 7374 return false; 7375 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 7376 return false; 7377 7378 if (status == NULL) 7379 return true; 7380 7381 if (!type_check (status, 2, BT_INTEGER)) 7382 return false; 7383 if (!scalar_check (status, 2)) 7384 return false; 7385 7386 return true; 7387 } 7388 7389 7390 bool 7391 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) 7392 { 7393 if (!type_check (cmd, 0, BT_CHARACTER)) 7394 return false; 7395 if (!kind_value_check (cmd, 0, gfc_default_character_kind)) 7396 return false; 7397 7398 if (!scalar_check (status, 1)) 7399 return false; 7400 7401 if (!type_check (status, 1, BT_INTEGER)) 7402 return false; 7403 7404 if (!kind_value_check (status, 1, gfc_default_integer_kind)) 7405 return false; 7406 7407 return true; 7408 } 7409 7410 7411 /* This is used for the GNU intrinsics AND, OR and XOR. */ 7412 bool 7413 gfc_check_and (gfc_expr *i, gfc_expr *j) 7414 { 7415 if (i->ts.type != BT_INTEGER 7416 && i->ts.type != BT_LOGICAL 7417 && i->ts.type != BT_BOZ) 7418 { 7419 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " 7420 "LOGICAL, or a BOZ literal constant", 7421 gfc_current_intrinsic_arg[0]->name, 7422 gfc_current_intrinsic, &i->where); 7423 return false; 7424 } 7425 7426 if (j->ts.type != BT_INTEGER 7427 && j->ts.type != BT_LOGICAL 7428 && j->ts.type != BT_BOZ) 7429 { 7430 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " 7431 "LOGICAL, or a BOZ literal constant", 7432 gfc_current_intrinsic_arg[1]->name, 7433 gfc_current_intrinsic, &j->where); 7434 return false; 7435 } 7436 7437 /* i and j cannot both be BOZ literal constants. */ 7438 if (!boz_args_check (i, j)) 7439 return false; 7440 7441 /* If i is BOZ and j is integer, convert i to type of j. */ 7442 if (i->ts.type == BT_BOZ) 7443 { 7444 if (j->ts.type != BT_INTEGER) 7445 { 7446 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", 7447 gfc_current_intrinsic_arg[1]->name, 7448 gfc_current_intrinsic, &j->where); 7449 reset_boz (i); 7450 return false; 7451 } 7452 if (!gfc_boz2int (i, j->ts.kind)) 7453 return false; 7454 } 7455 7456 /* If j is BOZ and i is integer, convert j to type of i. */ 7457 if (j->ts.type == BT_BOZ) 7458 { 7459 if (i->ts.type != BT_INTEGER) 7460 { 7461 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", 7462 gfc_current_intrinsic_arg[0]->name, 7463 gfc_current_intrinsic, &j->where); 7464 reset_boz (j); 7465 return false; 7466 } 7467 if (!gfc_boz2int (j, i->ts.kind)) 7468 return false; 7469 } 7470 7471 if (!same_type_check (i, 0, j, 1, false)) 7472 return false; 7473 7474 if (!scalar_check (i, 0)) 7475 return false; 7476 7477 if (!scalar_check (j, 1)) 7478 return false; 7479 7480 return true; 7481 } 7482 7483 7484 bool 7485 gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) 7486 { 7487 7488 if (a->expr_type == EXPR_NULL) 7489 { 7490 gfc_error ("Intrinsic function NULL at %L cannot be an actual " 7491 "argument to STORAGE_SIZE, because it returns a " 7492 "disassociated pointer", &a->where); 7493 return false; 7494 } 7495 7496 if (a->ts.type == BT_ASSUMED) 7497 { 7498 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", 7499 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 7500 &a->where); 7501 return false; 7502 } 7503 7504 if (a->ts.type == BT_PROCEDURE) 7505 { 7506 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " 7507 "procedure", gfc_current_intrinsic_arg[0]->name, 7508 gfc_current_intrinsic, &a->where); 7509 return false; 7510 } 7511 7512 if (a->ts.type == BT_BOZ && illegal_boz_arg (a)) 7513 return false; 7514 7515 if (kind == NULL) 7516 return true; 7517 7518 if (!type_check (kind, 1, BT_INTEGER)) 7519 return false; 7520 7521 if (!scalar_check (kind, 1)) 7522 return false; 7523 7524 if (kind->expr_type != EXPR_CONSTANT) 7525 { 7526 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", 7527 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 7528 &kind->where); 7529 return false; 7530 } 7531 7532 return true; 7533 } 7534
Indexes created Tue Oct 27 00:25:24 UTC 2026