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