1/* Deal with interfaces. 2 Copyright (C) 2000-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21 22/* Deal with interfaces. An explicit interface is represented as a 23 singly linked list of formal argument structures attached to the 24 relevant symbols. For an implicit interface, the arguments don't 25 point to symbols. Explicit interfaces point to namespaces that 26 contain the symbols within that interface. 27 28 Implicit interfaces are linked together in a singly linked list 29 along the next_if member of symbol nodes. Since a particular 30 symbol can only have a single explicit interface, the symbol cannot 31 be part of multiple lists and a single next-member suffices. 32 33 This is not the case for general classes, though. An operator 34 definition is independent of just about all other uses and has it's 35 own head pointer. 36 37 Nameless interfaces: 38 Nameless interfaces create symbols with explicit interfaces within 39 the current namespace. They are otherwise unlinked. 40 41 Generic interfaces: 42 The generic name points to a linked list of symbols. Each symbol 43 has an explicit interface. Each explicit interface has its own 44 namespace containing the arguments. Module procedures are symbols in 45 which the interface is added later when the module procedure is parsed. 46 47 User operators: 48 User-defined operators are stored in a their own set of symtrees 49 separate from regular symbols. The symtrees point to gfc_user_op 50 structures which in turn head up a list of relevant interfaces. 51 52 Extended intrinsics and assignment: 53 The head of these interface lists are stored in the containing namespace. 54 55 Implicit interfaces: 56 An implicit interface is represented as a singly linked list of 57 formal argument list structures that don't point to any symbol 58 nodes -- they just contain types. 59 60 61 When a subprogram is defined, the program unit's name points to an 62 interface as usual, but the link to the namespace is NULL and the 63 formal argument list points to symbols within the same namespace as 64 the program unit name. */ 65 66#include "config.h" 67#include "system.h" 68#include "coretypes.h" 69#include "flags.h" 70#include "gfortran.h" 71#include "match.h" 72#include "arith.h" 73 74/* The current_interface structure holds information about the 75 interface currently being parsed. This structure is saved and 76 restored during recursive interfaces. */ 77 78gfc_interface_info current_interface; 79 80 81/* Free a singly linked list of gfc_interface structures. */ 82 83void 84gfc_free_interface (gfc_interface *intr) 85{ 86 gfc_interface *next; 87 88 for (; intr; intr = next) 89 { 90 next = intr->next; 91 free (intr); 92 } 93} 94 95 96/* Change the operators unary plus and minus into binary plus and 97 minus respectively, leaving the rest unchanged. */ 98 99static gfc_intrinsic_op 100fold_unary_intrinsic (gfc_intrinsic_op op) 101{ 102 switch (op) 103 { 104 case INTRINSIC_UPLUS: 105 op = INTRINSIC_PLUS; 106 break; 107 case INTRINSIC_UMINUS: 108 op = INTRINSIC_MINUS; 109 break; 110 default: 111 break; 112 } 113 114 return op; 115} 116 117 118/* Match a generic specification. Depending on which type of 119 interface is found, the 'name' or 'op' pointers may be set. 120 This subroutine doesn't return MATCH_NO. */ 121 122match 123gfc_match_generic_spec (interface_type *type, 124 char *name, 125 gfc_intrinsic_op *op) 126{ 127 char buffer[GFC_MAX_SYMBOL_LEN + 1]; 128 match m; 129 gfc_intrinsic_op i; 130 131 if (gfc_match (" assignment ( = )") == MATCH_YES) 132 { 133 *type = INTERFACE_INTRINSIC_OP; 134 *op = INTRINSIC_ASSIGN; 135 return MATCH_YES; 136 } 137 138 if (gfc_match (" operator ( %o )", &i) == MATCH_YES) 139 { /* Operator i/f */ 140 *type = INTERFACE_INTRINSIC_OP; 141 *op = fold_unary_intrinsic (i); 142 return MATCH_YES; 143 } 144 145 *op = INTRINSIC_NONE; 146 if (gfc_match (" operator ( ") == MATCH_YES) 147 { 148 m = gfc_match_defined_op_name (buffer, 1); 149 if (m == MATCH_NO) 150 goto syntax; 151 if (m != MATCH_YES) 152 return MATCH_ERROR; 153 154 m = gfc_match_char (')'); 155 if (m == MATCH_NO) 156 goto syntax; 157 if (m != MATCH_YES) 158 return MATCH_ERROR; 159 160 strcpy (name, buffer); 161 *type = INTERFACE_USER_OP; 162 return MATCH_YES; 163 } 164 165 if (gfc_match_name (buffer) == MATCH_YES) 166 { 167 strcpy (name, buffer); 168 *type = INTERFACE_GENERIC; 169 return MATCH_YES; 170 } 171 172 *type = INTERFACE_NAMELESS; 173 return MATCH_YES; 174 175syntax: 176 gfc_error ("Syntax error in generic specification at %C"); 177 return MATCH_ERROR; 178} 179 180 181/* Match one of the five F95 forms of an interface statement. The 182 matcher for the abstract interface follows. */ 183 184match 185gfc_match_interface (void) 186{ 187 char name[GFC_MAX_SYMBOL_LEN + 1]; 188 interface_type type; 189 gfc_symbol *sym; 190 gfc_intrinsic_op op; 191 match m; 192 193 m = gfc_match_space (); 194 195 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) 196 return MATCH_ERROR; 197 198 /* If we're not looking at the end of the statement now, or if this 199 is not a nameless interface but we did not see a space, punt. */ 200 if (gfc_match_eos () != MATCH_YES 201 || (type != INTERFACE_NAMELESS && m != MATCH_YES)) 202 { 203 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement " 204 "at %C"); 205 return MATCH_ERROR; 206 } 207 208 current_interface.type = type; 209 210 switch (type) 211 { 212 case INTERFACE_GENERIC: 213 if (gfc_get_symbol (name, NULL, &sym)) 214 return MATCH_ERROR; 215 216 if (!sym->attr.generic 217 && !gfc_add_generic (&sym->attr, sym->name, NULL)) 218 return MATCH_ERROR; 219 220 if (sym->attr.dummy) 221 { 222 gfc_error ("Dummy procedure %qs at %C cannot have a " 223 "generic interface", sym->name); 224 return MATCH_ERROR; 225 } 226 227 current_interface.sym = gfc_new_block = sym; 228 break; 229 230 case INTERFACE_USER_OP: 231 current_interface.uop = gfc_get_uop (name); 232 break; 233 234 case INTERFACE_INTRINSIC_OP: 235 current_interface.op = op; 236 break; 237 238 case INTERFACE_NAMELESS: 239 case INTERFACE_ABSTRACT: 240 break; 241 } 242 243 return MATCH_YES; 244} 245 246 247 248/* Match a F2003 abstract interface. */ 249 250match 251gfc_match_abstract_interface (void) 252{ 253 match m; 254 255 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")) 256 return MATCH_ERROR; 257 258 m = gfc_match_eos (); 259 260 if (m != MATCH_YES) 261 { 262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C"); 263 return MATCH_ERROR; 264 } 265 266 current_interface.type = INTERFACE_ABSTRACT; 267 268 return m; 269} 270 271 272/* Match the different sort of generic-specs that can be present after 273 the END INTERFACE itself. */ 274 275match 276gfc_match_end_interface (void) 277{ 278 char name[GFC_MAX_SYMBOL_LEN + 1]; 279 interface_type type; 280 gfc_intrinsic_op op; 281 match m; 282 283 m = gfc_match_space (); 284 285 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) 286 return MATCH_ERROR; 287 288 /* If we're not looking at the end of the statement now, or if this 289 is not a nameless interface but we did not see a space, punt. */ 290 if (gfc_match_eos () != MATCH_YES 291 || (type != INTERFACE_NAMELESS && m != MATCH_YES)) 292 { 293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE " 294 "statement at %C"); 295 return MATCH_ERROR; 296 } 297 298 m = MATCH_YES; 299 300 switch (current_interface.type) 301 { 302 case INTERFACE_NAMELESS: 303 case INTERFACE_ABSTRACT: 304 if (type != INTERFACE_NAMELESS) 305 { 306 gfc_error ("Expected a nameless interface at %C"); 307 m = MATCH_ERROR; 308 } 309 310 break; 311 312 case INTERFACE_INTRINSIC_OP: 313 if (type != current_interface.type || op != current_interface.op) 314 { 315 316 if (current_interface.op == INTRINSIC_ASSIGN) 317 { 318 m = MATCH_ERROR; 319 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C"); 320 } 321 else 322 { 323 const char *s1, *s2; 324 s1 = gfc_op2string (current_interface.op); 325 s2 = gfc_op2string (op); 326 327 /* The following if-statements are used to enforce C1202 328 from F2003. */ 329 if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0) 330 || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0)) 331 break; 332 if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0) 333 || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0)) 334 break; 335 if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0) 336 || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0)) 337 break; 338 if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0) 339 || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0)) 340 break; 341 if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0) 342 || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0)) 343 break; 344 if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0) 345 || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0)) 346 break; 347 348 m = MATCH_ERROR; 349 if (strcmp(s2, "none") == 0) 350 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> " 351 "at %C, ", s1); 352 else 353 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, " 354 "but got %s", s1, s2); 355 } 356 357 } 358 359 break; 360 361 case INTERFACE_USER_OP: 362 /* Comparing the symbol node names is OK because only use-associated 363 symbols can be renamed. */ 364 if (type != current_interface.type 365 || strcmp (current_interface.uop->name, name) != 0) 366 { 367 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C", 368 current_interface.uop->name); 369 m = MATCH_ERROR; 370 } 371 372 break; 373 374 case INTERFACE_GENERIC: 375 if (type != current_interface.type 376 || strcmp (current_interface.sym->name, name) != 0) 377 { 378 gfc_error ("Expecting %<END INTERFACE %s%> at %C", 379 current_interface.sym->name); 380 m = MATCH_ERROR; 381 } 382 383 break; 384 } 385 386 return m; 387} 388 389 390/* Compare two derived types using the criteria in 4.4.2 of the standard, 391 recursing through gfc_compare_types for the components. */ 392 393int 394gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) 395{ 396 gfc_component *dt1, *dt2; 397 398 if (derived1 == derived2) 399 return 1; 400 401 gcc_assert (derived1 && derived2); 402 403 /* Special case for comparing derived types across namespaces. If the 404 true names and module names are the same and the module name is 405 nonnull, then they are equal. */ 406 if (strcmp (derived1->name, derived2->name) == 0 407 && derived1->module != NULL && derived2->module != NULL 408 && strcmp (derived1->module, derived2->module) == 0) 409 return 1; 410 411 /* Compare type via the rules of the standard. Both types must have 412 the SEQUENCE or BIND(C) attribute to be equal. */ 413 414 if (strcmp (derived1->name, derived2->name)) 415 return 0; 416 417 if (derived1->component_access == ACCESS_PRIVATE 418 || derived2->component_access == ACCESS_PRIVATE) 419 return 0; 420 421 if (!(derived1->attr.sequence && derived2->attr.sequence) 422 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)) 423 return 0; 424 425 dt1 = derived1->components; 426 dt2 = derived2->components; 427 428 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a 429 simple test can speed things up. Otherwise, lots of things have to 430 match. */ 431 for (;;) 432 { 433 if (strcmp (dt1->name, dt2->name) != 0) 434 return 0; 435 436 if (dt1->attr.access != dt2->attr.access) 437 return 0; 438 439 if (dt1->attr.pointer != dt2->attr.pointer) 440 return 0; 441 442 if (dt1->attr.dimension != dt2->attr.dimension) 443 return 0; 444 445 if (dt1->attr.allocatable != dt2->attr.allocatable) 446 return 0; 447 448 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) 449 return 0; 450 451 /* Make sure that link lists do not put this function into an 452 endless recursive loop! */ 453 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) 454 && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived) 455 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0) 456 return 0; 457 458 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) 459 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)) 460 return 0; 461 462 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) 463 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)) 464 return 0; 465 466 dt1 = dt1->next; 467 dt2 = dt2->next; 468 469 if (dt1 == NULL && dt2 == NULL) 470 break; 471 if (dt1 == NULL || dt2 == NULL) 472 return 0; 473 } 474 475 return 1; 476} 477 478 479/* Compare two typespecs, recursively if necessary. */ 480 481int 482gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) 483{ 484 /* See if one of the typespecs is a BT_VOID, which is what is being used 485 to allow the funcs like c_f_pointer to accept any pointer type. 486 TODO: Possibly should narrow this to just the one typespec coming in 487 that is for the formal arg, but oh well. */ 488 if (ts1->type == BT_VOID || ts2->type == BT_VOID) 489 return 1; 490 491 if (ts1->type == BT_CLASS 492 && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) 493 return 1; 494 495 /* F2003: C717 */ 496 if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED 497 && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic 498 && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) 499 return 1; 500 501 if (ts1->type != ts2->type 502 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) 503 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) 504 return 0; 505 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) 506 return (ts1->kind == ts2->kind); 507 508 /* Compare derived types. */ 509 if (gfc_type_compatible (ts1, ts2)) 510 return 1; 511 512 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived); 513} 514 515 516static int 517compare_type (gfc_symbol *s1, gfc_symbol *s2) 518{ 519 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 520 return 1; 521 522 /* TYPE and CLASS of the same declared type are type compatible, 523 but have different characteristics. */ 524 if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) 525 || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) 526 return 0; 527 528 return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; 529} 530 531 532static int 533compare_rank (gfc_symbol *s1, gfc_symbol *s2) 534{ 535 gfc_array_spec *as1, *as2; 536 int r1, r2; 537 538 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 539 return 1; 540 541 as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as; 542 as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as; 543 544 r1 = as1 ? as1->rank : 0; 545 r2 = as2 ? as2->rank : 0; 546 547 if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) 548 return 0; /* Ranks differ. */ 549 550 return 1; 551} 552 553 554/* Given two symbols that are formal arguments, compare their ranks 555 and types. Returns nonzero if they have the same rank and type, 556 zero otherwise. */ 557 558static int 559compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) 560{ 561 return compare_type (s1, s2) && compare_rank (s1, s2); 562} 563 564 565/* Given two symbols that are formal arguments, compare their types 566 and rank and their formal interfaces if they are both dummy 567 procedures. Returns nonzero if the same, zero if different. */ 568 569static int 570compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2) 571{ 572 if (s1 == NULL || s2 == NULL) 573 return s1 == s2 ? 1 : 0; 574 575 if (s1 == s2) 576 return 1; 577 578 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) 579 return compare_type_rank (s1, s2); 580 581 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) 582 return 0; 583 584 /* At this point, both symbols are procedures. It can happen that 585 external procedures are compared, where one is identified by usage 586 to be a function or subroutine but the other is not. Check TKR 587 nonetheless for these cases. */ 588 if (s1->attr.function == 0 && s1->attr.subroutine == 0) 589 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0; 590 591 if (s2->attr.function == 0 && s2->attr.subroutine == 0) 592 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0; 593 594 /* Now the type of procedure has been identified. */ 595 if (s1->attr.function != s2->attr.function 596 || s1->attr.subroutine != s2->attr.subroutine) 597 return 0; 598 599 if (s1->attr.function && compare_type_rank (s1, s2) == 0) 600 return 0; 601 602 /* Originally, gfortran recursed here to check the interfaces of passed 603 procedures. This is explicitly not required by the standard. */ 604 return 1; 605} 606 607 608/* Given a formal argument list and a keyword name, search the list 609 for that keyword. Returns the correct symbol node if found, NULL 610 if not found. */ 611 612static gfc_symbol * 613find_keyword_arg (const char *name, gfc_formal_arglist *f) 614{ 615 for (; f; f = f->next) 616 if (strcmp (f->sym->name, name) == 0) 617 return f->sym; 618 619 return NULL; 620} 621 622 623/******** Interface checking subroutines **********/ 624 625 626/* Given an operator interface and the operator, make sure that all 627 interfaces for that operator are legal. */ 628 629bool 630gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op, 631 locus opwhere) 632{ 633 gfc_formal_arglist *formal; 634 sym_intent i1, i2; 635 bt t1, t2; 636 int args, r1, r2, k1, k2; 637 638 gcc_assert (sym); 639 640 args = 0; 641 t1 = t2 = BT_UNKNOWN; 642 i1 = i2 = INTENT_UNKNOWN; 643 r1 = r2 = -1; 644 k1 = k2 = -1; 645 646 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) 647 { 648 gfc_symbol *fsym = formal->sym; 649 if (fsym == NULL) 650 { 651 gfc_error ("Alternate return cannot appear in operator " 652 "interface at %L", &sym->declared_at); 653 return false; 654 } 655 if (args == 0) 656 { 657 t1 = fsym->ts.type; 658 i1 = fsym->attr.intent; 659 r1 = (fsym->as != NULL) ? fsym->as->rank : 0; 660 k1 = fsym->ts.kind; 661 } 662 if (args == 1) 663 { 664 t2 = fsym->ts.type; 665 i2 = fsym->attr.intent; 666 r2 = (fsym->as != NULL) ? fsym->as->rank : 0; 667 k2 = fsym->ts.kind; 668 } 669 args++; 670 } 671 672 /* Only +, - and .not. can be unary operators. 673 .not. cannot be a binary operator. */ 674 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS 675 && op != INTRINSIC_MINUS 676 && op != INTRINSIC_NOT) 677 || (args == 2 && op == INTRINSIC_NOT)) 678 { 679 if (op == INTRINSIC_ASSIGN) 680 gfc_error ("Assignment operator interface at %L must have " 681 "two arguments", &sym->declared_at); 682 else 683 gfc_error ("Operator interface at %L has the wrong number of arguments", 684 &sym->declared_at); 685 return false; 686 } 687 688 /* Check that intrinsics are mapped to functions, except 689 INTRINSIC_ASSIGN which should map to a subroutine. */ 690 if (op == INTRINSIC_ASSIGN) 691 { 692 gfc_formal_arglist *dummy_args; 693 694 if (!sym->attr.subroutine) 695 { 696 gfc_error ("Assignment operator interface at %L must be " 697 "a SUBROUTINE", &sym->declared_at); 698 return false; 699 } 700 701 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments): 702 - First argument an array with different rank than second, 703 - First argument is a scalar and second an array, 704 - Types and kinds do not conform, or 705 - First argument is of derived type. */ 706 dummy_args = gfc_sym_get_dummy_args (sym); 707 if (dummy_args->sym->ts.type != BT_DERIVED 708 && dummy_args->sym->ts.type != BT_CLASS 709 && (r2 == 0 || r1 == r2) 710 && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type 711 || (gfc_numeric_ts (&dummy_args->sym->ts) 712 && gfc_numeric_ts (&dummy_args->next->sym->ts)))) 713 { 714 gfc_error ("Assignment operator interface at %L must not redefine " 715 "an INTRINSIC type assignment", &sym->declared_at); 716 return false; 717 } 718 } 719 else 720 { 721 if (!sym->attr.function) 722 { 723 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", 724 &sym->declared_at); 725 return false; 726 } 727 } 728 729 /* Check intents on operator interfaces. */ 730 if (op == INTRINSIC_ASSIGN) 731 { 732 if (i1 != INTENT_OUT && i1 != INTENT_INOUT) 733 { 734 gfc_error ("First argument of defined assignment at %L must be " 735 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at); 736 return false; 737 } 738 739 if (i2 != INTENT_IN) 740 { 741 gfc_error ("Second argument of defined assignment at %L must be " 742 "INTENT(IN)", &sym->declared_at); 743 return false; 744 } 745 } 746 else 747 { 748 if (i1 != INTENT_IN) 749 { 750 gfc_error ("First argument of operator interface at %L must be " 751 "INTENT(IN)", &sym->declared_at); 752 return false; 753 } 754 755 if (args == 2 && i2 != INTENT_IN) 756 { 757 gfc_error ("Second argument of operator interface at %L must be " 758 "INTENT(IN)", &sym->declared_at); 759 return false; 760 } 761 } 762 763 /* From now on, all we have to do is check that the operator definition 764 doesn't conflict with an intrinsic operator. The rules for this 765 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards, 766 as well as 12.3.2.1.1 of Fortran 2003: 767 768 "If the operator is an intrinsic-operator (R310), the number of 769 function arguments shall be consistent with the intrinsic uses of 770 that operator, and the types, kind type parameters, or ranks of the 771 dummy arguments shall differ from those required for the intrinsic 772 operation (7.1.2)." */ 773 774#define IS_NUMERIC_TYPE(t) \ 775 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX) 776 777 /* Unary ops are easy, do them first. */ 778 if (op == INTRINSIC_NOT) 779 { 780 if (t1 == BT_LOGICAL) 781 goto bad_repl; 782 else 783 return true; 784 } 785 786 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS)) 787 { 788 if (IS_NUMERIC_TYPE (t1)) 789 goto bad_repl; 790 else 791 return true; 792 } 793 794 /* Character intrinsic operators have same character kind, thus 795 operator definitions with operands of different character kinds 796 are always safe. */ 797 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) 798 return true; 799 800 /* Intrinsic operators always perform on arguments of same rank, 801 so different ranks is also always safe. (rank == 0) is an exception 802 to that, because all intrinsic operators are elemental. */ 803 if (r1 != r2 && r1 != 0 && r2 != 0) 804 return true; 805 806 switch (op) 807 { 808 case INTRINSIC_EQ: 809 case INTRINSIC_EQ_OS: 810 case INTRINSIC_NE: 811 case INTRINSIC_NE_OS: 812 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 813 goto bad_repl; 814 /* Fall through. */ 815 816 case INTRINSIC_PLUS: 817 case INTRINSIC_MINUS: 818 case INTRINSIC_TIMES: 819 case INTRINSIC_DIVIDE: 820 case INTRINSIC_POWER: 821 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2)) 822 goto bad_repl; 823 break; 824 825 case INTRINSIC_GT: 826 case INTRINSIC_GT_OS: 827 case INTRINSIC_GE: 828 case INTRINSIC_GE_OS: 829 case INTRINSIC_LT: 830 case INTRINSIC_LT_OS: 831 case INTRINSIC_LE: 832 case INTRINSIC_LE_OS: 833 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 834 goto bad_repl; 835 if ((t1 == BT_INTEGER || t1 == BT_REAL) 836 && (t2 == BT_INTEGER || t2 == BT_REAL)) 837 goto bad_repl; 838 break; 839 840 case INTRINSIC_CONCAT: 841 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 842 goto bad_repl; 843 break; 844 845 case INTRINSIC_AND: 846 case INTRINSIC_OR: 847 case INTRINSIC_EQV: 848 case INTRINSIC_NEQV: 849 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) 850 goto bad_repl; 851 break; 852 853 default: 854 break; 855 } 856 857 return true; 858 859#undef IS_NUMERIC_TYPE 860 861bad_repl: 862 gfc_error ("Operator interface at %L conflicts with intrinsic interface", 863 &opwhere); 864 return false; 865} 866 867 868/* Given a pair of formal argument lists, we see if the two lists can 869 be distinguished by counting the number of nonoptional arguments of 870 a given type/rank in f1 and seeing if there are less then that 871 number of those arguments in f2 (including optional arguments). 872 Since this test is asymmetric, it has to be called twice to make it 873 symmetric. Returns nonzero if the argument lists are incompatible 874 by this test. This subroutine implements rule 1 of section F03:16.2.3. 875 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ 876 877static int 878count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, 879 const char *p1, const char *p2) 880{ 881 int rc, ac1, ac2, i, j, k, n1; 882 gfc_formal_arglist *f; 883 884 typedef struct 885 { 886 int flag; 887 gfc_symbol *sym; 888 } 889 arginfo; 890 891 arginfo *arg; 892 893 n1 = 0; 894 895 for (f = f1; f; f = f->next) 896 n1++; 897 898 /* Build an array of integers that gives the same integer to 899 arguments of the same type/rank. */ 900 arg = XCNEWVEC (arginfo, n1); 901 902 f = f1; 903 for (i = 0; i < n1; i++, f = f->next) 904 { 905 arg[i].flag = -1; 906 arg[i].sym = f->sym; 907 } 908 909 k = 0; 910 911 for (i = 0; i < n1; i++) 912 { 913 if (arg[i].flag != -1) 914 continue; 915 916 if (arg[i].sym && (arg[i].sym->attr.optional 917 || (p1 && strcmp (arg[i].sym->name, p1) == 0))) 918 continue; /* Skip OPTIONAL and PASS arguments. */ 919 920 arg[i].flag = k; 921 922 /* Find other non-optional, non-pass arguments of the same type/rank. */ 923 for (j = i + 1; j < n1; j++) 924 if ((arg[j].sym == NULL 925 || !(arg[j].sym->attr.optional 926 || (p1 && strcmp (arg[j].sym->name, p1) == 0))) 927 && (compare_type_rank_if (arg[i].sym, arg[j].sym) 928 || compare_type_rank_if (arg[j].sym, arg[i].sym))) 929 arg[j].flag = k; 930 931 k++; 932 } 933 934 /* Now loop over each distinct type found in f1. */ 935 k = 0; 936 rc = 0; 937 938 for (i = 0; i < n1; i++) 939 { 940 if (arg[i].flag != k) 941 continue; 942 943 ac1 = 1; 944 for (j = i + 1; j < n1; j++) 945 if (arg[j].flag == k) 946 ac1++; 947 948 /* Count the number of non-pass arguments in f2 with that type, 949 including those that are optional. */ 950 ac2 = 0; 951 952 for (f = f2; f; f = f->next) 953 if ((!p2 || strcmp (f->sym->name, p2) != 0) 954 && (compare_type_rank_if (arg[i].sym, f->sym) 955 || compare_type_rank_if (f->sym, arg[i].sym))) 956 ac2++; 957 958 if (ac1 > ac2) 959 { 960 rc = 1; 961 break; 962 } 963 964 k++; 965 } 966 967 free (arg); 968 969 return rc; 970} 971 972 973/* Perform the correspondence test in rule (3) of F08:C1215. 974 Returns zero if no argument is found that satisfies this rule, 975 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures 976 (if applicable). 977 978 This test is also not symmetric in f1 and f2 and must be called 979 twice. This test finds problems caused by sorting the actual 980 argument list with keywords. For example: 981 982 INTERFACE FOO 983 SUBROUTINE F1(A, B) 984 INTEGER :: A ; REAL :: B 985 END SUBROUTINE F1 986 987 SUBROUTINE F2(B, A) 988 INTEGER :: A ; REAL :: B 989 END SUBROUTINE F1 990 END INTERFACE FOO 991 992 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ 993 994static int 995generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, 996 const char *p1, const char *p2) 997{ 998 gfc_formal_arglist *f2_save, *g; 999 gfc_symbol *sym; 1000 1001 f2_save = f2; 1002 1003 while (f1) 1004 { 1005 if (f1->sym->attr.optional) 1006 goto next; 1007 1008 if (p1 && strcmp (f1->sym->name, p1) == 0) 1009 f1 = f1->next; 1010 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0) 1011 f2 = f2->next; 1012 1013 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) 1014 || compare_type_rank (f2->sym, f1->sym)) 1015 && !((gfc_option.allow_std & GFC_STD_F2008) 1016 && ((f1->sym->attr.allocatable && f2->sym->attr.pointer) 1017 || (f2->sym->attr.allocatable && f1->sym->attr.pointer)))) 1018 goto next; 1019 1020 /* Now search for a disambiguating keyword argument starting at 1021 the current non-match. */ 1022 for (g = f1; g; g = g->next) 1023 { 1024 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0)) 1025 continue; 1026 1027 sym = find_keyword_arg (g->sym->name, f2_save); 1028 if (sym == NULL || !compare_type_rank (g->sym, sym) 1029 || ((gfc_option.allow_std & GFC_STD_F2008) 1030 && ((sym->attr.allocatable && g->sym->attr.pointer) 1031 || (sym->attr.pointer && g->sym->attr.allocatable)))) 1032 return 1; 1033 } 1034 1035 next: 1036 if (f1 != NULL) 1037 f1 = f1->next; 1038 if (f2 != NULL) 1039 f2 = f2->next; 1040 } 1041 1042 return 0; 1043} 1044 1045 1046static int 1047symbol_rank (gfc_symbol *sym) 1048{ 1049 gfc_array_spec *as; 1050 as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as; 1051 return as ? as->rank : 0; 1052} 1053 1054 1055/* Check if the characteristics of two dummy arguments match, 1056 cf. F08:12.3.2. */ 1057 1058static bool 1059check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, 1060 bool type_must_agree, char *errmsg, int err_len) 1061{ 1062 if (s1 == NULL || s2 == NULL) 1063 return s1 == s2 ? true : false; 1064 1065 /* Check type and rank. */ 1066 if (type_must_agree) 1067 { 1068 if (!compare_type (s1, s2) || !compare_type (s2, s1)) 1069 { 1070 snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)", 1071 s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts)); 1072 return false; 1073 } 1074 if (!compare_rank (s1, s2)) 1075 { 1076 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)", 1077 s1->name, symbol_rank (s1), symbol_rank (s2)); 1078 return false; 1079 } 1080 } 1081 1082 /* Check INTENT. */ 1083 if (s1->attr.intent != s2->attr.intent) 1084 { 1085 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", 1086 s1->name); 1087 return false; 1088 } 1089 1090 /* Check OPTIONAL attribute. */ 1091 if (s1->attr.optional != s2->attr.optional) 1092 { 1093 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", 1094 s1->name); 1095 return false; 1096 } 1097 1098 /* Check ALLOCATABLE attribute. */ 1099 if (s1->attr.allocatable != s2->attr.allocatable) 1100 { 1101 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", 1102 s1->name); 1103 return false; 1104 } 1105 1106 /* Check POINTER attribute. */ 1107 if (s1->attr.pointer != s2->attr.pointer) 1108 { 1109 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", 1110 s1->name); 1111 return false; 1112 } 1113 1114 /* Check TARGET attribute. */ 1115 if (s1->attr.target != s2->attr.target) 1116 { 1117 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", 1118 s1->name); 1119 return false; 1120 } 1121 1122 /* Check ASYNCHRONOUS attribute. */ 1123 if (s1->attr.asynchronous != s2->attr.asynchronous) 1124 { 1125 snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", 1126 s1->name); 1127 return false; 1128 } 1129 1130 /* Check CONTIGUOUS attribute. */ 1131 if (s1->attr.contiguous != s2->attr.contiguous) 1132 { 1133 snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", 1134 s1->name); 1135 return false; 1136 } 1137 1138 /* Check VALUE attribute. */ 1139 if (s1->attr.value != s2->attr.value) 1140 { 1141 snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", 1142 s1->name); 1143 return false; 1144 } 1145 1146 /* Check VOLATILE attribute. */ 1147 if (s1->attr.volatile_ != s2->attr.volatile_) 1148 { 1149 snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", 1150 s1->name); 1151 return false; 1152 } 1153 1154 /* Check interface of dummy procedures. */ 1155 if (s1->attr.flavor == FL_PROCEDURE) 1156 { 1157 char err[200]; 1158 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err), 1159 NULL, NULL)) 1160 { 1161 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure " 1162 "'%s': %s", s1->name, err); 1163 return false; 1164 } 1165 } 1166 1167 /* Check string length. */ 1168 if (s1->ts.type == BT_CHARACTER 1169 && s1->ts.u.cl && s1->ts.u.cl->length 1170 && s2->ts.u.cl && s2->ts.u.cl->length) 1171 { 1172 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length, 1173 s2->ts.u.cl->length); 1174 switch (compval) 1175 { 1176 case -1: 1177 case 1: 1178 case -3: 1179 snprintf (errmsg, err_len, "Character length mismatch " 1180 "in argument '%s'", s1->name); 1181 return false; 1182 1183 case -2: 1184 /* FIXME: Implement a warning for this case. 1185 gfc_warning (0, "Possible character length mismatch in argument %qs", 1186 s1->name);*/ 1187 break; 1188 1189 case 0: 1190 break; 1191 1192 default: 1193 gfc_internal_error ("check_dummy_characteristics: Unexpected result " 1194 "%i of gfc_dep_compare_expr", compval); 1195 break; 1196 } 1197 } 1198 1199 /* Check array shape. */ 1200 if (s1->as && s2->as) 1201 { 1202 int i, compval; 1203 gfc_expr *shape1, *shape2; 1204 1205 if (s1->as->type != s2->as->type) 1206 { 1207 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", 1208 s1->name); 1209 return false; 1210 } 1211 1212 if (s1->as->corank != s2->as->corank) 1213 { 1214 snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)", 1215 s1->name, s1->as->corank, s2->as->corank); 1216 return false; 1217 } 1218 1219 if (s1->as->type == AS_EXPLICIT) 1220 for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++) 1221 { 1222 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]), 1223 gfc_copy_expr (s1->as->lower[i])); 1224 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]), 1225 gfc_copy_expr (s2->as->lower[i])); 1226 compval = gfc_dep_compare_expr (shape1, shape2); 1227 gfc_free_expr (shape1); 1228 gfc_free_expr (shape2); 1229 switch (compval) 1230 { 1231 case -1: 1232 case 1: 1233 case -3: 1234 if (i < s1->as->rank) 1235 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of" 1236 " argument '%s'", i + 1, s1->name); 1237 else 1238 snprintf (errmsg, err_len, "Shape mismatch in codimension %i " 1239 "of argument '%s'", i - s1->as->rank + 1, s1->name); 1240 return false; 1241 1242 case -2: 1243 /* FIXME: Implement a warning for this case. 1244 gfc_warning (0, "Possible shape mismatch in argument %qs", 1245 s1->name);*/ 1246 break; 1247 1248 case 0: 1249 break; 1250 1251 default: 1252 gfc_internal_error ("check_dummy_characteristics: Unexpected " 1253 "result %i of gfc_dep_compare_expr", 1254 compval); 1255 break; 1256 } 1257 } 1258 } 1259 1260 return true; 1261} 1262 1263 1264/* Check if the characteristics of two function results match, 1265 cf. F08:12.3.3. */ 1266 1267static bool 1268check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, 1269 char *errmsg, int err_len) 1270{ 1271 gfc_symbol *r1, *r2; 1272 1273 if (s1->ts.interface && s1->ts.interface->result) 1274 r1 = s1->ts.interface->result; 1275 else 1276 r1 = s1->result ? s1->result : s1; 1277 1278 if (s2->ts.interface && s2->ts.interface->result) 1279 r2 = s2->ts.interface->result; 1280 else 1281 r2 = s2->result ? s2->result : s2; 1282 1283 if (r1->ts.type == BT_UNKNOWN) 1284 return true; 1285 1286 /* Check type and rank. */ 1287 if (!compare_type (r1, r2)) 1288 { 1289 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)", 1290 gfc_typename (&r1->ts), gfc_typename (&r2->ts)); 1291 return false; 1292 } 1293 if (!compare_rank (r1, r2)) 1294 { 1295 snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)", 1296 symbol_rank (r1), symbol_rank (r2)); 1297 return false; 1298 } 1299 1300 /* Check ALLOCATABLE attribute. */ 1301 if (r1->attr.allocatable != r2->attr.allocatable) 1302 { 1303 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " 1304 "function result"); 1305 return false; 1306 } 1307 1308 /* Check POINTER attribute. */ 1309 if (r1->attr.pointer != r2->attr.pointer) 1310 { 1311 snprintf (errmsg, err_len, "POINTER attribute mismatch in " 1312 "function result"); 1313 return false; 1314 } 1315 1316 /* Check CONTIGUOUS attribute. */ 1317 if (r1->attr.contiguous != r2->attr.contiguous) 1318 { 1319 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " 1320 "function result"); 1321 return false; 1322 } 1323 1324 /* Check PROCEDURE POINTER attribute. */ 1325 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) 1326 { 1327 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " 1328 "function result"); 1329 return false; 1330 } 1331 1332 /* Check string length. */ 1333 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) 1334 { 1335 if (r1->ts.deferred != r2->ts.deferred) 1336 { 1337 snprintf (errmsg, err_len, "Character length mismatch " 1338 "in function result"); 1339 return false; 1340 } 1341 1342 if (r1->ts.u.cl->length && r2->ts.u.cl->length) 1343 { 1344 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, 1345 r2->ts.u.cl->length); 1346 switch (compval) 1347 { 1348 case -1: 1349 case 1: 1350 case -3: 1351 snprintf (errmsg, err_len, "Character length mismatch " 1352 "in function result"); 1353 return false; 1354 1355 case -2: 1356 /* FIXME: Implement a warning for this case. 1357 snprintf (errmsg, err_len, "Possible character length mismatch " 1358 "in function result");*/ 1359 break; 1360 1361 case 0: 1362 break; 1363 1364 default: 1365 gfc_internal_error ("check_result_characteristics (1): Unexpected " 1366 "result %i of gfc_dep_compare_expr", compval); 1367 break; 1368 } 1369 } 1370 } 1371 1372 /* Check array shape. */ 1373 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) 1374 { 1375 int i, compval; 1376 gfc_expr *shape1, *shape2; 1377 1378 if (r1->as->type != r2->as->type) 1379 { 1380 snprintf (errmsg, err_len, "Shape mismatch in function result"); 1381 return false; 1382 } 1383 1384 if (r1->as->type == AS_EXPLICIT) 1385 for (i = 0; i < r1->as->rank + r1->as->corank; i++) 1386 { 1387 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), 1388 gfc_copy_expr (r1->as->lower[i])); 1389 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), 1390 gfc_copy_expr (r2->as->lower[i])); 1391 compval = gfc_dep_compare_expr (shape1, shape2); 1392 gfc_free_expr (shape1); 1393 gfc_free_expr (shape2); 1394 switch (compval) 1395 { 1396 case -1: 1397 case 1: 1398 case -3: 1399 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " 1400 "function result", i + 1); 1401 return false; 1402 1403 case -2: 1404 /* FIXME: Implement a warning for this case. 1405 gfc_warning (0, "Possible shape mismatch in return value");*/ 1406 break; 1407 1408 case 0: 1409 break; 1410 1411 default: 1412 gfc_internal_error ("check_result_characteristics (2): " 1413 "Unexpected result %i of " 1414 "gfc_dep_compare_expr", compval); 1415 break; 1416 } 1417 } 1418 } 1419 1420 return true; 1421} 1422 1423 1424/* 'Compare' two formal interfaces associated with a pair of symbols. 1425 We return nonzero if there exists an actual argument list that 1426 would be ambiguous between the two interfaces, zero otherwise. 1427 'strict_flag' specifies whether all the characteristics are 1428 required to match, which is not the case for ambiguity checks. 1429 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ 1430 1431int 1432gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, 1433 int generic_flag, int strict_flag, 1434 char *errmsg, int err_len, 1435 const char *p1, const char *p2) 1436{ 1437 gfc_formal_arglist *f1, *f2; 1438 1439 gcc_assert (name2 != NULL); 1440 1441 if (s1->attr.function && (s2->attr.subroutine 1442 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN 1443 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN))) 1444 { 1445 if (errmsg != NULL) 1446 snprintf (errmsg, err_len, "'%s' is not a function", name2); 1447 return 0; 1448 } 1449 1450 if (s1->attr.subroutine && s2->attr.function) 1451 { 1452 if (errmsg != NULL) 1453 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); 1454 return 0; 1455 } 1456 1457 /* Do strict checks on all characteristics 1458 (for dummy procedures and procedure pointer assignments). */ 1459 if (!generic_flag && strict_flag) 1460 { 1461 if (s1->attr.function && s2->attr.function) 1462 { 1463 /* If both are functions, check result characteristics. */ 1464 if (!check_result_characteristics (s1, s2, errmsg, err_len) 1465 || !check_result_characteristics (s2, s1, errmsg, err_len)) 1466 return 0; 1467 } 1468 1469 if (s1->attr.pure && !s2->attr.pure) 1470 { 1471 snprintf (errmsg, err_len, "Mismatch in PURE attribute"); 1472 return 0; 1473 } 1474 if (s1->attr.elemental && !s2->attr.elemental) 1475 { 1476 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute"); 1477 return 0; 1478 } 1479 } 1480 1481 if (s1->attr.if_source == IFSRC_UNKNOWN 1482 || s2->attr.if_source == IFSRC_UNKNOWN) 1483 return 1; 1484 1485 f1 = gfc_sym_get_dummy_args (s1); 1486 f2 = gfc_sym_get_dummy_args (s2); 1487 1488 if (f1 == NULL && f2 == NULL) 1489 return 1; /* Special case: No arguments. */ 1490 1491 if (generic_flag) 1492 { 1493 if (count_types_test (f1, f2, p1, p2) 1494 || count_types_test (f2, f1, p2, p1)) 1495 return 0; 1496 if (generic_correspondence (f1, f2, p1, p2) 1497 || generic_correspondence (f2, f1, p2, p1)) 1498 return 0; 1499 } 1500 else 1501 /* Perform the abbreviated correspondence test for operators (the 1502 arguments cannot be optional and are always ordered correctly). 1503 This is also done when comparing interfaces for dummy procedures and in 1504 procedure pointer assignments. */ 1505 1506 for (;;) 1507 { 1508 /* Check existence. */ 1509 if (f1 == NULL && f2 == NULL) 1510 break; 1511 if (f1 == NULL || f2 == NULL) 1512 { 1513 if (errmsg != NULL) 1514 snprintf (errmsg, err_len, "'%s' has the wrong number of " 1515 "arguments", name2); 1516 return 0; 1517 } 1518 1519 if (UNLIMITED_POLY (f1->sym)) 1520 goto next; 1521 1522 if (strict_flag) 1523 { 1524 /* Check all characteristics. */ 1525 if (!check_dummy_characteristics (f1->sym, f2->sym, true, 1526 errmsg, err_len)) 1527 return 0; 1528 } 1529 else 1530 { 1531 /* Only check type and rank. */ 1532 if (!compare_type (f2->sym, f1->sym)) 1533 { 1534 if (errmsg != NULL) 1535 snprintf (errmsg, err_len, "Type mismatch in argument '%s' " 1536 "(%s/%s)", f1->sym->name, 1537 gfc_typename (&f1->sym->ts), 1538 gfc_typename (&f2->sym->ts)); 1539 return 0; 1540 } 1541 if (!compare_rank (f2->sym, f1->sym)) 1542 { 1543 if (errmsg != NULL) 1544 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' " 1545 "(%i/%i)", f1->sym->name, symbol_rank (f1->sym), 1546 symbol_rank (f2->sym)); 1547 return 0; 1548 } 1549 } 1550next: 1551 f1 = f1->next; 1552 f2 = f2->next; 1553 } 1554 1555 return 1; 1556} 1557 1558 1559/* Given a pointer to an interface pointer, remove duplicate 1560 interfaces and make sure that all symbols are either functions 1561 or subroutines, and all of the same kind. Returns nonzero if 1562 something goes wrong. */ 1563 1564static int 1565check_interface0 (gfc_interface *p, const char *interface_name) 1566{ 1567 gfc_interface *psave, *q, *qlast; 1568 1569 psave = p; 1570 for (; p; p = p->next) 1571 { 1572 /* Make sure all symbols in the interface have been defined as 1573 functions or subroutines. */ 1574 if (((!p->sym->attr.function && !p->sym->attr.subroutine) 1575 || !p->sym->attr.if_source) 1576 && p->sym->attr.flavor != FL_DERIVED) 1577 { 1578 if (p->sym->attr.external) 1579 gfc_error ("Procedure %qs in %s at %L has no explicit interface", 1580 p->sym->name, interface_name, &p->sym->declared_at); 1581 else 1582 gfc_error ("Procedure %qs in %s at %L is neither function nor " 1583 "subroutine", p->sym->name, interface_name, 1584 &p->sym->declared_at); 1585 return 1; 1586 } 1587 1588 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ 1589 if ((psave->sym->attr.function && !p->sym->attr.function 1590 && p->sym->attr.flavor != FL_DERIVED) 1591 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) 1592 { 1593 if (p->sym->attr.flavor != FL_DERIVED) 1594 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" 1595 " or all FUNCTIONs", interface_name, 1596 &p->sym->declared_at); 1597 else 1598 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " 1599 "generic name is also the name of a derived type", 1600 interface_name, &p->sym->declared_at); 1601 return 1; 1602 } 1603 1604 /* F2003, C1207. F2008, C1207. */ 1605 if (p->sym->attr.proc == PROC_INTERNAL 1606 && !gfc_notify_std (GFC_STD_F2008, "Internal procedure " 1607 "%qs in %s at %L", p->sym->name, 1608 interface_name, &p->sym->declared_at)) 1609 return 1; 1610 } 1611 p = psave; 1612 1613 /* Remove duplicate interfaces in this interface list. */ 1614 for (; p; p = p->next) 1615 { 1616 qlast = p; 1617 1618 for (q = p->next; q;) 1619 { 1620 if (p->sym != q->sym) 1621 { 1622 qlast = q; 1623 q = q->next; 1624 } 1625 else 1626 { 1627 /* Duplicate interface. */ 1628 qlast->next = q->next; 1629 free (q); 1630 q = qlast->next; 1631 } 1632 } 1633 } 1634 1635 return 0; 1636} 1637 1638 1639/* Check lists of interfaces to make sure that no two interfaces are 1640 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */ 1641 1642static int 1643check_interface1 (gfc_interface *p, gfc_interface *q0, 1644 int generic_flag, const char *interface_name, 1645 bool referenced) 1646{ 1647 gfc_interface *q; 1648 for (; p; p = p->next) 1649 for (q = q0; q; q = q->next) 1650 { 1651 if (p->sym == q->sym) 1652 continue; /* Duplicates OK here. */ 1653 1654 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) 1655 continue; 1656 1657 if (p->sym->attr.flavor != FL_DERIVED 1658 && q->sym->attr.flavor != FL_DERIVED 1659 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, 1660 generic_flag, 0, NULL, 0, NULL, NULL)) 1661 { 1662 if (referenced) 1663 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L", 1664 p->sym->name, q->sym->name, interface_name, 1665 &p->where); 1666 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) 1667 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L", 1668 p->sym->name, q->sym->name, interface_name, 1669 &p->where); 1670 else 1671 gfc_warning (0, "Although not referenced, %qs has ambiguous " 1672 "interfaces at %L", interface_name, &p->where); 1673 return 1; 1674 } 1675 } 1676 return 0; 1677} 1678 1679 1680/* Check the generic and operator interfaces of symbols to make sure 1681 that none of the interfaces conflict. The check has to be done 1682 after all of the symbols are actually loaded. */ 1683 1684static void 1685check_sym_interfaces (gfc_symbol *sym) 1686{ 1687 char interface_name[100]; 1688 gfc_interface *p; 1689 1690 if (sym->ns != gfc_current_ns) 1691 return; 1692 1693 if (sym->generic != NULL) 1694 { 1695 sprintf (interface_name, "generic interface '%s'", sym->name); 1696 if (check_interface0 (sym->generic, interface_name)) 1697 return; 1698 1699 for (p = sym->generic; p; p = p->next) 1700 { 1701 if (p->sym->attr.mod_proc 1702 && (p->sym->attr.if_source != IFSRC_DECL 1703 || p->sym->attr.procedure)) 1704 { 1705 gfc_error ("%qs at %L is not a module procedure", 1706 p->sym->name, &p->where); 1707 return; 1708 } 1709 } 1710 1711 /* Originally, this test was applied to host interfaces too; 1712 this is incorrect since host associated symbols, from any 1713 source, cannot be ambiguous with local symbols. */ 1714 check_interface1 (sym->generic, sym->generic, 1, interface_name, 1715 sym->attr.referenced || !sym->attr.use_assoc); 1716 } 1717} 1718 1719 1720static void 1721check_uop_interfaces (gfc_user_op *uop) 1722{ 1723 char interface_name[100]; 1724 gfc_user_op *uop2; 1725 gfc_namespace *ns; 1726 1727 sprintf (interface_name, "operator interface '%s'", uop->name); 1728 if (check_interface0 (uop->op, interface_name)) 1729 return; 1730 1731 for (ns = gfc_current_ns; ns; ns = ns->parent) 1732 { 1733 uop2 = gfc_find_uop (uop->name, ns); 1734 if (uop2 == NULL) 1735 continue; 1736 1737 check_interface1 (uop->op, uop2->op, 0, 1738 interface_name, true); 1739 } 1740} 1741 1742/* Given an intrinsic op, return an equivalent op if one exists, 1743 or INTRINSIC_NONE otherwise. */ 1744 1745gfc_intrinsic_op 1746gfc_equivalent_op (gfc_intrinsic_op op) 1747{ 1748 switch(op) 1749 { 1750 case INTRINSIC_EQ: 1751 return INTRINSIC_EQ_OS; 1752 1753 case INTRINSIC_EQ_OS: 1754 return INTRINSIC_EQ; 1755 1756 case INTRINSIC_NE: 1757 return INTRINSIC_NE_OS; 1758 1759 case INTRINSIC_NE_OS: 1760 return INTRINSIC_NE; 1761 1762 case INTRINSIC_GT: 1763 return INTRINSIC_GT_OS; 1764 1765 case INTRINSIC_GT_OS: 1766 return INTRINSIC_GT; 1767 1768 case INTRINSIC_GE: 1769 return INTRINSIC_GE_OS; 1770 1771 case INTRINSIC_GE_OS: 1772 return INTRINSIC_GE; 1773 1774 case INTRINSIC_LT: 1775 return INTRINSIC_LT_OS; 1776 1777 case INTRINSIC_LT_OS: 1778 return INTRINSIC_LT; 1779 1780 case INTRINSIC_LE: 1781 return INTRINSIC_LE_OS; 1782 1783 case INTRINSIC_LE_OS: 1784 return INTRINSIC_LE; 1785 1786 default: 1787 return INTRINSIC_NONE; 1788 } 1789} 1790 1791/* For the namespace, check generic, user operator and intrinsic 1792 operator interfaces for consistency and to remove duplicate 1793 interfaces. We traverse the whole namespace, counting on the fact 1794 that most symbols will not have generic or operator interfaces. */ 1795 1796void 1797gfc_check_interfaces (gfc_namespace *ns) 1798{ 1799 gfc_namespace *old_ns, *ns2; 1800 char interface_name[100]; 1801 int i; 1802 1803 old_ns = gfc_current_ns; 1804 gfc_current_ns = ns; 1805 1806 gfc_traverse_ns (ns, check_sym_interfaces); 1807 1808 gfc_traverse_user_op (ns, check_uop_interfaces); 1809 1810 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) 1811 { 1812 if (i == INTRINSIC_USER) 1813 continue; 1814 1815 if (i == INTRINSIC_ASSIGN) 1816 strcpy (interface_name, "intrinsic assignment operator"); 1817 else 1818 sprintf (interface_name, "intrinsic '%s' operator", 1819 gfc_op2string ((gfc_intrinsic_op) i)); 1820 1821 if (check_interface0 (ns->op[i], interface_name)) 1822 continue; 1823 1824 if (ns->op[i]) 1825 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i, 1826 ns->op[i]->where); 1827 1828 for (ns2 = ns; ns2; ns2 = ns2->parent) 1829 { 1830 gfc_intrinsic_op other_op; 1831 1832 if (check_interface1 (ns->op[i], ns2->op[i], 0, 1833 interface_name, true)) 1834 goto done; 1835 1836 /* i should be gfc_intrinsic_op, but has to be int with this cast 1837 here for stupid C++ compatibility rules. */ 1838 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i); 1839 if (other_op != INTRINSIC_NONE 1840 && check_interface1 (ns->op[i], ns2->op[other_op], 1841 0, interface_name, true)) 1842 goto done; 1843 } 1844 } 1845 1846done: 1847 gfc_current_ns = old_ns; 1848} 1849 1850 1851/* Given a symbol of a formal argument list and an expression, if the 1852 formal argument is allocatable, check that the actual argument is 1853 allocatable. Returns nonzero if compatible, zero if not compatible. */ 1854 1855static int 1856compare_allocatable (gfc_symbol *formal, gfc_expr *actual) 1857{ 1858 symbol_attribute attr; 1859 1860 if (formal->attr.allocatable 1861 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) 1862 { 1863 attr = gfc_expr_attr (actual); 1864 if (!attr.allocatable) 1865 return 0; 1866 } 1867 1868 return 1; 1869} 1870 1871 1872/* Given a symbol of a formal argument list and an expression, if the 1873 formal argument is a pointer, see if the actual argument is a 1874 pointer. Returns nonzero if compatible, zero if not compatible. */ 1875 1876static int 1877compare_pointer (gfc_symbol *formal, gfc_expr *actual) 1878{ 1879 symbol_attribute attr; 1880 1881 if (formal->attr.pointer 1882 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal) 1883 && CLASS_DATA (formal)->attr.class_pointer)) 1884 { 1885 attr = gfc_expr_attr (actual); 1886 1887 /* Fortran 2008 allows non-pointer actual arguments. */ 1888 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN) 1889 return 2; 1890 1891 if (!attr.pointer) 1892 return 0; 1893 } 1894 1895 return 1; 1896} 1897 1898 1899/* Emit clear error messages for rank mismatch. */ 1900 1901static void 1902argument_rank_mismatch (const char *name, locus *where, 1903 int rank1, int rank2) 1904{ 1905 1906 /* TS 29113, C407b. */ 1907 if (rank2 == -1) 1908 { 1909 gfc_error ("The assumed-rank array at %L requires that the dummy argument" 1910 " %qs has assumed-rank", where, name); 1911 } 1912 else if (rank1 == 0) 1913 { 1914 gfc_error ("Rank mismatch in argument %qs at %L " 1915 "(scalar and rank-%d)", name, where, rank2); 1916 } 1917 else if (rank2 == 0) 1918 { 1919 gfc_error ("Rank mismatch in argument %qs at %L " 1920 "(rank-%d and scalar)", name, where, rank1); 1921 } 1922 else 1923 { 1924 gfc_error ("Rank mismatch in argument %qs at %L " 1925 "(rank-%d and rank-%d)", name, where, rank1, rank2); 1926 } 1927} 1928 1929 1930/* Given a symbol of a formal argument list and an expression, see if 1931 the two are compatible as arguments. Returns nonzero if 1932 compatible, zero if not compatible. */ 1933 1934static int 1935compare_parameter (gfc_symbol *formal, gfc_expr *actual, 1936 int ranks_must_agree, int is_elemental, locus *where) 1937{ 1938 gfc_ref *ref; 1939 bool rank_check, is_pointer; 1940 char err[200]; 1941 gfc_component *ppc; 1942 1943 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding 1944 procs c_f_pointer or c_f_procpointer, and we need to accept most 1945 pointers the user could give us. This should allow that. */ 1946 if (formal->ts.type == BT_VOID) 1947 return 1; 1948 1949 if (formal->ts.type == BT_DERIVED 1950 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c 1951 && actual->ts.type == BT_DERIVED 1952 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) 1953 return 1; 1954 1955 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) 1956 /* Make sure the vtab symbol is present when 1957 the module variables are generated. */ 1958 gfc_find_derived_vtab (actual->ts.u.derived); 1959 1960 if (actual->ts.type == BT_PROCEDURE) 1961 { 1962 gfc_symbol *act_sym = actual->symtree->n.sym; 1963 1964 if (formal->attr.flavor != FL_PROCEDURE) 1965 { 1966 if (where) 1967 gfc_error ("Invalid procedure argument at %L", &actual->where); 1968 return 0; 1969 } 1970 1971 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, 1972 sizeof(err), NULL, NULL)) 1973 { 1974 if (where) 1975 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", 1976 formal->name, &actual->where, err); 1977 return 0; 1978 } 1979 1980 if (formal->attr.function && !act_sym->attr.function) 1981 { 1982 gfc_add_function (&act_sym->attr, act_sym->name, 1983 &act_sym->declared_at); 1984 if (act_sym->ts.type == BT_UNKNOWN 1985 && !gfc_set_default_type (act_sym, 1, act_sym->ns)) 1986 return 0; 1987 } 1988 else if (formal->attr.subroutine && !act_sym->attr.subroutine) 1989 gfc_add_subroutine (&act_sym->attr, act_sym->name, 1990 &act_sym->declared_at); 1991 1992 return 1; 1993 } 1994 1995 ppc = gfc_get_proc_ptr_comp (actual); 1996 if (ppc && ppc->ts.interface) 1997 { 1998 if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1, 1999 err, sizeof(err), NULL, NULL)) 2000 { 2001 if (where) 2002 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", 2003 formal->name, &actual->where, err); 2004 return 0; 2005 } 2006 } 2007 2008 /* F2008, C1241. */ 2009 if (formal->attr.pointer && formal->attr.contiguous 2010 && !gfc_is_simply_contiguous (actual, true)) 2011 { 2012 if (where) 2013 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " 2014 "must be simply contiguous", formal->name, &actual->where); 2015 return 0; 2016 } 2017 2018 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) 2019 && actual->ts.type != BT_HOLLERITH 2020 && formal->ts.type != BT_ASSUMED 2021 && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 2022 && !gfc_compare_types (&formal->ts, &actual->ts) 2023 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS 2024 && gfc_compare_derived_types (formal->ts.u.derived, 2025 CLASS_DATA (actual)->ts.u.derived))) 2026 { 2027 if (where) 2028 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s", 2029 formal->name, &actual->where, gfc_typename (&actual->ts), 2030 gfc_typename (&formal->ts)); 2031 return 0; 2032 } 2033 2034 if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) 2035 { 2036 if (where) 2037 gfc_error ("Assumed-type actual argument at %L requires that dummy " 2038 "argument %qs is of assumed type", &actual->where, 2039 formal->name); 2040 return 0; 2041 } 2042 2043 /* F2008, 12.5.2.5; IR F08/0073. */ 2044 if (formal->ts.type == BT_CLASS && formal->attr.class_ok 2045 && actual->expr_type != EXPR_NULL 2046 && ((CLASS_DATA (formal)->attr.class_pointer 2047 && formal->attr.intent != INTENT_IN) 2048 || CLASS_DATA (formal)->attr.allocatable)) 2049 { 2050 if (actual->ts.type != BT_CLASS) 2051 { 2052 if (where) 2053 gfc_error ("Actual argument to %qs at %L must be polymorphic", 2054 formal->name, &actual->where); 2055 return 0; 2056 } 2057 2058 if (!gfc_expr_attr (actual).class_ok) 2059 return 0; 2060 2061 if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) 2062 && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, 2063 CLASS_DATA (formal)->ts.u.derived)) 2064 { 2065 if (where) 2066 gfc_error ("Actual argument to %qs at %L must have the same " 2067 "declared type", formal->name, &actual->where); 2068 return 0; 2069 } 2070 } 2071 2072 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this 2073 is necessary also for F03, so retain error for both. 2074 NOTE: Other type/kind errors pre-empt this error. Since they are F03 2075 compatible, no attempt has been made to channel to this one. */ 2076 if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) 2077 && (CLASS_DATA (formal)->attr.allocatable 2078 ||CLASS_DATA (formal)->attr.class_pointer)) 2079 { 2080 if (where) 2081 gfc_error ("Actual argument to %qs at %L must be unlimited " 2082 "polymorphic since the formal argument is a " 2083 "pointer or allocatable unlimited polymorphic " 2084 "entity [F2008: 12.5.2.5]", formal->name, 2085 &actual->where); 2086 return 0; 2087 } 2088 2089 if (formal->attr.codimension && !gfc_is_coarray (actual)) 2090 { 2091 if (where) 2092 gfc_error ("Actual argument to %qs at %L must be a coarray", 2093 formal->name, &actual->where); 2094 return 0; 2095 } 2096 2097 if (formal->attr.codimension && formal->attr.allocatable) 2098 { 2099 gfc_ref *last = NULL; 2100 2101 for (ref = actual->ref; ref; ref = ref->next) 2102 if (ref->type == REF_COMPONENT) 2103 last = ref; 2104 2105 /* F2008, 12.5.2.6. */ 2106 if ((last && last->u.c.component->as->corank != formal->as->corank) 2107 || (!last 2108 && actual->symtree->n.sym->as->corank != formal->as->corank)) 2109 { 2110 if (where) 2111 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", 2112 formal->name, &actual->where, formal->as->corank, 2113 last ? last->u.c.component->as->corank 2114 : actual->symtree->n.sym->as->corank); 2115 return 0; 2116 } 2117 } 2118 2119 if (formal->attr.codimension) 2120 { 2121 /* F2008, 12.5.2.8. */ 2122 if (formal->attr.dimension 2123 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) 2124 && gfc_expr_attr (actual).dimension 2125 && !gfc_is_simply_contiguous (actual, true)) 2126 { 2127 if (where) 2128 gfc_error ("Actual argument to %qs at %L must be simply " 2129 "contiguous", formal->name, &actual->where); 2130 return 0; 2131 } 2132 2133 /* F2008, C1303 and C1304. */ 2134 if (formal->attr.intent != INTENT_INOUT 2135 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) 2136 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2137 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 2138 || formal->attr.lock_comp)) 2139 2140 { 2141 if (where) 2142 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " 2143 "which is LOCK_TYPE or has a LOCK_TYPE component", 2144 formal->name, &actual->where); 2145 return 0; 2146 } 2147 2148 /* TS18508, C702/C703. */ 2149 if (formal->attr.intent != INTENT_INOUT 2150 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) 2151 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2152 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 2153 || formal->attr.event_comp)) 2154 2155 { 2156 if (where) 2157 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " 2158 "which is EVENT_TYPE or has a EVENT_TYPE component", 2159 formal->name, &actual->where); 2160 return 0; 2161 } 2162 } 2163 2164 /* F2008, C1239/C1240. */ 2165 if (actual->expr_type == EXPR_VARIABLE 2166 && (actual->symtree->n.sym->attr.asynchronous 2167 || actual->symtree->n.sym->attr.volatile_) 2168 && (formal->attr.asynchronous || formal->attr.volatile_) 2169 && actual->rank && formal->as && !gfc_is_simply_contiguous (actual, true) 2170 && ((formal->as->type != AS_ASSUMED_SHAPE 2171 && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) 2172 || formal->attr.contiguous)) 2173 { 2174 if (where) 2175 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " 2176 "assumed-rank array without CONTIGUOUS attribute - as actual" 2177 " argument at %L is not simply contiguous and both are " 2178 "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); 2179 return 0; 2180 } 2181 2182 if (formal->attr.allocatable && !formal->attr.codimension 2183 && gfc_expr_attr (actual).codimension) 2184 { 2185 if (formal->attr.intent == INTENT_OUT) 2186 { 2187 if (where) 2188 gfc_error ("Passing coarray at %L to allocatable, noncoarray, " 2189 "INTENT(OUT) dummy argument %qs", &actual->where, 2190 formal->name); 2191 return 0; 2192 } 2193 else if (warn_surprising && where && formal->attr.intent != INTENT_IN) 2194 gfc_warning (OPT_Wsurprising, 2195 "Passing coarray at %L to allocatable, noncoarray dummy " 2196 "argument %qs, which is invalid if the allocation status" 2197 " is modified", &actual->where, formal->name); 2198 } 2199 2200 /* If the rank is the same or the formal argument has assumed-rank. */ 2201 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) 2202 return 1; 2203 2204 rank_check = where != NULL && !is_elemental && formal->as 2205 && (formal->as->type == AS_ASSUMED_SHAPE 2206 || formal->as->type == AS_DEFERRED) 2207 && actual->expr_type != EXPR_NULL; 2208 2209 /* Skip rank checks for NO_ARG_CHECK. */ 2210 if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 2211 return 1; 2212 2213 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ 2214 if (rank_check || ranks_must_agree 2215 || (formal->attr.pointer && actual->expr_type != EXPR_NULL) 2216 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) 2217 || (actual->rank == 0 2218 && ((formal->ts.type == BT_CLASS 2219 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE) 2220 || (formal->ts.type != BT_CLASS 2221 && formal->as->type == AS_ASSUMED_SHAPE)) 2222 && actual->expr_type != EXPR_NULL) 2223 || (actual->rank == 0 && formal->attr.dimension 2224 && gfc_is_coindexed (actual))) 2225 { 2226 if (where) 2227 argument_rank_mismatch (formal->name, &actual->where, 2228 symbol_rank (formal), actual->rank); 2229 return 0; 2230 } 2231 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) 2232 return 1; 2233 2234 /* At this point, we are considering a scalar passed to an array. This 2235 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), 2236 - if the actual argument is (a substring of) an element of a 2237 non-assumed-shape/non-pointer/non-polymorphic array; or 2238 - (F2003) if the actual argument is of type character of default/c_char 2239 kind. */ 2240 2241 is_pointer = actual->expr_type == EXPR_VARIABLE 2242 ? actual->symtree->n.sym->attr.pointer : false; 2243 2244 for (ref = actual->ref; ref; ref = ref->next) 2245 { 2246 if (ref->type == REF_COMPONENT) 2247 is_pointer = ref->u.c.component->attr.pointer; 2248 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT 2249 && ref->u.ar.dimen > 0 2250 && (!ref->next 2251 || (ref->next->type == REF_SUBSTRING && !ref->next->next))) 2252 break; 2253 } 2254 2255 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) 2256 { 2257 if (where) 2258 gfc_error ("Polymorphic scalar passed to array dummy argument %qs " 2259 "at %L", formal->name, &actual->where); 2260 return 0; 2261 } 2262 2263 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER 2264 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) 2265 { 2266 if (where) 2267 gfc_error ("Element of assumed-shaped or pointer " 2268 "array passed to array dummy argument %qs at %L", 2269 formal->name, &actual->where); 2270 return 0; 2271 } 2272 2273 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL 2274 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) 2275 { 2276 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) 2277 { 2278 if (where) 2279 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " 2280 "CHARACTER actual argument with array dummy argument " 2281 "%qs at %L", formal->name, &actual->where); 2282 return 0; 2283 } 2284 2285 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) 2286 { 2287 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " 2288 "array dummy argument %qs at %L", 2289 formal->name, &actual->where); 2290 return 0; 2291 } 2292 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0) 2293 return 0; 2294 else 2295 return 1; 2296 } 2297 2298 if (ref == NULL && actual->expr_type != EXPR_NULL) 2299 { 2300 if (where) 2301 argument_rank_mismatch (formal->name, &actual->where, 2302 symbol_rank (formal), actual->rank); 2303 return 0; 2304 } 2305 2306 return 1; 2307} 2308 2309 2310/* Returns the storage size of a symbol (formal argument) or 2311 zero if it cannot be determined. */ 2312 2313static unsigned long 2314get_sym_storage_size (gfc_symbol *sym) 2315{ 2316 int i; 2317 unsigned long strlen, elements; 2318 2319 if (sym->ts.type == BT_CHARACTER) 2320 { 2321 if (sym->ts.u.cl && sym->ts.u.cl->length 2322 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2323 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); 2324 else 2325 return 0; 2326 } 2327 else 2328 strlen = 1; 2329 2330 if (symbol_rank (sym) == 0) 2331 return strlen; 2332 2333 elements = 1; 2334 if (sym->as->type != AS_EXPLICIT) 2335 return 0; 2336 for (i = 0; i < sym->as->rank; i++) 2337 { 2338 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT 2339 || sym->as->lower[i]->expr_type != EXPR_CONSTANT) 2340 return 0; 2341 2342 elements *= mpz_get_si (sym->as->upper[i]->value.integer) 2343 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; 2344 } 2345 2346 return strlen*elements; 2347} 2348 2349 2350/* Returns the storage size of an expression (actual argument) or 2351 zero if it cannot be determined. For an array element, it returns 2352 the remaining size as the element sequence consists of all storage 2353 units of the actual argument up to the end of the array. */ 2354 2355static unsigned long 2356get_expr_storage_size (gfc_expr *e) 2357{ 2358 int i; 2359 long int strlen, elements; 2360 long int substrlen = 0; 2361 bool is_str_storage = false; 2362 gfc_ref *ref; 2363 2364 if (e == NULL) 2365 return 0; 2366 2367 if (e->ts.type == BT_CHARACTER) 2368 { 2369 if (e->ts.u.cl && e->ts.u.cl->length 2370 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2371 strlen = mpz_get_si (e->ts.u.cl->length->value.integer); 2372 else if (e->expr_type == EXPR_CONSTANT 2373 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 2374 strlen = e->value.character.length; 2375 else 2376 return 0; 2377 } 2378 else 2379 strlen = 1; /* Length per element. */ 2380 2381 if (e->rank == 0 && !e->ref) 2382 return strlen; 2383 2384 elements = 1; 2385 if (!e->ref) 2386 { 2387 if (!e->shape) 2388 return 0; 2389 for (i = 0; i < e->rank; i++) 2390 elements *= mpz_get_si (e->shape[i]); 2391 return elements*strlen; 2392 } 2393 2394 for (ref = e->ref; ref; ref = ref->next) 2395 { 2396 if (ref->type == REF_SUBSTRING && ref->u.ss.start 2397 && ref->u.ss.start->expr_type == EXPR_CONSTANT) 2398 { 2399 if (is_str_storage) 2400 { 2401 /* The string length is the substring length. 2402 Set now to full string length. */ 2403 if (!ref->u.ss.length || !ref->u.ss.length->length 2404 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT) 2405 return 0; 2406 2407 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer); 2408 } 2409 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1; 2410 continue; 2411 } 2412 2413 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 2414 for (i = 0; i < ref->u.ar.dimen; i++) 2415 { 2416 long int start, end, stride; 2417 stride = 1; 2418 2419 if (ref->u.ar.stride[i]) 2420 { 2421 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT) 2422 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer); 2423 else 2424 return 0; 2425 } 2426 2427 if (ref->u.ar.start[i]) 2428 { 2429 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT) 2430 start = mpz_get_si (ref->u.ar.start[i]->value.integer); 2431 else 2432 return 0; 2433 } 2434 else if (ref->u.ar.as->lower[i] 2435 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT) 2436 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer); 2437 else 2438 return 0; 2439 2440 if (ref->u.ar.end[i]) 2441 { 2442 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT) 2443 end = mpz_get_si (ref->u.ar.end[i]->value.integer); 2444 else 2445 return 0; 2446 } 2447 else if (ref->u.ar.as->upper[i] 2448 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT) 2449 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer); 2450 else 2451 return 0; 2452 2453 elements *= (end - start)/stride + 1L; 2454 } 2455 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL) 2456 for (i = 0; i < ref->u.ar.as->rank; i++) 2457 { 2458 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] 2459 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT 2460 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER 2461 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT 2462 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) 2463 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2464 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2465 + 1L; 2466 else 2467 return 0; 2468 } 2469 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT 2470 && e->expr_type == EXPR_VARIABLE) 2471 { 2472 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE 2473 || e->symtree->n.sym->attr.pointer) 2474 { 2475 elements = 1; 2476 continue; 2477 } 2478 2479 /* Determine the number of remaining elements in the element 2480 sequence for array element designators. */ 2481 is_str_storage = true; 2482 for (i = ref->u.ar.dimen - 1; i >= 0; i--) 2483 { 2484 if (ref->u.ar.start[i] == NULL 2485 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT 2486 || ref->u.ar.as->upper[i] == NULL 2487 || ref->u.ar.as->lower[i] == NULL 2488 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT 2489 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT) 2490 return 0; 2491 2492 elements 2493 = elements 2494 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2495 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2496 + 1L) 2497 - (mpz_get_si (ref->u.ar.start[i]->value.integer) 2498 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)); 2499 } 2500 } 2501 else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function 2502 && ref->u.c.component->attr.proc_pointer 2503 && ref->u.c.component->attr.dimension) 2504 { 2505 /* Array-valued procedure-pointer components. */ 2506 gfc_array_spec *as = ref->u.c.component->as; 2507 for (i = 0; i < as->rank; i++) 2508 { 2509 if (!as->upper[i] || !as->lower[i] 2510 || as->upper[i]->expr_type != EXPR_CONSTANT 2511 || as->lower[i]->expr_type != EXPR_CONSTANT) 2512 return 0; 2513 2514 elements = elements 2515 * (mpz_get_si (as->upper[i]->value.integer) 2516 - mpz_get_si (as->lower[i]->value.integer) + 1L); 2517 } 2518 } 2519 } 2520 2521 if (substrlen) 2522 return (is_str_storage) ? substrlen + (elements-1)*strlen 2523 : elements*strlen; 2524 else 2525 return elements*strlen; 2526} 2527 2528 2529/* Given an expression, check whether it is an array section 2530 which has a vector subscript. If it has, one is returned, 2531 otherwise zero. */ 2532 2533int 2534gfc_has_vector_subscript (gfc_expr *e) 2535{ 2536 int i; 2537 gfc_ref *ref; 2538 2539 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) 2540 return 0; 2541 2542 for (ref = e->ref; ref; ref = ref->next) 2543 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 2544 for (i = 0; i < ref->u.ar.dimen; i++) 2545 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 2546 return 1; 2547 2548 return 0; 2549} 2550 2551 2552static bool 2553is_procptr_result (gfc_expr *expr) 2554{ 2555 gfc_component *c = gfc_get_proc_ptr_comp (expr); 2556 if (c) 2557 return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); 2558 else 2559 return ((expr->symtree->n.sym->result != expr->symtree->n.sym) 2560 && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); 2561} 2562 2563 2564/* Given formal and actual argument lists, see if they are compatible. 2565 If they are compatible, the actual argument list is sorted to 2566 correspond with the formal list, and elements for missing optional 2567 arguments are inserted. If WHERE pointer is nonnull, then we issue 2568 errors when things don't match instead of just returning the status 2569 code. */ 2570 2571static int 2572compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 2573 int ranks_must_agree, int is_elemental, locus *where) 2574{ 2575 gfc_actual_arglist **new_arg, *a, *actual, temp; 2576 gfc_formal_arglist *f; 2577 int i, n, na; 2578 unsigned long actual_size, formal_size; 2579 bool full_array = false; 2580 2581 actual = *ap; 2582 2583 if (actual == NULL && formal == NULL) 2584 return 1; 2585 2586 n = 0; 2587 for (f = formal; f; f = f->next) 2588 n++; 2589 2590 new_arg = XALLOCAVEC (gfc_actual_arglist *, n); 2591 2592 for (i = 0; i < n; i++) 2593 new_arg[i] = NULL; 2594 2595 na = 0; 2596 f = formal; 2597 i = 0; 2598 2599 for (a = actual; a; a = a->next, f = f->next) 2600 { 2601 /* Look for keywords but ignore g77 extensions like %VAL. */ 2602 if (a->name != NULL && a->name[0] != '%') 2603 { 2604 i = 0; 2605 for (f = formal; f; f = f->next, i++) 2606 { 2607 if (f->sym == NULL) 2608 continue; 2609 if (strcmp (f->sym->name, a->name) == 0) 2610 break; 2611 } 2612 2613 if (f == NULL) 2614 { 2615 if (where) 2616 gfc_error ("Keyword argument %qs at %L is not in " 2617 "the procedure", a->name, &a->expr->where); 2618 return 0; 2619 } 2620 2621 if (new_arg[i] != NULL) 2622 { 2623 if (where) 2624 gfc_error ("Keyword argument %qs at %L is already associated " 2625 "with another actual argument", a->name, 2626 &a->expr->where); 2627 return 0; 2628 } 2629 } 2630 2631 if (f == NULL) 2632 { 2633 if (where) 2634 gfc_error ("More actual than formal arguments in procedure " 2635 "call at %L", where); 2636 2637 return 0; 2638 } 2639 2640 if (f->sym == NULL && a->expr == NULL) 2641 goto match; 2642 2643 if (f->sym == NULL) 2644 { 2645 if (where) 2646 gfc_error ("Missing alternate return spec in subroutine call " 2647 "at %L", where); 2648 return 0; 2649 } 2650 2651 if (a->expr == NULL) 2652 { 2653 if (where) 2654 gfc_error ("Unexpected alternate return spec in subroutine " 2655 "call at %L", where); 2656 return 0; 2657 } 2658 2659 /* Make sure that intrinsic vtables exist for calls to unlimited 2660 polymorphic formal arguments. */ 2661 if (UNLIMITED_POLY (f->sym) 2662 && a->expr->ts.type != BT_DERIVED 2663 && a->expr->ts.type != BT_CLASS) 2664 gfc_find_vtab (&a->expr->ts); 2665 2666 if (a->expr->expr_type == EXPR_NULL 2667 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer 2668 && (f->sym->attr.allocatable || !f->sym->attr.optional 2669 || (gfc_option.allow_std & GFC_STD_F2008) == 0)) 2670 || (f->sym->ts.type == BT_CLASS 2671 && !CLASS_DATA (f->sym)->attr.class_pointer 2672 && (CLASS_DATA (f->sym)->attr.allocatable 2673 || !f->sym->attr.optional 2674 || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) 2675 { 2676 if (where 2677 && (!f->sym->attr.optional 2678 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) 2679 || (f->sym->ts.type == BT_CLASS 2680 && CLASS_DATA (f->sym)->attr.allocatable))) 2681 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", 2682 where, f->sym->name); 2683 else if (where) 2684 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " 2685 "dummy %qs", where, f->sym->name); 2686 2687 return 0; 2688 } 2689 2690 if (!compare_parameter (f->sym, a->expr, ranks_must_agree, 2691 is_elemental, where)) 2692 return 0; 2693 2694 /* TS 29113, 6.3p2. */ 2695 if (f->sym->ts.type == BT_ASSUMED 2696 && (a->expr->ts.type == BT_DERIVED 2697 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) 2698 { 2699 gfc_namespace *f2k_derived; 2700 2701 f2k_derived = a->expr->ts.type == BT_DERIVED 2702 ? a->expr->ts.u.derived->f2k_derived 2703 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived; 2704 2705 if (f2k_derived 2706 && (f2k_derived->finalizers || f2k_derived->tb_sym_root)) 2707 { 2708 gfc_error ("Actual argument at %L to assumed-type dummy is of " 2709 "derived type with type-bound or FINAL procedures", 2710 &a->expr->where); 2711 return false; 2712 } 2713 } 2714 2715 /* Special case for character arguments. For allocatable, pointer 2716 and assumed-shape dummies, the string length needs to match 2717 exactly. */ 2718 if (a->expr->ts.type == BT_CHARACTER 2719 && a->expr->ts.u.cl && a->expr->ts.u.cl->length 2720 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT 2721 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length 2722 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT 2723 && (f->sym->attr.pointer || f->sym->attr.allocatable 2724 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 2725 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, 2726 f->sym->ts.u.cl->length->value.integer) != 0)) 2727 { 2728 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) 2729 gfc_warning (0, 2730 "Character length mismatch (%ld/%ld) between actual " 2731 "argument and pointer or allocatable dummy argument " 2732 "%qs at %L", 2733 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 2734 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 2735 f->sym->name, &a->expr->where); 2736 else if (where) 2737 gfc_warning (0, 2738 "Character length mismatch (%ld/%ld) between actual " 2739 "argument and assumed-shape dummy argument %qs " 2740 "at %L", 2741 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 2742 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 2743 f->sym->name, &a->expr->where); 2744 return 0; 2745 } 2746 2747 if ((f->sym->attr.pointer || f->sym->attr.allocatable) 2748 && f->sym->ts.deferred != a->expr->ts.deferred 2749 && a->expr->ts.type == BT_CHARACTER) 2750 { 2751 if (where) 2752 gfc_error ("Actual argument at %L to allocatable or " 2753 "pointer dummy argument %qs must have a deferred " 2754 "length type parameter if and only if the dummy has one", 2755 &a->expr->where, f->sym->name); 2756 return 0; 2757 } 2758 2759 if (f->sym->ts.type == BT_CLASS) 2760 goto skip_size_check; 2761 2762 actual_size = get_expr_storage_size (a->expr); 2763 formal_size = get_sym_storage_size (f->sym); 2764 if (actual_size != 0 && actual_size < formal_size 2765 && a->expr->ts.type != BT_PROCEDURE 2766 && f->sym->attr.flavor != FL_PROCEDURE) 2767 { 2768 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) 2769 gfc_warning (0, "Character length of actual argument shorter " 2770 "than of dummy argument %qs (%lu/%lu) at %L", 2771 f->sym->name, actual_size, formal_size, 2772 &a->expr->where); 2773 else if (where) 2774 gfc_warning (0, "Actual argument contains too few " 2775 "elements for dummy argument %qs (%lu/%lu) at %L", 2776 f->sym->name, actual_size, formal_size, 2777 &a->expr->where); 2778 return 0; 2779 } 2780 2781 skip_size_check: 2782 2783 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual 2784 argument is provided for a procedure pointer formal argument. */ 2785 if (f->sym->attr.proc_pointer 2786 && !((a->expr->expr_type == EXPR_VARIABLE 2787 && (a->expr->symtree->n.sym->attr.proc_pointer 2788 || gfc_is_proc_ptr_comp (a->expr))) 2789 || (a->expr->expr_type == EXPR_FUNCTION 2790 && is_procptr_result (a->expr)))) 2791 { 2792 if (where) 2793 gfc_error ("Expected a procedure pointer for argument %qs at %L", 2794 f->sym->name, &a->expr->where); 2795 return 0; 2796 } 2797 2798 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is 2799 provided for a procedure formal argument. */ 2800 if (f->sym->attr.flavor == FL_PROCEDURE 2801 && !((a->expr->expr_type == EXPR_VARIABLE 2802 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE 2803 || a->expr->symtree->n.sym->attr.proc_pointer 2804 || gfc_is_proc_ptr_comp (a->expr))) 2805 || (a->expr->expr_type == EXPR_FUNCTION 2806 && is_procptr_result (a->expr)))) 2807 { 2808 if (where) 2809 gfc_error ("Expected a procedure for argument %qs at %L", 2810 f->sym->name, &a->expr->where); 2811 return 0; 2812 } 2813 2814 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE 2815 && a->expr->expr_type == EXPR_VARIABLE 2816 && a->expr->symtree->n.sym->as 2817 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE 2818 && (a->expr->ref == NULL 2819 || (a->expr->ref->type == REF_ARRAY 2820 && a->expr->ref->u.ar.type == AR_FULL))) 2821 { 2822 if (where) 2823 gfc_error ("Actual argument for %qs cannot be an assumed-size" 2824 " array at %L", f->sym->name, where); 2825 return 0; 2826 } 2827 2828 if (a->expr->expr_type != EXPR_NULL 2829 && compare_pointer (f->sym, a->expr) == 0) 2830 { 2831 if (where) 2832 gfc_error ("Actual argument for %qs must be a pointer at %L", 2833 f->sym->name, &a->expr->where); 2834 return 0; 2835 } 2836 2837 if (a->expr->expr_type != EXPR_NULL 2838 && (gfc_option.allow_std & GFC_STD_F2008) == 0 2839 && compare_pointer (f->sym, a->expr) == 2) 2840 { 2841 if (where) 2842 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " 2843 "pointer dummy %qs", &a->expr->where,f->sym->name); 2844 return 0; 2845 } 2846 2847 2848 /* Fortran 2008, C1242. */ 2849 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) 2850 { 2851 if (where) 2852 gfc_error ("Coindexed actual argument at %L to pointer " 2853 "dummy %qs", 2854 &a->expr->where, f->sym->name); 2855 return 0; 2856 } 2857 2858 /* Fortran 2008, 12.5.2.5 (no constraint). */ 2859 if (a->expr->expr_type == EXPR_VARIABLE 2860 && f->sym->attr.intent != INTENT_IN 2861 && f->sym->attr.allocatable 2862 && gfc_is_coindexed (a->expr)) 2863 { 2864 if (where) 2865 gfc_error ("Coindexed actual argument at %L to allocatable " 2866 "dummy %qs requires INTENT(IN)", 2867 &a->expr->where, f->sym->name); 2868 return 0; 2869 } 2870 2871 /* Fortran 2008, C1237. */ 2872 if (a->expr->expr_type == EXPR_VARIABLE 2873 && (f->sym->attr.asynchronous || f->sym->attr.volatile_) 2874 && gfc_is_coindexed (a->expr) 2875 && (a->expr->symtree->n.sym->attr.volatile_ 2876 || a->expr->symtree->n.sym->attr.asynchronous)) 2877 { 2878 if (where) 2879 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " 2880 "%L requires that dummy %qs has neither " 2881 "ASYNCHRONOUS nor VOLATILE", &a->expr->where, 2882 f->sym->name); 2883 return 0; 2884 } 2885 2886 /* Fortran 2008, 12.5.2.4 (no constraint). */ 2887 if (a->expr->expr_type == EXPR_VARIABLE 2888 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value 2889 && gfc_is_coindexed (a->expr) 2890 && gfc_has_ultimate_allocatable (a->expr)) 2891 { 2892 if (where) 2893 gfc_error ("Coindexed actual argument at %L with allocatable " 2894 "ultimate component to dummy %qs requires either VALUE " 2895 "or INTENT(IN)", &a->expr->where, f->sym->name); 2896 return 0; 2897 } 2898 2899 if (f->sym->ts.type == BT_CLASS 2900 && CLASS_DATA (f->sym)->attr.allocatable 2901 && gfc_is_class_array_ref (a->expr, &full_array) 2902 && !full_array) 2903 { 2904 if (where) 2905 gfc_error ("Actual CLASS array argument for %qs must be a full " 2906 "array at %L", f->sym->name, &a->expr->where); 2907 return 0; 2908 } 2909 2910 2911 if (a->expr->expr_type != EXPR_NULL 2912 && compare_allocatable (f->sym, a->expr) == 0) 2913 { 2914 if (where) 2915 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", 2916 f->sym->name, &a->expr->where); 2917 return 0; 2918 } 2919 2920 /* Check intent = OUT/INOUT for definable actual argument. */ 2921 if ((f->sym->attr.intent == INTENT_OUT 2922 || f->sym->attr.intent == INTENT_INOUT)) 2923 { 2924 const char* context = (where 2925 ? _("actual argument to INTENT = OUT/INOUT") 2926 : NULL); 2927 2928 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 2929 && CLASS_DATA (f->sym)->attr.class_pointer) 2930 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 2931 && !gfc_check_vardef_context (a->expr, true, false, false, context)) 2932 return 0; 2933 if (!gfc_check_vardef_context (a->expr, false, false, false, context)) 2934 return 0; 2935 } 2936 2937 if ((f->sym->attr.intent == INTENT_OUT 2938 || f->sym->attr.intent == INTENT_INOUT 2939 || f->sym->attr.volatile_ 2940 || f->sym->attr.asynchronous) 2941 && gfc_has_vector_subscript (a->expr)) 2942 { 2943 if (where) 2944 gfc_error ("Array-section actual argument with vector " 2945 "subscripts at %L is incompatible with INTENT(OUT), " 2946 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " 2947 "of the dummy argument %qs", 2948 &a->expr->where, f->sym->name); 2949 return 0; 2950 } 2951 2952 /* C1232 (R1221) For an actual argument which is an array section or 2953 an assumed-shape array, the dummy argument shall be an assumed- 2954 shape array, if the dummy argument has the VOLATILE attribute. */ 2955 2956 if (f->sym->attr.volatile_ 2957 && a->expr->symtree->n.sym->as 2958 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE 2959 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 2960 { 2961 if (where) 2962 gfc_error ("Assumed-shape actual argument at %L is " 2963 "incompatible with the non-assumed-shape " 2964 "dummy argument %qs due to VOLATILE attribute", 2965 &a->expr->where,f->sym->name); 2966 return 0; 2967 } 2968 2969 if (f->sym->attr.volatile_ 2970 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION 2971 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 2972 { 2973 if (where) 2974 gfc_error ("Array-section actual argument at %L is " 2975 "incompatible with the non-assumed-shape " 2976 "dummy argument %qs due to VOLATILE attribute", 2977 &a->expr->where,f->sym->name); 2978 return 0; 2979 } 2980 2981 /* C1233 (R1221) For an actual argument which is a pointer array, the 2982 dummy argument shall be an assumed-shape or pointer array, if the 2983 dummy argument has the VOLATILE attribute. */ 2984 2985 if (f->sym->attr.volatile_ 2986 && a->expr->symtree->n.sym->attr.pointer 2987 && a->expr->symtree->n.sym->as 2988 && !(f->sym->as 2989 && (f->sym->as->type == AS_ASSUMED_SHAPE 2990 || f->sym->attr.pointer))) 2991 { 2992 if (where) 2993 gfc_error ("Pointer-array actual argument at %L requires " 2994 "an assumed-shape or pointer-array dummy " 2995 "argument %qs due to VOLATILE attribute", 2996 &a->expr->where,f->sym->name); 2997 return 0; 2998 } 2999 3000 match: 3001 if (a == actual) 3002 na = i; 3003 3004 new_arg[i++] = a; 3005 } 3006 3007 /* Make sure missing actual arguments are optional. */ 3008 i = 0; 3009 for (f = formal; f; f = f->next, i++) 3010 { 3011 if (new_arg[i] != NULL) 3012 continue; 3013 if (f->sym == NULL) 3014 { 3015 if (where) 3016 gfc_error ("Missing alternate return spec in subroutine call " 3017 "at %L", where); 3018 return 0; 3019 } 3020 if (!f->sym->attr.optional) 3021 { 3022 if (where) 3023 gfc_error ("Missing actual argument for argument %qs at %L", 3024 f->sym->name, where); 3025 return 0; 3026 } 3027 } 3028 3029 /* The argument lists are compatible. We now relink a new actual 3030 argument list with null arguments in the right places. The head 3031 of the list remains the head. */ 3032 for (i = 0; i < n; i++) 3033 if (new_arg[i] == NULL) 3034 new_arg[i] = gfc_get_actual_arglist (); 3035 3036 if (na != 0) 3037 { 3038 temp = *new_arg[0]; 3039 *new_arg[0] = *actual; 3040 *actual = temp; 3041 3042 a = new_arg[0]; 3043 new_arg[0] = new_arg[na]; 3044 new_arg[na] = a; 3045 } 3046 3047 for (i = 0; i < n - 1; i++) 3048 new_arg[i]->next = new_arg[i + 1]; 3049 3050 new_arg[i]->next = NULL; 3051 3052 if (*ap == NULL && n > 0) 3053 *ap = new_arg[0]; 3054 3055 /* Note the types of omitted optional arguments. */ 3056 for (a = *ap, f = formal; a; a = a->next, f = f->next) 3057 if (a->expr == NULL && a->label == NULL) 3058 a->missing_arg_type = f->sym->ts.type; 3059 3060 return 1; 3061} 3062 3063 3064typedef struct 3065{ 3066 gfc_formal_arglist *f; 3067 gfc_actual_arglist *a; 3068} 3069argpair; 3070 3071/* qsort comparison function for argument pairs, with the following 3072 order: 3073 - p->a->expr == NULL 3074 - p->a->expr->expr_type != EXPR_VARIABLE 3075 - growing p->a->expr->symbol. */ 3076 3077static int 3078pair_cmp (const void *p1, const void *p2) 3079{ 3080 const gfc_actual_arglist *a1, *a2; 3081 3082 /* *p1 and *p2 are elements of the to-be-sorted array. */ 3083 a1 = ((const argpair *) p1)->a; 3084 a2 = ((const argpair *) p2)->a; 3085 if (!a1->expr) 3086 { 3087 if (!a2->expr) 3088 return 0; 3089 return -1; 3090 } 3091 if (!a2->expr) 3092 return 1; 3093 if (a1->expr->expr_type != EXPR_VARIABLE) 3094 { 3095 if (a2->expr->expr_type != EXPR_VARIABLE) 3096 return 0; 3097 return -1; 3098 } 3099 if (a2->expr->expr_type != EXPR_VARIABLE) 3100 return 1; 3101 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; 3102} 3103 3104 3105/* Given two expressions from some actual arguments, test whether they 3106 refer to the same expression. The analysis is conservative. 3107 Returning false will produce no warning. */ 3108 3109static bool 3110compare_actual_expr (gfc_expr *e1, gfc_expr *e2) 3111{ 3112 const gfc_ref *r1, *r2; 3113 3114 if (!e1 || !e2 3115 || e1->expr_type != EXPR_VARIABLE 3116 || e2->expr_type != EXPR_VARIABLE 3117 || e1->symtree->n.sym != e2->symtree->n.sym) 3118 return false; 3119 3120 /* TODO: improve comparison, see expr.c:show_ref(). */ 3121 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) 3122 { 3123 if (r1->type != r2->type) 3124 return false; 3125 switch (r1->type) 3126 { 3127 case REF_ARRAY: 3128 if (r1->u.ar.type != r2->u.ar.type) 3129 return false; 3130 /* TODO: At the moment, consider only full arrays; 3131 we could do better. */ 3132 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) 3133 return false; 3134 break; 3135 3136 case REF_COMPONENT: 3137 if (r1->u.c.component != r2->u.c.component) 3138 return false; 3139 break; 3140 3141 case REF_SUBSTRING: 3142 return false; 3143 3144 default: 3145 gfc_internal_error ("compare_actual_expr(): Bad component code"); 3146 } 3147 } 3148 if (!r1 && !r2) 3149 return true; 3150 return false; 3151} 3152 3153 3154/* Given formal and actual argument lists that correspond to one 3155 another, check that identical actual arguments aren't not 3156 associated with some incompatible INTENTs. */ 3157 3158static bool 3159check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) 3160{ 3161 sym_intent f1_intent, f2_intent; 3162 gfc_formal_arglist *f1; 3163 gfc_actual_arglist *a1; 3164 size_t n, i, j; 3165 argpair *p; 3166 bool t = true; 3167 3168 n = 0; 3169 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) 3170 { 3171 if (f1 == NULL && a1 == NULL) 3172 break; 3173 if (f1 == NULL || a1 == NULL) 3174 gfc_internal_error ("check_some_aliasing(): List mismatch"); 3175 n++; 3176 } 3177 if (n == 0) 3178 return t; 3179 p = XALLOCAVEC (argpair, n); 3180 3181 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) 3182 { 3183 p[i].f = f1; 3184 p[i].a = a1; 3185 } 3186 3187 qsort (p, n, sizeof (argpair), pair_cmp); 3188 3189 for (i = 0; i < n; i++) 3190 { 3191 if (!p[i].a->expr 3192 || p[i].a->expr->expr_type != EXPR_VARIABLE 3193 || p[i].a->expr->ts.type == BT_PROCEDURE) 3194 continue; 3195 f1_intent = p[i].f->sym->attr.intent; 3196 for (j = i + 1; j < n; j++) 3197 { 3198 /* Expected order after the sort. */ 3199 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) 3200 gfc_internal_error ("check_some_aliasing(): corrupted data"); 3201 3202 /* Are the expression the same? */ 3203 if (!compare_actual_expr (p[i].a->expr, p[j].a->expr)) 3204 break; 3205 f2_intent = p[j].f->sym->attr.intent; 3206 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) 3207 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN) 3208 || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT)) 3209 { 3210 gfc_warning (0, "Same actual argument associated with INTENT(%s) " 3211 "argument %qs and INTENT(%s) argument %qs at %L", 3212 gfc_intent_string (f1_intent), p[i].f->sym->name, 3213 gfc_intent_string (f2_intent), p[j].f->sym->name, 3214 &p[i].a->expr->where); 3215 t = false; 3216 } 3217 } 3218 } 3219 3220 return t; 3221} 3222 3223 3224/* Given formal and actual argument lists that correspond to one 3225 another, check that they are compatible in the sense that intents 3226 are not mismatched. */ 3227 3228static bool 3229check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 3230{ 3231 sym_intent f_intent; 3232 3233 for (;; f = f->next, a = a->next) 3234 { 3235 gfc_expr *expr; 3236 3237 if (f == NULL && a == NULL) 3238 break; 3239 if (f == NULL || a == NULL) 3240 gfc_internal_error ("check_intents(): List mismatch"); 3241 3242 if (a->expr && a->expr->expr_type == EXPR_FUNCTION 3243 && a->expr->value.function.isym 3244 && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET) 3245 expr = a->expr->value.function.actual->expr; 3246 else 3247 expr = a->expr; 3248 3249 if (expr == NULL || expr->expr_type != EXPR_VARIABLE) 3250 continue; 3251 3252 f_intent = f->sym->attr.intent; 3253 3254 if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym)) 3255 { 3256 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3257 && CLASS_DATA (f->sym)->attr.class_pointer) 3258 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3259 { 3260 gfc_error ("Procedure argument at %L is local to a PURE " 3261 "procedure and has the POINTER attribute", 3262 &expr->where); 3263 return false; 3264 } 3265 } 3266 3267 /* Fortran 2008, C1283. */ 3268 if (gfc_pure (NULL) && gfc_is_coindexed (expr)) 3269 { 3270 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) 3271 { 3272 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3273 "is passed to an INTENT(%s) argument", 3274 &expr->where, gfc_intent_string (f_intent)); 3275 return false; 3276 } 3277 3278 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3279 && CLASS_DATA (f->sym)->attr.class_pointer) 3280 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3281 { 3282 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3283 "is passed to a POINTER dummy argument", 3284 &expr->where); 3285 return false; 3286 } 3287 } 3288 3289 /* F2008, Section 12.5.2.4. */ 3290 if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS 3291 && gfc_is_coindexed (expr)) 3292 { 3293 gfc_error ("Coindexed polymorphic actual argument at %L is passed " 3294 "polymorphic dummy argument %qs", 3295 &expr->where, f->sym->name); 3296 return false; 3297 } 3298 } 3299 3300 return true; 3301} 3302 3303 3304/* Check how a procedure is used against its interface. If all goes 3305 well, the actual argument list will also end up being properly 3306 sorted. */ 3307 3308bool 3309gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) 3310{ 3311 gfc_formal_arglist *dummy_args; 3312 3313 /* Warn about calls with an implicit interface. Special case 3314 for calling a ISO_C_BINDING because c_loc and c_funloc 3315 are pseudo-unknown. Additionally, warn about procedures not 3316 explicitly declared at all if requested. */ 3317 if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) 3318 { 3319 if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN) 3320 { 3321 gfc_error ("Procedure %qs called at %L is not explicitly declared", 3322 sym->name, where); 3323 return false; 3324 } 3325 if (warn_implicit_interface) 3326 gfc_warning (OPT_Wimplicit_interface, 3327 "Procedure %qs called with an implicit interface at %L", 3328 sym->name, where); 3329 else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN) 3330 gfc_warning (OPT_Wimplicit_procedure, 3331 "Procedure %qs called at %L is not explicitly declared", 3332 sym->name, where); 3333 } 3334 3335 if (sym->attr.if_source == IFSRC_UNKNOWN) 3336 { 3337 gfc_actual_arglist *a; 3338 3339 if (sym->attr.pointer) 3340 { 3341 gfc_error ("The pointer object %qs at %L must have an explicit " 3342 "function interface or be declared as array", 3343 sym->name, where); 3344 return false; 3345 } 3346 3347 if (sym->attr.allocatable && !sym->attr.external) 3348 { 3349 gfc_error ("The allocatable object %qs at %L must have an explicit " 3350 "function interface or be declared as array", 3351 sym->name, where); 3352 return false; 3353 } 3354 3355 if (sym->attr.allocatable) 3356 { 3357 gfc_error ("Allocatable function %qs at %L must have an explicit " 3358 "function interface", sym->name, where); 3359 return false; 3360 } 3361 3362 for (a = *ap; a; a = a->next) 3363 { 3364 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 3365 if (a->name != NULL && a->name[0] != '%') 3366 { 3367 gfc_error ("Keyword argument requires explicit interface " 3368 "for procedure %qs at %L", sym->name, &a->expr->where); 3369 break; 3370 } 3371 3372 /* TS 29113, 6.2. */ 3373 if (a->expr && a->expr->ts.type == BT_ASSUMED 3374 && sym->intmod_sym_id != ISOCBINDING_LOC) 3375 { 3376 gfc_error ("Assumed-type argument %s at %L requires an explicit " 3377 "interface", a->expr->symtree->n.sym->name, 3378 &a->expr->where); 3379 break; 3380 } 3381 3382 /* F2008, C1303 and C1304. */ 3383 if (a->expr 3384 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 3385 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3386 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 3387 || gfc_expr_attr (a->expr).lock_comp)) 3388 { 3389 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " 3390 "component at %L requires an explicit interface for " 3391 "procedure %qs", &a->expr->where, sym->name); 3392 break; 3393 } 3394 3395 if (a->expr 3396 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 3397 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3398 && a->expr->ts.u.derived->intmod_sym_id 3399 == ISOFORTRAN_EVENT_TYPE) 3400 || gfc_expr_attr (a->expr).event_comp)) 3401 { 3402 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " 3403 "component at %L requires an explicit interface for " 3404 "procedure %qs", &a->expr->where, sym->name); 3405 break; 3406 } 3407 3408 if (a->expr && a->expr->expr_type == EXPR_NULL 3409 && a->expr->ts.type == BT_UNKNOWN) 3410 { 3411 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); 3412 return false; 3413 } 3414 3415 /* TS 29113, C407b. */ 3416 if (a->expr && a->expr->expr_type == EXPR_VARIABLE 3417 && symbol_rank (a->expr->symtree->n.sym) == -1) 3418 { 3419 gfc_error ("Assumed-rank argument requires an explicit interface " 3420 "at %L", &a->expr->where); 3421 return false; 3422 } 3423 } 3424 3425 return true; 3426 } 3427 3428 dummy_args = gfc_sym_get_dummy_args (sym); 3429 3430 if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where)) 3431 return false; 3432 3433 if (!check_intents (dummy_args, *ap)) 3434 return false; 3435 3436 if (warn_aliasing) 3437 check_some_aliasing (dummy_args, *ap); 3438 3439 return true; 3440} 3441 3442 3443/* Check how a procedure pointer component is used against its interface. 3444 If all goes well, the actual argument list will also end up being properly 3445 sorted. Completely analogous to gfc_procedure_use. */ 3446 3447void 3448gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) 3449{ 3450 /* Warn about calls with an implicit interface. Special case 3451 for calling a ISO_C_BINDING because c_loc and c_funloc 3452 are pseudo-unknown. */ 3453 if (warn_implicit_interface 3454 && comp->attr.if_source == IFSRC_UNKNOWN 3455 && !comp->attr.is_iso_c) 3456 gfc_warning (OPT_Wimplicit_interface, 3457 "Procedure pointer component %qs called with an implicit " 3458 "interface at %L", comp->name, where); 3459 3460 if (comp->attr.if_source == IFSRC_UNKNOWN) 3461 { 3462 gfc_actual_arglist *a; 3463 for (a = *ap; a; a = a->next) 3464 { 3465 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 3466 if (a->name != NULL && a->name[0] != '%') 3467 { 3468 gfc_error ("Keyword argument requires explicit interface " 3469 "for procedure pointer component %qs at %L", 3470 comp->name, &a->expr->where); 3471 break; 3472 } 3473 } 3474 3475 return; 3476 } 3477 3478 if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, 3479 comp->attr.elemental, where)) 3480 return; 3481 3482 check_intents (comp->ts.interface->formal, *ap); 3483 if (warn_aliasing) 3484 check_some_aliasing (comp->ts.interface->formal, *ap); 3485} 3486 3487 3488/* Try if an actual argument list matches the formal list of a symbol, 3489 respecting the symbol's attributes like ELEMENTAL. This is used for 3490 GENERIC resolution. */ 3491 3492bool 3493gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) 3494{ 3495 gfc_formal_arglist *dummy_args; 3496 bool r; 3497 3498 gcc_assert (sym->attr.flavor == FL_PROCEDURE); 3499 3500 dummy_args = gfc_sym_get_dummy_args (sym); 3501 3502 r = !sym->attr.elemental; 3503 if (compare_actual_formal (args, dummy_args, r, !r, NULL)) 3504 { 3505 check_intents (dummy_args, *args); 3506 if (warn_aliasing) 3507 check_some_aliasing (dummy_args, *args); 3508 return true; 3509 } 3510 3511 return false; 3512} 3513 3514 3515/* Given an interface pointer and an actual argument list, search for 3516 a formal argument list that matches the actual. If found, returns 3517 a pointer to the symbol of the correct interface. Returns NULL if 3518 not found. */ 3519 3520gfc_symbol * 3521gfc_search_interface (gfc_interface *intr, int sub_flag, 3522 gfc_actual_arglist **ap) 3523{ 3524 gfc_symbol *elem_sym = NULL; 3525 gfc_symbol *null_sym = NULL; 3526 locus null_expr_loc; 3527 gfc_actual_arglist *a; 3528 bool has_null_arg = false; 3529 3530 for (a = *ap; a; a = a->next) 3531 if (a->expr && a->expr->expr_type == EXPR_NULL 3532 && a->expr->ts.type == BT_UNKNOWN) 3533 { 3534 has_null_arg = true; 3535 null_expr_loc = a->expr->where; 3536 break; 3537 } 3538 3539 for (; intr; intr = intr->next) 3540 { 3541 if (intr->sym->attr.flavor == FL_DERIVED) 3542 continue; 3543 if (sub_flag && intr->sym->attr.function) 3544 continue; 3545 if (!sub_flag && intr->sym->attr.subroutine) 3546 continue; 3547 3548 if (gfc_arglist_matches_symbol (ap, intr->sym)) 3549 { 3550 if (has_null_arg && null_sym) 3551 { 3552 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " 3553 "between specific functions %s and %s", 3554 &null_expr_loc, null_sym->name, intr->sym->name); 3555 return NULL; 3556 } 3557 else if (has_null_arg) 3558 { 3559 null_sym = intr->sym; 3560 continue; 3561 } 3562 3563 /* Satisfy 12.4.4.1 such that an elemental match has lower 3564 weight than a non-elemental match. */ 3565 if (intr->sym->attr.elemental) 3566 { 3567 elem_sym = intr->sym; 3568 continue; 3569 } 3570 return intr->sym; 3571 } 3572 } 3573 3574 if (null_sym) 3575 return null_sym; 3576 3577 return elem_sym ? elem_sym : NULL; 3578} 3579 3580 3581/* Do a brute force recursive search for a symbol. */ 3582 3583static gfc_symtree * 3584find_symtree0 (gfc_symtree *root, gfc_symbol *sym) 3585{ 3586 gfc_symtree * st; 3587 3588 if (root->n.sym == sym) 3589 return root; 3590 3591 st = NULL; 3592 if (root->left) 3593 st = find_symtree0 (root->left, sym); 3594 if (root->right && ! st) 3595 st = find_symtree0 (root->right, sym); 3596 return st; 3597} 3598 3599 3600/* Find a symtree for a symbol. */ 3601 3602gfc_symtree * 3603gfc_find_sym_in_symtree (gfc_symbol *sym) 3604{ 3605 gfc_symtree *st; 3606 gfc_namespace *ns; 3607 3608 /* First try to find it by name. */ 3609 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); 3610 if (st && st->n.sym == sym) 3611 return st; 3612 3613 /* If it's been renamed, resort to a brute-force search. */ 3614 /* TODO: avoid having to do this search. If the symbol doesn't exist 3615 in the symtree for the current namespace, it should probably be added. */ 3616 for (ns = gfc_current_ns; ns; ns = ns->parent) 3617 { 3618 st = find_symtree0 (ns->sym_root, sym); 3619 if (st) 3620 return st; 3621 } 3622 gfc_internal_error ("Unable to find symbol %qs", sym->name); 3623 /* Not reached. */ 3624} 3625 3626 3627/* See if the arglist to an operator-call contains a derived-type argument 3628 with a matching type-bound operator. If so, return the matching specific 3629 procedure defined as operator-target as well as the base-object to use 3630 (which is the found derived-type argument with operator). The generic 3631 name, if any, is transmitted to the final expression via 'gname'. */ 3632 3633static gfc_typebound_proc* 3634matching_typebound_op (gfc_expr** tb_base, 3635 gfc_actual_arglist* args, 3636 gfc_intrinsic_op op, const char* uop, 3637 const char ** gname) 3638{ 3639 gfc_actual_arglist* base; 3640 3641 for (base = args; base; base = base->next) 3642 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS) 3643 { 3644 gfc_typebound_proc* tb; 3645 gfc_symbol* derived; 3646 bool result; 3647 3648 while (base->expr->expr_type == EXPR_OP 3649 && base->expr->value.op.op == INTRINSIC_PARENTHESES) 3650 base->expr = base->expr->value.op.op1; 3651 3652 if (base->expr->ts.type == BT_CLASS) 3653 { 3654 if (CLASS_DATA (base->expr) == NULL 3655 || !gfc_expr_attr (base->expr).class_ok) 3656 continue; 3657 derived = CLASS_DATA (base->expr)->ts.u.derived; 3658 } 3659 else 3660 derived = base->expr->ts.u.derived; 3661 3662 if (op == INTRINSIC_USER) 3663 { 3664 gfc_symtree* tb_uop; 3665 3666 gcc_assert (uop); 3667 tb_uop = gfc_find_typebound_user_op (derived, &result, uop, 3668 false, NULL); 3669 3670 if (tb_uop) 3671 tb = tb_uop->n.tb; 3672 else 3673 tb = NULL; 3674 } 3675 else 3676 tb = gfc_find_typebound_intrinsic_op (derived, &result, op, 3677 false, NULL); 3678 3679 /* This means we hit a PRIVATE operator which is use-associated and 3680 should thus not be seen. */ 3681 if (!result) 3682 tb = NULL; 3683 3684 /* Look through the super-type hierarchy for a matching specific 3685 binding. */ 3686 for (; tb; tb = tb->overridden) 3687 { 3688 gfc_tbp_generic* g; 3689 3690 gcc_assert (tb->is_generic); 3691 for (g = tb->u.generic; g; g = g->next) 3692 { 3693 gfc_symbol* target; 3694 gfc_actual_arglist* argcopy; 3695 bool matches; 3696 3697 gcc_assert (g->specific); 3698 if (g->specific->error) 3699 continue; 3700 3701 target = g->specific->u.specific->n.sym; 3702 3703 /* Check if this arglist matches the formal. */ 3704 argcopy = gfc_copy_actual_arglist (args); 3705 matches = gfc_arglist_matches_symbol (&argcopy, target); 3706 gfc_free_actual_arglist (argcopy); 3707 3708 /* Return if we found a match. */ 3709 if (matches) 3710 { 3711 *tb_base = base->expr; 3712 *gname = g->specific_st->name; 3713 return g->specific; 3714 } 3715 } 3716 } 3717 } 3718 3719 return NULL; 3720} 3721 3722 3723/* For the 'actual arglist' of an operator call and a specific typebound 3724 procedure that has been found the target of a type-bound operator, build the 3725 appropriate EXPR_COMPCALL and resolve it. We take this indirection over 3726 type-bound procedures rather than resolving type-bound operators 'directly' 3727 so that we can reuse the existing logic. */ 3728 3729static void 3730build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, 3731 gfc_expr* base, gfc_typebound_proc* target, 3732 const char *gname) 3733{ 3734 e->expr_type = EXPR_COMPCALL; 3735 e->value.compcall.tbp = target; 3736 e->value.compcall.name = gname ? gname : "$op"; 3737 e->value.compcall.actual = actual; 3738 e->value.compcall.base_object = base; 3739 e->value.compcall.ignore_pass = 1; 3740 e->value.compcall.assign = 0; 3741 if (e->ts.type == BT_UNKNOWN 3742 && target->function) 3743 { 3744 if (target->is_generic) 3745 e->ts = target->u.generic->specific->u.specific->n.sym->ts; 3746 else 3747 e->ts = target->u.specific->n.sym->ts; 3748 } 3749} 3750 3751 3752/* This subroutine is called when an expression is being resolved. 3753 The expression node in question is either a user defined operator 3754 or an intrinsic operator with arguments that aren't compatible 3755 with the operator. This subroutine builds an actual argument list 3756 corresponding to the operands, then searches for a compatible 3757 interface. If one is found, the expression node is replaced with 3758 the appropriate function call. We use the 'match' enum to specify 3759 whether a replacement has been made or not, or if an error occurred. */ 3760 3761match 3762gfc_extend_expr (gfc_expr *e) 3763{ 3764 gfc_actual_arglist *actual; 3765 gfc_symbol *sym; 3766 gfc_namespace *ns; 3767 gfc_user_op *uop; 3768 gfc_intrinsic_op i; 3769 const char *gname; 3770 gfc_typebound_proc* tbo; 3771 gfc_expr* tb_base; 3772 3773 sym = NULL; 3774 3775 actual = gfc_get_actual_arglist (); 3776 actual->expr = e->value.op.op1; 3777 3778 gname = NULL; 3779 3780 if (e->value.op.op2 != NULL) 3781 { 3782 actual->next = gfc_get_actual_arglist (); 3783 actual->next->expr = e->value.op.op2; 3784 } 3785 3786 i = fold_unary_intrinsic (e->value.op.op); 3787 3788 /* See if we find a matching type-bound operator. */ 3789 if (i == INTRINSIC_USER) 3790 tbo = matching_typebound_op (&tb_base, actual, 3791 i, e->value.op.uop->name, &gname); 3792 else 3793 switch (i) 3794 { 3795#define CHECK_OS_COMPARISON(comp) \ 3796 case INTRINSIC_##comp: \ 3797 case INTRINSIC_##comp##_OS: \ 3798 tbo = matching_typebound_op (&tb_base, actual, \ 3799 INTRINSIC_##comp, NULL, &gname); \ 3800 if (!tbo) \ 3801 tbo = matching_typebound_op (&tb_base, actual, \ 3802 INTRINSIC_##comp##_OS, NULL, &gname); \ 3803 break; 3804 CHECK_OS_COMPARISON(EQ) 3805 CHECK_OS_COMPARISON(NE) 3806 CHECK_OS_COMPARISON(GT) 3807 CHECK_OS_COMPARISON(GE) 3808 CHECK_OS_COMPARISON(LT) 3809 CHECK_OS_COMPARISON(LE) 3810#undef CHECK_OS_COMPARISON 3811 3812 default: 3813 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); 3814 break; 3815 } 3816 3817 /* If there is a matching typebound-operator, replace the expression with 3818 a call to it and succeed. */ 3819 if (tbo) 3820 { 3821 gcc_assert (tb_base); 3822 build_compcall_for_operator (e, actual, tb_base, tbo, gname); 3823 3824 if (!gfc_resolve_expr (e)) 3825 return MATCH_ERROR; 3826 else 3827 return MATCH_YES; 3828 } 3829 3830 if (i == INTRINSIC_USER) 3831 { 3832 for (ns = gfc_current_ns; ns; ns = ns->parent) 3833 { 3834 uop = gfc_find_uop (e->value.op.uop->name, ns); 3835 if (uop == NULL) 3836 continue; 3837 3838 sym = gfc_search_interface (uop->op, 0, &actual); 3839 if (sym != NULL) 3840 break; 3841 } 3842 } 3843 else 3844 { 3845 for (ns = gfc_current_ns; ns; ns = ns->parent) 3846 { 3847 /* Due to the distinction between '==' and '.eq.' and friends, one has 3848 to check if either is defined. */ 3849 switch (i) 3850 { 3851#define CHECK_OS_COMPARISON(comp) \ 3852 case INTRINSIC_##comp: \ 3853 case INTRINSIC_##comp##_OS: \ 3854 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ 3855 if (!sym) \ 3856 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ 3857 break; 3858 CHECK_OS_COMPARISON(EQ) 3859 CHECK_OS_COMPARISON(NE) 3860 CHECK_OS_COMPARISON(GT) 3861 CHECK_OS_COMPARISON(GE) 3862 CHECK_OS_COMPARISON(LT) 3863 CHECK_OS_COMPARISON(LE) 3864#undef CHECK_OS_COMPARISON 3865 3866 default: 3867 sym = gfc_search_interface (ns->op[i], 0, &actual); 3868 } 3869 3870 if (sym != NULL) 3871 break; 3872 } 3873 } 3874 3875 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are 3876 found rather than just taking the first one and not checking further. */ 3877 3878 if (sym == NULL) 3879 { 3880 /* Don't use gfc_free_actual_arglist(). */ 3881 free (actual->next); 3882 free (actual); 3883 return MATCH_NO; 3884 } 3885 3886 /* Change the expression node to a function call. */ 3887 e->expr_type = EXPR_FUNCTION; 3888 e->symtree = gfc_find_sym_in_symtree (sym); 3889 e->value.function.actual = actual; 3890 e->value.function.esym = NULL; 3891 e->value.function.isym = NULL; 3892 e->value.function.name = NULL; 3893 e->user_operator = 1; 3894 3895 if (!gfc_resolve_expr (e)) 3896 return MATCH_ERROR; 3897 3898 return MATCH_YES; 3899} 3900 3901 3902/* Tries to replace an assignment code node with a subroutine call to the 3903 subroutine associated with the assignment operator. Return true if the node 3904 was replaced. On false, no error is generated. */ 3905 3906bool 3907gfc_extend_assign (gfc_code *c, gfc_namespace *ns) 3908{ 3909 gfc_actual_arglist *actual; 3910 gfc_expr *lhs, *rhs, *tb_base; 3911 gfc_symbol *sym = NULL; 3912 const char *gname = NULL; 3913 gfc_typebound_proc* tbo; 3914 3915 lhs = c->expr1; 3916 rhs = c->expr2; 3917 3918 /* Don't allow an intrinsic assignment to be replaced. */ 3919 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS 3920 && (rhs->rank == 0 || rhs->rank == lhs->rank) 3921 && (lhs->ts.type == rhs->ts.type 3922 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts)))) 3923 return false; 3924 3925 actual = gfc_get_actual_arglist (); 3926 actual->expr = lhs; 3927 3928 actual->next = gfc_get_actual_arglist (); 3929 actual->next->expr = rhs; 3930 3931 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ 3932 3933 /* See if we find a matching type-bound assignment. */ 3934 tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, 3935 NULL, &gname); 3936 3937 if (tbo) 3938 { 3939 /* Success: Replace the expression with a type-bound call. */ 3940 gcc_assert (tb_base); 3941 c->expr1 = gfc_get_expr (); 3942 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); 3943 c->expr1->value.compcall.assign = 1; 3944 c->expr1->where = c->loc; 3945 c->expr2 = NULL; 3946 c->op = EXEC_COMPCALL; 3947 return true; 3948 } 3949 3950 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ 3951 for (; ns; ns = ns->parent) 3952 { 3953 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); 3954 if (sym != NULL) 3955 break; 3956 } 3957 3958 if (sym) 3959 { 3960 /* Success: Replace the assignment with the call. */ 3961 c->op = EXEC_ASSIGN_CALL; 3962 c->symtree = gfc_find_sym_in_symtree (sym); 3963 c->expr1 = NULL; 3964 c->expr2 = NULL; 3965 c->ext.actual = actual; 3966 return true; 3967 } 3968 3969 /* Failure: No assignment procedure found. */ 3970 free (actual->next); 3971 free (actual); 3972 return false; 3973} 3974 3975 3976/* Make sure that the interface just parsed is not already present in 3977 the given interface list. Ambiguity isn't checked yet since module 3978 procedures can be present without interfaces. */ 3979 3980bool 3981gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) 3982{ 3983 gfc_interface *ip; 3984 3985 for (ip = base; ip; ip = ip->next) 3986 { 3987 if (ip->sym == new_sym) 3988 { 3989 gfc_error ("Entity %qs at %L is already present in the interface", 3990 new_sym->name, &loc); 3991 return false; 3992 } 3993 } 3994 3995 return true; 3996} 3997 3998 3999/* Add a symbol to the current interface. */ 4000 4001bool 4002gfc_add_interface (gfc_symbol *new_sym) 4003{ 4004 gfc_interface **head, *intr; 4005 gfc_namespace *ns; 4006 gfc_symbol *sym; 4007 4008 switch (current_interface.type) 4009 { 4010 case INTERFACE_NAMELESS: 4011 case INTERFACE_ABSTRACT: 4012 return true; 4013 4014 case INTERFACE_INTRINSIC_OP: 4015 for (ns = current_interface.ns; ns; ns = ns->parent) 4016 switch (current_interface.op) 4017 { 4018 case INTRINSIC_EQ: 4019 case INTRINSIC_EQ_OS: 4020 if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, 4021 gfc_current_locus) 4022 || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], 4023 new_sym, gfc_current_locus)) 4024 return false; 4025 break; 4026 4027 case INTRINSIC_NE: 4028 case INTRINSIC_NE_OS: 4029 if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, 4030 gfc_current_locus) 4031 || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], 4032 new_sym, gfc_current_locus)) 4033 return false; 4034 break; 4035 4036 case INTRINSIC_GT: 4037 case INTRINSIC_GT_OS: 4038 if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], 4039 new_sym, gfc_current_locus) 4040 || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], 4041 new_sym, gfc_current_locus)) 4042 return false; 4043 break; 4044 4045 case INTRINSIC_GE: 4046 case INTRINSIC_GE_OS: 4047 if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], 4048 new_sym, gfc_current_locus) 4049 || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], 4050 new_sym, gfc_current_locus)) 4051 return false; 4052 break; 4053 4054 case INTRINSIC_LT: 4055 case INTRINSIC_LT_OS: 4056 if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], 4057 new_sym, gfc_current_locus) 4058 || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], 4059 new_sym, gfc_current_locus)) 4060 return false; 4061 break; 4062 4063 case INTRINSIC_LE: 4064 case INTRINSIC_LE_OS: 4065 if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], 4066 new_sym, gfc_current_locus) 4067 || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], 4068 new_sym, gfc_current_locus)) 4069 return false; 4070 break; 4071 4072 default: 4073 if (!gfc_check_new_interface (ns->op[current_interface.op], 4074 new_sym, gfc_current_locus)) 4075 return false; 4076 } 4077 4078 head = ¤t_interface.ns->op[current_interface.op]; 4079 break; 4080 4081 case INTERFACE_GENERIC: 4082 for (ns = current_interface.ns; ns; ns = ns->parent) 4083 { 4084 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); 4085 if (sym == NULL) 4086 continue; 4087 4088 if (!gfc_check_new_interface (sym->generic, 4089 new_sym, gfc_current_locus)) 4090 return false; 4091 } 4092 4093 head = ¤t_interface.sym->generic; 4094 break; 4095 4096 case INTERFACE_USER_OP: 4097 if (!gfc_check_new_interface (current_interface.uop->op, 4098 new_sym, gfc_current_locus)) 4099 return false; 4100 4101 head = ¤t_interface.uop->op; 4102 break; 4103 4104 default: 4105 gfc_internal_error ("gfc_add_interface(): Bad interface type"); 4106 } 4107 4108 intr = gfc_get_interface (); 4109 intr->sym = new_sym; 4110 intr->where = gfc_current_locus; 4111 4112 intr->next = *head; 4113 *head = intr; 4114 4115 return true; 4116} 4117 4118 4119gfc_interface * 4120gfc_current_interface_head (void) 4121{ 4122 switch (current_interface.type) 4123 { 4124 case INTERFACE_INTRINSIC_OP: 4125 return current_interface.ns->op[current_interface.op]; 4126 break; 4127 4128 case INTERFACE_GENERIC: 4129 return current_interface.sym->generic; 4130 break; 4131 4132 case INTERFACE_USER_OP: 4133 return current_interface.uop->op; 4134 break; 4135 4136 default: 4137 gcc_unreachable (); 4138 } 4139} 4140 4141 4142void 4143gfc_set_current_interface_head (gfc_interface *i) 4144{ 4145 switch (current_interface.type) 4146 { 4147 case INTERFACE_INTRINSIC_OP: 4148 current_interface.ns->op[current_interface.op] = i; 4149 break; 4150 4151 case INTERFACE_GENERIC: 4152 current_interface.sym->generic = i; 4153 break; 4154 4155 case INTERFACE_USER_OP: 4156 current_interface.uop->op = i; 4157 break; 4158 4159 default: 4160 gcc_unreachable (); 4161 } 4162} 4163 4164 4165/* Gets rid of a formal argument list. We do not free symbols. 4166 Symbols are freed when a namespace is freed. */ 4167 4168void 4169gfc_free_formal_arglist (gfc_formal_arglist *p) 4170{ 4171 gfc_formal_arglist *q; 4172 4173 for (; p; p = q) 4174 { 4175 q = p->next; 4176 free (p); 4177 } 4178} 4179 4180 4181/* Check that it is ok for the type-bound procedure 'proc' to override the 4182 procedure 'old', cf. F08:4.5.7.3. */ 4183 4184bool 4185gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) 4186{ 4187 locus where; 4188 gfc_symbol *proc_target, *old_target; 4189 unsigned proc_pass_arg, old_pass_arg, argpos; 4190 gfc_formal_arglist *proc_formal, *old_formal; 4191 bool check_type; 4192 char err[200]; 4193 4194 /* This procedure should only be called for non-GENERIC proc. */ 4195 gcc_assert (!proc->n.tb->is_generic); 4196 4197 /* If the overwritten procedure is GENERIC, this is an error. */ 4198 if (old->n.tb->is_generic) 4199 { 4200 gfc_error ("Can't overwrite GENERIC %qs at %L", 4201 old->name, &proc->n.tb->where); 4202 return false; 4203 } 4204 4205 where = proc->n.tb->where; 4206 proc_target = proc->n.tb->u.specific->n.sym; 4207 old_target = old->n.tb->u.specific->n.sym; 4208 4209 /* Check that overridden binding is not NON_OVERRIDABLE. */ 4210 if (old->n.tb->non_overridable) 4211 { 4212 gfc_error ("%qs at %L overrides a procedure binding declared" 4213 " NON_OVERRIDABLE", proc->name, &where); 4214 return false; 4215 } 4216 4217 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ 4218 if (!old->n.tb->deferred && proc->n.tb->deferred) 4219 { 4220 gfc_error ("%qs at %L must not be DEFERRED as it overrides a" 4221 " non-DEFERRED binding", proc->name, &where); 4222 return false; 4223 } 4224 4225 /* If the overridden binding is PURE, the overriding must be, too. */ 4226 if (old_target->attr.pure && !proc_target->attr.pure) 4227 { 4228 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", 4229 proc->name, &where); 4230 return false; 4231 } 4232 4233 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it 4234 is not, the overriding must not be either. */ 4235 if (old_target->attr.elemental && !proc_target->attr.elemental) 4236 { 4237 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" 4238 " ELEMENTAL", proc->name, &where); 4239 return false; 4240 } 4241 if (!old_target->attr.elemental && proc_target->attr.elemental) 4242 { 4243 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" 4244 " be ELEMENTAL, either", proc->name, &where); 4245 return false; 4246 } 4247 4248 /* If the overridden binding is a SUBROUTINE, the overriding must also be a 4249 SUBROUTINE. */ 4250 if (old_target->attr.subroutine && !proc_target->attr.subroutine) 4251 { 4252 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" 4253 " SUBROUTINE", proc->name, &where); 4254 return false; 4255 } 4256 4257 /* If the overridden binding is a FUNCTION, the overriding must also be a 4258 FUNCTION and have the same characteristics. */ 4259 if (old_target->attr.function) 4260 { 4261 if (!proc_target->attr.function) 4262 { 4263 gfc_error ("%qs at %L overrides a FUNCTION and must also be a" 4264 " FUNCTION", proc->name, &where); 4265 return false; 4266 } 4267 4268 if (!check_result_characteristics (proc_target, old_target, err, 4269 sizeof(err))) 4270 { 4271 gfc_error ("Result mismatch for the overriding procedure " 4272 "%qs at %L: %s", proc->name, &where, err); 4273 return false; 4274 } 4275 } 4276 4277 /* If the overridden binding is PUBLIC, the overriding one must not be 4278 PRIVATE. */ 4279 if (old->n.tb->access == ACCESS_PUBLIC 4280 && proc->n.tb->access == ACCESS_PRIVATE) 4281 { 4282 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" 4283 " PRIVATE", proc->name, &where); 4284 return false; 4285 } 4286 4287 /* Compare the formal argument lists of both procedures. This is also abused 4288 to find the position of the passed-object dummy arguments of both 4289 bindings as at least the overridden one might not yet be resolved and we 4290 need those positions in the check below. */ 4291 proc_pass_arg = old_pass_arg = 0; 4292 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) 4293 proc_pass_arg = 1; 4294 if (!old->n.tb->nopass && !old->n.tb->pass_arg) 4295 old_pass_arg = 1; 4296 argpos = 1; 4297 proc_formal = gfc_sym_get_dummy_args (proc_target); 4298 old_formal = gfc_sym_get_dummy_args (old_target); 4299 for ( ; proc_formal && old_formal; 4300 proc_formal = proc_formal->next, old_formal = old_formal->next) 4301 { 4302 if (proc->n.tb->pass_arg 4303 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) 4304 proc_pass_arg = argpos; 4305 if (old->n.tb->pass_arg 4306 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) 4307 old_pass_arg = argpos; 4308 4309 /* Check that the names correspond. */ 4310 if (strcmp (proc_formal->sym->name, old_formal->sym->name)) 4311 { 4312 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" 4313 " to match the corresponding argument of the overridden" 4314 " procedure", proc_formal->sym->name, proc->name, &where, 4315 old_formal->sym->name); 4316 return false; 4317 } 4318 4319 check_type = proc_pass_arg != argpos && old_pass_arg != argpos; 4320 if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym, 4321 check_type, err, sizeof(err))) 4322 { 4323 gfc_error ("Argument mismatch for the overriding procedure " 4324 "%qs at %L: %s", proc->name, &where, err); 4325 return false; 4326 } 4327 4328 ++argpos; 4329 } 4330 if (proc_formal || old_formal) 4331 { 4332 gfc_error ("%qs at %L must have the same number of formal arguments as" 4333 " the overridden procedure", proc->name, &where); 4334 return false; 4335 } 4336 4337 /* If the overridden binding is NOPASS, the overriding one must also be 4338 NOPASS. */ 4339 if (old->n.tb->nopass && !proc->n.tb->nopass) 4340 { 4341 gfc_error ("%qs at %L overrides a NOPASS binding and must also be" 4342 " NOPASS", proc->name, &where); 4343 return false; 4344 } 4345 4346 /* If the overridden binding is PASS(x), the overriding one must also be 4347 PASS and the passed-object dummy arguments must correspond. */ 4348 if (!old->n.tb->nopass) 4349 { 4350 if (proc->n.tb->nopass) 4351 { 4352 gfc_error ("%qs at %L overrides a binding with PASS and must also be" 4353 " PASS", proc->name, &where); 4354 return false; 4355 } 4356 4357 if (proc_pass_arg != old_pass_arg) 4358 { 4359 gfc_error ("Passed-object dummy argument of %qs at %L must be at" 4360 " the same position as the passed-object dummy argument of" 4361 " the overridden procedure", proc->name, &where); 4362 return false; 4363 } 4364 } 4365 4366 return true; 4367} 4368