1 /* Deal with interfaces. 2 Copyright (C) 2000-2020 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5 This file is part of GCC. 6 7 GCC is free software; you can redistribute it and/or modify it under 8 the terms of the GNU General Public License as published by the Free 9 Software Foundation; either version 3, or (at your option) any later 10 version. 11 12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13 WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GCC; see the file COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 22 /* 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 78 gfc_interface_info current_interface; 79 80 81 /* Free a singly linked list of gfc_interface structures. */ 82 83 void 84 gfc_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 99 static gfc_intrinsic_op 100 fold_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 122 static gfc_intrinsic_op 123 dtio_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 137 match 138 gfc_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 224 syntax: 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 233 match 234 gfc_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 300 match 301 gfc_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 325 match 326 gfc_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 443 static bool 444 is_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 459 static bool 460 is_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 474 static bool 475 compare_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 536 static bool 537 compare_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 610 bool 611 gfc_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 685 bool 686 gfc_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 742 static bool 743 compare_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 752 static bool 753 compare_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 765 static bool 766 compare_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 795 static bool 796 compare_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 806 static bool 807 compare_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 849 static gfc_symbol * 850 find_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 866 bool 867 gfc_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 1098 bad_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 1114 static bool 1115 count_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 1215 static bool 1216 compare_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 1249 static bool 1250 generic_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 1301 static int 1302 symbol_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 1318 bool 1319 gfc_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 1543 bool 1544 gfc_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 1707 bool 1708 gfc_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 1858 static bool 1859 check_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 1950 static bool 1951 check_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 1994 static void 1995 check_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 2034 static void 2035 check_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 2059 gfc_intrinsic_op 2060 gfc_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 2110 void 2111 gfc_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 2160 done: 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 2169 static bool 2170 compare_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 2190 static int 2191 compare_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 2215 static void 2216 argument_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 2262 bool 2263 maybe_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 2321 static bool 2322 compare_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 2753 static unsigned long 2754 get_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 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); 2764 else 2765 return 0; 2766 } 2767 else 2768 strlen = 1; 2769 2770 if (symbol_rank (sym) == 0) 2771 return strlen; 2772 2773 elements = 1; 2774 if (sym->as->type != AS_EXPLICIT) 2775 return 0; 2776 for (i = 0; i < sym->as->rank; i++) 2777 { 2778 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT 2779 || sym->as->lower[i]->expr_type != EXPR_CONSTANT) 2780 return 0; 2781 2782 elements *= mpz_get_si (sym->as->upper[i]->value.integer) 2783 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; 2784 } 2785 2786 return strlen*elements; 2787 } 2788 2789 2790 /* Returns the storage size of an expression (actual argument) or 2791 zero if it cannot be determined. For an array element, it returns 2792 the remaining size as the element sequence consists of all storage 2793 units of the actual argument up to the end of the array. */ 2794 2795 static unsigned long 2796 get_expr_storage_size (gfc_expr *e) 2797 { 2798 int i; 2799 long int strlen, elements; 2800 long int substrlen = 0; 2801 bool is_str_storage = false; 2802 gfc_ref *ref; 2803 2804 if (e == NULL) 2805 return 0; 2806 2807 if (e->ts.type == BT_CHARACTER) 2808 { 2809 if (e->ts.u.cl && e->ts.u.cl->length 2810 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2811 strlen = mpz_get_si (e->ts.u.cl->length->value.integer); 2812 else if (e->expr_type == EXPR_CONSTANT 2813 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) 2814 strlen = e->value.character.length; 2815 else 2816 return 0; 2817 } 2818 else 2819 strlen = 1; /* Length per element. */ 2820 2821 if (e->rank == 0 && !e->ref) 2822 return strlen; 2823 2824 elements = 1; 2825 if (!e->ref) 2826 { 2827 if (!e->shape) 2828 return 0; 2829 for (i = 0; i < e->rank; i++) 2830 elements *= mpz_get_si (e->shape[i]); 2831 return elements*strlen; 2832 } 2833 2834 for (ref = e->ref; ref; ref = ref->next) 2835 { 2836 if (ref->type == REF_SUBSTRING && ref->u.ss.start 2837 && ref->u.ss.start->expr_type == EXPR_CONSTANT) 2838 { 2839 if (is_str_storage) 2840 { 2841 /* The string length is the substring length. 2842 Set now to full string length. */ 2843 if (!ref->u.ss.length || !ref->u.ss.length->length 2844 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT) 2845 return 0; 2846 2847 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer); 2848 } 2849 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1; 2850 continue; 2851 } 2852 2853 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 2854 for (i = 0; i < ref->u.ar.dimen; i++) 2855 { 2856 long int start, end, stride; 2857 stride = 1; 2858 2859 if (ref->u.ar.stride[i]) 2860 { 2861 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT) 2862 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer); 2863 else 2864 return 0; 2865 } 2866 2867 if (ref->u.ar.start[i]) 2868 { 2869 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT) 2870 start = mpz_get_si (ref->u.ar.start[i]->value.integer); 2871 else 2872 return 0; 2873 } 2874 else if (ref->u.ar.as->lower[i] 2875 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT) 2876 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer); 2877 else 2878 return 0; 2879 2880 if (ref->u.ar.end[i]) 2881 { 2882 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT) 2883 end = mpz_get_si (ref->u.ar.end[i]->value.integer); 2884 else 2885 return 0; 2886 } 2887 else if (ref->u.ar.as->upper[i] 2888 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT) 2889 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer); 2890 else 2891 return 0; 2892 2893 elements *= (end - start)/stride + 1L; 2894 } 2895 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL) 2896 for (i = 0; i < ref->u.ar.as->rank; i++) 2897 { 2898 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] 2899 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT 2900 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER 2901 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT 2902 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) 2903 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2904 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2905 + 1L; 2906 else 2907 return 0; 2908 } 2909 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT 2910 && e->expr_type == EXPR_VARIABLE) 2911 { 2912 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE 2913 || e->symtree->n.sym->attr.pointer) 2914 { 2915 elements = 1; 2916 continue; 2917 } 2918 2919 /* Determine the number of remaining elements in the element 2920 sequence for array element designators. */ 2921 is_str_storage = true; 2922 for (i = ref->u.ar.dimen - 1; i >= 0; i--) 2923 { 2924 if (ref->u.ar.start[i] == NULL 2925 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT 2926 || ref->u.ar.as->upper[i] == NULL 2927 || ref->u.ar.as->lower[i] == NULL 2928 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT 2929 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT) 2930 return 0; 2931 2932 elements 2933 = elements 2934 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer) 2935 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) 2936 + 1L) 2937 - (mpz_get_si (ref->u.ar.start[i]->value.integer) 2938 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)); 2939 } 2940 } 2941 else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function 2942 && ref->u.c.component->attr.proc_pointer 2943 && ref->u.c.component->attr.dimension) 2944 { 2945 /* Array-valued procedure-pointer components. */ 2946 gfc_array_spec *as = ref->u.c.component->as; 2947 for (i = 0; i < as->rank; i++) 2948 { 2949 if (!as->upper[i] || !as->lower[i] 2950 || as->upper[i]->expr_type != EXPR_CONSTANT 2951 || as->lower[i]->expr_type != EXPR_CONSTANT) 2952 return 0; 2953 2954 elements = elements 2955 * (mpz_get_si (as->upper[i]->value.integer) 2956 - mpz_get_si (as->lower[i]->value.integer) + 1L); 2957 } 2958 } 2959 } 2960 2961 if (substrlen) 2962 return (is_str_storage) ? substrlen + (elements-1)*strlen 2963 : elements*strlen; 2964 else 2965 return elements*strlen; 2966 } 2967 2968 2969 /* Given an expression, check whether it is an array section 2970 which has a vector subscript. */ 2971 2972 bool 2973 gfc_has_vector_subscript (gfc_expr *e) 2974 { 2975 int i; 2976 gfc_ref *ref; 2977 2978 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) 2979 return false; 2980 2981 for (ref = e->ref; ref; ref = ref->next) 2982 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 2983 for (i = 0; i < ref->u.ar.dimen; i++) 2984 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 2985 return true; 2986 2987 return false; 2988 } 2989 2990 2991 static bool 2992 is_procptr_result (gfc_expr *expr) 2993 { 2994 gfc_component *c = gfc_get_proc_ptr_comp (expr); 2995 if (c) 2996 return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); 2997 else 2998 return ((expr->symtree->n.sym->result != expr->symtree->n.sym) 2999 && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); 3000 } 3001 3002 3003 /* Recursively append candidate argument ARG to CANDIDATES. Store the 3004 number of total candidates in CANDIDATES_LEN. */ 3005 3006 static void 3007 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg, 3008 char **&candidates, 3009 size_t &candidates_len) 3010 { 3011 for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next) 3012 vec_push (candidates, candidates_len, p->sym->name); 3013 } 3014 3015 3016 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */ 3017 3018 static const char* 3019 lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) 3020 { 3021 char **candidates = NULL; 3022 size_t candidates_len = 0; 3023 lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len); 3024 return gfc_closest_fuzzy_match (arg, candidates); 3025 } 3026 3027 3028 /* Given formal and actual argument lists, see if they are compatible. 3029 If they are compatible, the actual argument list is sorted to 3030 correspond with the formal list, and elements for missing optional 3031 arguments are inserted. If WHERE pointer is nonnull, then we issue 3032 errors when things don't match instead of just returning the status 3033 code. */ 3034 3035 bool 3036 gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 3037 int ranks_must_agree, int is_elemental, 3038 bool in_statement_function, locus *where) 3039 { 3040 gfc_actual_arglist **new_arg, *a, *actual; 3041 gfc_formal_arglist *f; 3042 int i, n, na; 3043 unsigned long actual_size, formal_size; 3044 bool full_array = false; 3045 gfc_array_ref *actual_arr_ref; 3046 3047 actual = *ap; 3048 3049 if (actual == NULL && formal == NULL) 3050 return true; 3051 3052 n = 0; 3053 for (f = formal; f; f = f->next) 3054 n++; 3055 3056 new_arg = XALLOCAVEC (gfc_actual_arglist *, n); 3057 3058 for (i = 0; i < n; i++) 3059 new_arg[i] = NULL; 3060 3061 na = 0; 3062 f = formal; 3063 i = 0; 3064 3065 for (a = actual; a; a = a->next, f = f->next) 3066 { 3067 if (a->name != NULL && in_statement_function) 3068 { 3069 gfc_error ("Keyword argument %qs at %L is invalid in " 3070 "a statement function", a->name, &a->expr->where); 3071 return false; 3072 } 3073 3074 /* Look for keywords but ignore g77 extensions like %VAL. */ 3075 if (a->name != NULL && a->name[0] != '%') 3076 { 3077 i = 0; 3078 for (f = formal; f; f = f->next, i++) 3079 { 3080 if (f->sym == NULL) 3081 continue; 3082 if (strcmp (f->sym->name, a->name) == 0) 3083 break; 3084 } 3085 3086 if (f == NULL) 3087 { 3088 if (where) 3089 { 3090 const char *guessed = lookup_arg_fuzzy (a->name, formal); 3091 if (guessed) 3092 gfc_error ("Keyword argument %qs at %L is not in " 3093 "the procedure; did you mean %qs?", 3094 a->name, &a->expr->where, guessed); 3095 else 3096 gfc_error ("Keyword argument %qs at %L is not in " 3097 "the procedure", a->name, &a->expr->where); 3098 } 3099 return false; 3100 } 3101 3102 if (new_arg[i] != NULL) 3103 { 3104 if (where) 3105 gfc_error ("Keyword argument %qs at %L is already associated " 3106 "with another actual argument", a->name, 3107 &a->expr->where); 3108 return false; 3109 } 3110 } 3111 3112 if (f == NULL) 3113 { 3114 if (where) 3115 gfc_error ("More actual than formal arguments in procedure " 3116 "call at %L", where); 3117 3118 return false; 3119 } 3120 3121 if (f->sym == NULL && a->expr == NULL) 3122 goto match; 3123 3124 if (f->sym == NULL) 3125 { 3126 /* These errors have to be issued, otherwise an ICE can occur. 3127 See PR 78865. */ 3128 if (where) 3129 gfc_error_now ("Missing alternate return specifier in subroutine " 3130 "call at %L", where); 3131 return false; 3132 } 3133 3134 if (a->expr == NULL) 3135 { 3136 if (f->sym->attr.optional) 3137 continue; 3138 else 3139 { 3140 if (where) 3141 gfc_error_now ("Unexpected alternate return specifier in " 3142 "subroutine call at %L", where); 3143 return false; 3144 } 3145 } 3146 3147 /* Make sure that intrinsic vtables exist for calls to unlimited 3148 polymorphic formal arguments. */ 3149 if (UNLIMITED_POLY (f->sym) 3150 && a->expr->ts.type != BT_DERIVED 3151 && a->expr->ts.type != BT_CLASS 3152 && a->expr->ts.type != BT_ASSUMED) 3153 gfc_find_vtab (&a->expr->ts); 3154 3155 if (a->expr->expr_type == EXPR_NULL 3156 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer 3157 && (f->sym->attr.allocatable || !f->sym->attr.optional 3158 || (gfc_option.allow_std & GFC_STD_F2008) == 0)) 3159 || (f->sym->ts.type == BT_CLASS 3160 && !CLASS_DATA (f->sym)->attr.class_pointer 3161 && (CLASS_DATA (f->sym)->attr.allocatable 3162 || !f->sym->attr.optional 3163 || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) 3164 { 3165 if (where 3166 && (!f->sym->attr.optional 3167 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) 3168 || (f->sym->ts.type == BT_CLASS 3169 && CLASS_DATA (f->sym)->attr.allocatable))) 3170 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", 3171 where, f->sym->name); 3172 else if (where) 3173 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " 3174 "dummy %qs", where, f->sym->name); 3175 3176 return false; 3177 } 3178 3179 if (!compare_parameter (f->sym, a->expr, ranks_must_agree, 3180 is_elemental, where)) 3181 return false; 3182 3183 /* TS 29113, 6.3p2. */ 3184 if (f->sym->ts.type == BT_ASSUMED 3185 && (a->expr->ts.type == BT_DERIVED 3186 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) 3187 { 3188 gfc_namespace *f2k_derived; 3189 3190 f2k_derived = a->expr->ts.type == BT_DERIVED 3191 ? a->expr->ts.u.derived->f2k_derived 3192 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived; 3193 3194 if (f2k_derived 3195 && (f2k_derived->finalizers || f2k_derived->tb_sym_root)) 3196 { 3197 gfc_error ("Actual argument at %L to assumed-type dummy is of " 3198 "derived type with type-bound or FINAL procedures", 3199 &a->expr->where); 3200 return false; 3201 } 3202 } 3203 3204 /* Special case for character arguments. For allocatable, pointer 3205 and assumed-shape dummies, the string length needs to match 3206 exactly. */ 3207 if (a->expr->ts.type == BT_CHARACTER 3208 && a->expr->ts.u.cl && a->expr->ts.u.cl->length 3209 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT 3210 && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl 3211 && f->sym->ts.u.cl->length 3212 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT 3213 && (f->sym->attr.pointer || f->sym->attr.allocatable 3214 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 3215 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, 3216 f->sym->ts.u.cl->length->value.integer) != 0)) 3217 { 3218 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) 3219 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " 3220 "argument and pointer or allocatable dummy argument " 3221 "%qs at %L", 3222 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 3223 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 3224 f->sym->name, &a->expr->where); 3225 else if (where) 3226 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " 3227 "argument and assumed-shape dummy argument %qs " 3228 "at %L", 3229 mpz_get_si (a->expr->ts.u.cl->length->value.integer), 3230 mpz_get_si (f->sym->ts.u.cl->length->value.integer), 3231 f->sym->name, &a->expr->where); 3232 return false; 3233 } 3234 3235 if ((f->sym->attr.pointer || f->sym->attr.allocatable) 3236 && f->sym->ts.deferred != a->expr->ts.deferred 3237 && a->expr->ts.type == BT_CHARACTER) 3238 { 3239 if (where) 3240 gfc_error ("Actual argument at %L to allocatable or " 3241 "pointer dummy argument %qs must have a deferred " 3242 "length type parameter if and only if the dummy has one", 3243 &a->expr->where, f->sym->name); 3244 return false; 3245 } 3246 3247 if (f->sym->ts.type == BT_CLASS) 3248 goto skip_size_check; 3249 3250 actual_size = get_expr_storage_size (a->expr); 3251 formal_size = get_sym_storage_size (f->sym); 3252 if (actual_size != 0 && actual_size < formal_size 3253 && a->expr->ts.type != BT_PROCEDURE 3254 && f->sym->attr.flavor != FL_PROCEDURE) 3255 { 3256 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) 3257 { 3258 gfc_warning (0, "Character length of actual argument shorter " 3259 "than of dummy argument %qs (%lu/%lu) at %L", 3260 f->sym->name, actual_size, formal_size, 3261 &a->expr->where); 3262 goto skip_size_check; 3263 } 3264 else if (where) 3265 { 3266 /* Emit a warning for -std=legacy and an error otherwise. */ 3267 if (gfc_option.warn_std == 0) 3268 gfc_warning (0, "Actual argument contains too few " 3269 "elements for dummy argument %qs (%lu/%lu) " 3270 "at %L", f->sym->name, actual_size, 3271 formal_size, &a->expr->where); 3272 else 3273 gfc_error_now ("Actual argument contains too few " 3274 "elements for dummy argument %qs (%lu/%lu) " 3275 "at %L", f->sym->name, actual_size, 3276 formal_size, &a->expr->where); 3277 } 3278 return false; 3279 } 3280 3281 skip_size_check: 3282 3283 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual 3284 argument is provided for a procedure pointer formal argument. */ 3285 if (f->sym->attr.proc_pointer 3286 && !((a->expr->expr_type == EXPR_VARIABLE 3287 && (a->expr->symtree->n.sym->attr.proc_pointer 3288 || gfc_is_proc_ptr_comp (a->expr))) 3289 || (a->expr->expr_type == EXPR_FUNCTION 3290 && is_procptr_result (a->expr)))) 3291 { 3292 if (where) 3293 gfc_error ("Expected a procedure pointer for argument %qs at %L", 3294 f->sym->name, &a->expr->where); 3295 return false; 3296 } 3297 3298 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is 3299 provided for a procedure formal argument. */ 3300 if (f->sym->attr.flavor == FL_PROCEDURE 3301 && !((a->expr->expr_type == EXPR_VARIABLE 3302 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE 3303 || a->expr->symtree->n.sym->attr.proc_pointer 3304 || gfc_is_proc_ptr_comp (a->expr))) 3305 || (a->expr->expr_type == EXPR_FUNCTION 3306 && is_procptr_result (a->expr)))) 3307 { 3308 if (where) 3309 gfc_error ("Expected a procedure for argument %qs at %L", 3310 f->sym->name, &a->expr->where); 3311 return false; 3312 } 3313 3314 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE 3315 && a->expr->expr_type == EXPR_VARIABLE 3316 && a->expr->symtree->n.sym->as 3317 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE 3318 && (a->expr->ref == NULL 3319 || (a->expr->ref->type == REF_ARRAY 3320 && a->expr->ref->u.ar.type == AR_FULL))) 3321 { 3322 if (where) 3323 gfc_error ("Actual argument for %qs cannot be an assumed-size" 3324 " array at %L", f->sym->name, where); 3325 return false; 3326 } 3327 3328 if (a->expr->expr_type != EXPR_NULL 3329 && compare_pointer (f->sym, a->expr) == 0) 3330 { 3331 if (where) 3332 gfc_error ("Actual argument for %qs must be a pointer at %L", 3333 f->sym->name, &a->expr->where); 3334 return false; 3335 } 3336 3337 if (a->expr->expr_type != EXPR_NULL 3338 && (gfc_option.allow_std & GFC_STD_F2008) == 0 3339 && compare_pointer (f->sym, a->expr) == 2) 3340 { 3341 if (where) 3342 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " 3343 "pointer dummy %qs", &a->expr->where,f->sym->name); 3344 return false; 3345 } 3346 3347 3348 /* Fortran 2008, C1242. */ 3349 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) 3350 { 3351 if (where) 3352 gfc_error ("Coindexed actual argument at %L to pointer " 3353 "dummy %qs", 3354 &a->expr->where, f->sym->name); 3355 return false; 3356 } 3357 3358 /* Fortran 2008, 12.5.2.5 (no constraint). */ 3359 if (a->expr->expr_type == EXPR_VARIABLE 3360 && f->sym->attr.intent != INTENT_IN 3361 && f->sym->attr.allocatable 3362 && gfc_is_coindexed (a->expr)) 3363 { 3364 if (where) 3365 gfc_error ("Coindexed actual argument at %L to allocatable " 3366 "dummy %qs requires INTENT(IN)", 3367 &a->expr->where, f->sym->name); 3368 return false; 3369 } 3370 3371 /* Fortran 2008, C1237. */ 3372 if (a->expr->expr_type == EXPR_VARIABLE 3373 && (f->sym->attr.asynchronous || f->sym->attr.volatile_) 3374 && gfc_is_coindexed (a->expr) 3375 && (a->expr->symtree->n.sym->attr.volatile_ 3376 || a->expr->symtree->n.sym->attr.asynchronous)) 3377 { 3378 if (where) 3379 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " 3380 "%L requires that dummy %qs has neither " 3381 "ASYNCHRONOUS nor VOLATILE", &a->expr->where, 3382 f->sym->name); 3383 return false; 3384 } 3385 3386 /* Fortran 2008, 12.5.2.4 (no constraint). */ 3387 if (a->expr->expr_type == EXPR_VARIABLE 3388 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value 3389 && gfc_is_coindexed (a->expr) 3390 && gfc_has_ultimate_allocatable (a->expr)) 3391 { 3392 if (where) 3393 gfc_error ("Coindexed actual argument at %L with allocatable " 3394 "ultimate component to dummy %qs requires either VALUE " 3395 "or INTENT(IN)", &a->expr->where, f->sym->name); 3396 return false; 3397 } 3398 3399 if (f->sym->ts.type == BT_CLASS 3400 && CLASS_DATA (f->sym)->attr.allocatable 3401 && gfc_is_class_array_ref (a->expr, &full_array) 3402 && !full_array) 3403 { 3404 if (where) 3405 gfc_error ("Actual CLASS array argument for %qs must be a full " 3406 "array at %L", f->sym->name, &a->expr->where); 3407 return false; 3408 } 3409 3410 3411 if (a->expr->expr_type != EXPR_NULL 3412 && !compare_allocatable (f->sym, a->expr)) 3413 { 3414 if (where) 3415 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", 3416 f->sym->name, &a->expr->where); 3417 return false; 3418 } 3419 3420 /* Check intent = OUT/INOUT for definable actual argument. */ 3421 if (!in_statement_function 3422 && (f->sym->attr.intent == INTENT_OUT 3423 || f->sym->attr.intent == INTENT_INOUT)) 3424 { 3425 const char* context = (where 3426 ? _("actual argument to INTENT = OUT/INOUT") 3427 : NULL); 3428 3429 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3430 && CLASS_DATA (f->sym)->attr.class_pointer) 3431 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3432 && !gfc_check_vardef_context (a->expr, true, false, false, context)) 3433 return false; 3434 if (!gfc_check_vardef_context (a->expr, false, false, false, context)) 3435 return false; 3436 } 3437 3438 if ((f->sym->attr.intent == INTENT_OUT 3439 || f->sym->attr.intent == INTENT_INOUT 3440 || f->sym->attr.volatile_ 3441 || f->sym->attr.asynchronous) 3442 && gfc_has_vector_subscript (a->expr)) 3443 { 3444 if (where) 3445 gfc_error ("Array-section actual argument with vector " 3446 "subscripts at %L is incompatible with INTENT(OUT), " 3447 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " 3448 "of the dummy argument %qs", 3449 &a->expr->where, f->sym->name); 3450 return false; 3451 } 3452 3453 /* C1232 (R1221) For an actual argument which is an array section or 3454 an assumed-shape array, the dummy argument shall be an assumed- 3455 shape array, if the dummy argument has the VOLATILE attribute. */ 3456 3457 if (f->sym->attr.volatile_ 3458 && a->expr->expr_type == EXPR_VARIABLE 3459 && a->expr->symtree->n.sym->as 3460 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE 3461 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 3462 { 3463 if (where) 3464 gfc_error ("Assumed-shape actual argument at %L is " 3465 "incompatible with the non-assumed-shape " 3466 "dummy argument %qs due to VOLATILE attribute", 3467 &a->expr->where,f->sym->name); 3468 return false; 3469 } 3470 3471 /* Find the last array_ref. */ 3472 actual_arr_ref = NULL; 3473 if (a->expr->ref) 3474 actual_arr_ref = gfc_find_array_ref (a->expr, true); 3475 3476 if (f->sym->attr.volatile_ 3477 && actual_arr_ref && actual_arr_ref->type == AR_SECTION 3478 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) 3479 { 3480 if (where) 3481 gfc_error ("Array-section actual argument at %L is " 3482 "incompatible with the non-assumed-shape " 3483 "dummy argument %qs due to VOLATILE attribute", 3484 &a->expr->where, f->sym->name); 3485 return false; 3486 } 3487 3488 /* C1233 (R1221) For an actual argument which is a pointer array, the 3489 dummy argument shall be an assumed-shape or pointer array, if the 3490 dummy argument has the VOLATILE attribute. */ 3491 3492 if (f->sym->attr.volatile_ 3493 && a->expr->expr_type == EXPR_VARIABLE 3494 && a->expr->symtree->n.sym->attr.pointer 3495 && a->expr->symtree->n.sym->as 3496 && !(f->sym->as 3497 && (f->sym->as->type == AS_ASSUMED_SHAPE 3498 || f->sym->attr.pointer))) 3499 { 3500 if (where) 3501 gfc_error ("Pointer-array actual argument at %L requires " 3502 "an assumed-shape or pointer-array dummy " 3503 "argument %qs due to VOLATILE attribute", 3504 &a->expr->where,f->sym->name); 3505 return false; 3506 } 3507 3508 match: 3509 if (a == actual) 3510 na = i; 3511 3512 new_arg[i++] = a; 3513 } 3514 3515 /* Make sure missing actual arguments are optional. */ 3516 i = 0; 3517 for (f = formal; f; f = f->next, i++) 3518 { 3519 if (new_arg[i] != NULL) 3520 continue; 3521 if (f->sym == NULL) 3522 { 3523 if (where) 3524 gfc_error ("Missing alternate return spec in subroutine call " 3525 "at %L", where); 3526 return false; 3527 } 3528 if (!f->sym->attr.optional 3529 || (in_statement_function && f->sym->attr.optional)) 3530 { 3531 if (where) 3532 gfc_error ("Missing actual argument for argument %qs at %L", 3533 f->sym->name, where); 3534 return false; 3535 } 3536 } 3537 3538 /* The argument lists are compatible. We now relink a new actual 3539 argument list with null arguments in the right places. The head 3540 of the list remains the head. */ 3541 for (i = 0; i < n; i++) 3542 if (new_arg[i] == NULL) 3543 new_arg[i] = gfc_get_actual_arglist (); 3544 3545 if (na != 0) 3546 { 3547 std::swap (*new_arg[0], *actual); 3548 std::swap (new_arg[0], new_arg[na]); 3549 } 3550 3551 for (i = 0; i < n - 1; i++) 3552 new_arg[i]->next = new_arg[i + 1]; 3553 3554 new_arg[i]->next = NULL; 3555 3556 if (*ap == NULL && n > 0) 3557 *ap = new_arg[0]; 3558 3559 /* Note the types of omitted optional arguments. */ 3560 for (a = *ap, f = formal; a; a = a->next, f = f->next) 3561 if (a->expr == NULL && a->label == NULL) 3562 a->missing_arg_type = f->sym->ts.type; 3563 3564 return true; 3565 } 3566 3567 3568 typedef struct 3569 { 3570 gfc_formal_arglist *f; 3571 gfc_actual_arglist *a; 3572 } 3573 argpair; 3574 3575 /* qsort comparison function for argument pairs, with the following 3576 order: 3577 - p->a->expr == NULL 3578 - p->a->expr->expr_type != EXPR_VARIABLE 3579 - by gfc_symbol pointer value (larger first). */ 3580 3581 static int 3582 pair_cmp (const void *p1, const void *p2) 3583 { 3584 const gfc_actual_arglist *a1, *a2; 3585 3586 /* *p1 and *p2 are elements of the to-be-sorted array. */ 3587 a1 = ((const argpair *) p1)->a; 3588 a2 = ((const argpair *) p2)->a; 3589 if (!a1->expr) 3590 { 3591 if (!a2->expr) 3592 return 0; 3593 return -1; 3594 } 3595 if (!a2->expr) 3596 return 1; 3597 if (a1->expr->expr_type != EXPR_VARIABLE) 3598 { 3599 if (a2->expr->expr_type != EXPR_VARIABLE) 3600 return 0; 3601 return -1; 3602 } 3603 if (a2->expr->expr_type != EXPR_VARIABLE) 3604 return 1; 3605 if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym) 3606 return -1; 3607 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; 3608 } 3609 3610 3611 /* Given two expressions from some actual arguments, test whether they 3612 refer to the same expression. The analysis is conservative. 3613 Returning false will produce no warning. */ 3614 3615 static bool 3616 compare_actual_expr (gfc_expr *e1, gfc_expr *e2) 3617 { 3618 const gfc_ref *r1, *r2; 3619 3620 if (!e1 || !e2 3621 || e1->expr_type != EXPR_VARIABLE 3622 || e2->expr_type != EXPR_VARIABLE 3623 || e1->symtree->n.sym != e2->symtree->n.sym) 3624 return false; 3625 3626 /* TODO: improve comparison, see expr.c:show_ref(). */ 3627 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) 3628 { 3629 if (r1->type != r2->type) 3630 return false; 3631 switch (r1->type) 3632 { 3633 case REF_ARRAY: 3634 if (r1->u.ar.type != r2->u.ar.type) 3635 return false; 3636 /* TODO: At the moment, consider only full arrays; 3637 we could do better. */ 3638 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) 3639 return false; 3640 break; 3641 3642 case REF_COMPONENT: 3643 if (r1->u.c.component != r2->u.c.component) 3644 return false; 3645 break; 3646 3647 case REF_SUBSTRING: 3648 return false; 3649 3650 case REF_INQUIRY: 3651 if (e1->symtree->n.sym->ts.type == BT_COMPLEX 3652 && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL 3653 && r1->u.i != r2->u.i) 3654 return false; 3655 break; 3656 3657 default: 3658 gfc_internal_error ("compare_actual_expr(): Bad component code"); 3659 } 3660 } 3661 if (!r1 && !r2) 3662 return true; 3663 return false; 3664 } 3665 3666 3667 /* Given formal and actual argument lists that correspond to one 3668 another, check that identical actual arguments aren't not 3669 associated with some incompatible INTENTs. */ 3670 3671 static bool 3672 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) 3673 { 3674 sym_intent f1_intent, f2_intent; 3675 gfc_formal_arglist *f1; 3676 gfc_actual_arglist *a1; 3677 size_t n, i, j; 3678 argpair *p; 3679 bool t = true; 3680 3681 n = 0; 3682 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) 3683 { 3684 if (f1 == NULL && a1 == NULL) 3685 break; 3686 if (f1 == NULL || a1 == NULL) 3687 gfc_internal_error ("check_some_aliasing(): List mismatch"); 3688 n++; 3689 } 3690 if (n == 0) 3691 return t; 3692 p = XALLOCAVEC (argpair, n); 3693 3694 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) 3695 { 3696 p[i].f = f1; 3697 p[i].a = a1; 3698 } 3699 3700 qsort (p, n, sizeof (argpair), pair_cmp); 3701 3702 for (i = 0; i < n; i++) 3703 { 3704 if (!p[i].a->expr 3705 || p[i].a->expr->expr_type != EXPR_VARIABLE 3706 || p[i].a->expr->ts.type == BT_PROCEDURE) 3707 continue; 3708 f1_intent = p[i].f->sym->attr.intent; 3709 for (j = i + 1; j < n; j++) 3710 { 3711 /* Expected order after the sort. */ 3712 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) 3713 gfc_internal_error ("check_some_aliasing(): corrupted data"); 3714 3715 /* Are the expression the same? */ 3716 if (!compare_actual_expr (p[i].a->expr, p[j].a->expr)) 3717 break; 3718 f2_intent = p[j].f->sym->attr.intent; 3719 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) 3720 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN) 3721 || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT)) 3722 { 3723 gfc_warning (0, "Same actual argument associated with INTENT(%s) " 3724 "argument %qs and INTENT(%s) argument %qs at %L", 3725 gfc_intent_string (f1_intent), p[i].f->sym->name, 3726 gfc_intent_string (f2_intent), p[j].f->sym->name, 3727 &p[i].a->expr->where); 3728 t = false; 3729 } 3730 } 3731 } 3732 3733 return t; 3734 } 3735 3736 3737 /* Given formal and actual argument lists that correspond to one 3738 another, check that they are compatible in the sense that intents 3739 are not mismatched. */ 3740 3741 static bool 3742 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 3743 { 3744 sym_intent f_intent; 3745 3746 for (;; f = f->next, a = a->next) 3747 { 3748 gfc_expr *expr; 3749 3750 if (f == NULL && a == NULL) 3751 break; 3752 if (f == NULL || a == NULL) 3753 gfc_internal_error ("check_intents(): List mismatch"); 3754 3755 if (a->expr && a->expr->expr_type == EXPR_FUNCTION 3756 && a->expr->value.function.isym 3757 && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET) 3758 expr = a->expr->value.function.actual->expr; 3759 else 3760 expr = a->expr; 3761 3762 if (expr == NULL || expr->expr_type != EXPR_VARIABLE) 3763 continue; 3764 3765 f_intent = f->sym->attr.intent; 3766 3767 if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym)) 3768 { 3769 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3770 && CLASS_DATA (f->sym)->attr.class_pointer) 3771 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3772 { 3773 gfc_error ("Procedure argument at %L is local to a PURE " 3774 "procedure and has the POINTER attribute", 3775 &expr->where); 3776 return false; 3777 } 3778 } 3779 3780 /* Fortran 2008, C1283. */ 3781 if (gfc_pure (NULL) && gfc_is_coindexed (expr)) 3782 { 3783 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) 3784 { 3785 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3786 "is passed to an INTENT(%s) argument", 3787 &expr->where, gfc_intent_string (f_intent)); 3788 return false; 3789 } 3790 3791 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok 3792 && CLASS_DATA (f->sym)->attr.class_pointer) 3793 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) 3794 { 3795 gfc_error ("Coindexed actual argument at %L in PURE procedure " 3796 "is passed to a POINTER dummy argument", 3797 &expr->where); 3798 return false; 3799 } 3800 } 3801 3802 /* F2008, Section 12.5.2.4. */ 3803 if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS 3804 && gfc_is_coindexed (expr)) 3805 { 3806 gfc_error ("Coindexed polymorphic actual argument at %L is passed " 3807 "polymorphic dummy argument %qs", 3808 &expr->where, f->sym->name); 3809 return false; 3810 } 3811 } 3812 3813 return true; 3814 } 3815 3816 3817 /* Check how a procedure is used against its interface. If all goes 3818 well, the actual argument list will also end up being properly 3819 sorted. */ 3820 3821 bool 3822 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) 3823 { 3824 gfc_actual_arglist *a; 3825 gfc_formal_arglist *dummy_args; 3826 bool implicit = false; 3827 3828 /* Warn about calls with an implicit interface. Special case 3829 for calling a ISO_C_BINDING because c_loc and c_funloc 3830 are pseudo-unknown. Additionally, warn about procedures not 3831 explicitly declared at all if requested. */ 3832 if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) 3833 { 3834 bool has_implicit_none_export = false; 3835 implicit = true; 3836 if (sym->attr.proc == PROC_UNKNOWN) 3837 for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) 3838 if (ns->has_implicit_none_export) 3839 { 3840 has_implicit_none_export = true; 3841 break; 3842 } 3843 if (has_implicit_none_export) 3844 { 3845 const char *guessed 3846 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); 3847 if (guessed) 3848 gfc_error ("Procedure %qs called at %L is not explicitly declared" 3849 "; did you mean %qs?", 3850 sym->name, where, guessed); 3851 else 3852 gfc_error ("Procedure %qs called at %L is not explicitly declared", 3853 sym->name, where); 3854 return false; 3855 } 3856 if (warn_implicit_interface) 3857 gfc_warning (OPT_Wimplicit_interface, 3858 "Procedure %qs called with an implicit interface at %L", 3859 sym->name, where); 3860 else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN) 3861 gfc_warning (OPT_Wimplicit_procedure, 3862 "Procedure %qs called at %L is not explicitly declared", 3863 sym->name, where); 3864 gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1; 3865 } 3866 3867 if (sym->attr.if_source == IFSRC_UNKNOWN) 3868 { 3869 if (sym->attr.pointer) 3870 { 3871 gfc_error ("The pointer object %qs at %L must have an explicit " 3872 "function interface or be declared as array", 3873 sym->name, where); 3874 return false; 3875 } 3876 3877 if (sym->attr.allocatable && !sym->attr.external) 3878 { 3879 gfc_error ("The allocatable object %qs at %L must have an explicit " 3880 "function interface or be declared as array", 3881 sym->name, where); 3882 return false; 3883 } 3884 3885 if (sym->attr.allocatable) 3886 { 3887 gfc_error ("Allocatable function %qs at %L must have an explicit " 3888 "function interface", sym->name, where); 3889 return false; 3890 } 3891 3892 for (a = *ap; a; a = a->next) 3893 { 3894 if (a->expr && a->expr->error) 3895 return false; 3896 3897 /* F2018, 15.4.2.2 Explicit interface is required for a 3898 polymorphic dummy argument, so there is no way to 3899 legally have a class appear in an argument with an 3900 implicit interface. */ 3901 3902 if (implicit && a->expr && a->expr->ts.type == BT_CLASS) 3903 { 3904 gfc_error ("Explicit interface required for polymorphic " 3905 "argument at %L",&a->expr->where); 3906 a->expr->error = 1; 3907 break; 3908 } 3909 3910 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 3911 if (a->name != NULL && a->name[0] != '%') 3912 { 3913 gfc_error ("Keyword argument requires explicit interface " 3914 "for procedure %qs at %L", sym->name, &a->expr->where); 3915 break; 3916 } 3917 3918 /* TS 29113, 6.2. */ 3919 if (a->expr && a->expr->ts.type == BT_ASSUMED 3920 && sym->intmod_sym_id != ISOCBINDING_LOC) 3921 { 3922 gfc_error ("Assumed-type argument %s at %L requires an explicit " 3923 "interface", a->expr->symtree->n.sym->name, 3924 &a->expr->where); 3925 a->expr->error = 1; 3926 break; 3927 } 3928 3929 /* F2008, C1303 and C1304. */ 3930 if (a->expr 3931 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 3932 && a->expr->ts.u.derived 3933 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3934 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 3935 || gfc_expr_attr (a->expr).lock_comp)) 3936 { 3937 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " 3938 "component at %L requires an explicit interface for " 3939 "procedure %qs", &a->expr->where, sym->name); 3940 a->expr->error = 1; 3941 break; 3942 } 3943 3944 if (a->expr 3945 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) 3946 && a->expr->ts.u.derived 3947 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 3948 && a->expr->ts.u.derived->intmod_sym_id 3949 == ISOFORTRAN_EVENT_TYPE) 3950 || gfc_expr_attr (a->expr).event_comp)) 3951 { 3952 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " 3953 "component at %L requires an explicit interface for " 3954 "procedure %qs", &a->expr->where, sym->name); 3955 a->expr->error = 1; 3956 break; 3957 } 3958 3959 if (a->expr && a->expr->expr_type == EXPR_NULL 3960 && a->expr->ts.type == BT_UNKNOWN) 3961 { 3962 gfc_error ("MOLD argument to NULL required at %L", 3963 &a->expr->where); 3964 a->expr->error = 1; 3965 return false; 3966 } 3967 3968 /* TS 29113, C407b. */ 3969 if (a->expr && a->expr->expr_type == EXPR_VARIABLE 3970 && symbol_rank (a->expr->symtree->n.sym) == -1) 3971 { 3972 gfc_error ("Assumed-rank argument requires an explicit interface " 3973 "at %L", &a->expr->where); 3974 a->expr->error = 1; 3975 return false; 3976 } 3977 } 3978 3979 return true; 3980 } 3981 3982 dummy_args = gfc_sym_get_dummy_args (sym); 3983 3984 /* For a statement function, check that types and type parameters of actual 3985 arguments and dummy arguments match. */ 3986 if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, 3987 sym->attr.proc == PROC_ST_FUNCTION, where)) 3988 return false; 3989 3990 if (!check_intents (dummy_args, *ap)) 3991 return false; 3992 3993 if (warn_aliasing) 3994 check_some_aliasing (dummy_args, *ap); 3995 3996 return true; 3997 } 3998 3999 4000 /* Check how a procedure pointer component is used against its interface. 4001 If all goes well, the actual argument list will also end up being properly 4002 sorted. Completely analogous to gfc_procedure_use. */ 4003 4004 void 4005 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) 4006 { 4007 /* Warn about calls with an implicit interface. Special case 4008 for calling a ISO_C_BINDING because c_loc and c_funloc 4009 are pseudo-unknown. */ 4010 if (warn_implicit_interface 4011 && comp->attr.if_source == IFSRC_UNKNOWN 4012 && !comp->attr.is_iso_c) 4013 gfc_warning (OPT_Wimplicit_interface, 4014 "Procedure pointer component %qs called with an implicit " 4015 "interface at %L", comp->name, where); 4016 4017 if (comp->attr.if_source == IFSRC_UNKNOWN) 4018 { 4019 gfc_actual_arglist *a; 4020 for (a = *ap; a; a = a->next) 4021 { 4022 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ 4023 if (a->name != NULL && a->name[0] != '%') 4024 { 4025 gfc_error ("Keyword argument requires explicit interface " 4026 "for procedure pointer component %qs at %L", 4027 comp->name, &a->expr->where); 4028 break; 4029 } 4030 } 4031 4032 return; 4033 } 4034 4035 if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0, 4036 comp->attr.elemental, false, where)) 4037 return; 4038 4039 check_intents (comp->ts.interface->formal, *ap); 4040 if (warn_aliasing) 4041 check_some_aliasing (comp->ts.interface->formal, *ap); 4042 } 4043 4044 4045 /* Try if an actual argument list matches the formal list of a symbol, 4046 respecting the symbol's attributes like ELEMENTAL. This is used for 4047 GENERIC resolution. */ 4048 4049 bool 4050 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) 4051 { 4052 gfc_formal_arglist *dummy_args; 4053 bool r; 4054 4055 if (sym->attr.flavor != FL_PROCEDURE) 4056 return false; 4057 4058 dummy_args = gfc_sym_get_dummy_args (sym); 4059 4060 r = !sym->attr.elemental; 4061 if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL)) 4062 { 4063 check_intents (dummy_args, *args); 4064 if (warn_aliasing) 4065 check_some_aliasing (dummy_args, *args); 4066 return true; 4067 } 4068 4069 return false; 4070 } 4071 4072 4073 /* Given an interface pointer and an actual argument list, search for 4074 a formal argument list that matches the actual. If found, returns 4075 a pointer to the symbol of the correct interface. Returns NULL if 4076 not found. */ 4077 4078 gfc_symbol * 4079 gfc_search_interface (gfc_interface *intr, int sub_flag, 4080 gfc_actual_arglist **ap) 4081 { 4082 gfc_symbol *elem_sym = NULL; 4083 gfc_symbol *null_sym = NULL; 4084 locus null_expr_loc; 4085 gfc_actual_arglist *a; 4086 bool has_null_arg = false; 4087 4088 for (a = *ap; a; a = a->next) 4089 if (a->expr && a->expr->expr_type == EXPR_NULL 4090 && a->expr->ts.type == BT_UNKNOWN) 4091 { 4092 has_null_arg = true; 4093 null_expr_loc = a->expr->where; 4094 break; 4095 } 4096 4097 for (; intr; intr = intr->next) 4098 { 4099 if (gfc_fl_struct (intr->sym->attr.flavor)) 4100 continue; 4101 if (sub_flag && intr->sym->attr.function) 4102 continue; 4103 if (!sub_flag && intr->sym->attr.subroutine) 4104 continue; 4105 4106 if (gfc_arglist_matches_symbol (ap, intr->sym)) 4107 { 4108 if (has_null_arg && null_sym) 4109 { 4110 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " 4111 "between specific functions %s and %s", 4112 &null_expr_loc, null_sym->name, intr->sym->name); 4113 return NULL; 4114 } 4115 else if (has_null_arg) 4116 { 4117 null_sym = intr->sym; 4118 continue; 4119 } 4120 4121 /* Satisfy 12.4.4.1 such that an elemental match has lower 4122 weight than a non-elemental match. */ 4123 if (intr->sym->attr.elemental) 4124 { 4125 elem_sym = intr->sym; 4126 continue; 4127 } 4128 return intr->sym; 4129 } 4130 } 4131 4132 if (null_sym) 4133 return null_sym; 4134 4135 return elem_sym ? elem_sym : NULL; 4136 } 4137 4138 4139 /* Do a brute force recursive search for a symbol. */ 4140 4141 static gfc_symtree * 4142 find_symtree0 (gfc_symtree *root, gfc_symbol *sym) 4143 { 4144 gfc_symtree * st; 4145 4146 if (root->n.sym == sym) 4147 return root; 4148 4149 st = NULL; 4150 if (root->left) 4151 st = find_symtree0 (root->left, sym); 4152 if (root->right && ! st) 4153 st = find_symtree0 (root->right, sym); 4154 return st; 4155 } 4156 4157 4158 /* Find a symtree for a symbol. */ 4159 4160 gfc_symtree * 4161 gfc_find_sym_in_symtree (gfc_symbol *sym) 4162 { 4163 gfc_symtree *st; 4164 gfc_namespace *ns; 4165 4166 /* First try to find it by name. */ 4167 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); 4168 if (st && st->n.sym == sym) 4169 return st; 4170 4171 /* If it's been renamed, resort to a brute-force search. */ 4172 /* TODO: avoid having to do this search. If the symbol doesn't exist 4173 in the symtree for the current namespace, it should probably be added. */ 4174 for (ns = gfc_current_ns; ns; ns = ns->parent) 4175 { 4176 st = find_symtree0 (ns->sym_root, sym); 4177 if (st) 4178 return st; 4179 } 4180 gfc_internal_error ("Unable to find symbol %qs", sym->name); 4181 /* Not reached. */ 4182 } 4183 4184 4185 /* See if the arglist to an operator-call contains a derived-type argument 4186 with a matching type-bound operator. If so, return the matching specific 4187 procedure defined as operator-target as well as the base-object to use 4188 (which is the found derived-type argument with operator). The generic 4189 name, if any, is transmitted to the final expression via 'gname'. */ 4190 4191 static gfc_typebound_proc* 4192 matching_typebound_op (gfc_expr** tb_base, 4193 gfc_actual_arglist* args, 4194 gfc_intrinsic_op op, const char* uop, 4195 const char ** gname) 4196 { 4197 gfc_actual_arglist* base; 4198 4199 for (base = args; base; base = base->next) 4200 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS) 4201 { 4202 gfc_typebound_proc* tb; 4203 gfc_symbol* derived; 4204 bool result; 4205 4206 while (base->expr->expr_type == EXPR_OP 4207 && base->expr->value.op.op == INTRINSIC_PARENTHESES) 4208 base->expr = base->expr->value.op.op1; 4209 4210 if (base->expr->ts.type == BT_CLASS) 4211 { 4212 if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL 4213 || !gfc_expr_attr (base->expr).class_ok) 4214 continue; 4215 derived = CLASS_DATA (base->expr)->ts.u.derived; 4216 } 4217 else 4218 derived = base->expr->ts.u.derived; 4219 4220 if (op == INTRINSIC_USER) 4221 { 4222 gfc_symtree* tb_uop; 4223 4224 gcc_assert (uop); 4225 tb_uop = gfc_find_typebound_user_op (derived, &result, uop, 4226 false, NULL); 4227 4228 if (tb_uop) 4229 tb = tb_uop->n.tb; 4230 else 4231 tb = NULL; 4232 } 4233 else 4234 tb = gfc_find_typebound_intrinsic_op (derived, &result, op, 4235 false, NULL); 4236 4237 /* This means we hit a PRIVATE operator which is use-associated and 4238 should thus not be seen. */ 4239 if (!result) 4240 tb = NULL; 4241 4242 /* Look through the super-type hierarchy for a matching specific 4243 binding. */ 4244 for (; tb; tb = tb->overridden) 4245 { 4246 gfc_tbp_generic* g; 4247 4248 gcc_assert (tb->is_generic); 4249 for (g = tb->u.generic; g; g = g->next) 4250 { 4251 gfc_symbol* target; 4252 gfc_actual_arglist* argcopy; 4253 bool matches; 4254 4255 gcc_assert (g->specific); 4256 if (g->specific->error) 4257 continue; 4258 4259 target = g->specific->u.specific->n.sym; 4260 4261 /* Check if this arglist matches the formal. */ 4262 argcopy = gfc_copy_actual_arglist (args); 4263 matches = gfc_arglist_matches_symbol (&argcopy, target); 4264 gfc_free_actual_arglist (argcopy); 4265 4266 /* Return if we found a match. */ 4267 if (matches) 4268 { 4269 *tb_base = base->expr; 4270 *gname = g->specific_st->name; 4271 return g->specific; 4272 } 4273 } 4274 } 4275 } 4276 4277 return NULL; 4278 } 4279 4280 4281 /* For the 'actual arglist' of an operator call and a specific typebound 4282 procedure that has been found the target of a type-bound operator, build the 4283 appropriate EXPR_COMPCALL and resolve it. We take this indirection over 4284 type-bound procedures rather than resolving type-bound operators 'directly' 4285 so that we can reuse the existing logic. */ 4286 4287 static void 4288 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, 4289 gfc_expr* base, gfc_typebound_proc* target, 4290 const char *gname) 4291 { 4292 e->expr_type = EXPR_COMPCALL; 4293 e->value.compcall.tbp = target; 4294 e->value.compcall.name = gname ? gname : "$op"; 4295 e->value.compcall.actual = actual; 4296 e->value.compcall.base_object = base; 4297 e->value.compcall.ignore_pass = 1; 4298 e->value.compcall.assign = 0; 4299 if (e->ts.type == BT_UNKNOWN 4300 && target->function) 4301 { 4302 if (target->is_generic) 4303 e->ts = target->u.generic->specific->u.specific->n.sym->ts; 4304 else 4305 e->ts = target->u.specific->n.sym->ts; 4306 } 4307 } 4308 4309 4310 /* This subroutine is called when an expression is being resolved. 4311 The expression node in question is either a user defined operator 4312 or an intrinsic operator with arguments that aren't compatible 4313 with the operator. This subroutine builds an actual argument list 4314 corresponding to the operands, then searches for a compatible 4315 interface. If one is found, the expression node is replaced with 4316 the appropriate function call. We use the 'match' enum to specify 4317 whether a replacement has been made or not, or if an error occurred. */ 4318 4319 match 4320 gfc_extend_expr (gfc_expr *e) 4321 { 4322 gfc_actual_arglist *actual; 4323 gfc_symbol *sym; 4324 gfc_namespace *ns; 4325 gfc_user_op *uop; 4326 gfc_intrinsic_op i; 4327 const char *gname; 4328 gfc_typebound_proc* tbo; 4329 gfc_expr* tb_base; 4330 4331 sym = NULL; 4332 4333 actual = gfc_get_actual_arglist (); 4334 actual->expr = e->value.op.op1; 4335 4336 gname = NULL; 4337 4338 if (e->value.op.op2 != NULL) 4339 { 4340 actual->next = gfc_get_actual_arglist (); 4341 actual->next->expr = e->value.op.op2; 4342 } 4343 4344 i = fold_unary_intrinsic (e->value.op.op); 4345 4346 /* See if we find a matching type-bound operator. */ 4347 if (i == INTRINSIC_USER) 4348 tbo = matching_typebound_op (&tb_base, actual, 4349 i, e->value.op.uop->name, &gname); 4350 else 4351 switch (i) 4352 { 4353 #define CHECK_OS_COMPARISON(comp) \ 4354 case INTRINSIC_##comp: \ 4355 case INTRINSIC_##comp##_OS: \ 4356 tbo = matching_typebound_op (&tb_base, actual, \ 4357 INTRINSIC_##comp, NULL, &gname); \ 4358 if (!tbo) \ 4359 tbo = matching_typebound_op (&tb_base, actual, \ 4360 INTRINSIC_##comp##_OS, NULL, &gname); \ 4361 break; 4362 CHECK_OS_COMPARISON(EQ) 4363 CHECK_OS_COMPARISON(NE) 4364 CHECK_OS_COMPARISON(GT) 4365 CHECK_OS_COMPARISON(GE) 4366 CHECK_OS_COMPARISON(LT) 4367 CHECK_OS_COMPARISON(LE) 4368 #undef CHECK_OS_COMPARISON 4369 4370 default: 4371 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); 4372 break; 4373 } 4374 4375 /* If there is a matching typebound-operator, replace the expression with 4376 a call to it and succeed. */ 4377 if (tbo) 4378 { 4379 gcc_assert (tb_base); 4380 build_compcall_for_operator (e, actual, tb_base, tbo, gname); 4381 4382 if (!gfc_resolve_expr (e)) 4383 return MATCH_ERROR; 4384 else 4385 return MATCH_YES; 4386 } 4387 4388 if (i == INTRINSIC_USER) 4389 { 4390 for (ns = gfc_current_ns; ns; ns = ns->parent) 4391 { 4392 uop = gfc_find_uop (e->value.op.uop->name, ns); 4393 if (uop == NULL) 4394 continue; 4395 4396 sym = gfc_search_interface (uop->op, 0, &actual); 4397 if (sym != NULL) 4398 break; 4399 } 4400 } 4401 else 4402 { 4403 for (ns = gfc_current_ns; ns; ns = ns->parent) 4404 { 4405 /* Due to the distinction between '==' and '.eq.' and friends, one has 4406 to check if either is defined. */ 4407 switch (i) 4408 { 4409 #define CHECK_OS_COMPARISON(comp) \ 4410 case INTRINSIC_##comp: \ 4411 case INTRINSIC_##comp##_OS: \ 4412 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ 4413 if (!sym) \ 4414 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ 4415 break; 4416 CHECK_OS_COMPARISON(EQ) 4417 CHECK_OS_COMPARISON(NE) 4418 CHECK_OS_COMPARISON(GT) 4419 CHECK_OS_COMPARISON(GE) 4420 CHECK_OS_COMPARISON(LT) 4421 CHECK_OS_COMPARISON(LE) 4422 #undef CHECK_OS_COMPARISON 4423 4424 default: 4425 sym = gfc_search_interface (ns->op[i], 0, &actual); 4426 } 4427 4428 if (sym != NULL) 4429 break; 4430 } 4431 } 4432 4433 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are 4434 found rather than just taking the first one and not checking further. */ 4435 4436 if (sym == NULL) 4437 { 4438 /* Don't use gfc_free_actual_arglist(). */ 4439 free (actual->next); 4440 free (actual); 4441 return MATCH_NO; 4442 } 4443 4444 /* Change the expression node to a function call. */ 4445 e->expr_type = EXPR_FUNCTION; 4446 e->symtree = gfc_find_sym_in_symtree (sym); 4447 e->value.function.actual = actual; 4448 e->value.function.esym = NULL; 4449 e->value.function.isym = NULL; 4450 e->value.function.name = NULL; 4451 e->user_operator = 1; 4452 4453 if (!gfc_resolve_expr (e)) 4454 return MATCH_ERROR; 4455 4456 return MATCH_YES; 4457 } 4458 4459 4460 /* Tries to replace an assignment code node with a subroutine call to the 4461 subroutine associated with the assignment operator. Return true if the node 4462 was replaced. On false, no error is generated. */ 4463 4464 bool 4465 gfc_extend_assign (gfc_code *c, gfc_namespace *ns) 4466 { 4467 gfc_actual_arglist *actual; 4468 gfc_expr *lhs, *rhs, *tb_base; 4469 gfc_symbol *sym = NULL; 4470 const char *gname = NULL; 4471 gfc_typebound_proc* tbo; 4472 4473 lhs = c->expr1; 4474 rhs = c->expr2; 4475 4476 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */ 4477 if (c->op == EXEC_ASSIGN 4478 && c->expr1->expr_type == EXPR_VARIABLE 4479 && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ) 4480 return false; 4481 4482 /* Don't allow an intrinsic assignment to be replaced. */ 4483 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS 4484 && (rhs->rank == 0 || rhs->rank == lhs->rank) 4485 && (lhs->ts.type == rhs->ts.type 4486 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts)))) 4487 return false; 4488 4489 actual = gfc_get_actual_arglist (); 4490 actual->expr = lhs; 4491 4492 actual->next = gfc_get_actual_arglist (); 4493 actual->next->expr = rhs; 4494 4495 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ 4496 4497 /* See if we find a matching type-bound assignment. */ 4498 tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, 4499 NULL, &gname); 4500 4501 if (tbo) 4502 { 4503 /* Success: Replace the expression with a type-bound call. */ 4504 gcc_assert (tb_base); 4505 c->expr1 = gfc_get_expr (); 4506 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); 4507 c->expr1->value.compcall.assign = 1; 4508 c->expr1->where = c->loc; 4509 c->expr2 = NULL; 4510 c->op = EXEC_COMPCALL; 4511 return true; 4512 } 4513 4514 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ 4515 for (; ns; ns = ns->parent) 4516 { 4517 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); 4518 if (sym != NULL) 4519 break; 4520 } 4521 4522 if (sym) 4523 { 4524 /* Success: Replace the assignment with the call. */ 4525 c->op = EXEC_ASSIGN_CALL; 4526 c->symtree = gfc_find_sym_in_symtree (sym); 4527 c->expr1 = NULL; 4528 c->expr2 = NULL; 4529 c->ext.actual = actual; 4530 return true; 4531 } 4532 4533 /* Failure: No assignment procedure found. */ 4534 free (actual->next); 4535 free (actual); 4536 return false; 4537 } 4538 4539 4540 /* Make sure that the interface just parsed is not already present in 4541 the given interface list. Ambiguity isn't checked yet since module 4542 procedures can be present without interfaces. */ 4543 4544 bool 4545 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) 4546 { 4547 gfc_interface *ip; 4548 4549 for (ip = base; ip; ip = ip->next) 4550 { 4551 if (ip->sym == new_sym) 4552 { 4553 gfc_error ("Entity %qs at %L is already present in the interface", 4554 new_sym->name, &loc); 4555 return false; 4556 } 4557 } 4558 4559 return true; 4560 } 4561 4562 4563 /* Add a symbol to the current interface. */ 4564 4565 bool 4566 gfc_add_interface (gfc_symbol *new_sym) 4567 { 4568 gfc_interface **head, *intr; 4569 gfc_namespace *ns; 4570 gfc_symbol *sym; 4571 4572 switch (current_interface.type) 4573 { 4574 case INTERFACE_NAMELESS: 4575 case INTERFACE_ABSTRACT: 4576 return true; 4577 4578 case INTERFACE_INTRINSIC_OP: 4579 for (ns = current_interface.ns; ns; ns = ns->parent) 4580 switch (current_interface.op) 4581 { 4582 case INTRINSIC_EQ: 4583 case INTRINSIC_EQ_OS: 4584 if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, 4585 gfc_current_locus) 4586 || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], 4587 new_sym, gfc_current_locus)) 4588 return false; 4589 break; 4590 4591 case INTRINSIC_NE: 4592 case INTRINSIC_NE_OS: 4593 if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, 4594 gfc_current_locus) 4595 || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], 4596 new_sym, gfc_current_locus)) 4597 return false; 4598 break; 4599 4600 case INTRINSIC_GT: 4601 case INTRINSIC_GT_OS: 4602 if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], 4603 new_sym, gfc_current_locus) 4604 || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], 4605 new_sym, gfc_current_locus)) 4606 return false; 4607 break; 4608 4609 case INTRINSIC_GE: 4610 case INTRINSIC_GE_OS: 4611 if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], 4612 new_sym, gfc_current_locus) 4613 || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], 4614 new_sym, gfc_current_locus)) 4615 return false; 4616 break; 4617 4618 case INTRINSIC_LT: 4619 case INTRINSIC_LT_OS: 4620 if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], 4621 new_sym, gfc_current_locus) 4622 || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], 4623 new_sym, gfc_current_locus)) 4624 return false; 4625 break; 4626 4627 case INTRINSIC_LE: 4628 case INTRINSIC_LE_OS: 4629 if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], 4630 new_sym, gfc_current_locus) 4631 || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], 4632 new_sym, gfc_current_locus)) 4633 return false; 4634 break; 4635 4636 default: 4637 if (!gfc_check_new_interface (ns->op[current_interface.op], 4638 new_sym, gfc_current_locus)) 4639 return false; 4640 } 4641 4642 head = ¤t_interface.ns->op[current_interface.op]; 4643 break; 4644 4645 case INTERFACE_GENERIC: 4646 case INTERFACE_DTIO: 4647 for (ns = current_interface.ns; ns; ns = ns->parent) 4648 { 4649 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); 4650 if (sym == NULL) 4651 continue; 4652 4653 if (!gfc_check_new_interface (sym->generic, 4654 new_sym, gfc_current_locus)) 4655 return false; 4656 } 4657 4658 head = ¤t_interface.sym->generic; 4659 break; 4660 4661 case INTERFACE_USER_OP: 4662 if (!gfc_check_new_interface (current_interface.uop->op, 4663 new_sym, gfc_current_locus)) 4664 return false; 4665 4666 head = ¤t_interface.uop->op; 4667 break; 4668 4669 default: 4670 gfc_internal_error ("gfc_add_interface(): Bad interface type"); 4671 } 4672 4673 intr = gfc_get_interface (); 4674 intr->sym = new_sym; 4675 intr->where = gfc_current_locus; 4676 4677 intr->next = *head; 4678 *head = intr; 4679 4680 return true; 4681 } 4682 4683 4684 gfc_interface * 4685 gfc_current_interface_head (void) 4686 { 4687 switch (current_interface.type) 4688 { 4689 case INTERFACE_INTRINSIC_OP: 4690 return current_interface.ns->op[current_interface.op]; 4691 4692 case INTERFACE_GENERIC: 4693 case INTERFACE_DTIO: 4694 return current_interface.sym->generic; 4695 4696 case INTERFACE_USER_OP: 4697 return current_interface.uop->op; 4698 4699 default: 4700 gcc_unreachable (); 4701 } 4702 } 4703 4704 4705 void 4706 gfc_set_current_interface_head (gfc_interface *i) 4707 { 4708 switch (current_interface.type) 4709 { 4710 case INTERFACE_INTRINSIC_OP: 4711 current_interface.ns->op[current_interface.op] = i; 4712 break; 4713 4714 case INTERFACE_GENERIC: 4715 case INTERFACE_DTIO: 4716 current_interface.sym->generic = i; 4717 break; 4718 4719 case INTERFACE_USER_OP: 4720 current_interface.uop->op = i; 4721 break; 4722 4723 default: 4724 gcc_unreachable (); 4725 } 4726 } 4727 4728 4729 /* Gets rid of a formal argument list. We do not free symbols. 4730 Symbols are freed when a namespace is freed. */ 4731 4732 void 4733 gfc_free_formal_arglist (gfc_formal_arglist *p) 4734 { 4735 gfc_formal_arglist *q; 4736 4737 for (; p; p = q) 4738 { 4739 q = p->next; 4740 free (p); 4741 } 4742 } 4743 4744 4745 /* Check that it is ok for the type-bound procedure 'proc' to override the 4746 procedure 'old', cf. F08:4.5.7.3. */ 4747 4748 bool 4749 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) 4750 { 4751 locus where; 4752 gfc_symbol *proc_target, *old_target; 4753 unsigned proc_pass_arg, old_pass_arg, argpos; 4754 gfc_formal_arglist *proc_formal, *old_formal; 4755 bool check_type; 4756 char err[200]; 4757 4758 /* This procedure should only be called for non-GENERIC proc. */ 4759 gcc_assert (!proc->n.tb->is_generic); 4760 4761 /* If the overwritten procedure is GENERIC, this is an error. */ 4762 if (old->n.tb->is_generic) 4763 { 4764 gfc_error ("Cannot overwrite GENERIC %qs at %L", 4765 old->name, &proc->n.tb->where); 4766 return false; 4767 } 4768 4769 where = proc->n.tb->where; 4770 proc_target = proc->n.tb->u.specific->n.sym; 4771 old_target = old->n.tb->u.specific->n.sym; 4772 4773 /* Check that overridden binding is not NON_OVERRIDABLE. */ 4774 if (old->n.tb->non_overridable) 4775 { 4776 gfc_error ("%qs at %L overrides a procedure binding declared" 4777 " NON_OVERRIDABLE", proc->name, &where); 4778 return false; 4779 } 4780 4781 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ 4782 if (!old->n.tb->deferred && proc->n.tb->deferred) 4783 { 4784 gfc_error ("%qs at %L must not be DEFERRED as it overrides a" 4785 " non-DEFERRED binding", proc->name, &where); 4786 return false; 4787 } 4788 4789 /* If the overridden binding is PURE, the overriding must be, too. */ 4790 if (old_target->attr.pure && !proc_target->attr.pure) 4791 { 4792 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", 4793 proc->name, &where); 4794 return false; 4795 } 4796 4797 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it 4798 is not, the overriding must not be either. */ 4799 if (old_target->attr.elemental && !proc_target->attr.elemental) 4800 { 4801 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" 4802 " ELEMENTAL", proc->name, &where); 4803 return false; 4804 } 4805 if (!old_target->attr.elemental && proc_target->attr.elemental) 4806 { 4807 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" 4808 " be ELEMENTAL, either", proc->name, &where); 4809 return false; 4810 } 4811 4812 /* If the overridden binding is a SUBROUTINE, the overriding must also be a 4813 SUBROUTINE. */ 4814 if (old_target->attr.subroutine && !proc_target->attr.subroutine) 4815 { 4816 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" 4817 " SUBROUTINE", proc->name, &where); 4818 return false; 4819 } 4820 4821 /* If the overridden binding is a FUNCTION, the overriding must also be a 4822 FUNCTION and have the same characteristics. */ 4823 if (old_target->attr.function) 4824 { 4825 if (!proc_target->attr.function) 4826 { 4827 gfc_error ("%qs at %L overrides a FUNCTION and must also be a" 4828 " FUNCTION", proc->name, &where); 4829 return false; 4830 } 4831 4832 if (!gfc_check_result_characteristics (proc_target, old_target, 4833 err, sizeof(err))) 4834 { 4835 gfc_error ("Result mismatch for the overriding procedure " 4836 "%qs at %L: %s", proc->name, &where, err); 4837 return false; 4838 } 4839 } 4840 4841 /* If the overridden binding is PUBLIC, the overriding one must not be 4842 PRIVATE. */ 4843 if (old->n.tb->access == ACCESS_PUBLIC 4844 && proc->n.tb->access == ACCESS_PRIVATE) 4845 { 4846 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" 4847 " PRIVATE", proc->name, &where); 4848 return false; 4849 } 4850 4851 /* Compare the formal argument lists of both procedures. This is also abused 4852 to find the position of the passed-object dummy arguments of both 4853 bindings as at least the overridden one might not yet be resolved and we 4854 need those positions in the check below. */ 4855 proc_pass_arg = old_pass_arg = 0; 4856 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) 4857 proc_pass_arg = 1; 4858 if (!old->n.tb->nopass && !old->n.tb->pass_arg) 4859 old_pass_arg = 1; 4860 argpos = 1; 4861 proc_formal = gfc_sym_get_dummy_args (proc_target); 4862 old_formal = gfc_sym_get_dummy_args (old_target); 4863 for ( ; proc_formal && old_formal; 4864 proc_formal = proc_formal->next, old_formal = old_formal->next) 4865 { 4866 if (proc->n.tb->pass_arg 4867 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) 4868 proc_pass_arg = argpos; 4869 if (old->n.tb->pass_arg 4870 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) 4871 old_pass_arg = argpos; 4872 4873 /* Check that the names correspond. */ 4874 if (strcmp (proc_formal->sym->name, old_formal->sym->name)) 4875 { 4876 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" 4877 " to match the corresponding argument of the overridden" 4878 " procedure", proc_formal->sym->name, proc->name, &where, 4879 old_formal->sym->name); 4880 return false; 4881 } 4882 4883 check_type = proc_pass_arg != argpos && old_pass_arg != argpos; 4884 if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, 4885 check_type, err, sizeof(err))) 4886 { 4887 gfc_error_opt (0, "Argument mismatch for the overriding procedure " 4888 "%qs at %L: %s", proc->name, &where, err); 4889 return false; 4890 } 4891 4892 ++argpos; 4893 } 4894 if (proc_formal || old_formal) 4895 { 4896 gfc_error ("%qs at %L must have the same number of formal arguments as" 4897 " the overridden procedure", proc->name, &where); 4898 return false; 4899 } 4900 4901 /* If the overridden binding is NOPASS, the overriding one must also be 4902 NOPASS. */ 4903 if (old->n.tb->nopass && !proc->n.tb->nopass) 4904 { 4905 gfc_error ("%qs at %L overrides a NOPASS binding and must also be" 4906 " NOPASS", proc->name, &where); 4907 return false; 4908 } 4909 4910 /* If the overridden binding is PASS(x), the overriding one must also be 4911 PASS and the passed-object dummy arguments must correspond. */ 4912 if (!old->n.tb->nopass) 4913 { 4914 if (proc->n.tb->nopass) 4915 { 4916 gfc_error ("%qs at %L overrides a binding with PASS and must also be" 4917 " PASS", proc->name, &where); 4918 return false; 4919 } 4920 4921 if (proc_pass_arg != old_pass_arg) 4922 { 4923 gfc_error ("Passed-object dummy argument of %qs at %L must be at" 4924 " the same position as the passed-object dummy argument of" 4925 " the overridden procedure", proc->name, &where); 4926 return false; 4927 } 4928 } 4929 4930 return true; 4931 } 4932 4933 4934 /* The following three functions check that the formal arguments 4935 of user defined derived type IO procedures are compliant with 4936 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */ 4937 4938 static void 4939 check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, 4940 int kind, int rank, sym_intent intent) 4941 { 4942 if (fsym->ts.type != type) 4943 { 4944 gfc_error ("DTIO dummy argument at %L must be of type %s", 4945 &fsym->declared_at, gfc_basic_typename (type)); 4946 return; 4947 } 4948 4949 if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED 4950 && fsym->ts.kind != kind) 4951 gfc_error ("DTIO dummy argument at %L must be of KIND = %d", 4952 &fsym->declared_at, kind); 4953 4954 if (!typebound 4955 && rank == 0 4956 && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension) 4957 || ((type != BT_CLASS) && fsym->attr.dimension))) 4958 gfc_error ("DTIO dummy argument at %L must be a scalar", 4959 &fsym->declared_at); 4960 else if (rank == 1 4961 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) 4962 gfc_error ("DTIO dummy argument at %L must be an " 4963 "ASSUMED SHAPE ARRAY", &fsym->declared_at); 4964 4965 if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL) 4966 gfc_error ("DTIO character argument at %L must have assumed length", 4967 &fsym->declared_at); 4968 4969 if (fsym->attr.intent != intent) 4970 gfc_error ("DTIO dummy argument at %L must have INTENT %s", 4971 &fsym->declared_at, gfc_code2string (intents, (int)intent)); 4972 return; 4973 } 4974 4975 4976 static void 4977 check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, 4978 bool typebound, bool formatted, int code) 4979 { 4980 gfc_symbol *dtio_sub, *generic_proc, *fsym; 4981 gfc_typebound_proc *tb_io_proc, *specific_proc; 4982 gfc_interface *intr; 4983 gfc_formal_arglist *formal; 4984 int arg_num; 4985 4986 bool read = ((dtio_codes)code == DTIO_RF) 4987 || ((dtio_codes)code == DTIO_RUF); 4988 bt type; 4989 sym_intent intent; 4990 int kind; 4991 4992 dtio_sub = NULL; 4993 if (typebound) 4994 { 4995 /* Typebound DTIO binding. */ 4996 tb_io_proc = tb_io_st->n.tb; 4997 if (tb_io_proc == NULL) 4998 return; 4999 5000 gcc_assert (tb_io_proc->is_generic); 5001 5002 specific_proc = tb_io_proc->u.generic->specific; 5003 if (specific_proc == NULL || specific_proc->is_generic) 5004 return; 5005 5006 dtio_sub = specific_proc->u.specific->n.sym; 5007 } 5008 else 5009 { 5010 generic_proc = tb_io_st->n.sym; 5011 if (generic_proc == NULL || generic_proc->generic == NULL) 5012 return; 5013 5014 for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) 5015 { 5016 if (intr->sym && intr->sym->formal && intr->sym->formal->sym 5017 && ((intr->sym->formal->sym->ts.type == BT_CLASS 5018 && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived 5019 == derived) 5020 || (intr->sym->formal->sym->ts.type == BT_DERIVED 5021 && intr->sym->formal->sym->ts.u.derived == derived))) 5022 { 5023 dtio_sub = intr->sym; 5024 break; 5025 } 5026 else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym) 5027 { 5028 gfc_error ("Alternate return at %L is not permitted in a DTIO " 5029 "procedure", &intr->sym->declared_at); 5030 return; 5031 } 5032 } 5033 5034 if (dtio_sub == NULL) 5035 return; 5036 } 5037 5038 gcc_assert (dtio_sub); 5039 if (!dtio_sub->attr.subroutine) 5040 gfc_error ("DTIO procedure %qs at %L must be a subroutine", 5041 dtio_sub->name, &dtio_sub->declared_at); 5042 5043 if (!dtio_sub->resolve_symbol_called) 5044 gfc_resolve_formal_arglist (dtio_sub); 5045 5046 arg_num = 0; 5047 for (formal = dtio_sub->formal; formal; formal = formal->next) 5048 arg_num++; 5049 5050 if (arg_num < (formatted ? 6 : 4)) 5051 { 5052 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L", 5053 dtio_sub->name, &dtio_sub->declared_at); 5054 return; 5055 } 5056 5057 if (arg_num > (formatted ? 6 : 4)) 5058 { 5059 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L", 5060 dtio_sub->name, &dtio_sub->declared_at); 5061 return; 5062 } 5063 5064 /* Now go through the formal arglist. */ 5065 arg_num = 1; 5066 for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) 5067 { 5068 if (!formatted && arg_num == 3) 5069 arg_num = 5; 5070 fsym = formal->sym; 5071 5072 if (fsym == NULL) 5073 { 5074 gfc_error ("Alternate return at %L is not permitted in a DTIO " 5075 "procedure", &dtio_sub->declared_at); 5076 return; 5077 } 5078 5079 switch (arg_num) 5080 { 5081 case(1): /* DTV */ 5082 type = derived->attr.sequence || derived->attr.is_bind_c ? 5083 BT_DERIVED : BT_CLASS; 5084 kind = 0; 5085 intent = read ? INTENT_INOUT : INTENT_IN; 5086 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5087 0, intent); 5088 break; 5089 5090 case(2): /* UNIT */ 5091 type = BT_INTEGER; 5092 kind = gfc_default_integer_kind; 5093 intent = INTENT_IN; 5094 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5095 0, intent); 5096 break; 5097 case(3): /* IOTYPE */ 5098 type = BT_CHARACTER; 5099 kind = gfc_default_character_kind; 5100 intent = INTENT_IN; 5101 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5102 0, intent); 5103 break; 5104 case(4): /* VLIST */ 5105 type = BT_INTEGER; 5106 kind = gfc_default_integer_kind; 5107 intent = INTENT_IN; 5108 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5109 1, intent); 5110 break; 5111 case(5): /* IOSTAT */ 5112 type = BT_INTEGER; 5113 kind = gfc_default_integer_kind; 5114 intent = INTENT_OUT; 5115 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5116 0, intent); 5117 break; 5118 case(6): /* IOMSG */ 5119 type = BT_CHARACTER; 5120 kind = gfc_default_character_kind; 5121 intent = INTENT_INOUT; 5122 check_dtio_arg_TKR_intent (fsym, typebound, type, kind, 5123 0, intent); 5124 break; 5125 default: 5126 gcc_unreachable (); 5127 } 5128 } 5129 derived->attr.has_dtio_procs = 1; 5130 return; 5131 } 5132 5133 void 5134 gfc_check_dtio_interfaces (gfc_symbol *derived) 5135 { 5136 gfc_symtree *tb_io_st; 5137 bool t = false; 5138 int code; 5139 bool formatted; 5140 5141 if (derived->attr.is_class == 1 || derived->attr.vtype == 1) 5142 return; 5143 5144 /* Check typebound DTIO bindings. */ 5145 for (code = 0; code < 4; code++) 5146 { 5147 formatted = ((dtio_codes)code == DTIO_RF) 5148 || ((dtio_codes)code == DTIO_WF); 5149 5150 tb_io_st = gfc_find_typebound_proc (derived, &t, 5151 gfc_code2string (dtio_procs, code), 5152 true, &derived->declared_at); 5153 if (tb_io_st != NULL) 5154 check_dtio_interface1 (derived, tb_io_st, true, formatted, code); 5155 } 5156 5157 /* Check generic DTIO interfaces. */ 5158 for (code = 0; code < 4; code++) 5159 { 5160 formatted = ((dtio_codes)code == DTIO_RF) 5161 || ((dtio_codes)code == DTIO_WF); 5162 5163 tb_io_st = gfc_find_symtree (derived->ns->sym_root, 5164 gfc_code2string (dtio_procs, code)); 5165 if (tb_io_st != NULL) 5166 check_dtio_interface1 (derived, tb_io_st, false, formatted, code); 5167 } 5168 } 5169 5170 5171 gfc_symtree* 5172 gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) 5173 { 5174 gfc_symtree *tb_io_st = NULL; 5175 bool t = false; 5176 5177 if (!derived || !derived->resolve_symbol_called 5178 || derived->attr.flavor != FL_DERIVED) 5179 return NULL; 5180 5181 /* Try to find a typebound DTIO binding. */ 5182 if (formatted == true) 5183 { 5184 if (write == true) 5185 tb_io_st = gfc_find_typebound_proc (derived, &t, 5186 gfc_code2string (dtio_procs, 5187 DTIO_WF), 5188 true, 5189 &derived->declared_at); 5190 else 5191 tb_io_st = gfc_find_typebound_proc (derived, &t, 5192 gfc_code2string (dtio_procs, 5193 DTIO_RF), 5194 true, 5195 &derived->declared_at); 5196 } 5197 else 5198 { 5199 if (write == true) 5200 tb_io_st = gfc_find_typebound_proc (derived, &t, 5201 gfc_code2string (dtio_procs, 5202 DTIO_WUF), 5203 true, 5204 &derived->declared_at); 5205 else 5206 tb_io_st = gfc_find_typebound_proc (derived, &t, 5207 gfc_code2string (dtio_procs, 5208 DTIO_RUF), 5209 true, 5210 &derived->declared_at); 5211 } 5212 return tb_io_st; 5213 } 5214 5215 5216 gfc_symbol * 5217 gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) 5218 { 5219 gfc_symtree *tb_io_st = NULL; 5220 gfc_symbol *dtio_sub = NULL; 5221 gfc_symbol *extended; 5222 gfc_typebound_proc *tb_io_proc, *specific_proc; 5223 5224 tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); 5225 5226 if (tb_io_st != NULL) 5227 { 5228 const char *genname; 5229 gfc_symtree *st; 5230 5231 tb_io_proc = tb_io_st->n.tb; 5232 gcc_assert (tb_io_proc != NULL); 5233 gcc_assert (tb_io_proc->is_generic); 5234 gcc_assert (tb_io_proc->u.generic->next == NULL); 5235 5236 specific_proc = tb_io_proc->u.generic->specific; 5237 gcc_assert (!specific_proc->is_generic); 5238 5239 /* Go back and make sure that we have the right specific procedure. 5240 Here we most likely have a procedure from the parent type, which 5241 can be overridden in extensions. */ 5242 genname = tb_io_proc->u.generic->specific_st->name; 5243 st = gfc_find_typebound_proc (derived, NULL, genname, 5244 true, &tb_io_proc->where); 5245 if (st) 5246 dtio_sub = st->n.tb->u.specific->n.sym; 5247 else 5248 dtio_sub = specific_proc->u.specific->n.sym; 5249 5250 goto finish; 5251 } 5252 5253 /* If there is not a typebound binding, look for a generic 5254 DTIO interface. */ 5255 for (extended = derived; extended; 5256 extended = gfc_get_derived_super_type (extended)) 5257 { 5258 if (extended == NULL || extended->ns == NULL 5259 || extended->attr.flavor == FL_UNKNOWN) 5260 return NULL; 5261 5262 if (formatted == true) 5263 { 5264 if (write == true) 5265 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5266 gfc_code2string (dtio_procs, 5267 DTIO_WF)); 5268 else 5269 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5270 gfc_code2string (dtio_procs, 5271 DTIO_RF)); 5272 } 5273 else 5274 { 5275 if (write == true) 5276 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5277 gfc_code2string (dtio_procs, 5278 DTIO_WUF)); 5279 else 5280 tb_io_st = gfc_find_symtree (extended->ns->sym_root, 5281 gfc_code2string (dtio_procs, 5282 DTIO_RUF)); 5283 } 5284 5285 if (tb_io_st != NULL 5286 && tb_io_st->n.sym 5287 && tb_io_st->n.sym->generic) 5288 { 5289 for (gfc_interface *intr = tb_io_st->n.sym->generic; 5290 intr && intr->sym; intr = intr->next) 5291 { 5292 if (intr->sym->formal) 5293 { 5294 gfc_symbol *fsym = intr->sym->formal->sym; 5295 if ((fsym->ts.type == BT_CLASS 5296 && CLASS_DATA (fsym)->ts.u.derived == extended) 5297 || (fsym->ts.type == BT_DERIVED 5298 && fsym->ts.u.derived == extended)) 5299 { 5300 dtio_sub = intr->sym; 5301 break; 5302 } 5303 } 5304 } 5305 } 5306 } 5307 5308 finish: 5309 if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived) 5310 gfc_find_derived_vtab (derived); 5311 5312 return dtio_sub; 5313 } 5314 5315 /* Helper function - if we do not find an interface for a procedure, 5316 construct it from the actual arglist. Luckily, this can only 5317 happen for call by reference, so the information we actually need 5318 to provide (and which would be impossible to guess from the call 5319 itself) is not actually needed. */ 5320 5321 void 5322 gfc_get_formal_from_actual_arglist (gfc_symbol *sym, 5323 gfc_actual_arglist *actual_args) 5324 { 5325 gfc_actual_arglist *a; 5326 gfc_formal_arglist **f; 5327 gfc_symbol *s; 5328 char name[GFC_MAX_SYMBOL_LEN + 1]; 5329 static int var_num; 5330 5331 f = &sym->formal; 5332 for (a = actual_args; a != NULL; a = a->next) 5333 { 5334 (*f) = gfc_get_formal_arglist (); 5335 if (a->expr) 5336 { 5337 snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); 5338 gfc_get_symbol (name, gfc_current_ns, &s); 5339 if (a->expr->ts.type == BT_PROCEDURE) 5340 { 5341 s->attr.flavor = FL_PROCEDURE; 5342 } 5343 else 5344 { 5345 s->ts = a->expr->ts; 5346 5347 if (s->ts.type == BT_CHARACTER) 5348 s->ts.u.cl = gfc_get_charlen (); 5349 5350 s->ts.deferred = 0; 5351 s->ts.is_iso_c = 0; 5352 s->ts.is_c_interop = 0; 5353 s->attr.flavor = FL_VARIABLE; 5354 if (a->expr->rank > 0) 5355 { 5356 s->attr.dimension = 1; 5357 s->as = gfc_get_array_spec (); 5358 s->as->rank = 1; 5359 s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, 5360 &a->expr->where, 1); 5361 s->as->upper[0] = NULL; 5362 s->as->type = AS_ASSUMED_SIZE; 5363 } 5364 else 5365 s->maybe_array = maybe_dummy_array_arg (a->expr); 5366 } 5367 s->attr.dummy = 1; 5368 s->attr.artificial = 1; 5369 s->declared_at = a->expr->where; 5370 s->attr.intent = INTENT_UNKNOWN; 5371 (*f)->sym = s; 5372 } 5373 else /* If a->expr is NULL, this is an alternate rerturn. */ 5374 (*f)->sym = NULL; 5375 5376 f = &((*f)->next); 5377 } 5378 } 5379