1/* Deal with interfaces. 2 Copyright (C) 2000-2022 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 "options.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/* Return the operator depending on the DTIO moded string. Note that 119 these are not operators in the normal sense and so have been placed 120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */ 121 122static gfc_intrinsic_op 123dtio_op (char* mode) 124{ 125 if (strcmp (mode, "formatted") == 0) 126 return INTRINSIC_FORMATTED; 127 if (strcmp (mode, "unformatted") == 0) 128 return INTRINSIC_UNFORMATTED; 129 return INTRINSIC_NONE; 130} 131 132 133/* Match a generic specification. Depending on which type of 134 interface is found, the 'name' or 'op' pointers may be set. 135 This subroutine doesn't return MATCH_NO. */ 136 137match 138gfc_match_generic_spec (interface_type *type, 139 char *name, 140 gfc_intrinsic_op *op) 141{ 142 char buffer[GFC_MAX_SYMBOL_LEN + 1]; 143 match m; 144 gfc_intrinsic_op i; 145 146 if (gfc_match (" assignment ( = )") == MATCH_YES) 147 { 148 *type = INTERFACE_INTRINSIC_OP; 149 *op = INTRINSIC_ASSIGN; 150 return MATCH_YES; 151 } 152 153 if (gfc_match (" operator ( %o )", &i) == MATCH_YES) 154 { /* Operator i/f */ 155 *type = INTERFACE_INTRINSIC_OP; 156 *op = fold_unary_intrinsic (i); 157 return MATCH_YES; 158 } 159 160 *op = INTRINSIC_NONE; 161 if (gfc_match (" operator ( ") == MATCH_YES) 162 { 163 m = gfc_match_defined_op_name (buffer, 1); 164 if (m == MATCH_NO) 165 goto syntax; 166 if (m != MATCH_YES) 167 return MATCH_ERROR; 168 169 m = gfc_match_char (')'); 170 if (m == MATCH_NO) 171 goto syntax; 172 if (m != MATCH_YES) 173 return MATCH_ERROR; 174 175 strcpy (name, buffer); 176 *type = INTERFACE_USER_OP; 177 return MATCH_YES; 178 } 179 180 if (gfc_match (" read ( %n )", buffer) == MATCH_YES) 181 { 182 *op = dtio_op (buffer); 183 if (*op == INTRINSIC_FORMATTED) 184 { 185 strcpy (name, gfc_code2string (dtio_procs, DTIO_RF)); 186 *type = INTERFACE_DTIO; 187 } 188 if (*op == INTRINSIC_UNFORMATTED) 189 { 190 strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF)); 191 *type = INTERFACE_DTIO; 192 } 193 if (*op != INTRINSIC_NONE) 194 return MATCH_YES; 195 } 196 197 if (gfc_match (" write ( %n )", buffer) == MATCH_YES) 198 { 199 *op = dtio_op (buffer); 200 if (*op == INTRINSIC_FORMATTED) 201 { 202 strcpy (name, gfc_code2string (dtio_procs, DTIO_WF)); 203 *type = INTERFACE_DTIO; 204 } 205 if (*op == INTRINSIC_UNFORMATTED) 206 { 207 strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF)); 208 *type = INTERFACE_DTIO; 209 } 210 if (*op != INTRINSIC_NONE) 211 return MATCH_YES; 212 } 213 214 if (gfc_match_name (buffer) == MATCH_YES) 215 { 216 strcpy (name, buffer); 217 *type = INTERFACE_GENERIC; 218 return MATCH_YES; 219 } 220 221 *type = INTERFACE_NAMELESS; 222 return MATCH_YES; 223 224syntax: 225 gfc_error ("Syntax error in generic specification at %C"); 226 return MATCH_ERROR; 227} 228 229 230/* Match one of the five F95 forms of an interface statement. The 231 matcher for the abstract interface follows. */ 232 233match 234gfc_match_interface (void) 235{ 236 char name[GFC_MAX_SYMBOL_LEN + 1]; 237 interface_type type; 238 gfc_symbol *sym; 239 gfc_intrinsic_op op; 240 match m; 241 242 m = gfc_match_space (); 243 244 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) 245 return MATCH_ERROR; 246 247 /* If we're not looking at the end of the statement now, or if this 248 is not a nameless interface but we did not see a space, punt. */ 249 if (gfc_match_eos () != MATCH_YES 250 || (type != INTERFACE_NAMELESS && m != MATCH_YES)) 251 { 252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement " 253 "at %C"); 254 return MATCH_ERROR; 255 } 256 257 current_interface.type = type; 258 259 switch (type) 260 { 261 case INTERFACE_DTIO: 262 case INTERFACE_GENERIC: 263 if (gfc_get_symbol (name, NULL, &sym)) 264 return MATCH_ERROR; 265 266 if (!sym->attr.generic 267 && !gfc_add_generic (&sym->attr, sym->name, NULL)) 268 return MATCH_ERROR; 269 270 if (sym->attr.dummy) 271 { 272 gfc_error ("Dummy procedure %qs at %C cannot have a " 273 "generic interface", sym->name); 274 return MATCH_ERROR; 275 } 276 277 current_interface.sym = gfc_new_block = sym; 278 break; 279 280 case INTERFACE_USER_OP: 281 current_interface.uop = gfc_get_uop (name); 282 break; 283 284 case INTERFACE_INTRINSIC_OP: 285 current_interface.op = op; 286 break; 287 288 case INTERFACE_NAMELESS: 289 case INTERFACE_ABSTRACT: 290 break; 291 } 292 293 return MATCH_YES; 294} 295 296 297 298/* Match a F2003 abstract interface. */ 299 300match 301gfc_match_abstract_interface (void) 302{ 303 match m; 304 305 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")) 306 return MATCH_ERROR; 307 308 m = gfc_match_eos (); 309 310 if (m != MATCH_YES) 311 { 312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C"); 313 return MATCH_ERROR; 314 } 315 316 current_interface.type = INTERFACE_ABSTRACT; 317 318 return m; 319} 320 321 322/* Match the different sort of generic-specs that can be present after 323 the END INTERFACE itself. */ 324 325match 326gfc_match_end_interface (void) 327{ 328 char name[GFC_MAX_SYMBOL_LEN + 1]; 329 interface_type type; 330 gfc_intrinsic_op op; 331 match m; 332 333 m = gfc_match_space (); 334 335 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) 336 return MATCH_ERROR; 337 338 /* If we're not looking at the end of the statement now, or if this 339 is not a nameless interface but we did not see a space, punt. */ 340 if (gfc_match_eos () != MATCH_YES 341 || (type != INTERFACE_NAMELESS && m != MATCH_YES)) 342 { 343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE " 344 "statement at %C"); 345 return MATCH_ERROR; 346 } 347 348 m = MATCH_YES; 349 350 switch (current_interface.type) 351 { 352 case INTERFACE_NAMELESS: 353 case INTERFACE_ABSTRACT: 354 if (type != INTERFACE_NAMELESS) 355 { 356 gfc_error ("Expected a nameless interface at %C"); 357 m = MATCH_ERROR; 358 } 359 360 break; 361 362 case INTERFACE_INTRINSIC_OP: 363 if (type != current_interface.type || op != current_interface.op) 364 { 365 366 if (current_interface.op == INTRINSIC_ASSIGN) 367 { 368 m = MATCH_ERROR; 369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C"); 370 } 371 else 372 { 373 const char *s1, *s2; 374 s1 = gfc_op2string (current_interface.op); 375 s2 = gfc_op2string (op); 376 377 /* The following if-statements are used to enforce C1202 378 from F2003. */ 379 if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0) 380 || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0)) 381 break; 382 if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0) 383 || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0)) 384 break; 385 if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0) 386 || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0)) 387 break; 388 if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0) 389 || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0)) 390 break; 391 if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0) 392 || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0)) 393 break; 394 if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0) 395 || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0)) 396 break; 397 398 m = MATCH_ERROR; 399 if (strcmp(s2, "none") == 0) 400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> " 401 "at %C", s1); 402 else 403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, " 404 "but got %qs", s1, s2); 405 } 406 407 } 408 409 break; 410 411 case INTERFACE_USER_OP: 412 /* Comparing the symbol node names is OK because only use-associated 413 symbols can be renamed. */ 414 if (type != current_interface.type 415 || strcmp (current_interface.uop->name, name) != 0) 416 { 417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C", 418 current_interface.uop->name); 419 m = MATCH_ERROR; 420 } 421 422 break; 423 424 case INTERFACE_DTIO: 425 case INTERFACE_GENERIC: 426 if (type != current_interface.type 427 || strcmp (current_interface.sym->name, name) != 0) 428 { 429 gfc_error ("Expecting %<END INTERFACE %s%> at %C", 430 current_interface.sym->name); 431 m = MATCH_ERROR; 432 } 433 434 break; 435 } 436 437 return m; 438} 439 440 441/* Return whether the component was defined anonymously. */ 442 443static bool 444is_anonymous_component (gfc_component *cmp) 445{ 446 /* Only UNION and MAP components are anonymous. In the case of a MAP, 447 the derived type symbol is FL_STRUCT and the component name looks like mM*. 448 This is the only case in which the second character of a component name is 449 uppercase. */ 450 return cmp->ts.type == BT_UNION 451 || (cmp->ts.type == BT_DERIVED 452 && cmp->ts.u.derived->attr.flavor == FL_STRUCT 453 && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1])); 454} 455 456 457/* Return whether the derived type was defined anonymously. */ 458 459static bool 460is_anonymous_dt (gfc_symbol *derived) 461{ 462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE 463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT 464 and the type name looks like XX*. This is the only case in which the 465 second character of a type name is uppercase. */ 466 return derived->attr.flavor == FL_UNION 467 || (derived->attr.flavor == FL_STRUCT 468 && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1])); 469} 470 471 472/* Compare components according to 4.4.2 of the Fortran standard. */ 473 474static bool 475compare_components (gfc_component *cmp1, gfc_component *cmp2, 476 gfc_symbol *derived1, gfc_symbol *derived2) 477{ 478 /* Compare names, but not for anonymous components such as UNION or MAP. */ 479 if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2) 480 && strcmp (cmp1->name, cmp2->name) != 0) 481 return false; 482 483 if (cmp1->attr.access != cmp2->attr.access) 484 return false; 485 486 if (cmp1->attr.pointer != cmp2->attr.pointer) 487 return false; 488 489 if (cmp1->attr.dimension != cmp2->attr.dimension) 490 return false; 491 492 if (cmp1->attr.allocatable != cmp2->attr.allocatable) 493 return false; 494 495 if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) 496 return false; 497 498 if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER) 499 { 500 gfc_charlen *l1 = cmp1->ts.u.cl; 501 gfc_charlen *l2 = cmp2->ts.u.cl; 502 if (l1 && l2 && l1->length && l2->length 503 && l1->length->expr_type == EXPR_CONSTANT 504 && l2->length->expr_type == EXPR_CONSTANT 505 && gfc_dep_compare_expr (l1->length, l2->length) != 0) 506 return false; 507 } 508 509 /* Make sure that link lists do not put this function into an 510 endless recursive loop! */ 511 if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) 512 && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived) 513 && !gfc_compare_types (&cmp1->ts, &cmp2->ts)) 514 return false; 515 516 else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) 517 && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) 518 return false; 519 520 else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) 521 && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) 522 return false; 523 524 return true; 525} 526 527 528/* Compare two union types by comparing the components of their maps. 529 Because unions and maps are anonymous their types get special internal 530 names; therefore the usual derived type comparison will fail on them. 531 532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with 533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate 534 definitions' than 'equivalent structure'. */ 535 536static bool 537compare_union_types (gfc_symbol *un1, gfc_symbol *un2) 538{ 539 gfc_component *map1, *map2, *cmp1, *cmp2; 540 gfc_symbol *map1_t, *map2_t; 541 542 if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION) 543 return false; 544 545 if (un1->attr.zero_comp != un2->attr.zero_comp) 546 return false; 547 548 if (un1->attr.zero_comp) 549 return true; 550 551 map1 = un1->components; 552 map2 = un2->components; 553 554 /* In terms of 'equality' here we are worried about types which are 555 declared the same in two places, not types that represent equivalent 556 structures. (This is common because of FORTRAN's weird scoping rules.) 557 Though two unions with their maps in different orders could be equivalent, 558 we will say they are not equal for the purposes of this test; therefore 559 we compare the maps sequentially. */ 560 for (;;) 561 { 562 map1_t = map1->ts.u.derived; 563 map2_t = map2->ts.u.derived; 564 565 cmp1 = map1_t->components; 566 cmp2 = map2_t->components; 567 568 /* Protect against null components. */ 569 if (map1_t->attr.zero_comp != map2_t->attr.zero_comp) 570 return false; 571 572 if (map1_t->attr.zero_comp) 573 return true; 574 575 for (;;) 576 { 577 /* No two fields will ever point to the same map type unless they are 578 the same component, because one map field is created with its type 579 declaration. Therefore don't worry about recursion here. */ 580 /* TODO: worry about recursion into parent types of the unions? */ 581 if (!compare_components (cmp1, cmp2, map1_t, map2_t)) 582 return false; 583 584 cmp1 = cmp1->next; 585 cmp2 = cmp2->next; 586 587 if (cmp1 == NULL && cmp2 == NULL) 588 break; 589 if (cmp1 == NULL || cmp2 == NULL) 590 return false; 591 } 592 593 map1 = map1->next; 594 map2 = map2->next; 595 596 if (map1 == NULL && map2 == NULL) 597 break; 598 if (map1 == NULL || map2 == NULL) 599 return false; 600 } 601 602 return true; 603} 604 605 606 607/* Compare two derived types using the criteria in 4.4.2 of the standard, 608 recursing through gfc_compare_types for the components. */ 609 610bool 611gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) 612{ 613 gfc_component *cmp1, *cmp2; 614 615 if (derived1 == derived2) 616 return true; 617 618 if (!derived1 || !derived2) 619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type"); 620 621 if (derived1->attr.unlimited_polymorphic 622 && derived2->attr.unlimited_polymorphic) 623 return true; 624 625 if (derived1->attr.unlimited_polymorphic 626 != derived2->attr.unlimited_polymorphic) 627 return false; 628 629 /* Compare UNION types specially. */ 630 if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION) 631 return compare_union_types (derived1, derived2); 632 633 /* Special case for comparing derived types across namespaces. If the 634 true names and module names are the same and the module name is 635 nonnull, then they are equal. */ 636 if (strcmp (derived1->name, derived2->name) == 0 637 && derived1->module != NULL && derived2->module != NULL 638 && strcmp (derived1->module, derived2->module) == 0) 639 return true; 640 641 /* Compare type via the rules of the standard. Both types must have the 642 SEQUENCE or BIND(C) attribute to be equal. We also compare types 643 recursively if they are class descriptors types or virtual tables types. 644 STRUCTUREs are special because they can be anonymous; therefore two 645 structures with different names may be equal. */ 646 647 /* Compare names, but not for anonymous types such as UNION or MAP. */ 648 if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) 649 && strcmp (derived1->name, derived2->name) != 0) 650 return false; 651 652 if (derived1->component_access == ACCESS_PRIVATE 653 || derived2->component_access == ACCESS_PRIVATE) 654 return false; 655 656 if (!(derived1->attr.sequence && derived2->attr.sequence) 657 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c) 658 && !(derived1->attr.is_class && derived2->attr.is_class) 659 && !(derived1->attr.vtype && derived2->attr.vtype) 660 && !(derived1->attr.pdt_type && derived2->attr.pdt_type)) 661 return false; 662 663 /* Protect against null components. */ 664 if (derived1->attr.zero_comp != derived2->attr.zero_comp) 665 return false; 666 667 if (derived1->attr.zero_comp) 668 return true; 669 670 cmp1 = derived1->components; 671 cmp2 = derived2->components; 672 673 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a 674 simple test can speed things up. Otherwise, lots of things have to 675 match. */ 676 for (;;) 677 { 678 if (!compare_components (cmp1, cmp2, derived1, derived2)) 679 return false; 680 681 cmp1 = cmp1->next; 682 cmp2 = cmp2->next; 683 684 if (cmp1 == NULL && cmp2 == NULL) 685 break; 686 if (cmp1 == NULL || cmp2 == NULL) 687 return false; 688 } 689 690 return true; 691} 692 693 694/* Compare two typespecs, recursively if necessary. */ 695 696bool 697gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) 698{ 699 /* See if one of the typespecs is a BT_VOID, which is what is being used 700 to allow the funcs like c_f_pointer to accept any pointer type. 701 TODO: Possibly should narrow this to just the one typespec coming in 702 that is for the formal arg, but oh well. */ 703 if (ts1->type == BT_VOID || ts2->type == BT_VOID) 704 return true; 705 706 /* Special case for our C interop types. FIXME: There should be a 707 better way of doing this. When ISO C binding is cleared up, 708 this can probably be removed. See PR 57048. */ 709 710 if (((ts1->type == BT_INTEGER && ts2->type == BT_DERIVED) 711 || (ts1->type == BT_DERIVED && ts2->type == BT_INTEGER)) 712 && ts1->u.derived && ts2->u.derived 713 && ts1->u.derived == ts2->u.derived) 714 return true; 715 716 /* The _data component is not always present, therefore check for its 717 presence before assuming, that its derived->attr is available. 718 When the _data component is not present, then nevertheless the 719 unlimited_polymorphic flag may be set in the derived type's attr. */ 720 if (ts1->type == BT_CLASS && ts1->u.derived->components 721 && ((ts1->u.derived->attr.is_class 722 && ts1->u.derived->components->ts.u.derived->attr 723 .unlimited_polymorphic) 724 || ts1->u.derived->attr.unlimited_polymorphic)) 725 return true; 726 727 /* F2003: C717 */ 728 if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED 729 && ts2->u.derived->components 730 && ((ts2->u.derived->attr.is_class 731 && ts2->u.derived->components->ts.u.derived->attr 732 .unlimited_polymorphic) 733 || ts2->u.derived->attr.unlimited_polymorphic) 734 && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) 735 return true; 736 737 if (ts1->type != ts2->type 738 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) 739 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) 740 return false; 741 742 if (ts1->type == BT_UNION) 743 return compare_union_types (ts1->u.derived, ts2->u.derived); 744 745 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) 746 return (ts1->kind == ts2->kind); 747 748 /* Compare derived types. */ 749 return gfc_type_compatible (ts1, ts2); 750} 751 752 753static bool 754compare_type (gfc_symbol *s1, gfc_symbol *s2) 755{ 756 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 757 return true; 758 759 return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; 760} 761 762 763static bool 764compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2) 765{ 766 /* TYPE and CLASS of the same declared type are type compatible, 767 but have different characteristics. */ 768 if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) 769 || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) 770 return false; 771 772 return compare_type (s1, s2); 773} 774 775 776static bool 777compare_rank (gfc_symbol *s1, gfc_symbol *s2) 778{ 779 gfc_array_spec *as1, *as2; 780 int r1, r2; 781 782 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 783 return true; 784 785 as1 = (s1->ts.type == BT_CLASS 786 && !s1->ts.u.derived->attr.unlimited_polymorphic) 787 ? CLASS_DATA (s1)->as : s1->as; 788 as2 = (s2->ts.type == BT_CLASS 789 && !s2->ts.u.derived->attr.unlimited_polymorphic) 790 ? CLASS_DATA (s2)->as : s2->as; 791 792 r1 = as1 ? as1->rank : 0; 793 r2 = as2 ? as2->rank : 0; 794 795 if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) 796 return false; /* Ranks differ. */ 797 798 return true; 799} 800 801 802/* Given two symbols that are formal arguments, compare their ranks 803 and types. Returns true if they have the same rank and type, 804 false otherwise. */ 805 806static bool 807compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) 808{ 809 return compare_type (s1, s2) && compare_rank (s1, s2); 810} 811 812 813/* Given two symbols that are formal arguments, compare their types 814 and rank and their formal interfaces if they are both dummy 815 procedures. Returns true if the same, false if different. */ 816 817static bool 818compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2) 819{ 820 if (s1 == NULL || s2 == NULL) 821 return (s1 == s2); 822 823 if (s1 == s2) 824 return true; 825 826 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) 827 return compare_type_rank (s1, s2); 828 829 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) 830 return false; 831 832 /* At this point, both symbols are procedures. It can happen that 833 external procedures are compared, where one is identified by usage 834 to be a function or subroutine but the other is not. Check TKR 835 nonetheless for these cases. */ 836 if (s1->attr.function == 0 && s1->attr.subroutine == 0) 837 return s1->attr.external ? compare_type_rank (s1, s2) : false; 838 839 if (s2->attr.function == 0 && s2->attr.subroutine == 0) 840 return s2->attr.external ? compare_type_rank (s1, s2) : false; 841 842 /* Now the type of procedure has been identified. */ 843 if (s1->attr.function != s2->attr.function 844 || s1->attr.subroutine != s2->attr.subroutine) 845 return false; 846 847 if (s1->attr.function && !compare_type_rank (s1, s2)) 848 return false; 849 850 /* Originally, gfortran recursed here to check the interfaces of passed 851 procedures. This is explicitly not required by the standard. */ 852 return true; 853} 854 855 856/* Given a formal argument list and a keyword name, search the list 857 for that keyword. Returns the correct symbol node if found, NULL 858 if not found. */ 859 860static gfc_symbol * 861find_keyword_arg (const char *name, gfc_formal_arglist *f) 862{ 863 for (; f; f = f->next) 864 if (strcmp (f->sym->name, name) == 0) 865 return f->sym; 866 867 return NULL; 868} 869 870 871/******** Interface checking subroutines **********/ 872 873 874/* Given an operator interface and the operator, make sure that all 875 interfaces for that operator are legal. */ 876 877bool 878gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op, 879 locus opwhere) 880{ 881 gfc_formal_arglist *formal; 882 sym_intent i1, i2; 883 bt t1, t2; 884 int args, r1, r2, k1, k2; 885 886 gcc_assert (sym); 887 888 args = 0; 889 t1 = t2 = BT_UNKNOWN; 890 i1 = i2 = INTENT_UNKNOWN; 891 r1 = r2 = -1; 892 k1 = k2 = -1; 893 894 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) 895 { 896 gfc_symbol *fsym = formal->sym; 897 if (fsym == NULL) 898 { 899 gfc_error ("Alternate return cannot appear in operator " 900 "interface at %L", &sym->declared_at); 901 return false; 902 } 903 if (args == 0) 904 { 905 t1 = fsym->ts.type; 906 i1 = fsym->attr.intent; 907 r1 = (fsym->as != NULL) ? fsym->as->rank : 0; 908 k1 = fsym->ts.kind; 909 } 910 if (args == 1) 911 { 912 t2 = fsym->ts.type; 913 i2 = fsym->attr.intent; 914 r2 = (fsym->as != NULL) ? fsym->as->rank : 0; 915 k2 = fsym->ts.kind; 916 } 917 args++; 918 } 919 920 /* Only +, - and .not. can be unary operators. 921 .not. cannot be a binary operator. */ 922 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS 923 && op != INTRINSIC_MINUS 924 && op != INTRINSIC_NOT) 925 || (args == 2 && op == INTRINSIC_NOT)) 926 { 927 if (op == INTRINSIC_ASSIGN) 928 gfc_error ("Assignment operator interface at %L must have " 929 "two arguments", &sym->declared_at); 930 else 931 gfc_error ("Operator interface at %L has the wrong number of arguments", 932 &sym->declared_at); 933 return false; 934 } 935 936 /* Check that intrinsics are mapped to functions, except 937 INTRINSIC_ASSIGN which should map to a subroutine. */ 938 if (op == INTRINSIC_ASSIGN) 939 { 940 gfc_formal_arglist *dummy_args; 941 942 if (!sym->attr.subroutine) 943 { 944 gfc_error ("Assignment operator interface at %L must be " 945 "a SUBROUTINE", &sym->declared_at); 946 return false; 947 } 948 949 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments): 950 - First argument an array with different rank than second, 951 - First argument is a scalar and second an array, 952 - Types and kinds do not conform, or 953 - First argument is of derived type. */ 954 dummy_args = gfc_sym_get_dummy_args (sym); 955 if (dummy_args->sym->ts.type != BT_DERIVED 956 && dummy_args->sym->ts.type != BT_CLASS 957 && (r2 == 0 || r1 == r2) 958 && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type 959 || (gfc_numeric_ts (&dummy_args->sym->ts) 960 && gfc_numeric_ts (&dummy_args->next->sym->ts)))) 961 { 962 gfc_error ("Assignment operator interface at %L must not redefine " 963 "an INTRINSIC type assignment", &sym->declared_at); 964 return false; 965 } 966 } 967 else 968 { 969 if (!sym->attr.function) 970 { 971 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", 972 &sym->declared_at); 973 return false; 974 } 975 } 976 977 /* Check intents on operator interfaces. */ 978 if (op == INTRINSIC_ASSIGN) 979 { 980 if (i1 != INTENT_OUT && i1 != INTENT_INOUT) 981 { 982 gfc_error ("First argument of defined assignment at %L must be " 983 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at); 984 return false; 985 } 986 987 if (i2 != INTENT_IN) 988 { 989 gfc_error ("Second argument of defined assignment at %L must be " 990 "INTENT(IN)", &sym->declared_at); 991 return false; 992 } 993 } 994 else 995 { 996 if (i1 != INTENT_IN) 997 { 998 gfc_error ("First argument of operator interface at %L must be " 999 "INTENT(IN)", &sym->declared_at); 1000 return false; 1001 } 1002 1003 if (args == 2 && i2 != INTENT_IN) 1004 { 1005 gfc_error ("Second argument of operator interface at %L must be " 1006 "INTENT(IN)", &sym->declared_at); 1007 return false; 1008 } 1009 } 1010 1011 /* From now on, all we have to do is check that the operator definition 1012 doesn't conflict with an intrinsic operator. The rules for this 1013 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards, 1014 as well as 12.3.2.1.1 of Fortran 2003: 1015 1016 "If the operator is an intrinsic-operator (R310), the number of 1017 function arguments shall be consistent with the intrinsic uses of 1018 that operator, and the types, kind type parameters, or ranks of the 1019 dummy arguments shall differ from those required for the intrinsic 1020 operation (7.1.2)." */ 1021 1022#define IS_NUMERIC_TYPE(t) \ 1023 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX) 1024 1025 /* Unary ops are easy, do them first. */ 1026 if (op == INTRINSIC_NOT) 1027 { 1028 if (t1 == BT_LOGICAL) 1029 goto bad_repl; 1030 else 1031 return true; 1032 } 1033 1034 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS)) 1035 { 1036 if (IS_NUMERIC_TYPE (t1)) 1037 goto bad_repl; 1038 else 1039 return true; 1040 } 1041 1042 /* Character intrinsic operators have same character kind, thus 1043 operator definitions with operands of different character kinds 1044 are always safe. */ 1045 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) 1046 return true; 1047 1048 /* Intrinsic operators always perform on arguments of same rank, 1049 so different ranks is also always safe. (rank == 0) is an exception 1050 to that, because all intrinsic operators are elemental. */ 1051 if (r1 != r2 && r1 != 0 && r2 != 0) 1052 return true; 1053 1054 switch (op) 1055 { 1056 case INTRINSIC_EQ: 1057 case INTRINSIC_EQ_OS: 1058 case INTRINSIC_NE: 1059 case INTRINSIC_NE_OS: 1060 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 1061 goto bad_repl; 1062 /* Fall through. */ 1063 1064 case INTRINSIC_PLUS: 1065 case INTRINSIC_MINUS: 1066 case INTRINSIC_TIMES: 1067 case INTRINSIC_DIVIDE: 1068 case INTRINSIC_POWER: 1069 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2)) 1070 goto bad_repl; 1071 break; 1072 1073 case INTRINSIC_GT: 1074 case INTRINSIC_GT_OS: 1075 case INTRINSIC_GE: 1076 case INTRINSIC_GE_OS: 1077 case INTRINSIC_LT: 1078 case INTRINSIC_LT_OS: 1079 case INTRINSIC_LE: 1080 case INTRINSIC_LE_OS: 1081 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 1082 goto bad_repl; 1083 if ((t1 == BT_INTEGER || t1 == BT_REAL) 1084 && (t2 == BT_INTEGER || t2 == BT_REAL)) 1085 goto bad_repl; 1086 break; 1087 1088 case INTRINSIC_CONCAT: 1089 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) 1090 goto bad_repl; 1091 break; 1092 1093 case INTRINSIC_AND: 1094 case INTRINSIC_OR: 1095 case INTRINSIC_EQV: 1096 case INTRINSIC_NEQV: 1097 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) 1098 goto bad_repl; 1099 break; 1100 1101 default: 1102 break; 1103 } 1104 1105 return true; 1106 1107#undef IS_NUMERIC_TYPE 1108 1109bad_repl: 1110 gfc_error ("Operator interface at %L conflicts with intrinsic interface", 1111 &opwhere); 1112 return false; 1113} 1114 1115 1116/* Given a pair of formal argument lists, we see if the two lists can 1117 be distinguished by counting the number of nonoptional arguments of 1118 a given type/rank in f1 and seeing if there are less then that 1119 number of those arguments in f2 (including optional arguments). 1120 Since this test is asymmetric, it has to be called twice to make it 1121 symmetric. Returns nonzero if the argument lists are incompatible 1122 by this test. This subroutine implements rule 1 of section F03:16.2.3. 1123 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ 1124 1125static bool 1126count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, 1127 const char *p1, const char *p2) 1128{ 1129 int ac1, ac2, i, j, k, n1; 1130 gfc_formal_arglist *f; 1131 1132 typedef struct 1133 { 1134 int flag; 1135 gfc_symbol *sym; 1136 } 1137 arginfo; 1138 1139 arginfo *arg; 1140 1141 n1 = 0; 1142 1143 for (f = f1; f; f = f->next) 1144 n1++; 1145 1146 /* Build an array of integers that gives the same integer to 1147 arguments of the same type/rank. */ 1148 arg = XCNEWVEC (arginfo, n1); 1149 1150 f = f1; 1151 for (i = 0; i < n1; i++, f = f->next) 1152 { 1153 arg[i].flag = -1; 1154 arg[i].sym = f->sym; 1155 } 1156 1157 k = 0; 1158 1159 for (i = 0; i < n1; i++) 1160 { 1161 if (arg[i].flag != -1) 1162 continue; 1163 1164 if (arg[i].sym && (arg[i].sym->attr.optional 1165 || (p1 && strcmp (arg[i].sym->name, p1) == 0))) 1166 continue; /* Skip OPTIONAL and PASS arguments. */ 1167 1168 arg[i].flag = k; 1169 1170 /* Find other non-optional, non-pass arguments of the same type/rank. */ 1171 for (j = i + 1; j < n1; j++) 1172 if ((arg[j].sym == NULL 1173 || !(arg[j].sym->attr.optional 1174 || (p1 && strcmp (arg[j].sym->name, p1) == 0))) 1175 && (compare_type_rank_if (arg[i].sym, arg[j].sym) 1176 || compare_type_rank_if (arg[j].sym, arg[i].sym))) 1177 arg[j].flag = k; 1178 1179 k++; 1180 } 1181 1182 /* Now loop over each distinct type found in f1. */ 1183 k = 0; 1184 bool rc = false; 1185 1186 for (i = 0; i < n1; i++) 1187 { 1188 if (arg[i].flag != k) 1189 continue; 1190 1191 ac1 = 1; 1192 for (j = i + 1; j < n1; j++) 1193 if (arg[j].flag == k) 1194 ac1++; 1195 1196 /* Count the number of non-pass arguments in f2 with that type, 1197 including those that are optional. */ 1198 ac2 = 0; 1199 1200 for (f = f2; f; f = f->next) 1201 if ((!p2 || strcmp (f->sym->name, p2) != 0) 1202 && (compare_type_rank_if (arg[i].sym, f->sym) 1203 || compare_type_rank_if (f->sym, arg[i].sym))) 1204 ac2++; 1205 1206 if (ac1 > ac2) 1207 { 1208 rc = true; 1209 break; 1210 } 1211 1212 k++; 1213 } 1214 1215 free (arg); 1216 1217 return rc; 1218} 1219 1220 1221/* Returns true if two dummy arguments are distinguishable due to their POINTER 1222 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3). 1223 The function is asymmetric wrt to the arguments s1 and s2 and should always 1224 be called twice (with flipped arguments in the second call). */ 1225 1226static bool 1227compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2) 1228{ 1229 /* Is s1 allocatable? */ 1230 const bool a1 = s1->ts.type == BT_CLASS ? 1231 CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable; 1232 /* Is s2 a pointer? */ 1233 const bool p2 = s2->ts.type == BT_CLASS ? 1234 CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer; 1235 return a1 && p2 && (s2->attr.intent != INTENT_IN); 1236} 1237 1238 1239/* Perform the correspondence test in rule (3) of F08:C1215. 1240 Returns zero if no argument is found that satisfies this rule, 1241 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures 1242 (if applicable). 1243 1244 This test is also not symmetric in f1 and f2 and must be called 1245 twice. This test finds problems caused by sorting the actual 1246 argument list with keywords. For example: 1247 1248 INTERFACE FOO 1249 SUBROUTINE F1(A, B) 1250 INTEGER :: A ; REAL :: B 1251 END SUBROUTINE F1 1252 1253 SUBROUTINE F2(B, A) 1254 INTEGER :: A ; REAL :: B 1255 END SUBROUTINE F1 1256 END INTERFACE FOO 1257 1258 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ 1259 1260static bool 1261generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, 1262 const char *p1, const char *p2) 1263{ 1264 gfc_formal_arglist *f2_save, *g; 1265 gfc_symbol *sym; 1266 1267 f2_save = f2; 1268 1269 while (f1) 1270 { 1271 if (!f1->sym || f1->sym->attr.optional) 1272 goto next; 1273 1274 if (p1 && strcmp (f1->sym->name, p1) == 0) 1275 f1 = f1->next; 1276 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0) 1277 f2 = f2->next; 1278 1279 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) 1280 || compare_type_rank (f2->sym, f1->sym)) 1281 && !((gfc_option.allow_std & GFC_STD_F2008) 1282 && (compare_ptr_alloc(f1->sym, f2->sym) 1283 || compare_ptr_alloc(f2->sym, f1->sym)))) 1284 goto next; 1285 1286 /* Now search for a disambiguating keyword argument starting at 1287 the current non-match. */ 1288 for (g = f1; g; g = g->next) 1289 { 1290 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0)) 1291 continue; 1292 1293 sym = find_keyword_arg (g->sym->name, f2_save); 1294 if (sym == NULL || !compare_type_rank (g->sym, sym) 1295 || ((gfc_option.allow_std & GFC_STD_F2008) 1296 && (compare_ptr_alloc(sym, g->sym) 1297 || compare_ptr_alloc(g->sym, sym)))) 1298 return true; 1299 } 1300 1301 next: 1302 if (f1 != NULL) 1303 f1 = f1->next; 1304 if (f2 != NULL) 1305 f2 = f2->next; 1306 } 1307 1308 return false; 1309} 1310 1311 1312static int 1313symbol_rank (gfc_symbol *sym) 1314{ 1315 gfc_array_spec *as = NULL; 1316 1317 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) 1318 as = CLASS_DATA (sym)->as; 1319 else 1320 as = sym->as; 1321 1322 return as ? as->rank : 0; 1323} 1324 1325 1326/* Check if the characteristics of two dummy arguments match, 1327 cf. F08:12.3.2. */ 1328 1329bool 1330gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, 1331 bool type_must_agree, char *errmsg, 1332 int err_len) 1333{ 1334 if (s1 == NULL || s2 == NULL) 1335 return s1 == s2 ? true : false; 1336 1337 /* Check type and rank. */ 1338 if (type_must_agree) 1339 { 1340 if (!compare_type_characteristics (s1, s2) 1341 || !compare_type_characteristics (s2, s1)) 1342 { 1343 snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)", 1344 s1->name, gfc_dummy_typename (&s1->ts), 1345 gfc_dummy_typename (&s2->ts)); 1346 return false; 1347 } 1348 if (!compare_rank (s1, s2)) 1349 { 1350 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)", 1351 s1->name, symbol_rank (s1), symbol_rank (s2)); 1352 return false; 1353 } 1354 } 1355 1356 /* Check INTENT. */ 1357 if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial 1358 && !s2->attr.artificial) 1359 { 1360 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", 1361 s1->name); 1362 return false; 1363 } 1364 1365 /* Check OPTIONAL attribute. */ 1366 if (s1->attr.optional != s2->attr.optional) 1367 { 1368 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", 1369 s1->name); 1370 return false; 1371 } 1372 1373 /* Check ALLOCATABLE attribute. */ 1374 if (s1->attr.allocatable != s2->attr.allocatable) 1375 { 1376 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", 1377 s1->name); 1378 return false; 1379 } 1380 1381 /* Check POINTER attribute. */ 1382 if (s1->attr.pointer != s2->attr.pointer) 1383 { 1384 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", 1385 s1->name); 1386 return false; 1387 } 1388 1389 /* Check TARGET attribute. */ 1390 if (s1->attr.target != s2->attr.target) 1391 { 1392 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", 1393 s1->name); 1394 return false; 1395 } 1396 1397 /* Check ASYNCHRONOUS attribute. */ 1398 if (s1->attr.asynchronous != s2->attr.asynchronous) 1399 { 1400 snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", 1401 s1->name); 1402 return false; 1403 } 1404 1405 /* Check CONTIGUOUS attribute. */ 1406 if (s1->attr.contiguous != s2->attr.contiguous) 1407 { 1408 snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", 1409 s1->name); 1410 return false; 1411 } 1412 1413 /* Check VALUE attribute. */ 1414 if (s1->attr.value != s2->attr.value) 1415 { 1416 snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", 1417 s1->name); 1418 return false; 1419 } 1420 1421 /* Check VOLATILE attribute. */ 1422 if (s1->attr.volatile_ != s2->attr.volatile_) 1423 { 1424 snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", 1425 s1->name); 1426 return false; 1427 } 1428 1429 /* Check interface of dummy procedures. */ 1430 if (s1->attr.flavor == FL_PROCEDURE) 1431 { 1432 char err[200]; 1433 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err), 1434 NULL, NULL)) 1435 { 1436 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure " 1437 "'%s': %s", s1->name, err); 1438 return false; 1439 } 1440 } 1441 1442 /* Check string length. */ 1443 if (s1->ts.type == BT_CHARACTER 1444 && s1->ts.u.cl && s1->ts.u.cl->length 1445 && s2->ts.u.cl && s2->ts.u.cl->length) 1446 { 1447 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length, 1448 s2->ts.u.cl->length); 1449 switch (compval) 1450 { 1451 case -1: 1452 case 1: 1453 case -3: 1454 snprintf (errmsg, err_len, "Character length mismatch " 1455 "in argument '%s'", s1->name); 1456 return false; 1457 1458 case -2: 1459 /* FIXME: Implement a warning for this case. 1460 gfc_warning (0, "Possible character length mismatch in argument %qs", 1461 s1->name);*/ 1462 break; 1463 1464 case 0: 1465 break; 1466 1467 default: 1468 gfc_internal_error ("check_dummy_characteristics: Unexpected result " 1469 "%i of gfc_dep_compare_expr", compval); 1470 break; 1471 } 1472 } 1473 1474 /* Check array shape. */ 1475 if (s1->as && s2->as) 1476 { 1477 int i, compval; 1478 gfc_expr *shape1, *shape2; 1479 1480 /* Sometimes the ambiguity between deferred shape and assumed shape 1481 does not get resolved in module procedures, where the only explicit 1482 declaration of the dummy is in the interface. */ 1483 if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure 1484 && s1->as->type == AS_ASSUMED_SHAPE 1485 && s2->as->type == AS_DEFERRED) 1486 { 1487 s2->as->type = AS_ASSUMED_SHAPE; 1488 for (i = 0; i < s2->as->rank; i++) 1489 if (s1->as->lower[i] != NULL) 1490 s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]); 1491 } 1492 1493 if (s1->as->type != s2->as->type) 1494 { 1495 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", 1496 s1->name); 1497 return false; 1498 } 1499 1500 if (s1->as->corank != s2->as->corank) 1501 { 1502 snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)", 1503 s1->name, s1->as->corank, s2->as->corank); 1504 return false; 1505 } 1506 1507 if (s1->as->type == AS_EXPLICIT) 1508 for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++) 1509 { 1510 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]), 1511 gfc_copy_expr (s1->as->lower[i])); 1512 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]), 1513 gfc_copy_expr (s2->as->lower[i])); 1514 compval = gfc_dep_compare_expr (shape1, shape2); 1515 gfc_free_expr (shape1); 1516 gfc_free_expr (shape2); 1517 switch (compval) 1518 { 1519 case -1: 1520 case 1: 1521 case -3: 1522 if (i < s1->as->rank) 1523 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of" 1524 " argument '%s'", i + 1, s1->name); 1525 else 1526 snprintf (errmsg, err_len, "Shape mismatch in codimension %i " 1527 "of argument '%s'", i - s1->as->rank + 1, s1->name); 1528 return false; 1529 1530 case -2: 1531 /* FIXME: Implement a warning for this case. 1532 gfc_warning (0, "Possible shape mismatch in argument %qs", 1533 s1->name);*/ 1534 break; 1535 1536 case 0: 1537 break; 1538 1539 default: 1540 gfc_internal_error ("check_dummy_characteristics: Unexpected " 1541 "result %i of gfc_dep_compare_expr", 1542 compval); 1543 break; 1544 } 1545 } 1546 } 1547 1548 return true; 1549} 1550 1551 1552/* Check if the characteristics of two function results match, 1553 cf. F08:12.3.3. */ 1554 1555bool 1556gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, 1557 char *errmsg, int err_len) 1558{ 1559 gfc_symbol *r1, *r2; 1560 1561 if (s1->ts.interface && s1->ts.interface->result) 1562 r1 = s1->ts.interface->result; 1563 else 1564 r1 = s1->result ? s1->result : s1; 1565 1566 if (s2->ts.interface && s2->ts.interface->result) 1567 r2 = s2->ts.interface->result; 1568 else 1569 r2 = s2->result ? s2->result : s2; 1570 1571 if (r1->ts.type == BT_UNKNOWN) 1572 return true; 1573 1574 /* Check type and rank. */ 1575 if (!compare_type_characteristics (r1, r2)) 1576 { 1577 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)", 1578 gfc_typename (&r1->ts), gfc_typename (&r2->ts)); 1579 return false; 1580 } 1581 if (!compare_rank (r1, r2)) 1582 { 1583 snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)", 1584 symbol_rank (r1), symbol_rank (r2)); 1585 return false; 1586 } 1587 1588 /* Check ALLOCATABLE attribute. */ 1589 if (r1->attr.allocatable != r2->attr.allocatable) 1590 { 1591 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " 1592 "function result"); 1593 return false; 1594 } 1595 1596 /* Check POINTER attribute. */ 1597 if (r1->attr.pointer != r2->attr.pointer) 1598 { 1599 snprintf (errmsg, err_len, "POINTER attribute mismatch in " 1600 "function result"); 1601 return false; 1602 } 1603 1604 /* Check CONTIGUOUS attribute. */ 1605 if (r1->attr.contiguous != r2->attr.contiguous) 1606 { 1607 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " 1608 "function result"); 1609 return false; 1610 } 1611 1612 /* Check PROCEDURE POINTER attribute. */ 1613 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) 1614 { 1615 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " 1616 "function result"); 1617 return false; 1618 } 1619 1620 /* Check string length. */ 1621 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) 1622 { 1623 if (r1->ts.deferred != r2->ts.deferred) 1624 { 1625 snprintf (errmsg, err_len, "Character length mismatch " 1626 "in function result"); 1627 return false; 1628 } 1629 1630 if (r1->ts.u.cl->length && r2->ts.u.cl->length) 1631 { 1632 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, 1633 r2->ts.u.cl->length); 1634 switch (compval) 1635 { 1636 case -1: 1637 case 1: 1638 case -3: 1639 snprintf (errmsg, err_len, "Character length mismatch " 1640 "in function result"); 1641 return false; 1642 1643 case -2: 1644 /* FIXME: Implement a warning for this case. 1645 snprintf (errmsg, err_len, "Possible character length mismatch " 1646 "in function result");*/ 1647 break; 1648 1649 case 0: 1650 break; 1651 1652 default: 1653 gfc_internal_error ("check_result_characteristics (1): Unexpected " 1654 "result %i of gfc_dep_compare_expr", compval); 1655 break; 1656 } 1657 } 1658 } 1659 1660 /* Check array shape. */ 1661 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) 1662 { 1663 int i, compval; 1664 gfc_expr *shape1, *shape2; 1665 1666 if (r1->as->type != r2->as->type) 1667 { 1668 snprintf (errmsg, err_len, "Shape mismatch in function result"); 1669 return false; 1670 } 1671 1672 if (r1->as->type == AS_EXPLICIT) 1673 for (i = 0; i < r1->as->rank + r1->as->corank; i++) 1674 { 1675 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), 1676 gfc_copy_expr (r1->as->lower[i])); 1677 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), 1678 gfc_copy_expr (r2->as->lower[i])); 1679 compval = gfc_dep_compare_expr (shape1, shape2); 1680 gfc_free_expr (shape1); 1681 gfc_free_expr (shape2); 1682 switch (compval) 1683 { 1684 case -1: 1685 case 1: 1686 case -3: 1687 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " 1688 "function result", i + 1); 1689 return false; 1690 1691 case -2: 1692 /* FIXME: Implement a warning for this case. 1693 gfc_warning (0, "Possible shape mismatch in return value");*/ 1694 break; 1695 1696 case 0: 1697 break; 1698 1699 default: 1700 gfc_internal_error ("check_result_characteristics (2): " 1701 "Unexpected result %i of " 1702 "gfc_dep_compare_expr", compval); 1703 break; 1704 } 1705 } 1706 } 1707 1708 return true; 1709} 1710 1711 1712/* 'Compare' two formal interfaces associated with a pair of symbols. 1713 We return true if there exists an actual argument list that 1714 would be ambiguous between the two interfaces, zero otherwise. 1715 'strict_flag' specifies whether all the characteristics are 1716 required to match, which is not the case for ambiguity checks. 1717 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ 1718 1719bool 1720gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, 1721 int generic_flag, int strict_flag, 1722 char *errmsg, int err_len, 1723 const char *p1, const char *p2, 1724 bool *bad_result_characteristics) 1725{ 1726 gfc_formal_arglist *f1, *f2; 1727 1728 gcc_assert (name2 != NULL); 1729 1730 if (bad_result_characteristics) 1731 *bad_result_characteristics = false; 1732 1733 if (s1->attr.function && (s2->attr.subroutine 1734 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN 1735 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN))) 1736 { 1737 if (errmsg != NULL) 1738 snprintf (errmsg, err_len, "'%s' is not a function", name2); 1739 return false; 1740 } 1741 1742 if (s1->attr.subroutine && s2->attr.function) 1743 { 1744 if (errmsg != NULL) 1745 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); 1746 return false; 1747 } 1748 1749 /* Do strict checks on all characteristics 1750 (for dummy procedures and procedure pointer assignments). */ 1751 if (!generic_flag && strict_flag) 1752 { 1753 if (s1->attr.function && s2->attr.function) 1754 { 1755 /* If both are functions, check result characteristics. */ 1756 if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len) 1757 || !gfc_check_result_characteristics (s2, s1, errmsg, err_len)) 1758 { 1759 if (bad_result_characteristics) 1760 *bad_result_characteristics = true; 1761 return false; 1762 } 1763 } 1764 1765 if (s1->attr.pure && !s2->attr.pure) 1766 { 1767 snprintf (errmsg, err_len, "Mismatch in PURE attribute"); 1768 return false; 1769 } 1770 if (s1->attr.elemental && !s2->attr.elemental) 1771 { 1772 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute"); 1773 return false; 1774 } 1775 } 1776 1777 if (s1->attr.if_source == IFSRC_UNKNOWN 1778 || s2->attr.if_source == IFSRC_UNKNOWN) 1779 return true; 1780 1781 f1 = gfc_sym_get_dummy_args (s1); 1782 f2 = gfc_sym_get_dummy_args (s2); 1783 1784 /* Special case: No arguments. */ 1785 if (f1 == NULL && f2 == NULL) 1786 return true; 1787 1788 if (generic_flag) 1789 { 1790 if (count_types_test (f1, f2, p1, p2) 1791 || count_types_test (f2, f1, p2, p1)) 1792 return false; 1793 1794 /* Special case: alternate returns. If both f1->sym and f2->sym are 1795 NULL, then the leading formal arguments are alternate returns. 1796 The previous conditional should catch argument lists with 1797 different number of argument. */ 1798 if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) 1799 return true; 1800 1801 if (generic_correspondence (f1, f2, p1, p2) 1802 || generic_correspondence (f2, f1, p2, p1)) 1803 return false; 1804 } 1805 else 1806 /* Perform the abbreviated correspondence test for operators (the 1807 arguments cannot be optional and are always ordered correctly). 1808 This is also done when comparing interfaces for dummy procedures and in 1809 procedure pointer assignments. */ 1810 1811 for (; f1 || f2; f1 = f1->next, f2 = f2->next) 1812 { 1813 /* Check existence. */ 1814 if (f1 == NULL || f2 == NULL) 1815 { 1816 if (errmsg != NULL) 1817 snprintf (errmsg, err_len, "'%s' has the wrong number of " 1818 "arguments", name2); 1819 return false; 1820 } 1821 1822 if (strict_flag) 1823 { 1824 /* Check all characteristics. */ 1825 if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true, 1826 errmsg, err_len)) 1827 return false; 1828 } 1829 else 1830 { 1831 /* Operators: Only check type and rank of arguments. */ 1832 if (!compare_type (f2->sym, f1->sym)) 1833 { 1834 if (errmsg != NULL) 1835 snprintf (errmsg, err_len, "Type mismatch in argument '%s' " 1836 "(%s/%s)", f1->sym->name, 1837 gfc_typename (&f1->sym->ts), 1838 gfc_typename (&f2->sym->ts)); 1839 return false; 1840 } 1841 if (!compare_rank (f2->sym, f1->sym)) 1842 { 1843 if (errmsg != NULL) 1844 snprintf (errmsg, err_len, "Rank mismatch in argument " 1845 "'%s' (%i/%i)", f1->sym->name, 1846 symbol_rank (f1->sym), symbol_rank (f2->sym)); 1847 return false; 1848 } 1849 if ((gfc_option.allow_std & GFC_STD_F2008) 1850 && (compare_ptr_alloc(f1->sym, f2->sym) 1851 || compare_ptr_alloc(f2->sym, f1->sym))) 1852 { 1853 if (errmsg != NULL) 1854 snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE " 1855 "attribute in argument '%s' ", f1->sym->name); 1856 return false; 1857 } 1858 } 1859 } 1860 1861 return true; 1862} 1863 1864 1865/* Given a pointer to an interface pointer, remove duplicate 1866 interfaces and make sure that all symbols are either functions 1867 or subroutines, and all of the same kind. Returns true if 1868 something goes wrong. */ 1869 1870static bool 1871check_interface0 (gfc_interface *p, const char *interface_name) 1872{ 1873 gfc_interface *psave, *q, *qlast; 1874 1875 psave = p; 1876 for (; p; p = p->next) 1877 { 1878 /* Make sure all symbols in the interface have been defined as 1879 functions or subroutines. */ 1880 if (((!p->sym->attr.function && !p->sym->attr.subroutine) 1881 || !p->sym->attr.if_source) 1882 && !gfc_fl_struct (p->sym->attr.flavor)) 1883 { 1884 const char *guessed 1885 = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root); 1886 1887 if (p->sym->attr.external) 1888 if (guessed) 1889 gfc_error ("Procedure %qs in %s at %L has no explicit interface" 1890 "; did you mean %qs?", 1891 p->sym->name, interface_name, &p->sym->declared_at, 1892 guessed); 1893 else 1894 gfc_error ("Procedure %qs in %s at %L has no explicit interface", 1895 p->sym->name, interface_name, &p->sym->declared_at); 1896 else 1897 if (guessed) 1898 gfc_error ("Procedure %qs in %s at %L is neither function nor " 1899 "subroutine; did you mean %qs?", p->sym->name, 1900 interface_name, &p->sym->declared_at, guessed); 1901 else 1902 gfc_error ("Procedure %qs in %s at %L is neither function nor " 1903 "subroutine", p->sym->name, interface_name, 1904 &p->sym->declared_at); 1905 return true; 1906 } 1907 1908 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ 1909 if ((psave->sym->attr.function && !p->sym->attr.function 1910 && !gfc_fl_struct (p->sym->attr.flavor)) 1911 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) 1912 { 1913 if (!gfc_fl_struct (p->sym->attr.flavor)) 1914 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" 1915 " or all FUNCTIONs", interface_name, 1916 &p->sym->declared_at); 1917 else if (p->sym->attr.flavor == FL_DERIVED) 1918 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " 1919 "generic name is also the name of a derived type", 1920 interface_name, &p->sym->declared_at); 1921 return true; 1922 } 1923 1924 /* F2003, C1207. F2008, C1207. */ 1925 if (p->sym->attr.proc == PROC_INTERNAL 1926 && !gfc_notify_std (GFC_STD_F2008, "Internal procedure " 1927 "%qs in %s at %L", p->sym->name, 1928 interface_name, &p->sym->declared_at)) 1929 return true; 1930 } 1931 p = psave; 1932 1933 /* Remove duplicate interfaces in this interface list. */ 1934 for (; p; p = p->next) 1935 { 1936 qlast = p; 1937 1938 for (q = p->next; q;) 1939 { 1940 if (p->sym != q->sym) 1941 { 1942 qlast = q; 1943 q = q->next; 1944 } 1945 else 1946 { 1947 /* Duplicate interface. */ 1948 qlast->next = q->next; 1949 free (q); 1950 q = qlast->next; 1951 } 1952 } 1953 } 1954 1955 return false; 1956} 1957 1958 1959/* Check lists of interfaces to make sure that no two interfaces are 1960 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */ 1961 1962static bool 1963check_interface1 (gfc_interface *p, gfc_interface *q0, 1964 int generic_flag, const char *interface_name, 1965 bool referenced) 1966{ 1967 gfc_interface *q; 1968 for (; p; p = p->next) 1969 for (q = q0; q; q = q->next) 1970 { 1971 if (p->sym == q->sym) 1972 continue; /* Duplicates OK here. */ 1973 1974 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) 1975 continue; 1976 1977 if (!gfc_fl_struct (p->sym->attr.flavor) 1978 && !gfc_fl_struct (q->sym->attr.flavor) 1979 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, 1980 generic_flag, 0, NULL, 0, NULL, NULL)) 1981 { 1982 if (referenced) 1983 gfc_error ("Ambiguous interfaces in %s for %qs at %L " 1984 "and %qs at %L", interface_name, 1985 q->sym->name, &q->sym->declared_at, 1986 p->sym->name, &p->sym->declared_at); 1987 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) 1988 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L " 1989 "and %qs at %L", interface_name, 1990 q->sym->name, &q->sym->declared_at, 1991 p->sym->name, &p->sym->declared_at); 1992 else 1993 gfc_warning (0, "Although not referenced, %qs has ambiguous " 1994 "interfaces at %L", interface_name, &p->where); 1995 return true; 1996 } 1997 } 1998 return false; 1999} 2000 2001 2002/* Check the generic and operator interfaces of symbols to make sure 2003 that none of the interfaces conflict. The check has to be done 2004 after all of the symbols are actually loaded. */ 2005 2006static void 2007check_sym_interfaces (gfc_symbol *sym) 2008{ 2009 /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */ 2010 char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")]; 2011 gfc_interface *p; 2012 2013 if (sym->ns != gfc_current_ns) 2014 return; 2015 2016 if (sym->generic != NULL) 2017 { 2018 size_t len = strlen (sym->name) + sizeof("generic interface ''"); 2019 gcc_assert (len < sizeof (interface_name)); 2020 sprintf (interface_name, "generic interface '%s'", sym->name); 2021 if (check_interface0 (sym->generic, interface_name)) 2022 return; 2023 2024 for (p = sym->generic; p; p = p->next) 2025 { 2026 if (p->sym->attr.mod_proc 2027 && !p->sym->attr.module_procedure 2028 && (p->sym->attr.if_source != IFSRC_DECL 2029 || p->sym->attr.procedure)) 2030 { 2031 gfc_error ("%qs at %L is not a module procedure", 2032 p->sym->name, &p->where); 2033 return; 2034 } 2035 } 2036 2037 /* Originally, this test was applied to host interfaces too; 2038 this is incorrect since host associated symbols, from any 2039 source, cannot be ambiguous with local symbols. */ 2040 check_interface1 (sym->generic, sym->generic, 1, interface_name, 2041 sym->attr.referenced || !sym->attr.use_assoc); 2042 } 2043} 2044 2045 2046static void 2047check_uop_interfaces (gfc_user_op *uop) 2048{ 2049 char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")]; 2050 gfc_user_op *uop2; 2051 gfc_namespace *ns; 2052 2053 sprintf (interface_name, "operator interface '%s'", uop->name); 2054 if (check_interface0 (uop->op, interface_name)) 2055 return; 2056 2057 for (ns = gfc_current_ns; ns; ns = ns->parent) 2058 { 2059 uop2 = gfc_find_uop (uop->name, ns); 2060 if (uop2 == NULL) 2061 continue; 2062 2063 check_interface1 (uop->op, uop2->op, 0, 2064 interface_name, true); 2065 } 2066} 2067 2068/* Given an intrinsic op, return an equivalent op if one exists, 2069 or INTRINSIC_NONE otherwise. */ 2070 2071gfc_intrinsic_op 2072gfc_equivalent_op (gfc_intrinsic_op op) 2073{ 2074 switch(op) 2075 { 2076 case INTRINSIC_EQ: 2077 return INTRINSIC_EQ_OS; 2078 2079 case INTRINSIC_EQ_OS: 2080 return INTRINSIC_EQ; 2081 2082 case INTRINSIC_NE: 2083 return INTRINSIC_NE_OS; 2084 2085 case INTRINSIC_NE_OS: 2086 return INTRINSIC_NE; 2087 2088 case INTRINSIC_GT: 2089 return INTRINSIC_GT_OS; 2090 2091 case INTRINSIC_GT_OS: 2092 return INTRINSIC_GT; 2093 2094 case INTRINSIC_GE: 2095 return INTRINSIC_GE_OS; 2096 2097 case INTRINSIC_GE_OS: 2098 return INTRINSIC_GE; 2099 2100 case INTRINSIC_LT: 2101 return INTRINSIC_LT_OS; 2102 2103 case INTRINSIC_LT_OS: 2104 return INTRINSIC_LT; 2105 2106 case INTRINSIC_LE: 2107 return INTRINSIC_LE_OS; 2108 2109 case INTRINSIC_LE_OS: 2110 return INTRINSIC_LE; 2111 2112 default: 2113 return INTRINSIC_NONE; 2114 } 2115} 2116 2117/* For the namespace, check generic, user operator and intrinsic 2118 operator interfaces for consistency and to remove duplicate 2119 interfaces. We traverse the whole namespace, counting on the fact 2120 that most symbols will not have generic or operator interfaces. */ 2121 2122void 2123gfc_check_interfaces (gfc_namespace *ns) 2124{ 2125 gfc_namespace *old_ns, *ns2; 2126 char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")]; 2127 int i; 2128 2129 old_ns = gfc_current_ns; 2130 gfc_current_ns = ns; 2131 2132 gfc_traverse_ns (ns, check_sym_interfaces); 2133 2134 gfc_traverse_user_op (ns, check_uop_interfaces); 2135 2136 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) 2137 { 2138 if (i == INTRINSIC_USER) 2139 continue; 2140 2141 if (i == INTRINSIC_ASSIGN) 2142 strcpy (interface_name, "intrinsic assignment operator"); 2143 else 2144 sprintf (interface_name, "intrinsic '%s' operator", 2145 gfc_op2string ((gfc_intrinsic_op) i)); 2146 2147 if (check_interface0 (ns->op[i], interface_name)) 2148 continue; 2149 2150 if (ns->op[i]) 2151 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i, 2152 ns->op[i]->where); 2153 2154 for (ns2 = ns; ns2; ns2 = ns2->parent) 2155 { 2156 gfc_intrinsic_op other_op; 2157 2158 if (check_interface1 (ns->op[i], ns2->op[i], 0, 2159 interface_name, true)) 2160 goto done; 2161 2162 /* i should be gfc_intrinsic_op, but has to be int with this cast 2163 here for stupid C++ compatibility rules. */ 2164 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i); 2165 if (other_op != INTRINSIC_NONE 2166 && check_interface1 (ns->op[i], ns2->op[other_op], 2167 0, interface_name, true)) 2168 goto done; 2169 } 2170 } 2171 2172done: 2173 gfc_current_ns = old_ns; 2174} 2175 2176 2177/* Given a symbol of a formal argument list and an expression, if the 2178 formal argument is allocatable, check that the actual argument is 2179 allocatable. Returns true if compatible, zero if not compatible. */ 2180 2181static bool 2182compare_allocatable (gfc_symbol *formal, gfc_expr *actual) 2183{ 2184 if (formal->attr.allocatable 2185 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) 2186 { 2187 symbol_attribute attr = gfc_expr_attr (actual); 2188 if (actual->ts.type == BT_CLASS && !attr.class_ok) 2189 return true; 2190 else if (!attr.allocatable) 2191 return false; 2192 } 2193 2194 return true; 2195} 2196 2197 2198/* Given a symbol of a formal argument list and an expression, if the 2199 formal argument is a pointer, see if the actual argument is a 2200 pointer. Returns nonzero if compatible, zero if not compatible. */ 2201 2202static int 2203compare_pointer (gfc_symbol *formal, gfc_expr *actual) 2204{ 2205 symbol_attribute attr; 2206 2207 if (formal->attr.pointer 2208 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal) 2209 && CLASS_DATA (formal)->attr.class_pointer)) 2210 { 2211 attr = gfc_expr_attr (actual); 2212 2213 /* Fortran 2008 allows non-pointer actual arguments. */ 2214 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN) 2215 return 2; 2216 2217 if (!attr.pointer) 2218 return 0; 2219 } 2220 2221 return 1; 2222} 2223 2224 2225/* Emit clear error messages for rank mismatch. */ 2226 2227static void 2228argument_rank_mismatch (const char *name, locus *where, 2229 int rank1, int rank2, locus *where_formal) 2230{ 2231 2232 /* TS 29113, C407b. */ 2233 if (where_formal == NULL) 2234 { 2235 if (rank2 == -1) 2236 gfc_error ("The assumed-rank array at %L requires that the dummy " 2237 "argument %qs has assumed-rank", where, name); 2238 else if (rank1 == 0) 2239 gfc_error_opt (0, "Rank mismatch in argument %qs " 2240 "at %L (scalar and rank-%d)", name, where, rank2); 2241 else if (rank2 == 0) 2242 gfc_error_opt (0, "Rank mismatch in argument %qs " 2243 "at %L (rank-%d and scalar)", name, where, rank1); 2244 else 2245 gfc_error_opt (0, "Rank mismatch in argument %qs " 2246 "at %L (rank-%d and rank-%d)", name, where, rank1, 2247 rank2); 2248 } 2249 else 2250 { 2251 if (rank2 == -1) 2252 /* This is an assumed rank-actual passed to a function without 2253 an explicit interface, which is already diagnosed in 2254 gfc_procedure_use. */ 2255 return; 2256 if (rank1 == 0) 2257 gfc_error_opt (0, "Rank mismatch between actual argument at %L " 2258 "and actual argument at %L (scalar and rank-%d)", 2259 where, where_formal, rank2); 2260 else if (rank2 == 0) 2261 gfc_error_opt (0, "Rank mismatch between actual argument at %L " 2262 "and actual argument at %L (rank-%d and scalar)", 2263 where, where_formal, rank1); 2264 else 2265 gfc_error_opt (0, "Rank mismatch between actual argument at %L " 2266 "and actual argument at %L (rank-%d and rank-%d)", where, 2267 where_formal, rank1, rank2); 2268 } 2269} 2270 2271 2272/* Under certain conditions, a scalar actual argument can be passed 2273 to an array dummy argument - see F2018, 15.5.2.4, paragraph 14. 2274 This function returns true for these conditions so that an error 2275 or warning for this can be suppressed later. Always return false 2276 for expressions with rank > 0. */ 2277 2278bool 2279maybe_dummy_array_arg (gfc_expr *e) 2280{ 2281 gfc_symbol *s; 2282 gfc_ref *ref; 2283 bool array_pointer = false; 2284 bool assumed_shape = false; 2285 bool scalar_ref = true; 2286 2287 if (e->rank > 0) 2288 return false; 2289 2290 if (e->ts.type == BT_CHARACTER && e->ts.kind == 1) 2291 return true; 2292 2293 /* If this comes from a constructor, it has been an array element 2294 originally. */ 2295 2296 if (e->expr_type == EXPR_CONSTANT) 2297 return e->from_constructor; 2298 2299 if (e->expr_type != EXPR_VARIABLE) 2300 return false; 2301 2302 s = e->symtree->n.sym; 2303 2304 if (s->attr.dimension) 2305 { 2306 scalar_ref = false; 2307 array_pointer = s->attr.pointer; 2308 } 2309 2310 if (s->as && s->as->type == AS_ASSUMED_SHAPE) 2311 assumed_shape = true; 2312 2313 for (ref=e->ref; ref; ref=ref->next) 2314 { 2315 if (ref->type == REF_COMPONENT) 2316 { 2317 symbol_attribute *attr; 2318 attr = &ref->u.c.component->attr; 2319 if (attr->dimension) 2320 { 2321 array_pointer = attr->pointer; 2322 assumed_shape = false; 2323 scalar_ref = false; 2324 } 2325 else 2326 scalar_ref = true; 2327 } 2328 } 2329 2330 return !(scalar_ref || array_pointer || assumed_shape); 2331} 2332 2333/* Given a symbol of a formal argument list and an expression, see if 2334 the two are compatible as arguments. Returns true if 2335 compatible, false if not compatible. */ 2336 2337static bool 2338compare_parameter (gfc_symbol *formal, gfc_expr *actual, 2339 int ranks_must_agree, int is_elemental, locus *where) 2340{ 2341 gfc_ref *ref; 2342 bool rank_check, is_pointer; 2343 char err[200]; 2344 gfc_component *ppc; 2345 bool codimension = false; 2346 2347 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding 2348 procs c_f_pointer or c_f_procpointer, and we need to accept most 2349 pointers the user could give us. This should allow that. */ 2350 if (formal->ts.type == BT_VOID) 2351 return true; 2352 2353 if (formal->ts.type == BT_DERIVED 2354 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c 2355 && actual->ts.type == BT_DERIVED 2356 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) 2357 { 2358 if (formal->ts.u.derived->intmod_sym_id 2359 != actual->ts.u.derived->intmod_sym_id) 2360 return false; 2361 2362 if (ranks_must_agree 2363 && symbol_rank (formal) != actual->rank 2364 && symbol_rank (formal) != -1) 2365 { 2366 if (where) 2367 argument_rank_mismatch (formal->name, &actual->where, 2368 symbol_rank (formal), actual->rank, 2369 NULL); 2370 return false; 2371 } 2372 return true; 2373 } 2374 2375 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) 2376 /* Make sure the vtab symbol is present when 2377 the module variables are generated. */ 2378 gfc_find_derived_vtab (actual->ts.u.derived); 2379 2380 if (actual->ts.type == BT_PROCEDURE) 2381 { 2382 gfc_symbol *act_sym = actual->symtree->n.sym; 2383 2384 if (formal->attr.flavor != FL_PROCEDURE) 2385 { 2386 if (where) 2387 gfc_error ("Invalid procedure argument at %L", &actual->where); 2388 return false; 2389 } 2390 2391 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, 2392 sizeof(err), NULL, NULL)) 2393 { 2394 if (where) 2395 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" 2396 " %s", formal->name, &actual->where, err); 2397 return false; 2398 } 2399 2400 if (formal->attr.function && !act_sym->attr.function) 2401 { 2402 gfc_add_function (&act_sym->attr, act_sym->name, 2403 &act_sym->declared_at); 2404 if (act_sym->ts.type == BT_UNKNOWN 2405 && !gfc_set_default_type (act_sym, 1, act_sym->ns)) 2406 return false; 2407 } 2408 else if (formal->attr.subroutine && !act_sym->attr.subroutine) 2409 gfc_add_subroutine (&act_sym->attr, act_sym->name, 2410 &act_sym->declared_at); 2411 2412 return true; 2413 } 2414 2415 ppc = gfc_get_proc_ptr_comp (actual); 2416 if (ppc && ppc->ts.interface) 2417 { 2418 if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1, 2419 err, sizeof(err), NULL, NULL)) 2420 { 2421 if (where) 2422 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" 2423 " %s", formal->name, &actual->where, err); 2424 return false; 2425 } 2426 } 2427 2428 /* F2008, C1241. */ 2429 if (formal->attr.pointer && formal->attr.contiguous 2430 && !gfc_is_simply_contiguous (actual, true, false)) 2431 { 2432 if (where) 2433 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " 2434 "must be simply contiguous", formal->name, &actual->where); 2435 return false; 2436 } 2437 2438 symbol_attribute actual_attr = gfc_expr_attr (actual); 2439 if (actual->ts.type == BT_CLASS && !actual_attr.class_ok) 2440 return true; 2441 2442 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) 2443 && actual->ts.type != BT_HOLLERITH 2444 && formal->ts.type != BT_ASSUMED 2445 && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 2446 && !gfc_compare_types (&formal->ts, &actual->ts) 2447 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS 2448 && gfc_compare_derived_types (formal->ts.u.derived, 2449 CLASS_DATA (actual)->ts.u.derived))) 2450 { 2451 if (where) 2452 { 2453 if (formal->attr.artificial) 2454 { 2455 if (!flag_allow_argument_mismatch || !formal->error) 2456 gfc_error_opt (0, "Type mismatch between actual argument at %L " 2457 "and actual argument at %L (%s/%s).", 2458 &actual->where, 2459 &formal->declared_at, 2460 gfc_typename (actual), 2461 gfc_dummy_typename (&formal->ts)); 2462 2463 formal->error = 1; 2464 } 2465 else 2466 gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s " 2467 "to %s", formal->name, where, gfc_typename (actual), 2468 gfc_dummy_typename (&formal->ts)); 2469 } 2470 return false; 2471 } 2472 2473 if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) 2474 { 2475 if (where) 2476 gfc_error ("Assumed-type actual argument at %L requires that dummy " 2477 "argument %qs is of assumed type", &actual->where, 2478 formal->name); 2479 return false; 2480 } 2481 2482 /* TS29113 C407c; F2018 C711. */ 2483 if (actual->ts.type == BT_ASSUMED 2484 && symbol_rank (formal) == -1 2485 && actual->rank != -1 2486 && !(actual->symtree->n.sym->as 2487 && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)) 2488 { 2489 if (where) 2490 gfc_error ("Assumed-type actual argument at %L corresponding to " 2491 "assumed-rank dummy argument %qs must be " 2492 "assumed-shape or assumed-rank", 2493 &actual->where, formal->name); 2494 return false; 2495 } 2496 2497 /* F2008, 12.5.2.5; IR F08/0073. */ 2498 if (formal->ts.type == BT_CLASS && formal->attr.class_ok 2499 && actual->expr_type != EXPR_NULL 2500 && ((CLASS_DATA (formal)->attr.class_pointer 2501 && formal->attr.intent != INTENT_IN) 2502 || CLASS_DATA (formal)->attr.allocatable)) 2503 { 2504 if (actual->ts.type != BT_CLASS) 2505 { 2506 if (where) 2507 gfc_error ("Actual argument to %qs at %L must be polymorphic", 2508 formal->name, &actual->where); 2509 return false; 2510 } 2511 2512 if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) 2513 && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, 2514 CLASS_DATA (formal)->ts.u.derived)) 2515 { 2516 if (where) 2517 gfc_error ("Actual argument to %qs at %L must have the same " 2518 "declared type", formal->name, &actual->where); 2519 return false; 2520 } 2521 } 2522 2523 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this 2524 is necessary also for F03, so retain error for both. 2525 NOTE: Other type/kind errors pre-empt this error. Since they are F03 2526 compatible, no attempt has been made to channel to this one. */ 2527 if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) 2528 && (CLASS_DATA (formal)->attr.allocatable 2529 ||CLASS_DATA (formal)->attr.class_pointer)) 2530 { 2531 if (where) 2532 gfc_error ("Actual argument to %qs at %L must be unlimited " 2533 "polymorphic since the formal argument is a " 2534 "pointer or allocatable unlimited polymorphic " 2535 "entity [F2008: 12.5.2.5]", formal->name, 2536 &actual->where); 2537 return false; 2538 } 2539 2540 if (formal->ts.type == BT_CLASS && formal->attr.class_ok) 2541 codimension = CLASS_DATA (formal)->attr.codimension; 2542 else 2543 codimension = formal->attr.codimension; 2544 2545 if (codimension && !gfc_is_coarray (actual)) 2546 { 2547 if (where) 2548 gfc_error ("Actual argument to %qs at %L must be a coarray", 2549 formal->name, &actual->where); 2550 return false; 2551 } 2552 2553 if (codimension && formal->attr.allocatable) 2554 { 2555 gfc_ref *last = NULL; 2556 2557 for (ref = actual->ref; ref; ref = ref->next) 2558 if (ref->type == REF_COMPONENT) 2559 last = ref; 2560 2561 /* F2008, 12.5.2.6. */ 2562 if ((last && last->u.c.component->as->corank != formal->as->corank) 2563 || (!last 2564 && actual->symtree->n.sym->as->corank != formal->as->corank)) 2565 { 2566 if (where) 2567 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", 2568 formal->name, &actual->where, formal->as->corank, 2569 last ? last->u.c.component->as->corank 2570 : actual->symtree->n.sym->as->corank); 2571 return false; 2572 } 2573 } 2574 2575 if (codimension) 2576 { 2577 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */ 2578 /* F2018, 12.5.2.8. */ 2579 if (formal->attr.dimension 2580 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) 2581 && actual_attr.dimension 2582 && !gfc_is_simply_contiguous (actual, true, true)) 2583 { 2584 if (where) 2585 gfc_error ("Actual argument to %qs at %L must be simply " 2586 "contiguous or an element of such an array", 2587 formal->name, &actual->where); 2588 return false; 2589 } 2590 2591 /* F2008, C1303 and C1304. */ 2592 if (formal->attr.intent != INTENT_INOUT 2593 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) 2594 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2595 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 2596 || formal->attr.lock_comp)) 2597 2598 { 2599 if (where) 2600 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " 2601 "which is LOCK_TYPE or has a LOCK_TYPE component", 2602 formal->name, &actual->where); 2603 return false; 2604 } 2605 2606 /* TS18508, C702/C703. */ 2607 if (formal->attr.intent != INTENT_INOUT 2608 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) 2609 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2610 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 2611 || formal->attr.event_comp)) 2612 2613 { 2614 if (where) 2615 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " 2616 "which is EVENT_TYPE or has a EVENT_TYPE component", 2617 formal->name, &actual->where); 2618 return false; 2619 } 2620 } 2621 2622 /* F2008, C1239/C1240. */ 2623 if (actual->expr_type == EXPR_VARIABLE 2624 && (actual->symtree->n.sym->attr.asynchronous 2625 || actual->symtree->n.sym->attr.volatile_) 2626 && (formal->attr.asynchronous || formal->attr.volatile_) 2627 && actual->rank && formal->as 2628 && !gfc_is_simply_contiguous (actual, true, false) 2629 && ((formal->as->type != AS_ASSUMED_SHAPE 2630 && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) 2631 || formal->attr.contiguous)) 2632 { 2633 if (where) 2634 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " 2635 "assumed-rank array without CONTIGUOUS attribute - as actual" 2636 " argument at %L is not simply contiguous and both are " 2637 "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); 2638 return false; 2639 } 2640 2641 if (formal->attr.allocatable && !codimension 2642 && actual_attr.codimension) 2643 { 2644 if (formal->attr.intent == INTENT_OUT) 2645 { 2646 if (where) 2647 gfc_error ("Passing coarray at %L to allocatable, noncoarray, " 2648 "INTENT(OUT) dummy argument %qs", &actual->where, 2649 formal->name); 2650 return false; 2651 } 2652 else if (warn_surprising && where && formal->attr.intent != INTENT_IN) 2653 gfc_warning (OPT_Wsurprising, 2654 "Passing coarray at %L to allocatable, noncoarray dummy " 2655 "argument %qs, which is invalid if the allocation status" 2656 " is modified", &actual->where, formal->name); 2657 } 2658 2659 /* If the rank is the same or the formal argument has assumed-rank. */ 2660 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) 2661 return true; 2662 2663 rank_check = where != NULL && !is_elemental && formal->as 2664 && (formal->as->type == AS_ASSUMED_SHAPE 2665 || formal->as->type == AS_DEFERRED) 2666 && actual->expr_type != EXPR_NULL; 2667 2668 /* Skip rank checks for NO_ARG_CHECK. */ 2669 if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 2670 return true; 2671 2672 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ 2673 if (rank_check || ranks_must_agree 2674 || (formal->attr.pointer && actual->expr_type != EXPR_NULL) 2675 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) 2676 || (actual->rank == 0 2677 && ((formal->ts.type == BT_CLASS 2678 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE) 2679 || (formal->ts.type != BT_CLASS 2680 && formal->as->type == AS_ASSUMED_SHAPE)) 2681 && actual->expr_type != EXPR_NULL) 2682 || (actual->rank == 0 && formal->attr.dimension 2683 && gfc_is_coindexed (actual)) 2684 /* Assumed-rank actual argument; F2018 C838. */ 2685 || actual->rank == -1) 2686 { 2687 if (where 2688 && (!formal->attr.artificial || (!formal->maybe_array 2689 && !maybe_dummy_array_arg (actual)))) 2690 { 2691 locus *where_formal; 2692 if (formal->attr.artificial) 2693 where_formal = &formal->declared_at; 2694 else 2695 where_formal = NULL; 2696 2697 argument_rank_mismatch (formal->name, &actual->where, 2698 symbol_rank (formal), actual->rank, 2699 where_formal); 2700 } 2701 return false; 2702 } 2703 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) 2704 return true; 2705 2706 /* At this point, we are considering a scalar passed to an array. This 2707 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), 2708 - if the actual argument is (a substring of) an element of a 2709 non-assumed-shape/non-pointer/non-polymorphic array; or 2710 - (F2003) if the actual argument is of type character of default/c_char 2711 kind. */ 2712 2713 is_pointer = actual->expr_type == EXPR_VARIABLE 2714 ? actual->symtree->n.sym->attr.pointer : false; 2715 2716 for (ref = actual->ref; ref; ref = ref->next) 2717 { 2718 if (ref->type == REF_COMPONENT) 2719 is_pointer = ref->u.c.component->attr.pointer; 2720 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT 2721 && ref->u.ar.dimen > 0 2722 && (!ref->next 2723 || (ref->next->type == REF_SUBSTRING && !ref->next->next))) 2724 break; 2725 } 2726 2727 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) 2728 { 2729 if (where) 2730 gfc_error ("Polymorphic scalar passed to array dummy argument %qs " 2731 "at %L", formal->name, &actual->where); 2732 return false; 2733 } 2734 2735 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER 2736 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) 2737 { 2738 if (where) 2739 { 2740 if (formal->attr.artificial) 2741 gfc_error ("Element of assumed-shape or pointer array " 2742 "as actual argument at %L cannot correspond to " 2743 "actual argument at %L", 2744 &actual->where, &formal->declared_at); 2745 else 2746 gfc_error ("Element of assumed-shape or pointer " 2747 "array passed to array dummy argument %qs at %L", 2748 formal->name, &actual->where); 2749 } 2750 return false; 2751 } 2752 2753 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL 2754 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) 2755 { 2756 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) 2757 { 2758 if (where) 2759 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " 2760 "CHARACTER actual argument with array dummy argument " 2761 "%qs at %L", formal->name, &actual->where); 2762 return false; 2763 } 2764 2765 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) 2766 { 2767 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " 2768 "array dummy argument %qs at %L", 2769 formal->name, &actual->where); 2770 return false; 2771 } 2772 else 2773 return ((gfc_option.allow_std & GFC_STD_F2003) != 0); 2774 } 2775 2776 if (ref == NULL && actual->expr_type != EXPR_NULL) 2777 { 2778 if (where 2779 && (!formal->attr.artificial || (!formal->maybe_array 2780 && !maybe_dummy_array_arg (actual)))) 2781 { 2782 locus *where_formal; 2783 if (formal->attr.artificial) 2784 where_formal = &formal->declared_at; 2785 else 2786 where_formal = NULL; 2787 2788 argument_rank_mismatch (formal->name, &actual->where, 2789 symbol_rank (formal), actual->rank, 2790 where_formal); 2791 } 2792 return false; 2793 } 2794 2795 return true; 2796} 2797 2798 2799/* Returns the storage size of a symbol (formal argument) or 2800 zero if it cannot be determined. */ 2801 2802static unsigned long 2803get_sym_storage_size (gfc_symbol *sym) 2804{ 2805 int i; 2806 unsigned long strlen, elements; 2807 2808 if (sym->ts.type == BT_CHARACTER) 2809 { 2810 if (sym->ts.u.cl && sym->ts.u.cl->length 2811 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT 2812 && sym->ts.u.cl->length->ts.type == BT_INTEGER) 2813 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); 2814 else 2815 return 0; 2816 } 2817 else 2818 strlen = 1; 2819 2820 if (symbol_rank (sym) == 0) 2821 return strlen; 2822 2823 elements = 1; 2824 if (sym->as->type != AS_EXPLICIT) 2825 return 0; 2826 for (i = 0; i < sym->as->rank; i++) 2827 { 2828 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT 2829 || sym->as->lower[i]->expr_type != EXPR_CONSTANT 2830 || sym->as->upper[i]->ts.type != BT_INTEGER 2831 || sym->as->lower[i]->ts.type != BT_INTEGER) 2832 return 0; 2833 2834 elements *= mpz_get_si (sym->as->upper[i]->value.integer) 2835 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; 2836 } 2837 2838 return strlen*elements; 2839} 2840 2841 2842/* Returns the storage size of an expression (actual argument) or 2843 zero if it cannot be determined. For an array element, it returns 2844 the remaining size as the element sequence consists of all storage 2845 units of the actual argument up to the end of the array. */ 2846 2847static unsigned long 2848get_expr_storage_size (gfc_expr *e) 2849{ 2850 int i; 2851 long int strlen, elements; 2852 long int substrlen = 0; 2853 bool is_str_storage = false; 2854 gfc_ref *ref; 2855 2856 if (e == NULL) 2857 return 0; 2858 2859 if (e->ts.type == BT_CHARACTER) 2860 { 2861 if (e->ts.u.cl && e->ts.u.cl->length 2862 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT 2863 && e->ts.u.cl->length->ts.type == BT_INTEGER) 2864 strlen = mpz_get_si (e->ts.u.cl->length->value.integer); 2865 else if (e->expr_type == EXPR_CONSTANT 2866 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 2867 strlen = e->value.character.length; 2868 else 2869 return 0; 2870 } 2871 else 2872 strlen = 1; /* Length per element. */ 2873 2874 if (e->rank == 0 && !e->ref) 2875 return strlen; 2876 2877 elements = 1; 2878 if (!e->ref) 2879 { 2880 if (!e->shape) 2881 return 0; 2882 for (i = 0; i < e->rank; i++) 2883 elements *= mpz_get_si (e->shape[i]); 2884 return elements*strlen; 2885 } 2886 2887 for (ref = e->ref; ref; ref = ref->next) 2888 { 2889 if (ref->type == REF_SUBSTRING && ref->u.ss.start 2890 && ref->u.ss.start->expr_type == EXPR_CONSTANT) 2891 { 2892 if (is_str_storage) 2893 { 2894 /* The string length is the substring length. 2895 Set now to full string length. */ 2896 if (!ref->u.ss.length || !ref->u.ss.length->length 2897 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT) 2898 return 0; 2899 2900 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer); 2901 } 2902 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1; 2903 continue; 2904 } 2905 2906 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 2907 for (i = 0; i < ref->u.ar.dimen; i++) 2908 { 2909 long int start, end, stride; 2910 stride = 1; 2911 2912 if (ref->u.ar.stride[i]) 2913 { 2914 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT 2915 && ref->u.ar.stride[i]->ts.type == BT_INTEGER) 2916 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer); 2917 else 2918 return 0; 2919 } 2920 2921 if (ref->u.ar.start[i]) 2922 { 2923 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT 2924 && ref->u.ar.start[i]->ts.type == BT_INTEGER) 2925 start = mpz_get_si (ref->u.ar.start[i]->value.integer); 2926 else 2927 return 0; 2928 } 2929 else if (ref->u.ar.as->lower[i] 2930 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT 2931 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER) 2932 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer); 2933 else 2934 return 0; 2935 2936 if (ref->u.ar.end[i]) 2937 { 2938 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT 2939 && ref->u.ar.end[i]->ts.type == BT_INTEGER) 2940 end = mpz_get_si (ref->u.ar.end[i]->value.integer); 2941 else 2942 return 0; 2943 } 2944 else if (ref->u.ar.as->upper[i] 2945 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT 2946 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) 2947 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer); 2948 else 2949 return 0; 2950 2951 elements *= (end - start)/stride + 1L; 2952 } 2953 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL) 2954 for (i = 0; i < ref->u.ar.as->rank; i++) 2955 { 2956 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] 2957 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT 2958 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER 2959 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT 2960 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) 2961 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2962 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2963 + 1L; 2964 else 2965 return 0; 2966 } 2967 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT 2968 && e->expr_type == EXPR_VARIABLE) 2969 { 2970 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE 2971 || e->symtree->n.sym->attr.pointer) 2972 { 2973 elements = 1; 2974 continue; 2975 } 2976 2977 /* Determine the number of remaining elements in the element 2978 sequence for array element designators. */ 2979 is_str_storage = true; 2980 for (i = ref->u.ar.dimen - 1; i >= 0; i--) 2981 { 2982 if (ref->u.ar.start[i] == NULL 2983 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT 2984 || ref->u.ar.as->upper[i] == NULL 2985 || ref->u.ar.as->lower[i] == NULL 2986 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT 2987 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT 2988 || ref->u.ar.as->upper[i]->ts.type != BT_INTEGER 2989 || ref->u.ar.as->lower[i]->ts.type != BT_INTEGER) 2990 return 0; 2991 2992 elements 2993 = elements 2994 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2995 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2996 + 1L) 2997 - (mpz_get_si (ref->u.ar.start[i]->value.integer) 2998 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)); 2999 } 3000 } 3001 else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function 3002 && ref->u.c.component->attr.proc_pointer 3003 && ref->u.c.component->attr.dimension) 3004 { 3005 /* Array-valued procedure-pointer components. */ 3006 gfc_array_spec *as = ref->u.c.component->as; 3007 for (i = 0; i < as->rank; i++) 3008 { 3009 if (!as->upper[i] || !as->lower[i] 3010 || as->upper[i]->expr_type != EXPR_CONSTANT 3011 || as->lower[i]->expr_type != EXPR_CONSTANT 3012 || as->upper[i]->ts.type != BT_INTEGER 3013 || as->lower[i]->ts.type != BT_INTEGER) 3014 return 0; 3015 3016 elements = elements 3017 * (mpz_get_si (as->upper[i]->value.integer) 3018 - mpz_get_si (as->lower[i]->value.integer) + 1L); 3019 } 3020 } 3021 } 3022 3023 if (substrlen) 3024 return (is_str_storage) ? substrlen + (elements-1)*strlen 3025 : elements*strlen; 3026 else 3027 return elements*strlen; 3028} 3029 3030 3031/* Given an expression, check whether it is an array section 3032 which has a vector subscript. */ 3033 3034bool 3035gfc_has_vector_subscript (gfc_expr *e) 3036{ 3037 int i; 3038 gfc_ref *ref; 3039 3040 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) 3041 return false; 3042 3043 for (ref = e->ref; ref; ref = ref->next) 3044 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 3045 for (i = 0; i < ref->u.ar.dimen; i++) 3046 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 3047 return true; 3048 3049 return false; 3050} 3051 3052 3053static bool 3054is_procptr_result (gfc_expr *expr) 3055{ 3056 gfc_component *c = gfc_get_proc_ptr_comp (expr); 3057 if (c) 3058 return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); 3059 else 3060 return ((expr->symtree->n.sym->result != expr->symtree->n.sym) 3061 && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); 3062} 3063 3064 3065/* Recursively append candidate argument ARG to CANDIDATES. Store the 3066 number of total candidates in CANDIDATES_LEN. */ 3067 3068static void 3069lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg, 3070 char **&candidates, 3071 size_t &candidates_len) 3072{ 3073 for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next) 3074 vec_push (candidates, candidates_len, p->sym->name); 3075} 3076 3077 3078/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */ 3079 3080static const char* 3081lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) 3082{ 3083 char **candidates = NULL; 3084 size_t candidates_len = 0; 3085 lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len); 3086 return gfc_closest_fuzzy_match (arg, candidates); 3087} 3088 3089 3090static gfc_dummy_arg * 3091get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal) 3092{ 3093 gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg (); 3094 3095 dummy_arg->intrinsicness = GFC_NON_INTRINSIC_DUMMY_ARG; 3096 dummy_arg->u.non_intrinsic = formal; 3097 3098 return dummy_arg; 3099} 3100 3101 3102/* Given formal and actual argument lists, see if they are compatible. 3103 If they are compatible, the actual argument list is sorted to 3104 correspond with the formal list, and elements for missing optional 3105 arguments are inserted. If WHERE pointer is nonnull, then we issue 3106 errors when things don't match instead of just returning the status 3107 code. */ 3108 3109bool 3110gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 3111 int ranks_must_agree, int is_elemental, 3112 bool in_statement_function, locus *where) 3113{ 3114 gfc_actual_arglist **new_arg, *a, *actual; 3115 gfc_formal_arglist *f; 3116 int i, n, na; 3117 unsigned long actual_size, formal_size; 3118 bool full_array = false; 3119 gfc_array_ref *actual_arr_ref; 3120 gfc_array_spec *fas, *aas; 3121 bool pointer_dummy, pointer_arg, allocatable_arg; 3122 3123 bool ok = true; 3124 3125 actual = *ap; 3126 3127 if (actual == NULL && formal == NULL) 3128 return true; 3129 3130 n = 0; 3131 for (f = formal; f; f = f->next) 3132 n++; 3133 3134 new_arg = XALLOCAVEC (gfc_actual_arglist *, n); 3135 3136 for (i = 0; i < n; i++) 3137 new_arg[i] = NULL; 3138 3139 na = 0; 3140 f = formal; 3141 i = 0; 3142 3143 for (a = actual; a; a = a->next, f = f->next) 3144 { 3145 if (a->name != NULL && in_statement_function) 3146 { 3147 gfc_error ("Keyword argument %qs at %L is invalid in " 3148 "a statement function", a->name, &a->expr->where); 3149 return false; 3150 } 3151 3152 /* Look for keywords but ignore g77 extensions like %VAL. */ 3153 if (a->name != NULL && a->name[0] != '%') 3154 { 3155 i = 0; 3156 for (f = formal; f; f = f->next, i++) 3157 { 3158 if (f->sym == NULL) 3159 continue; 3160 if (strcmp (f->sym->name, a->name) == 0) 3161 break; 3162 } 3163 3164 if (f == NULL) 3165 { 3166 if (where) 3167 { 3168 const char *guessed = lookup_arg_fuzzy (a->name, formal); 3169 if (guessed) 3170 gfc_error ("Keyword argument %qs at %L is not in " 3171 "the procedure; did you mean %qs?", 3172 a->name, &a->expr->where, guessed); 3173 else 3174 gfc_error ("Keyword argument %qs at %L is not in " 3175 "the procedure", a->name, &a->expr->where); 3176 } 3177 return false; 3178 } 3179 3180 if (new_arg[i] != NULL) 3181 { 3182 if (where) 3183 gfc_error ("Keyword argument %qs at %L is already associated " 3184 "with another actual argument", a->name, 3185 &a->expr->where); 3186 return false; 3187 } 3188 } 3189 3190 if (f == NULL) 3191 { 3192 if (where) 3193 gfc_error ("More actual than formal arguments in procedure " 3194 "call at %L", where); 3195 return false; 3196 } 3197 3198 if (f->sym == NULL && a->expr == NULL) 3199 goto match; 3200 3201 if (f->sym == NULL) 3202 { 3203 /* These errors have to be issued, otherwise an ICE can occur. 3204 See PR 78865. */ 3205 if (where) 3206 gfc_error_now ("Missing alternate return specifier in subroutine " 3207 "call at %L", where); 3208 return false; 3209 } 3210 else 3211 a->associated_dummy = get_nonintrinsic_dummy_arg (f); 3212 3213 if (a->expr == NULL) 3214 { 3215 if (f->sym->attr.optional) 3216 continue; 3217 else 3218 { 3219 if (where) 3220 gfc_error_now ("Unexpected alternate return specifier in " 3221 "subroutine call at %L", where); 3222 return false; 3223 } 3224 } 3225 3226 /* Make sure that intrinsic vtables exist for calls to unlimited 3227 polymorphic formal arguments. */ 3228 if (UNLIMITED_POLY (f->sym) 3229 && a->expr->ts.type != BT_DERIVED 3230 && a->expr->ts.type != BT_CLASS 3231 && a->expr->ts.type != BT_ASSUMED) 3232 gfc_find_vtab (&a->expr->ts); 3233 3234 if (a->expr->expr_type == EXPR_NULL 3235 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer 3236 && (f->sym->attr.allocatable || !f->sym->attr.optional 3237 || (gfc_option.allow_std & GFC_STD_F2008) == 0)) 3238 || (f->sym->ts.type == BT_CLASS 3239 && !CLASS_DATA (f->sym)->attr.class_pointer 3240 && (CLASS_DATA (f->sym)->attr.allocatable 3241 || !f->sym->attr.optional 3242 || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) 3243 { 3244 if (where 3245 && (!f->sym->attr.optional 3246 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) 3247 || (f->sym->ts.type == BT_CLASS 3248 && CLASS_DATA (f->sym)->attr.allocatable))) 3249 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", 3250 where, f->sym->name); 3251 else if (where) 3252 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " 3253 "dummy %qs", where, f->sym->name); 3254 ok = false; 3255 goto match; 3256 } 3257 3258 if (!compare_parameter (f->sym, a->expr, ranks_must_agree, 3259 is_elemental, where)) 3260 { 3261 ok = false; 3262 goto match; 3263 } 3264 3265 /* TS 29113, 6.3p2; F2018 15.5.2.4. */ 3266 if (f->sym->ts.type == BT_ASSUMED 3267 && (a->expr->ts.type == BT_DERIVED 3268 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) 3269 { 3270 gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED 3271 ? a->expr->ts.u.derived 3272 : CLASS_DATA (a->expr)->ts.u.derived); 3273 gfc_namespace *f2k_derived = derived->f2k_derived; 3274 if (derived->attr.pdt_type 3275 || (f2k_derived 3276 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))) 3277 { 3278 gfc_error ("Actual argument at %L to assumed-type dummy " 3279 "has type parameters or is of " 3280 "derived type with type-bound or FINAL procedures", 3281 &a->expr->where); 3282 ok = false; 3283 goto match; 3284 } 3285 } 3286 3287 /* Special case for character arguments. For allocatable, pointer 3288 and assumed-shape dummies, the string length needs to match 3289 exactly. */ 3290 if (a->expr->ts.type == BT_CHARACTER 3291 && a->expr->ts.u.cl && a->expr->ts.u.cl->length 3292 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT 3293 && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl 3294 && f->sym->ts.u.cl->length 3295 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT 3296 && (f->sym->attr.pointer || f->sym->attr.allocatable 3297 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 3298 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, 3299 f->sym->ts.u.cl->length->value.integer) != 0)) 3300 { 3301 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) 3302 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " 3303 "argument and pointer or allocatable dummy argument " 3304 "%qs at %L", 3305 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 3306 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 3307 f->sym->name, &a->expr->where); 3308 else if (where) 3309 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " 3310 "argument and assumed-shape dummy argument %qs " 3311 "at %L", 3312 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 3313 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 3314 f->sym->name, &a->expr->where); 3315 ok = false; 3316 goto match; 3317 } 3318 3319 if ((f->sym->attr.pointer || f->sym->attr.allocatable) 3320 && f->sym->ts.deferred != a->expr->ts.deferred 3321 && a->expr->ts.type == BT_CHARACTER) 3322 { 3323 if (where) 3324 gfc_error ("Actual argument at %L to allocatable or " 3325 "pointer dummy argument %qs must have a deferred " 3326 "length type parameter if and only if the dummy has one", 3327 &a->expr->where, f->sym->name); 3328 ok = false; 3329 goto match; 3330 } 3331 3332 if (f->sym->ts.type == BT_CLASS) 3333 goto skip_size_check; 3334 3335 actual_size = get_expr_storage_size (a->expr); 3336 formal_size = get_sym_storage_size (f->sym); 3337 if (actual_size != 0 && actual_size < formal_size 3338 && a->expr->ts.type != BT_PROCEDURE 3339 && f->sym->attr.flavor != FL_PROCEDURE) 3340 { 3341 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) 3342 { 3343 gfc_warning (0, "Character length of actual argument shorter " 3344 "than of dummy argument %qs (%lu/%lu) at %L", 3345 f->sym->name, actual_size, formal_size, 3346 &a->expr->where); 3347 goto skip_size_check; 3348 } 3349 else if (where) 3350 { 3351 /* Emit a warning for -std=legacy and an error otherwise. */ 3352 if (gfc_option.warn_std == 0) 3353 gfc_warning (0, "Actual argument contains too few " 3354 "elements for dummy argument %qs (%lu/%lu) " 3355 "at %L", f->sym->name, actual_size, 3356 formal_size, &a->expr->where); 3357 else 3358 gfc_error_now ("Actual argument contains too few " 3359 "elements for dummy argument %qs (%lu/%lu) " 3360 "at %L", f->sym->name, actual_size, 3361 formal_size, &a->expr->where); 3362 } 3363 ok = false; 3364 goto match; 3365 } 3366 3367 skip_size_check: 3368 3369 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual 3370 argument is provided for a procedure pointer formal argument. */ 3371 if (f->sym->attr.proc_pointer 3372 && !((a->expr->expr_type == EXPR_VARIABLE 3373 && (a->expr->symtree->n.sym->attr.proc_pointer 3374 || gfc_is_proc_ptr_comp (a->expr))) 3375 || (a->expr->expr_type == EXPR_FUNCTION 3376 && is_procptr_result (a->expr)))) 3377 { 3378 if (where) 3379 gfc_error ("Expected a procedure pointer for argument %qs at %L", 3380 f->sym->name, &a->expr->where); 3381 ok = false; 3382 goto match; 3383 } 3384 3385 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is 3386 provided for a procedure formal argument. */ 3387 if (f->sym->attr.flavor == FL_PROCEDURE 3388 && !((a->expr->expr_type == EXPR_VARIABLE 3389 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE 3390 || a->expr->symtree->n.sym->attr.proc_pointer 3391 || gfc_is_proc_ptr_comp (a->expr))) 3392 || (a->expr->expr_type == EXPR_FUNCTION 3393 && is_procptr_result (a->expr)))) 3394 { 3395 if (where) 3396 gfc_error ("Expected a procedure for argument %qs at %L", 3397 f->sym->name, &a->expr->where); 3398 ok = false; 3399 goto match; 3400 } 3401 3402 /* Class array variables and expressions store array info in a 3403 different place from non-class objects; consolidate the logic 3404 to access it here instead of repeating it below. Note that 3405 pointer_arg and allocatable_arg are not fully general and are 3406 only used in a specific situation below with an assumed-rank 3407 argument. */ 3408 if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)) 3409 { 3410 gfc_component *classdata = CLASS_DATA (f->sym); 3411 fas = classdata->as; 3412 pointer_dummy = classdata->attr.class_pointer; 3413 } 3414 else 3415 { 3416 fas = f->sym->as; 3417 pointer_dummy = f->sym->attr.pointer; 3418 } 3419 3420 if (a->expr->expr_type != EXPR_VARIABLE) 3421 { 3422 aas = NULL; 3423 pointer_arg = false; 3424 allocatable_arg = false; 3425 } 3426 else if (a->expr->ts.type == BT_CLASS 3427 && a->expr->symtree->n.sym 3428 && CLASS_DATA (a->expr->symtree->n.sym)) 3429 { 3430 gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym); 3431 aas = classdata->as; 3432 pointer_arg = classdata->attr.class_pointer; 3433 allocatable_arg = classdata->attr.allocatable; 3434 } 3435 else 3436 { 3437 aas = a->expr->symtree->n.sym->as; 3438 pointer_arg = a->expr->symtree->n.sym->attr.pointer; 3439 allocatable_arg = a->expr->symtree->n.sym->attr.allocatable; 3440 } 3441 3442 /* F2018:9.5.2(2) permits assumed-size whole array expressions as 3443 actual arguments only if the shape is not required; thus it 3444 cannot be passed to an assumed-shape array dummy. 3445 F2018:15.5.2.(2) permits passing a nonpointer actual to an 3446 intent(in) pointer dummy argument and this is accepted by 3447 the compare_pointer check below, but this also requires shape 3448 information. 3449 There's more discussion of this in PR94110. */ 3450 if (fas 3451 && (fas->type == AS_ASSUMED_SHAPE 3452 || fas->type == AS_DEFERRED 3453 || (fas->type == AS_ASSUMED_RANK && pointer_dummy)) 3454 && aas 3455 && aas->type == AS_ASSUMED_SIZE 3456 && (a->expr->ref == NULL 3457 || (a->expr->ref->type == REF_ARRAY 3458 && a->expr->ref->u.ar.type == AR_FULL))) 3459 { 3460 if (where) 3461 gfc_error ("Actual argument for %qs cannot be an assumed-size" 3462 " array at %L", f->sym->name, where); 3463 ok = false; 3464 goto match; 3465 } 3466 3467 /* Diagnose F2018 C839 (TS29113 C535c). Here the problem is 3468 passing an assumed-size array to an INTENT(OUT) assumed-rank 3469 dummy when it doesn't have the size information needed to run 3470 initializers and finalizers. */ 3471 if (f->sym->attr.intent == INTENT_OUT 3472 && fas 3473 && fas->type == AS_ASSUMED_RANK 3474 && aas 3475 && ((aas->type == AS_ASSUMED_SIZE 3476 && (a->expr->ref == NULL 3477 || (a->expr->ref->type == REF_ARRAY 3478 && a->expr->ref->u.ar.type == AR_FULL))) 3479 || (aas->type == AS_ASSUMED_RANK 3480 && !pointer_arg 3481 && !allocatable_arg)) 3482 && (a->expr->ts.type == BT_CLASS 3483 || (a->expr->ts.type == BT_DERIVED 3484 && (gfc_is_finalizable (a->expr->ts.u.derived, NULL) 3485 || gfc_has_ultimate_allocatable (a->expr) 3486 || gfc_has_default_initializer 3487 (a->expr->ts.u.derived))))) 3488 { 3489 if (where) 3490 gfc_error ("Actual argument to assumed-rank INTENT(OUT) " 3491 "dummy %qs at %L cannot be of unknown size", 3492 f->sym->name, where); 3493 ok = false; 3494 goto match; 3495 } 3496 3497 if (a->expr->expr_type != EXPR_NULL 3498 && compare_pointer (f->sym, a->expr) == 0) 3499 { 3500 if (where) 3501 gfc_error ("Actual argument for %qs must be a pointer at %L", 3502 f->sym->name, &a->expr->where); 3503 ok = false; 3504 goto match; 3505 } 3506 3507 if (a->expr->expr_type != EXPR_NULL 3508 && (gfc_option.allow_std & GFC_STD_F2008) == 0 3509 && compare_pointer (f->sym, a->expr) == 2) 3510 { 3511 if (where) 3512 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " 3513 "pointer dummy %qs", &a->expr->where,f->sym->name); 3514 ok = false; 3515 goto match; 3516 } 3517 3518 3519 /* Fortran 2008, C1242. */ 3520 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) 3521 { 3522 if (where) 3523 gfc_error ("Coindexed actual argument at %L to pointer " 3524 "dummy %qs", 3525 &a->expr->where, f->sym->name); 3526 ok = false; 3527 goto match; 3528 } 3529 3530 /* Fortran 2008, 12.5.2.5 (no constraint). */ 3531 if (a->expr->expr_type == EXPR_VARIABLE 3532 && f->sym->attr.intent != INTENT_IN 3533 && f->sym->attr.allocatable 3534 && gfc_is_coindexed (a->expr)) 3535 { 3536 if (where) 3537 gfc_error ("Coindexed actual argument at %L to allocatable " 3538 "dummy %qs requires INTENT(IN)", 3539 &a->expr->where, f->sym->name); 3540 ok = false; 3541 goto match; 3542 } 3543 3544 /* Fortran 2008, C1237. */ 3545 if (a->expr->expr_type == EXPR_VARIABLE 3546 && (f->sym->attr.asynchronous || f->sym->attr.volatile_) 3547 && gfc_is_coindexed (a->expr) 3548 && (a->expr->symtree->n.sym->attr.volatile_ 3549 || a->expr->symtree->n.sym->attr.asynchronous)) 3550 { 3551 if (where) 3552 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " 3553 "%L requires that dummy %qs has neither " 3554 "ASYNCHRONOUS nor VOLATILE", &a->expr->where, 3555 f->sym->name); 3556 ok = false; 3557 goto match; 3558 } 3559 3560 /* Fortran 2008, 12.5.2.4 (no constraint). */ 3561 if (a->expr->expr_type == EXPR_VARIABLE 3562 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value 3563 && gfc_is_coindexed (a->expr) 3564 && gfc_has_ultimate_allocatable (a->expr)) 3565 { 3566 if (where) 3567 gfc_error ("Coindexed actual argument at %L with allocatable " 3568 "ultimate component to dummy %qs requires either VALUE " 3569 "or INTENT(IN)", &a->expr->where, f->sym->name); 3570 ok = false; 3571 goto match; 3572 } 3573 3574 if (f->sym->ts.type == BT_CLASS 3575 && CLASS_DATA (f->sym)->attr.allocatable 3576 && gfc_is_class_array_ref (a->expr, &full_array) 3577 && !full_array) 3578 { 3579 if (where) 3580 gfc_error ("Actual CLASS array argument for %qs must be a full " 3581 "array at %L", f->sym->name, &a->expr->where); 3582 ok = false; 3583 goto match; 3584 } 3585 3586 3587 if (a->expr->expr_type != EXPR_NULL 3588 && !compare_allocatable (f->sym, a->expr)) 3589 { 3590 if (where) 3591 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", 3592 f->sym->name, &a->expr->where); 3593 ok = false; 3594 goto match; 3595 } 3596 3597 /* Check intent = OUT/INOUT for definable actual argument. */ 3598 if (!in_statement_function 3599 && (f->sym->attr.intent == INTENT_OUT 3600 || f->sym->attr.intent == INTENT_INOUT)) 3601 { 3602 const char* context = (where 3603 ? _("actual argument to INTENT = OUT/INOUT") 3604 : NULL); 3605 3606 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3607 && CLASS_DATA (f->sym)->attr.class_pointer) 3608 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3609 && !gfc_check_vardef_context (a->expr, true, false, false, context)) 3610 { 3611 ok = false; 3612 goto match; 3613 } 3614 if (!gfc_check_vardef_context (a->expr, false, false, false, context)) 3615 { 3616 ok = false; 3617 goto match; 3618 } 3619 } 3620 3621 if ((f->sym->attr.intent == INTENT_OUT 3622 || f->sym->attr.intent == INTENT_INOUT 3623 || f->sym->attr.volatile_ 3624 || f->sym->attr.asynchronous) 3625 && gfc_has_vector_subscript (a->expr)) 3626 { 3627 if (where) 3628 gfc_error ("Array-section actual argument with vector " 3629 "subscripts at %L is incompatible with INTENT(OUT), " 3630 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " 3631 "of the dummy argument %qs", 3632 &a->expr->where, f->sym->name); 3633 ok = false; 3634 goto match; 3635 } 3636 3637 /* C1232 (R1221) For an actual argument which is an array section or 3638 an assumed-shape array, the dummy argument shall be an assumed- 3639 shape array, if the dummy argument has the VOLATILE attribute. */ 3640 3641 if (f->sym->attr.volatile_ 3642 && a->expr->expr_type == EXPR_VARIABLE 3643 && a->expr->symtree->n.sym->as 3644 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE 3645 && !(fas && fas->type == AS_ASSUMED_SHAPE)) 3646 { 3647 if (where) 3648 gfc_error ("Assumed-shape actual argument at %L is " 3649 "incompatible with the non-assumed-shape " 3650 "dummy argument %qs due to VOLATILE attribute", 3651 &a->expr->where,f->sym->name); 3652 ok = false; 3653 goto match; 3654 } 3655 3656 /* Find the last array_ref. */ 3657 actual_arr_ref = NULL; 3658 if (a->expr->ref) 3659 actual_arr_ref = gfc_find_array_ref (a->expr, true); 3660 3661 if (f->sym->attr.volatile_ 3662 && actual_arr_ref && actual_arr_ref->type == AR_SECTION 3663 && !(fas && fas->type == AS_ASSUMED_SHAPE)) 3664 { 3665 if (where) 3666 gfc_error ("Array-section actual argument at %L is " 3667 "incompatible with the non-assumed-shape " 3668 "dummy argument %qs due to VOLATILE attribute", 3669 &a->expr->where, f->sym->name); 3670 ok = false; 3671 goto match; 3672 } 3673 3674 /* C1233 (R1221) For an actual argument which is a pointer array, the 3675 dummy argument shall be an assumed-shape or pointer array, if the 3676 dummy argument has the VOLATILE attribute. */ 3677 3678 if (f->sym->attr.volatile_ 3679 && a->expr->expr_type == EXPR_VARIABLE 3680 && a->expr->symtree->n.sym->attr.pointer 3681 && a->expr->symtree->n.sym->as 3682 && !(fas 3683 && (fas->type == AS_ASSUMED_SHAPE 3684 || f->sym->attr.pointer))) 3685 { 3686 if (where) 3687 gfc_error ("Pointer-array actual argument at %L requires " 3688 "an assumed-shape or pointer-array dummy " 3689 "argument %qs due to VOLATILE attribute", 3690 &a->expr->where,f->sym->name); 3691 ok = false; 3692 goto match; 3693 } 3694 3695 match: 3696 if (a == actual) 3697 na = i; 3698 3699 new_arg[i++] = a; 3700 } 3701 3702 /* Give up now if we saw any bad argument. */ 3703 if (!ok) 3704 return false; 3705 3706 /* Make sure missing actual arguments are optional. */ 3707 i = 0; 3708 for (f = formal; f; f = f->next, i++) 3709 { 3710 if (new_arg[i] != NULL) 3711 continue; 3712 if (f->sym == NULL) 3713 { 3714 if (where) 3715 gfc_error ("Missing alternate return spec in subroutine call " 3716 "at %L", where); 3717 return false; 3718 } 3719 /* For CLASS, the optional attribute might be set at either location. */ 3720 if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional) 3721 && !f->sym->attr.optional) 3722 || (in_statement_function 3723 && (f->sym->attr.optional 3724 || (f->sym->ts.type == BT_CLASS 3725 && CLASS_DATA (f->sym)->attr.optional)))) 3726 { 3727 if (where) 3728 gfc_error ("Missing actual argument for argument %qs at %L", 3729 f->sym->name, where); 3730 return false; 3731 } 3732 } 3733 3734 /* We should have handled the cases where the formal arglist is null 3735 already. */ 3736 gcc_assert (n > 0); 3737 3738 /* The argument lists are compatible. We now relink a new actual 3739 argument list with null arguments in the right places. The head 3740 of the list remains the head. */ 3741 for (f = formal, i = 0; f; f = f->next, i++) 3742 if (new_arg[i] == NULL) 3743 { 3744 new_arg[i] = gfc_get_actual_arglist (); 3745 new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (f); 3746 } 3747 3748 if (na != 0) 3749 { 3750 std::swap (*new_arg[0], *actual); 3751 std::swap (new_arg[0], new_arg[na]); 3752 } 3753 3754 for (i = 0; i < n - 1; i++) 3755 new_arg[i]->next = new_arg[i + 1]; 3756 3757 new_arg[i]->next = NULL; 3758 3759 if (*ap == NULL && n > 0) 3760 *ap = new_arg[0]; 3761 3762 return true; 3763} 3764 3765 3766typedef struct 3767{ 3768 gfc_formal_arglist *f; 3769 gfc_actual_arglist *a; 3770} 3771argpair; 3772 3773/* qsort comparison function for argument pairs, with the following 3774 order: 3775 - p->a->expr == NULL 3776 - p->a->expr->expr_type != EXPR_VARIABLE 3777 - by gfc_symbol pointer value (larger first). */ 3778 3779static int 3780pair_cmp (const void *p1, const void *p2) 3781{ 3782 const gfc_actual_arglist *a1, *a2; 3783 3784 /* *p1 and *p2 are elements of the to-be-sorted array. */ 3785 a1 = ((const argpair *) p1)->a; 3786 a2 = ((const argpair *) p2)->a; 3787 if (!a1->expr) 3788 { 3789 if (!a2->expr) 3790 return 0; 3791 return -1; 3792 } 3793 if (!a2->expr) 3794 return 1; 3795 if (a1->expr->expr_type != EXPR_VARIABLE) 3796 { 3797 if (a2->expr->expr_type != EXPR_VARIABLE) 3798 return 0; 3799 return -1; 3800 } 3801 if (a2->expr->expr_type != EXPR_VARIABLE) 3802 return 1; 3803 if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym) 3804 return -1; 3805 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; 3806} 3807 3808 3809/* Given two expressions from some actual arguments, test whether they 3810 refer to the same expression. The analysis is conservative. 3811 Returning false will produce no warning. */ 3812 3813static bool 3814compare_actual_expr (gfc_expr *e1, gfc_expr *e2) 3815{ 3816 const gfc_ref *r1, *r2; 3817 3818 if (!e1 || !e2 3819 || e1->expr_type != EXPR_VARIABLE 3820 || e2->expr_type != EXPR_VARIABLE 3821 || e1->symtree->n.sym != e2->symtree->n.sym) 3822 return false; 3823 3824 /* TODO: improve comparison, see expr.cc:show_ref(). */ 3825 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) 3826 { 3827 if (r1->type != r2->type) 3828 return false; 3829 switch (r1->type) 3830 { 3831 case REF_ARRAY: 3832 if (r1->u.ar.type != r2->u.ar.type) 3833 return false; 3834 /* TODO: At the moment, consider only full arrays; 3835 we could do better. */ 3836 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) 3837 return false; 3838 break; 3839 3840 case REF_COMPONENT: 3841 if (r1->u.c.component != r2->u.c.component) 3842 return false; 3843 break; 3844 3845 case REF_SUBSTRING: 3846 return false; 3847 3848 case REF_INQUIRY: 3849 if (e1->symtree->n.sym->ts.type == BT_COMPLEX 3850 && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL 3851 && r1->u.i != r2->u.i) 3852 return false; 3853 break; 3854 3855 default: 3856 gfc_internal_error ("compare_actual_expr(): Bad component code"); 3857 } 3858 } 3859 if (!r1 && !r2) 3860 return true; 3861 return false; 3862} 3863 3864 3865/* Given formal and actual argument lists that correspond to one 3866 another, check that identical actual arguments aren't not 3867 associated with some incompatible INTENTs. */ 3868 3869static bool 3870check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) 3871{ 3872 sym_intent f1_intent, f2_intent; 3873 gfc_formal_arglist *f1; 3874 gfc_actual_arglist *a1; 3875 size_t n, i, j; 3876 argpair *p; 3877 bool t = true; 3878 3879 n = 0; 3880 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) 3881 { 3882 if (f1 == NULL && a1 == NULL) 3883 break; 3884 if (f1 == NULL || a1 == NULL) 3885 gfc_internal_error ("check_some_aliasing(): List mismatch"); 3886 n++; 3887 } 3888 if (n == 0) 3889 return t; 3890 p = XALLOCAVEC (argpair, n); 3891 3892 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) 3893 { 3894 p[i].f = f1; 3895 p[i].a = a1; 3896 } 3897 3898 qsort (p, n, sizeof (argpair), pair_cmp); 3899 3900 for (i = 0; i < n; i++) 3901 { 3902 if (!p[i].a->expr 3903 || p[i].a->expr->expr_type != EXPR_VARIABLE 3904 || p[i].a->expr->ts.type == BT_PROCEDURE) 3905 continue; 3906 f1_intent = p[i].f->sym->attr.intent; 3907 for (j = i + 1; j < n; j++) 3908 { 3909 /* Expected order after the sort. */ 3910 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) 3911 gfc_internal_error ("check_some_aliasing(): corrupted data"); 3912 3913 /* Are the expression the same? */ 3914 if (!compare_actual_expr (p[i].a->expr, p[j].a->expr)) 3915 break; 3916 f2_intent = p[j].f->sym->attr.intent; 3917 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) 3918 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN) 3919 || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT)) 3920 { 3921 gfc_warning (0, "Same actual argument associated with INTENT(%s) " 3922 "argument %qs and INTENT(%s) argument %qs at %L", 3923 gfc_intent_string (f1_intent), p[i].f->sym->name, 3924 gfc_intent_string (f2_intent), p[j].f->sym->name, 3925 &p[i].a->expr->where); 3926 t = false; 3927 } 3928 } 3929 } 3930 3931 return t; 3932} 3933 3934 3935/* Given formal and actual argument lists that correspond to one 3936 another, check that they are compatible in the sense that intents 3937 are not mismatched. */ 3938 3939static bool 3940check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 3941{ 3942 sym_intent f_intent; 3943 3944 for (;; f = f->next, a = a->next) 3945 { 3946 gfc_expr *expr; 3947 3948 if (f == NULL && a == NULL) 3949 break; 3950 if (f == NULL || a == NULL) 3951 gfc_internal_error ("check_intents(): List mismatch"); 3952 3953 if (a->expr && a->expr->expr_type == EXPR_FUNCTION 3954 && a->expr->value.function.isym 3955 && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET) 3956 expr = a->expr->value.function.actual->expr; 3957 else 3958 expr = a->expr; 3959 3960 if (expr == NULL || expr->expr_type != EXPR_VARIABLE) 3961 continue; 3962 3963 f_intent = f->sym->attr.intent; 3964 3965 if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym)) 3966 { 3967 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3968 && CLASS_DATA (f->sym)->attr.class_pointer) 3969 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3970 { 3971 gfc_error ("Procedure argument at %L is local to a PURE " 3972 "procedure and has the POINTER attribute", 3973 &expr->where); 3974 return false; 3975 } 3976 } 3977 3978 /* Fortran 2008, C1283. */ 3979 if (gfc_pure (NULL) && gfc_is_coindexed (expr)) 3980 { 3981 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) 3982 { 3983 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3984 "is passed to an INTENT(%s) argument", 3985 &expr->where, gfc_intent_string (f_intent)); 3986 return false; 3987 } 3988 3989 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3990 && CLASS_DATA (f->sym)->attr.class_pointer) 3991 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3992 { 3993 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3994 "is passed to a POINTER dummy argument", 3995 &expr->where); 3996 return false; 3997 } 3998 } 3999 4000 /* F2008, Section 12.5.2.4. */ 4001 if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS 4002 && gfc_is_coindexed (expr)) 4003 { 4004 gfc_error ("Coindexed polymorphic actual argument at %L is passed " 4005 "polymorphic dummy argument %qs", 4006 &expr->where, f->sym->name); 4007 return false; 4008 } 4009 } 4010 4011 return true; 4012} 4013 4014 4015/* Check how a procedure is used against its interface. If all goes 4016 well, the actual argument list will also end up being properly 4017 sorted. */ 4018 4019bool 4020gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) 4021{ 4022 gfc_actual_arglist *a; 4023 gfc_formal_arglist *dummy_args; 4024 bool implicit = false; 4025 4026 /* Warn about calls with an implicit interface. Special case 4027 for calling a ISO_C_BINDING because c_loc and c_funloc 4028 are pseudo-unknown. Additionally, warn about procedures not 4029 explicitly declared at all if requested. */ 4030 if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) 4031 { 4032 bool has_implicit_none_export = false; 4033 implicit = true; 4034 if (sym->attr.proc == PROC_UNKNOWN) 4035 for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) 4036 if (ns->has_implicit_none_export) 4037 { 4038 has_implicit_none_export = true; 4039 break; 4040 } 4041 if (has_implicit_none_export) 4042 { 4043 const char *guessed 4044 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); 4045 if (guessed) 4046 gfc_error ("Procedure %qs called at %L is not explicitly declared" 4047 "; did you mean %qs?", 4048 sym->name, where, guessed); 4049 else 4050 gfc_error ("Procedure %qs called at %L is not explicitly declared", 4051 sym->name, where); 4052 return false; 4053 } 4054 if (warn_implicit_interface) 4055 gfc_warning (OPT_Wimplicit_interface, 4056 "Procedure %qs called with an implicit interface at %L", 4057 sym->name, where); 4058 else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN) 4059 gfc_warning (OPT_Wimplicit_procedure, 4060 "Procedure %qs called at %L is not explicitly declared", 4061 sym->name, where); 4062 gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1; 4063 } 4064 4065 if (sym->attr.if_source == IFSRC_UNKNOWN) 4066 { 4067 if (sym->attr.pointer) 4068 { 4069 gfc_error ("The pointer object %qs at %L must have an explicit " 4070 "function interface or be declared as array", 4071 sym->name, where); 4072 return false; 4073 } 4074 4075 if (sym->attr.allocatable && !sym->attr.external) 4076 { 4077 gfc_error ("The allocatable object %qs at %L must have an explicit " 4078 "function interface or be declared as array", 4079 sym->name, where); 4080 return false; 4081 } 4082 4083 if (sym->attr.allocatable) 4084 { 4085 gfc_error ("Allocatable function %qs at %L must have an explicit " 4086 "function interface", sym->name, where); 4087 return false; 4088 } 4089 4090 for (a = *ap; a; a = a->next) 4091 { 4092 if (a->expr && a->expr->error) 4093 return false; 4094 4095 /* F2018, 15.4.2.2 Explicit interface is required for a 4096 polymorphic dummy argument, so there is no way to 4097 legally have a class appear in an argument with an 4098 implicit interface. */ 4099 4100 if (implicit && a->expr && a->expr->ts.type == BT_CLASS) 4101 { 4102 gfc_error ("Explicit interface required for polymorphic " 4103 "argument at %L",&a->expr->where); 4104 a->expr->error = 1; 4105 break; 4106 } 4107 4108 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 4109 if (a->name != NULL && a->name[0] != '%') 4110 { 4111 gfc_error ("Keyword argument requires explicit interface " 4112 "for procedure %qs at %L", sym->name, &a->expr->where); 4113 break; 4114 } 4115 4116 /* TS 29113, 6.2. */ 4117 if (a->expr && a->expr->ts.type == BT_ASSUMED 4118 && sym->intmod_sym_id != ISOCBINDING_LOC) 4119 { 4120 gfc_error ("Assumed-type argument %s at %L requires an explicit " 4121 "interface", a->expr->symtree->n.sym->name, 4122 &a->expr->where); 4123 a->expr->error = 1; 4124 break; 4125 } 4126 4127 /* F2008, C1303 and C1304. */ 4128 if (a->expr 4129 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 4130 && a->expr->ts.u.derived 4131 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 4132 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 4133 || gfc_expr_attr (a->expr).lock_comp)) 4134 { 4135 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " 4136 "component at %L requires an explicit interface for " 4137 "procedure %qs", &a->expr->where, sym->name); 4138 a->expr->error = 1; 4139 break; 4140 } 4141 4142 if (a->expr 4143 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 4144 && a->expr->ts.u.derived 4145 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 4146 && a->expr->ts.u.derived->intmod_sym_id 4147 == ISOFORTRAN_EVENT_TYPE) 4148 || gfc_expr_attr (a->expr).event_comp)) 4149 { 4150 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " 4151 "component at %L requires an explicit interface for " 4152 "procedure %qs", &a->expr->where, sym->name); 4153 a->expr->error = 1; 4154 break; 4155 } 4156 4157 if (a->expr && a->expr->expr_type == EXPR_NULL 4158 && a->expr->ts.type == BT_UNKNOWN) 4159 { 4160 gfc_error ("MOLD argument to NULL required at %L", 4161 &a->expr->where); 4162 a->expr->error = 1; 4163 return false; 4164 } 4165 4166 if (a->expr && a->expr->expr_type == EXPR_NULL) 4167 { 4168 gfc_error ("Passing intrinsic NULL as actual argument at %L " 4169 "requires an explicit interface", &a->expr->where); 4170 a->expr->error = 1; 4171 return false; 4172 } 4173 4174 /* TS 29113, C407b. */ 4175 if (a->expr && a->expr->expr_type == EXPR_VARIABLE 4176 && symbol_rank (a->expr->symtree->n.sym) == -1) 4177 { 4178 gfc_error ("Assumed-rank argument requires an explicit interface " 4179 "at %L", &a->expr->where); 4180 a->expr->error = 1; 4181 return false; 4182 } 4183 } 4184 4185 return true; 4186 } 4187 4188 dummy_args = gfc_sym_get_dummy_args (sym); 4189 4190 /* For a statement function, check that types and type parameters of actual 4191 arguments and dummy arguments match. */ 4192 if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, 4193 sym->attr.proc == PROC_ST_FUNCTION, where)) 4194 return false; 4195 4196 if (!check_intents (dummy_args, *ap)) 4197 return false; 4198 4199 if (warn_aliasing) 4200 check_some_aliasing (dummy_args, *ap); 4201 4202 return true; 4203} 4204 4205 4206/* Check how a procedure pointer component is used against its interface. 4207 If all goes well, the actual argument list will also end up being properly 4208 sorted. Completely analogous to gfc_procedure_use. */ 4209 4210void 4211gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) 4212{ 4213 /* Warn about calls with an implicit interface. Special case 4214 for calling a ISO_C_BINDING because c_loc and c_funloc 4215 are pseudo-unknown. */ 4216 if (warn_implicit_interface 4217 && comp->attr.if_source == IFSRC_UNKNOWN 4218 && !comp->attr.is_iso_c) 4219 gfc_warning (OPT_Wimplicit_interface, 4220 "Procedure pointer component %qs called with an implicit " 4221 "interface at %L", comp->name, where); 4222 4223 if (comp->attr.if_source == IFSRC_UNKNOWN) 4224 { 4225 gfc_actual_arglist *a; 4226 for (a = *ap; a; a = a->next) 4227 { 4228 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 4229 if (a->name != NULL && a->name[0] != '%') 4230 { 4231 gfc_error ("Keyword argument requires explicit interface " 4232 "for procedure pointer component %qs at %L", 4233 comp->name, &a->expr->where); 4234 break; 4235 } 4236 } 4237 4238 return; 4239 } 4240 4241 if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0, 4242 comp->attr.elemental, false, where)) 4243 return; 4244 4245 check_intents (comp->ts.interface->formal, *ap); 4246 if (warn_aliasing) 4247 check_some_aliasing (comp->ts.interface->formal, *ap); 4248} 4249 4250 4251/* Try if an actual argument list matches the formal list of a symbol, 4252 respecting the symbol's attributes like ELEMENTAL. This is used for 4253 GENERIC resolution. */ 4254 4255bool 4256gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) 4257{ 4258 gfc_formal_arglist *dummy_args; 4259 bool r; 4260 4261 if (sym->attr.flavor != FL_PROCEDURE) 4262 return false; 4263 4264 dummy_args = gfc_sym_get_dummy_args (sym); 4265 4266 r = !sym->attr.elemental; 4267 if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL)) 4268 { 4269 check_intents (dummy_args, *args); 4270 if (warn_aliasing) 4271 check_some_aliasing (dummy_args, *args); 4272 return true; 4273 } 4274 4275 return false; 4276} 4277 4278 4279/* Given an interface pointer and an actual argument list, search for 4280 a formal argument list that matches the actual. If found, returns 4281 a pointer to the symbol of the correct interface. Returns NULL if 4282 not found. */ 4283 4284gfc_symbol * 4285gfc_search_interface (gfc_interface *intr, int sub_flag, 4286 gfc_actual_arglist **ap) 4287{ 4288 gfc_symbol *elem_sym = NULL; 4289 gfc_symbol *null_sym = NULL; 4290 locus null_expr_loc; 4291 gfc_actual_arglist *a; 4292 bool has_null_arg = false; 4293 4294 for (a = *ap; a; a = a->next) 4295 if (a->expr && a->expr->expr_type == EXPR_NULL 4296 && a->expr->ts.type == BT_UNKNOWN) 4297 { 4298 has_null_arg = true; 4299 null_expr_loc = a->expr->where; 4300 break; 4301 } 4302 4303 for (; intr; intr = intr->next) 4304 { 4305 if (gfc_fl_struct (intr->sym->attr.flavor)) 4306 continue; 4307 if (sub_flag && intr->sym->attr.function) 4308 continue; 4309 if (!sub_flag && intr->sym->attr.subroutine) 4310 continue; 4311 4312 if (gfc_arglist_matches_symbol (ap, intr->sym)) 4313 { 4314 if (has_null_arg && null_sym) 4315 { 4316 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " 4317 "between specific functions %s and %s", 4318 &null_expr_loc, null_sym->name, intr->sym->name); 4319 return NULL; 4320 } 4321 else if (has_null_arg) 4322 { 4323 null_sym = intr->sym; 4324 continue; 4325 } 4326 4327 /* Satisfy 12.4.4.1 such that an elemental match has lower 4328 weight than a non-elemental match. */ 4329 if (intr->sym->attr.elemental) 4330 { 4331 elem_sym = intr->sym; 4332 continue; 4333 } 4334 return intr->sym; 4335 } 4336 } 4337 4338 if (null_sym) 4339 return null_sym; 4340 4341 return elem_sym ? elem_sym : NULL; 4342} 4343 4344 4345/* Do a brute force recursive search for a symbol. */ 4346 4347static gfc_symtree * 4348find_symtree0 (gfc_symtree *root, gfc_symbol *sym) 4349{ 4350 gfc_symtree * st; 4351 4352 if (root->n.sym == sym) 4353 return root; 4354 4355 st = NULL; 4356 if (root->left) 4357 st = find_symtree0 (root->left, sym); 4358 if (root->right && ! st) 4359 st = find_symtree0 (root->right, sym); 4360 return st; 4361} 4362 4363 4364/* Find a symtree for a symbol. */ 4365 4366gfc_symtree * 4367gfc_find_sym_in_symtree (gfc_symbol *sym) 4368{ 4369 gfc_symtree *st; 4370 gfc_namespace *ns; 4371 4372 /* First try to find it by name. */ 4373 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); 4374 if (st && st->n.sym == sym) 4375 return st; 4376 4377 /* If it's been renamed, resort to a brute-force search. */ 4378 /* TODO: avoid having to do this search. If the symbol doesn't exist 4379 in the symtree for the current namespace, it should probably be added. */ 4380 for (ns = gfc_current_ns; ns; ns = ns->parent) 4381 { 4382 st = find_symtree0 (ns->sym_root, sym); 4383 if (st) 4384 return st; 4385 } 4386 gfc_internal_error ("Unable to find symbol %qs", sym->name); 4387 /* Not reached. */ 4388} 4389 4390 4391/* See if the arglist to an operator-call contains a derived-type argument 4392 with a matching type-bound operator. If so, return the matching specific 4393 procedure defined as operator-target as well as the base-object to use 4394 (which is the found derived-type argument with operator). The generic 4395 name, if any, is transmitted to the final expression via 'gname'. */ 4396 4397static gfc_typebound_proc* 4398matching_typebound_op (gfc_expr** tb_base, 4399 gfc_actual_arglist* args, 4400 gfc_intrinsic_op op, const char* uop, 4401 const char ** gname) 4402{ 4403 gfc_actual_arglist* base; 4404 4405 for (base = args; base; base = base->next) 4406 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS) 4407 { 4408 gfc_typebound_proc* tb; 4409 gfc_symbol* derived; 4410 bool result; 4411 4412 while (base->expr->expr_type == EXPR_OP 4413 && base->expr->value.op.op == INTRINSIC_PARENTHESES) 4414 base->expr = base->expr->value.op.op1; 4415 4416 if (base->expr->ts.type == BT_CLASS) 4417 { 4418 if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL 4419 || !gfc_expr_attr (base->expr).class_ok) 4420 continue; 4421 derived = CLASS_DATA (base->expr)->ts.u.derived; 4422 } 4423 else 4424 derived = base->expr->ts.u.derived; 4425 4426 if (op == INTRINSIC_USER) 4427 { 4428 gfc_symtree* tb_uop; 4429 4430 gcc_assert (uop); 4431 tb_uop = gfc_find_typebound_user_op (derived, &result, uop, 4432 false, NULL); 4433 4434 if (tb_uop) 4435 tb = tb_uop->n.tb; 4436 else 4437 tb = NULL; 4438 } 4439 else 4440 tb = gfc_find_typebound_intrinsic_op (derived, &result, op, 4441 false, NULL); 4442 4443 /* This means we hit a PRIVATE operator which is use-associated and 4444 should thus not be seen. */ 4445 if (!result) 4446 tb = NULL; 4447 4448 /* Look through the super-type hierarchy for a matching specific 4449 binding. */ 4450 for (; tb; tb = tb->overridden) 4451 { 4452 gfc_tbp_generic* g; 4453 4454 gcc_assert (tb->is_generic); 4455 for (g = tb->u.generic; g; g = g->next) 4456 { 4457 gfc_symbol* target; 4458 gfc_actual_arglist* argcopy; 4459 bool matches; 4460 4461 gcc_assert (g->specific); 4462 if (g->specific->error) 4463 continue; 4464 4465 target = g->specific->u.specific->n.sym; 4466 4467 /* Check if this arglist matches the formal. */ 4468 argcopy = gfc_copy_actual_arglist (args); 4469 matches = gfc_arglist_matches_symbol (&argcopy, target); 4470 gfc_free_actual_arglist (argcopy); 4471 4472 /* Return if we found a match. */ 4473 if (matches) 4474 { 4475 *tb_base = base->expr; 4476 *gname = g->specific_st->name; 4477 return g->specific; 4478 } 4479 } 4480 } 4481 } 4482 4483 return NULL; 4484} 4485 4486 4487/* For the 'actual arglist' of an operator call and a specific typebound 4488 procedure that has been found the target of a type-bound operator, build the 4489 appropriate EXPR_COMPCALL and resolve it. We take this indirection over 4490 type-bound procedures rather than resolving type-bound operators 'directly' 4491 so that we can reuse the existing logic. */ 4492 4493static void 4494build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, 4495 gfc_expr* base, gfc_typebound_proc* target, 4496 const char *gname) 4497{ 4498 e->expr_type = EXPR_COMPCALL; 4499 e->value.compcall.tbp = target; 4500 e->value.compcall.name = gname ? gname : "$op"; 4501 e->value.compcall.actual = actual; 4502 e->value.compcall.base_object = base; 4503 e->value.compcall.ignore_pass = 1; 4504 e->value.compcall.assign = 0; 4505 if (e->ts.type == BT_UNKNOWN 4506 && target->function) 4507 { 4508 if (target->is_generic) 4509 e->ts = target->u.generic->specific->u.specific->n.sym->ts; 4510 else 4511 e->ts = target->u.specific->n.sym->ts; 4512 } 4513} 4514 4515 4516/* This subroutine is called when an expression is being resolved. 4517 The expression node in question is either a user defined operator 4518 or an intrinsic operator with arguments that aren't compatible 4519 with the operator. This subroutine builds an actual argument list 4520 corresponding to the operands, then searches for a compatible 4521 interface. If one is found, the expression node is replaced with 4522 the appropriate function call. We use the 'match' enum to specify 4523 whether a replacement has been made or not, or if an error occurred. */ 4524 4525match 4526gfc_extend_expr (gfc_expr *e) 4527{ 4528 gfc_actual_arglist *actual; 4529 gfc_symbol *sym; 4530 gfc_namespace *ns; 4531 gfc_user_op *uop; 4532 gfc_intrinsic_op i; 4533 const char *gname; 4534 gfc_typebound_proc* tbo; 4535 gfc_expr* tb_base; 4536 4537 sym = NULL; 4538 4539 actual = gfc_get_actual_arglist (); 4540 actual->expr = e->value.op.op1; 4541 4542 gname = NULL; 4543 4544 if (e->value.op.op2 != NULL) 4545 { 4546 actual->next = gfc_get_actual_arglist (); 4547 actual->next->expr = e->value.op.op2; 4548 } 4549 4550 i = fold_unary_intrinsic (e->value.op.op); 4551 4552 /* See if we find a matching type-bound operator. */ 4553 if (i == INTRINSIC_USER) 4554 tbo = matching_typebound_op (&tb_base, actual, 4555 i, e->value.op.uop->name, &gname); 4556 else 4557 switch (i) 4558 { 4559#define CHECK_OS_COMPARISON(comp) \ 4560 case INTRINSIC_##comp: \ 4561 case INTRINSIC_##comp##_OS: \ 4562 tbo = matching_typebound_op (&tb_base, actual, \ 4563 INTRINSIC_##comp, NULL, &gname); \ 4564 if (!tbo) \ 4565 tbo = matching_typebound_op (&tb_base, actual, \ 4566 INTRINSIC_##comp##_OS, NULL, &gname); \ 4567 break; 4568 CHECK_OS_COMPARISON(EQ) 4569 CHECK_OS_COMPARISON(NE) 4570 CHECK_OS_COMPARISON(GT) 4571 CHECK_OS_COMPARISON(GE) 4572 CHECK_OS_COMPARISON(LT) 4573 CHECK_OS_COMPARISON(LE) 4574#undef CHECK_OS_COMPARISON 4575 4576 default: 4577 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); 4578 break; 4579 } 4580 4581 /* If there is a matching typebound-operator, replace the expression with 4582 a call to it and succeed. */ 4583 if (tbo) 4584 { 4585 gcc_assert (tb_base); 4586 build_compcall_for_operator (e, actual, tb_base, tbo, gname); 4587 4588 if (!gfc_resolve_expr (e)) 4589 return MATCH_ERROR; 4590 else 4591 return MATCH_YES; 4592 } 4593 4594 if (i == INTRINSIC_USER) 4595 { 4596 for (ns = gfc_current_ns; ns; ns = ns->parent) 4597 { 4598 uop = gfc_find_uop (e->value.op.uop->name, ns); 4599 if (uop == NULL) 4600 continue; 4601 4602 sym = gfc_search_interface (uop->op, 0, &actual); 4603 if (sym != NULL) 4604 break; 4605 } 4606 } 4607 else 4608 { 4609 for (ns = gfc_current_ns; ns; ns = ns->parent) 4610 { 4611 /* Due to the distinction between '==' and '.eq.' and friends, one has 4612 to check if either is defined. */ 4613 switch (i) 4614 { 4615#define CHECK_OS_COMPARISON(comp) \ 4616 case INTRINSIC_##comp: \ 4617 case INTRINSIC_##comp##_OS: \ 4618 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ 4619 if (!sym) \ 4620 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ 4621 break; 4622 CHECK_OS_COMPARISON(EQ) 4623 CHECK_OS_COMPARISON(NE) 4624 CHECK_OS_COMPARISON(GT) 4625 CHECK_OS_COMPARISON(GE) 4626 CHECK_OS_COMPARISON(LT) 4627 CHECK_OS_COMPARISON(LE) 4628#undef CHECK_OS_COMPARISON 4629 4630 default: 4631 sym = gfc_search_interface (ns->op[i], 0, &actual); 4632 } 4633 4634 if (sym != NULL) 4635 break; 4636 } 4637 } 4638 4639 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are 4640 found rather than just taking the first one and not checking further. */ 4641 4642 if (sym == NULL) 4643 { 4644 /* Don't use gfc_free_actual_arglist(). */ 4645 free (actual->next); 4646 free (actual); 4647 return MATCH_NO; 4648 } 4649 4650 /* Change the expression node to a function call. */ 4651 e->expr_type = EXPR_FUNCTION; 4652 e->symtree = gfc_find_sym_in_symtree (sym); 4653 e->value.function.actual = actual; 4654 e->value.function.esym = NULL; 4655 e->value.function.isym = NULL; 4656 e->value.function.name = NULL; 4657 e->user_operator = 1; 4658 4659 if (!gfc_resolve_expr (e)) 4660 return MATCH_ERROR; 4661 4662 return MATCH_YES; 4663} 4664 4665 4666/* Tries to replace an assignment code node with a subroutine call to the 4667 subroutine associated with the assignment operator. Return true if the node 4668 was replaced. On false, no error is generated. */ 4669 4670bool 4671gfc_extend_assign (gfc_code *c, gfc_namespace *ns) 4672{ 4673 gfc_actual_arglist *actual; 4674 gfc_expr *lhs, *rhs, *tb_base; 4675 gfc_symbol *sym = NULL; 4676 const char *gname = NULL; 4677 gfc_typebound_proc* tbo; 4678 4679 lhs = c->expr1; 4680 rhs = c->expr2; 4681 4682 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */ 4683 if (c->op == EXEC_ASSIGN 4684 && c->expr1->expr_type == EXPR_VARIABLE 4685 && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ) 4686 return false; 4687 4688 /* Don't allow an intrinsic assignment to be replaced. */ 4689 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS 4690 && (rhs->rank == 0 || rhs->rank == lhs->rank) 4691 && (lhs->ts.type == rhs->ts.type 4692 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts)))) 4693 return false; 4694 4695 actual = gfc_get_actual_arglist (); 4696 actual->expr = lhs; 4697 4698 actual->next = gfc_get_actual_arglist (); 4699 actual->next->expr = rhs; 4700 4701 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ 4702 4703 /* See if we find a matching type-bound assignment. */ 4704 tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, 4705 NULL, &gname); 4706 4707 if (tbo) 4708 { 4709 /* Success: Replace the expression with a type-bound call. */ 4710 gcc_assert (tb_base); 4711 c->expr1 = gfc_get_expr (); 4712 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); 4713 c->expr1->value.compcall.assign = 1; 4714 c->expr1->where = c->loc; 4715 c->expr2 = NULL; 4716 c->op = EXEC_COMPCALL; 4717 return true; 4718 } 4719 4720 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ 4721 for (; ns; ns = ns->parent) 4722 { 4723 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); 4724 if (sym != NULL) 4725 break; 4726 } 4727 4728 if (sym) 4729 { 4730 /* Success: Replace the assignment with the call. */ 4731 c->op = EXEC_ASSIGN_CALL; 4732 c->symtree = gfc_find_sym_in_symtree (sym); 4733 c->expr1 = NULL; 4734 c->expr2 = NULL; 4735 c->ext.actual = actual; 4736 return true; 4737 } 4738 4739 /* Failure: No assignment procedure found. */ 4740 free (actual->next); 4741 free (actual); 4742 return false; 4743} 4744 4745 4746/* Make sure that the interface just parsed is not already present in 4747 the given interface list. Ambiguity isn't checked yet since module 4748 procedures can be present without interfaces. */ 4749 4750bool 4751gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) 4752{ 4753 gfc_interface *ip; 4754 4755 for (ip = base; ip; ip = ip->next) 4756 { 4757 if (ip->sym == new_sym) 4758 { 4759 gfc_error ("Entity %qs at %L is already present in the interface", 4760 new_sym->name, &loc); 4761 return false; 4762 } 4763 } 4764 4765 return true; 4766} 4767 4768 4769/* Add a symbol to the current interface. */ 4770 4771bool 4772gfc_add_interface (gfc_symbol *new_sym) 4773{ 4774 gfc_interface **head, *intr; 4775 gfc_namespace *ns; 4776 gfc_symbol *sym; 4777 4778 switch (current_interface.type) 4779 { 4780 case INTERFACE_NAMELESS: 4781 case INTERFACE_ABSTRACT: 4782 return true; 4783 4784 case INTERFACE_INTRINSIC_OP: 4785 for (ns = current_interface.ns; ns; ns = ns->parent) 4786 switch (current_interface.op) 4787 { 4788 case INTRINSIC_EQ: 4789 case INTRINSIC_EQ_OS: 4790 if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, 4791 gfc_current_locus) 4792 || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], 4793 new_sym, gfc_current_locus)) 4794 return false; 4795 break; 4796 4797 case INTRINSIC_NE: 4798 case INTRINSIC_NE_OS: 4799 if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, 4800 gfc_current_locus) 4801 || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], 4802 new_sym, gfc_current_locus)) 4803 return false; 4804 break; 4805 4806 case INTRINSIC_GT: 4807 case INTRINSIC_GT_OS: 4808 if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], 4809 new_sym, gfc_current_locus) 4810 || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], 4811 new_sym, gfc_current_locus)) 4812 return false; 4813 break; 4814 4815 case INTRINSIC_GE: 4816 case INTRINSIC_GE_OS: 4817 if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], 4818 new_sym, gfc_current_locus) 4819 || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], 4820 new_sym, gfc_current_locus)) 4821 return false; 4822 break; 4823 4824 case INTRINSIC_LT: 4825 case INTRINSIC_LT_OS: 4826 if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], 4827 new_sym, gfc_current_locus) 4828 || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], 4829 new_sym, gfc_current_locus)) 4830 return false; 4831 break; 4832 4833 case INTRINSIC_LE: 4834 case INTRINSIC_LE_OS: 4835 if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], 4836 new_sym, gfc_current_locus) 4837 || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], 4838 new_sym, gfc_current_locus)) 4839 return false; 4840 break; 4841 4842 default: 4843 if (!gfc_check_new_interface (ns->op[current_interface.op], 4844 new_sym, gfc_current_locus)) 4845 return false; 4846 } 4847 4848 head = ¤t_interface.ns->op[current_interface.op]; 4849 break; 4850 4851 case INTERFACE_GENERIC: 4852 case INTERFACE_DTIO: 4853 for (ns = current_interface.ns; ns; ns = ns->parent) 4854 { 4855 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); 4856 if (sym == NULL) 4857 continue; 4858 4859 if (!gfc_check_new_interface (sym->generic, 4860 new_sym, gfc_current_locus)) 4861 return false; 4862 } 4863 4864 head = ¤t_interface.sym->generic; 4865 break; 4866 4867 case INTERFACE_USER_OP: 4868 if (!gfc_check_new_interface (current_interface.uop->op, 4869 new_sym, gfc_current_locus)) 4870 return false; 4871 4872 head = ¤t_interface.uop->op; 4873 break; 4874 4875 default: 4876 gfc_internal_error ("gfc_add_interface(): Bad interface type"); 4877 } 4878 4879 intr = gfc_get_interface (); 4880 intr->sym = new_sym; 4881 intr->where = gfc_current_locus; 4882 4883 intr->next = *head; 4884 *head = intr; 4885 4886 return true; 4887} 4888 4889 4890gfc_interface * 4891gfc_current_interface_head (void) 4892{ 4893 switch (current_interface.type) 4894 { 4895 case INTERFACE_INTRINSIC_OP: 4896 return current_interface.ns->op[current_interface.op]; 4897 4898 case INTERFACE_GENERIC: 4899 case INTERFACE_DTIO: 4900 return current_interface.sym->generic; 4901 4902 case INTERFACE_USER_OP: 4903 return current_interface.uop->op; 4904 4905 default: 4906 gcc_unreachable (); 4907 } 4908} 4909 4910 4911void 4912gfc_set_current_interface_head (gfc_interface *i) 4913{ 4914 switch (current_interface.type) 4915 { 4916 case INTERFACE_INTRINSIC_OP: 4917 current_interface.ns->op[current_interface.op] = i; 4918 break; 4919 4920 case INTERFACE_GENERIC: 4921 case INTERFACE_DTIO: 4922 current_interface.sym->generic = i; 4923 break; 4924 4925 case INTERFACE_USER_OP: 4926 current_interface.uop->op = i; 4927 break; 4928 4929 default: 4930 gcc_unreachable (); 4931 } 4932} 4933 4934 4935/* Gets rid of a formal argument list. We do not free symbols. 4936 Symbols are freed when a namespace is freed. */ 4937 4938void 4939gfc_free_formal_arglist (gfc_formal_arglist *p) 4940{ 4941 gfc_formal_arglist *q; 4942 4943 for (; p; p = q) 4944 { 4945 q = p->next; 4946 free (p); 4947 } 4948} 4949 4950 4951/* Check that it is ok for the type-bound procedure 'proc' to override the 4952 procedure 'old', cf. F08:4.5.7.3. */ 4953 4954bool 4955gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) 4956{ 4957 locus where; 4958 gfc_symbol *proc_target, *old_target; 4959 unsigned proc_pass_arg, old_pass_arg, argpos; 4960 gfc_formal_arglist *proc_formal, *old_formal; 4961 bool check_type; 4962 char err[200]; 4963 4964 /* This procedure should only be called for non-GENERIC proc. */ 4965 gcc_assert (!proc->n.tb->is_generic); 4966 4967 /* If the overwritten procedure is GENERIC, this is an error. */ 4968 if (old->n.tb->is_generic) 4969 { 4970 gfc_error ("Cannot overwrite GENERIC %qs at %L", 4971 old->name, &proc->n.tb->where); 4972 return false; 4973 } 4974 4975 where = proc->n.tb->where; 4976 proc_target = proc->n.tb->u.specific->n.sym; 4977 old_target = old->n.tb->u.specific->n.sym; 4978 4979 /* Check that overridden binding is not NON_OVERRIDABLE. */ 4980 if (old->n.tb->non_overridable) 4981 { 4982 gfc_error ("%qs at %L overrides a procedure binding declared" 4983 " NON_OVERRIDABLE", proc->name, &where); 4984 return false; 4985 } 4986 4987 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ 4988 if (!old->n.tb->deferred && proc->n.tb->deferred) 4989 { 4990 gfc_error ("%qs at %L must not be DEFERRED as it overrides a" 4991 " non-DEFERRED binding", proc->name, &where); 4992 return false; 4993 } 4994 4995 /* If the overridden binding is PURE, the overriding must be, too. */ 4996 if (old_target->attr.pure && !proc_target->attr.pure) 4997 { 4998 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", 4999 proc->name, &where); 5000 return false; 5001 } 5002 5003 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it 5004 is not, the overriding must not be either. */ 5005 if (old_target->attr.elemental && !proc_target->attr.elemental) 5006 { 5007 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" 5008 " ELEMENTAL", proc->name, &where); 5009 return false; 5010 } 5011 if (!old_target->attr.elemental && proc_target->attr.elemental) 5012 { 5013 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" 5014 " be ELEMENTAL, either", proc->name, &where); 5015 return false; 5016 } 5017 5018 /* If the overridden binding is a SUBROUTINE, the overriding must also be a 5019 SUBROUTINE. */ 5020 if (old_target->attr.subroutine && !proc_target->attr.subroutine) 5021 { 5022 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" 5023 " SUBROUTINE", proc->name, &where); 5024 return false; 5025 } 5026 5027 /* If the overridden binding is a FUNCTION, the overriding must also be a 5028 FUNCTION and have the same characteristics. */ 5029 if (old_target->attr.function) 5030 { 5031 if (!proc_target->attr.function) 5032 { 5033 gfc_error ("%qs at %L overrides a FUNCTION and must also be a" 5034 " FUNCTION", proc->name, &where); 5035 return false; 5036 } 5037 5038 if (!gfc_check_result_characteristics (proc_target, old_target, 5039 err, sizeof(err))) 5040 { 5041 gfc_error ("Result mismatch for the overriding procedure " 5042 "%qs at %L: %s", proc->name, &where, err); 5043 return false; 5044 } 5045 } 5046 5047 /* If the overridden binding is PUBLIC, the overriding one must not be 5048 PRIVATE. */ 5049 if (old->n.tb->access == ACCESS_PUBLIC 5050 && proc->n.tb->access == ACCESS_PRIVATE) 5051 { 5052 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" 5053 " PRIVATE", proc->name, &where); 5054 return false; 5055 } 5056 5057 /* Compare the formal argument lists of both procedures. This is also abused 5058 to find the position of the passed-object dummy arguments of both 5059 bindings as at least the overridden one might not yet be resolved and we 5060 need those positions in the check below. */ 5061 proc_pass_arg = old_pass_arg = 0; 5062 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) 5063 proc_pass_arg = 1; 5064 if (!old->n.tb->nopass && !old->n.tb->pass_arg) 5065 old_pass_arg = 1; 5066 argpos = 1; 5067 proc_formal = gfc_sym_get_dummy_args (proc_target); 5068 old_formal = gfc_sym_get_dummy_args (old_target); 5069 for ( ; proc_formal && old_formal; 5070 proc_formal = proc_formal->next, old_formal = old_formal->next) 5071 { 5072 if (proc->n.tb->pass_arg 5073 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) 5074 proc_pass_arg = argpos; 5075 if (old->n.tb->pass_arg 5076 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) 5077 old_pass_arg = argpos; 5078 5079 /* Check that the names correspond. */ 5080 if (strcmp (proc_formal->sym->name, old_formal->sym->name)) 5081 { 5082 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" 5083 " to match the corresponding argument of the overridden" 5084 " procedure", proc_formal->sym->name, proc->name, &where, 5085 old_formal->sym->name); 5086 return false; 5087 } 5088 5089 check_type = proc_pass_arg != argpos && old_pass_arg != argpos; 5090 if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, 5091 check_type, err, sizeof(err))) 5092 { 5093 gfc_error_opt (0, "Argument mismatch for the overriding procedure " 5094 "%qs at %L: %s", proc->name, &where, err); 5095 return false; 5096 } 5097 5098 ++argpos; 5099 } 5100 if (proc_formal || old_formal) 5101 { 5102 gfc_error ("%qs at %L must have the same number of formal arguments as" 5103 " the overridden procedure", proc->name, &where); 5104 return false; 5105 } 5106 5107 /* If the overridden binding is NOPASS, the overriding one must also be 5108 NOPASS. */ 5109 if (old->n.tb->nopass && !proc->n.tb->nopass) 5110 { 5111 gfc_error ("%qs at %L overrides a NOPASS binding and must also be" 5112 " NOPASS", proc->name, &where); 5113 return false; 5114 } 5115 5116 /* If the overridden binding is PASS(x), the overriding one must also be 5117 PASS and the passed-object dummy arguments must correspond. */ 5118 if (!old->n.tb->nopass) 5119 { 5120 if (proc->n.tb->nopass) 5121 { 5122 gfc_error ("%qs at %L overrides a binding with PASS and must also be" 5123 " PASS", proc->name, &where); 5124 return false; 5125 } 5126 5127 if (proc_pass_arg != old_pass_arg) 5128 { 5129 gfc_error ("Passed-object dummy argument of %qs at %L must be at" 5130 " the same position as the passed-object dummy argument of" 5131 " the overridden procedure", proc->name, &where); 5132 return false; 5133 } 5134 } 5135 5136 return true; 5137} 5138 5139 5140/* The following three functions check that the formal arguments 5141 of user defined derived type IO procedures are compliant with 5142 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */ 5143 5144static void 5145check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, 5146 int kind, int rank, sym_intent intent) 5147{ 5148 if (fsym->ts.type != type) 5149 { 5150 gfc_error ("DTIO dummy argument at %L must be of type %s", 5151 &fsym->declared_at, gfc_basic_typename (type)); 5152 return; 5153 } 5154 5155 if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED 5156 && fsym->ts.kind != kind) 5157 gfc_error ("DTIO dummy argument at %L must be of KIND = %d", 5158 &fsym->declared_at, kind); 5159 5160 if (!typebound 5161 && rank == 0 5162 && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension) 5163 || ((type != BT_CLASS) && fsym->attr.dimension))) 5164 gfc_error ("DTIO dummy argument at %L must be a scalar", 5165 &fsym->declared_at); 5166 else if (rank == 1 5167 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) 5168 gfc_error ("DTIO dummy argument at %L must be an " 5169 "ASSUMED SHAPE ARRAY", &fsym->declared_at); 5170 5171 if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL) 5172 gfc_error ("DTIO character argument at %L must have assumed length", 5173 &fsym->declared_at); 5174 5175 if (fsym->attr.intent != intent) 5176 gfc_error ("DTIO dummy argument at %L must have INTENT %s", 5177 &fsym->declared_at, gfc_code2string (intents, (int)intent)); 5178 return; 5179} 5180 5181 5182static void 5183check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, 5184 bool typebound, bool formatted, int code) 5185{ 5186 gfc_symbol *dtio_sub, *generic_proc, *fsym; 5187 gfc_typebound_proc *tb_io_proc, *specific_proc; 5188 gfc_interface *intr; 5189 gfc_formal_arglist *formal; 5190 int arg_num; 5191 5192 bool read = ((dtio_codes)code == DTIO_RF) 5193 || ((dtio_codes)code == DTIO_RUF); 5194 bt type; 5195 sym_intent intent; 5196 int kind; 5197 5198 dtio_sub = NULL; 5199 if (typebound) 5200 { 5201 /* Typebound DTIO binding. */ 5202 tb_io_proc = tb_io_st->n.tb; 5203 if (tb_io_proc == NULL) 5204 return; 5205 5206 gcc_assert (tb_io_proc->is_generic); 5207 5208 specific_proc = tb_io_proc->u.generic->specific; 5209 if (specific_proc == NULL || specific_proc->is_generic) 5210 return; 5211 5212 dtio_sub = specific_proc->u.specific->n.sym; 5213 } 5214 else 5215 { 5216 generic_proc = tb_io_st->n.sym; 5217 if (generic_proc == NULL || generic_proc->generic == NULL) 5218 return; 5219 5220 for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) 5221 { 5222 if (intr->sym && intr->sym->formal && intr->sym->formal->sym 5223 && ((intr->sym->formal->sym->ts.type == BT_CLASS 5224 && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived 5225 == derived) 5226 || (intr->sym->formal->sym->ts.type == BT_DERIVED 5227 && intr->sym->formal->sym->ts.u.derived == derived))) 5228 { 5229 dtio_sub = intr->sym; 5230 break; 5231 } 5232 else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym) 5233 { 5234 gfc_error ("Alternate return at %L is not permitted in a DTIO " 5235 "procedure", &intr->sym->declared_at); 5236 return; 5237 } 5238 } 5239 5240 if (dtio_sub == NULL) 5241 return; 5242 } 5243 5244 gcc_assert (dtio_sub); 5245 if (!dtio_sub->attr.subroutine) 5246 gfc_error ("DTIO procedure %qs at %L must be a subroutine", 5247 dtio_sub->name, &dtio_sub->declared_at); 5248 5249 if (!dtio_sub->resolve_symbol_called) 5250 gfc_resolve_formal_arglist (dtio_sub); 5251 5252 arg_num = 0; 5253 for (formal = dtio_sub->formal; formal; formal = formal->next) 5254 arg_num++; 5255 5256 if (arg_num < (formatted ? 6 : 4)) 5257 { 5258 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L", 5259 dtio_sub->name, &dtio_sub->declared_at); 5260 return; 5261 } 5262 5263 if (arg_num > (formatted ? 6 : 4)) 5264 { 5265 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L", 5266 dtio_sub->name, &dtio_sub->declared_at); 5267 return; 5268 } 5269 5270 /* Now go through the formal arglist. */ 5271 arg_num = 1; 5272 for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) 5273 { 5274 if (!formatted && arg_num == 3) 5275 arg_num = 5; 5276 fsym = formal->sym; 5277 5278 if (fsym == NULL) 5279 { 5280 gfc_error ("Alternate return at %L is not permitted in a DTIO " 5281 "procedure", &dtio_sub->declared_at); 5282 return; 5283 } 5284 5285 switch (arg_num) 5286 { 5287 case(1): /* DTV */ 5288 type = derived->attr.sequence || derived->attr.is_bind_c ? 5289 BT_DERIVED : BT_CLASS; 5290 kind = 0; 5291 intent = read ? INTENT_INOUT : INTENT_IN; 5292 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5293 0, intent); 5294 break; 5295 5296 case(2): /* UNIT */ 5297 type = BT_INTEGER; 5298 kind = gfc_default_integer_kind; 5299 intent = INTENT_IN; 5300 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5301 0, intent); 5302 break; 5303 case(3): /* IOTYPE */ 5304 type = BT_CHARACTER; 5305 kind = gfc_default_character_kind; 5306 intent = INTENT_IN; 5307 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5308 0, intent); 5309 break; 5310 case(4): /* VLIST */ 5311 type = BT_INTEGER; 5312 kind = gfc_default_integer_kind; 5313 intent = INTENT_IN; 5314 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5315 1, intent); 5316 break; 5317 case(5): /* IOSTAT */ 5318 type = BT_INTEGER; 5319 kind = gfc_default_integer_kind; 5320 intent = INTENT_OUT; 5321 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5322 0, intent); 5323 break; 5324 case(6): /* IOMSG */ 5325 type = BT_CHARACTER; 5326 kind = gfc_default_character_kind; 5327 intent = INTENT_INOUT; 5328 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5329 0, intent); 5330 break; 5331 default: 5332 gcc_unreachable (); 5333 } 5334 } 5335 derived->attr.has_dtio_procs = 1; 5336 return; 5337} 5338 5339void 5340gfc_check_dtio_interfaces (gfc_symbol *derived) 5341{ 5342 gfc_symtree *tb_io_st; 5343 bool t = false; 5344 int code; 5345 bool formatted; 5346 5347 if (derived->attr.is_class == 1 || derived->attr.vtype == 1) 5348 return; 5349 5350 /* Check typebound DTIO bindings. */ 5351 for (code = 0; code < 4; code++) 5352 { 5353 formatted = ((dtio_codes)code == DTIO_RF) 5354 || ((dtio_codes)code == DTIO_WF); 5355 5356 tb_io_st = gfc_find_typebound_proc (derived, &t, 5357 gfc_code2string (dtio_procs, code), 5358 true, &derived->declared_at); 5359 if (tb_io_st != NULL) 5360 check_dtio_interface1 (derived, tb_io_st, true, formatted, code); 5361 } 5362 5363 /* Check generic DTIO interfaces. */ 5364 for (code = 0; code < 4; code++) 5365 { 5366 formatted = ((dtio_codes)code == DTIO_RF) 5367 || ((dtio_codes)code == DTIO_WF); 5368 5369 tb_io_st = gfc_find_symtree (derived->ns->sym_root, 5370 gfc_code2string (dtio_procs, code)); 5371 if (tb_io_st != NULL) 5372 check_dtio_interface1 (derived, tb_io_st, false, formatted, code); 5373 } 5374} 5375 5376 5377gfc_symtree* 5378gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) 5379{ 5380 gfc_symtree *tb_io_st = NULL; 5381 bool t = false; 5382 5383 if (!derived || !derived->resolve_symbol_called 5384 || derived->attr.flavor != FL_DERIVED) 5385 return NULL; 5386 5387 /* Try to find a typebound DTIO binding. */ 5388 if (formatted == true) 5389 { 5390 if (write == true) 5391 tb_io_st = gfc_find_typebound_proc (derived, &t, 5392 gfc_code2string (dtio_procs, 5393 DTIO_WF), 5394 true, 5395 &derived->declared_at); 5396 else 5397 tb_io_st = gfc_find_typebound_proc (derived, &t, 5398 gfc_code2string (dtio_procs, 5399 DTIO_RF), 5400 true, 5401 &derived->declared_at); 5402 } 5403 else 5404 { 5405 if (write == true) 5406 tb_io_st = gfc_find_typebound_proc (derived, &t, 5407 gfc_code2string (dtio_procs, 5408 DTIO_WUF), 5409 true, 5410 &derived->declared_at); 5411 else 5412 tb_io_st = gfc_find_typebound_proc (derived, &t, 5413 gfc_code2string (dtio_procs, 5414 DTIO_RUF), 5415 true, 5416 &derived->declared_at); 5417 } 5418 return tb_io_st; 5419} 5420 5421 5422gfc_symbol * 5423gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) 5424{ 5425 gfc_symtree *tb_io_st = NULL; 5426 gfc_symbol *dtio_sub = NULL; 5427 gfc_symbol *extended; 5428 gfc_typebound_proc *tb_io_proc, *specific_proc; 5429 5430 tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); 5431 5432 if (tb_io_st != NULL) 5433 { 5434 const char *genname; 5435 gfc_symtree *st; 5436 5437 tb_io_proc = tb_io_st->n.tb; 5438 gcc_assert (tb_io_proc != NULL); 5439 gcc_assert (tb_io_proc->is_generic); 5440 gcc_assert (tb_io_proc->u.generic->next == NULL); 5441 5442 specific_proc = tb_io_proc->u.generic->specific; 5443 gcc_assert (!specific_proc->is_generic); 5444 5445 /* Go back and make sure that we have the right specific procedure. 5446 Here we most likely have a procedure from the parent type, which 5447 can be overridden in extensions. */ 5448 genname = tb_io_proc->u.generic->specific_st->name; 5449 st = gfc_find_typebound_proc (derived, NULL, genname, 5450 true, &tb_io_proc->where); 5451 if (st) 5452 dtio_sub = st->n.tb->u.specific->n.sym; 5453 else 5454 dtio_sub = specific_proc->u.specific->n.sym; 5455 5456 goto finish; 5457 } 5458 5459 /* If there is not a typebound binding, look for a generic 5460 DTIO interface. */ 5461 for (extended = derived; extended; 5462 extended = gfc_get_derived_super_type (extended)) 5463 { 5464 if (extended == NULL || extended->ns == NULL 5465 || extended->attr.flavor == FL_UNKNOWN) 5466 return NULL; 5467 5468 if (formatted == true) 5469 { 5470 if (write == true) 5471 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5472 gfc_code2string (dtio_procs, 5473 DTIO_WF)); 5474 else 5475 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5476 gfc_code2string (dtio_procs, 5477 DTIO_RF)); 5478 } 5479 else 5480 { 5481 if (write == true) 5482 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5483 gfc_code2string (dtio_procs, 5484 DTIO_WUF)); 5485 else 5486 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5487 gfc_code2string (dtio_procs, 5488 DTIO_RUF)); 5489 } 5490 5491 if (tb_io_st != NULL 5492 && tb_io_st->n.sym 5493 && tb_io_st->n.sym->generic) 5494 { 5495 for (gfc_interface *intr = tb_io_st->n.sym->generic; 5496 intr && intr->sym; intr = intr->next) 5497 { 5498 if (intr->sym->formal) 5499 { 5500 gfc_symbol *fsym = intr->sym->formal->sym; 5501 if ((fsym->ts.type == BT_CLASS 5502 && CLASS_DATA (fsym)->ts.u.derived == extended) 5503 || (fsym->ts.type == BT_DERIVED 5504 && fsym->ts.u.derived == extended)) 5505 { 5506 dtio_sub = intr->sym; 5507 break; 5508 } 5509 } 5510 } 5511 } 5512 } 5513 5514finish: 5515 if (dtio_sub 5516 && dtio_sub->formal->sym->ts.type == BT_CLASS 5517 && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived) 5518 gfc_find_derived_vtab (derived); 5519 5520 return dtio_sub; 5521} 5522 5523/* Helper function - if we do not find an interface for a procedure, 5524 construct it from the actual arglist. Luckily, this can only 5525 happen for call by reference, so the information we actually need 5526 to provide (and which would be impossible to guess from the call 5527 itself) is not actually needed. */ 5528 5529void 5530gfc_get_formal_from_actual_arglist (gfc_symbol *sym, 5531 gfc_actual_arglist *actual_args) 5532{ 5533 gfc_actual_arglist *a; 5534 gfc_formal_arglist **f; 5535 gfc_symbol *s; 5536 char name[GFC_MAX_SYMBOL_LEN + 1]; 5537 static int var_num; 5538 5539 f = &sym->formal; 5540 for (a = actual_args; a != NULL; a = a->next) 5541 { 5542 (*f) = gfc_get_formal_arglist (); 5543 if (a->expr) 5544 { 5545 snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); 5546 gfc_get_symbol (name, gfc_current_ns, &s); 5547 if (a->expr->ts.type == BT_PROCEDURE) 5548 { 5549 s->attr.flavor = FL_PROCEDURE; 5550 } 5551 else 5552 { 5553 s->ts = a->expr->ts; 5554 5555 if (s->ts.type == BT_CHARACTER) 5556 s->ts.u.cl = gfc_get_charlen (); 5557 5558 s->ts.deferred = 0; 5559 s->ts.is_iso_c = 0; 5560 s->ts.is_c_interop = 0; 5561 s->attr.flavor = FL_VARIABLE; 5562 if (a->expr->rank > 0) 5563 { 5564 s->attr.dimension = 1; 5565 s->as = gfc_get_array_spec (); 5566 s->as->rank = 1; 5567 s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, 5568 &a->expr->where, 1); 5569 s->as->upper[0] = NULL; 5570 s->as->type = AS_ASSUMED_SIZE; 5571 } 5572 else 5573 s->maybe_array = maybe_dummy_array_arg (a->expr); 5574 } 5575 s->attr.dummy = 1; 5576 s->attr.artificial = 1; 5577 s->declared_at = a->expr->where; 5578 s->attr.intent = INTENT_UNKNOWN; 5579 (*f)->sym = s; 5580 } 5581 else /* If a->expr is NULL, this is an alternate rerturn. */ 5582 (*f)->sym = NULL; 5583 5584 f = &((*f)->next); 5585 } 5586} 5587 5588 5589const char * 5590gfc_dummy_arg_get_name (gfc_dummy_arg & dummy_arg) 5591{ 5592 switch (dummy_arg.intrinsicness) 5593 { 5594 case GFC_INTRINSIC_DUMMY_ARG: 5595 return dummy_arg.u.intrinsic->name; 5596 5597 case GFC_NON_INTRINSIC_DUMMY_ARG: 5598 return dummy_arg.u.non_intrinsic->sym->name; 5599 5600 default: 5601 gcc_unreachable (); 5602 } 5603} 5604 5605 5606const gfc_typespec & 5607gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg) 5608{ 5609 switch (dummy_arg.intrinsicness) 5610 { 5611 case GFC_INTRINSIC_DUMMY_ARG: 5612 return dummy_arg.u.intrinsic->ts; 5613 5614 case GFC_NON_INTRINSIC_DUMMY_ARG: 5615 return dummy_arg.u.non_intrinsic->sym->ts; 5616 5617 default: 5618 gcc_unreachable (); 5619 } 5620} 5621 5622 5623bool 5624gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg) 5625{ 5626 switch (dummy_arg.intrinsicness) 5627 { 5628 case GFC_INTRINSIC_DUMMY_ARG: 5629 return dummy_arg.u.intrinsic->optional; 5630 5631 case GFC_NON_INTRINSIC_DUMMY_ARG: 5632 return dummy_arg.u.non_intrinsic->sym->attr.optional; 5633 5634 default: 5635 gcc_unreachable (); 5636 } 5637} 5638