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