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