1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ D I S P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Elists; use Elists; 29with Einfo; use Einfo; 30with Exp_Disp; use Exp_Disp; 31with Exp_Util; use Exp_Util; 32with Exp_Ch7; use Exp_Ch7; 33with Exp_Tss; use Exp_Tss; 34with Errout; use Errout; 35with Lib.Xref; use Lib.Xref; 36with Namet; use Namet; 37with Nlists; use Nlists; 38with Nmake; use Nmake; 39with Opt; use Opt; 40with Output; use Output; 41with Restrict; use Restrict; 42with Rident; use Rident; 43with Sem; use Sem; 44with Sem_Aux; use Sem_Aux; 45with Sem_Ch3; use Sem_Ch3; 46with Sem_Ch6; use Sem_Ch6; 47with Sem_Ch8; use Sem_Ch8; 48with Sem_Eval; use Sem_Eval; 49with Sem_Type; use Sem_Type; 50with Sem_Util; use Sem_Util; 51with Snames; use Snames; 52with Sinfo; use Sinfo; 53with Tbuild; use Tbuild; 54with Uintp; use Uintp; 55with Warnsw; use Warnsw; 56 57package body Sem_Disp is 58 59 ----------------------- 60 -- Local Subprograms -- 61 ----------------------- 62 63 procedure Add_Dispatching_Operation 64 (Tagged_Type : Entity_Id; 65 New_Op : Entity_Id); 66 -- Add New_Op in the list of primitive operations of Tagged_Type 67 68 function Check_Controlling_Type 69 (T : Entity_Id; 70 Subp : Entity_Id) return Entity_Id; 71 -- T is the tagged type of a formal parameter or the result of Subp. 72 -- If the subprogram has a controlling parameter or result that matches 73 -- the type, then returns the tagged type of that parameter or result 74 -- (returning the designated tagged type in the case of an access 75 -- parameter); otherwise returns empty. 76 77 function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id; 78 -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching 79 -- type of S that has the same name of S, a type-conformant profile, an 80 -- original corresponding operation O that is a primitive of a visible 81 -- ancestor of the dispatching type of S and O is visible at the point of 82 -- of declaration of S. If the entity is found the Alias of S is set to the 83 -- original corresponding operation S and its Overridden_Operation is set 84 -- to the found entity; otherwise return Empty. 85 -- 86 -- This routine does not search for non-hidden primitives since they are 87 -- covered by the normal Ada 2005 rules. 88 89 function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean; 90 -- Check whether a primitive operation is inherited from an operation 91 -- declared in the visible part of its package. 92 93 ------------------------------- 94 -- Add_Dispatching_Operation -- 95 ------------------------------- 96 97 procedure Add_Dispatching_Operation 98 (Tagged_Type : Entity_Id; 99 New_Op : Entity_Id) 100 is 101 List : constant Elist_Id := Primitive_Operations (Tagged_Type); 102 103 begin 104 -- The dispatching operation may already be on the list, if it is the 105 -- wrapper for an inherited function of a null extension (see Exp_Ch3 106 -- for the construction of function wrappers). The list of primitive 107 -- operations must not contain duplicates. 108 109 Append_Unique_Elmt (New_Op, List); 110 end Add_Dispatching_Operation; 111 112 -------------------------- 113 -- Covered_Interface_Op -- 114 -------------------------- 115 116 function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id is 117 Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); 118 Elmt : Elmt_Id; 119 E : Entity_Id; 120 121 begin 122 pragma Assert (Is_Dispatching_Operation (Prim)); 123 124 -- Although this is a dispatching primitive we must check if its 125 -- dispatching type is available because it may be the primitive 126 -- of a private type not defined as tagged in its partial view. 127 128 if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then 129 130 -- If the tagged type is frozen then the internal entities associated 131 -- with interfaces are available in the list of primitives of the 132 -- tagged type and can be used to speed up this search. 133 134 if Is_Frozen (Tagged_Type) then 135 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 136 while Present (Elmt) loop 137 E := Node (Elmt); 138 139 if Present (Interface_Alias (E)) 140 and then Alias (E) = Prim 141 then 142 return Interface_Alias (E); 143 end if; 144 145 Next_Elmt (Elmt); 146 end loop; 147 148 -- Otherwise we must collect all the interface primitives and check 149 -- if the Prim overrides (implements) some interface primitive. 150 151 else 152 declare 153 Ifaces_List : Elist_Id; 154 Iface_Elmt : Elmt_Id; 155 Iface : Entity_Id; 156 Iface_Prim : Entity_Id; 157 158 begin 159 Collect_Interfaces (Tagged_Type, Ifaces_List); 160 Iface_Elmt := First_Elmt (Ifaces_List); 161 while Present (Iface_Elmt) loop 162 Iface := Node (Iface_Elmt); 163 164 Elmt := First_Elmt (Primitive_Operations (Iface)); 165 while Present (Elmt) loop 166 Iface_Prim := Node (Elmt); 167 168 if Chars (Iface_Prim) = Chars (Prim) 169 and then Is_Interface_Conformant 170 (Tagged_Type, Iface_Prim, Prim) 171 then 172 return Iface_Prim; 173 end if; 174 175 Next_Elmt (Elmt); 176 end loop; 177 178 Next_Elmt (Iface_Elmt); 179 end loop; 180 end; 181 end if; 182 end if; 183 184 return Empty; 185 end Covered_Interface_Op; 186 187 ------------------------------- 188 -- Check_Controlling_Formals -- 189 ------------------------------- 190 191 procedure Check_Controlling_Formals 192 (Typ : Entity_Id; 193 Subp : Entity_Id) 194 is 195 Formal : Entity_Id; 196 Ctrl_Type : Entity_Id; 197 198 begin 199 Formal := First_Formal (Subp); 200 while Present (Formal) loop 201 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); 202 203 if Present (Ctrl_Type) then 204 205 -- When controlling type is concurrent and declared within a 206 -- generic or inside an instance use corresponding record type. 207 208 if Is_Concurrent_Type (Ctrl_Type) 209 and then Present (Corresponding_Record_Type (Ctrl_Type)) 210 then 211 Ctrl_Type := Corresponding_Record_Type (Ctrl_Type); 212 end if; 213 214 if Ctrl_Type = Typ then 215 Set_Is_Controlling_Formal (Formal); 216 217 -- Ada 2005 (AI-231): Anonymous access types that are used in 218 -- controlling parameters exclude null because it is necessary 219 -- to read the tag to dispatch, and null has no tag. 220 221 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then 222 Set_Can_Never_Be_Null (Etype (Formal)); 223 Set_Is_Known_Non_Null (Etype (Formal)); 224 end if; 225 226 -- Check that the parameter's nominal subtype statically 227 -- matches the first subtype. 228 229 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then 230 if not Subtypes_Statically_Match 231 (Typ, Designated_Type (Etype (Formal))) 232 then 233 Error_Msg_N 234 ("parameter subtype does not match controlling type", 235 Formal); 236 end if; 237 238 -- Within a predicate function, the formal may be a subtype 239 -- of a tagged type, given that the predicate is expressed 240 -- in terms of the subtype. 241 242 elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) 243 and then not Is_Predicate_Function (Subp) 244 then 245 Error_Msg_N 246 ("parameter subtype does not match controlling type", 247 Formal); 248 end if; 249 250 if Present (Default_Value (Formal)) then 251 252 -- In Ada 2005, access parameters can have defaults 253 254 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 255 and then Ada_Version < Ada_2005 256 then 257 Error_Msg_N 258 ("default not allowed for controlling access parameter", 259 Default_Value (Formal)); 260 261 elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then 262 Error_Msg_N 263 ("default expression must be a tag indeterminate" & 264 " function call", Default_Value (Formal)); 265 end if; 266 end if; 267 268 elsif Comes_From_Source (Subp) then 269 Error_Msg_N 270 ("operation can be dispatching in only one type", Subp); 271 end if; 272 end if; 273 274 Next_Formal (Formal); 275 end loop; 276 277 if Ekind_In (Subp, E_Function, E_Generic_Function) then 278 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); 279 280 if Present (Ctrl_Type) then 281 if Ctrl_Type = Typ then 282 Set_Has_Controlling_Result (Subp); 283 284 -- Check that result subtype statically matches first subtype 285 -- (Ada 2005): Subp may have a controlling access result. 286 287 if Subtypes_Statically_Match (Typ, Etype (Subp)) 288 or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type 289 and then 290 Subtypes_Statically_Match 291 (Typ, Designated_Type (Etype (Subp)))) 292 then 293 null; 294 295 else 296 Error_Msg_N 297 ("result subtype does not match controlling type", Subp); 298 end if; 299 300 elsif Comes_From_Source (Subp) then 301 Error_Msg_N 302 ("operation can be dispatching in only one type", Subp); 303 end if; 304 end if; 305 end if; 306 end Check_Controlling_Formals; 307 308 ---------------------------- 309 -- Check_Controlling_Type -- 310 ---------------------------- 311 312 function Check_Controlling_Type 313 (T : Entity_Id; 314 Subp : Entity_Id) return Entity_Id 315 is 316 Tagged_Type : Entity_Id := Empty; 317 318 begin 319 if Is_Tagged_Type (T) then 320 if Is_First_Subtype (T) then 321 Tagged_Type := T; 322 else 323 Tagged_Type := Base_Type (T); 324 end if; 325 326 -- If the type is incomplete, it may have been declared without a 327 -- Tagged indication, but the full view may be tagged, in which case 328 -- that is the controlling type of the subprogram. This is one of the 329 -- approx. 579 places in the language where a lookahead would help. 330 331 elsif Ekind (T) = E_Incomplete_Type 332 and then Present (Full_View (T)) 333 and then Is_Tagged_Type (Full_View (T)) 334 then 335 Set_Is_Tagged_Type (T); 336 Tagged_Type := Full_View (T); 337 338 elsif Ekind (T) = E_Anonymous_Access_Type 339 and then Is_Tagged_Type (Designated_Type (T)) 340 then 341 if Ekind (Designated_Type (T)) /= E_Incomplete_Type then 342 if Is_First_Subtype (Designated_Type (T)) then 343 Tagged_Type := Designated_Type (T); 344 else 345 Tagged_Type := Base_Type (Designated_Type (T)); 346 end if; 347 348 -- Ada 2005: an incomplete type can be tagged. An operation with an 349 -- access parameter of the type is dispatching. 350 351 elsif Scope (Designated_Type (T)) = Current_Scope then 352 Tagged_Type := Designated_Type (T); 353 354 -- Ada 2005 (AI-50217) 355 356 elsif From_Limited_With (Designated_Type (T)) 357 and then Has_Non_Limited_View (Designated_Type (T)) 358 and then Scope (Designated_Type (T)) = Scope (Subp) 359 then 360 if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then 361 Tagged_Type := Non_Limited_View (Designated_Type (T)); 362 else 363 Tagged_Type := Base_Type (Non_Limited_View 364 (Designated_Type (T))); 365 end if; 366 end if; 367 end if; 368 369 if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then 370 return Empty; 371 372 -- The dispatching type and the primitive operation must be defined in 373 -- the same scope, except in the case of internal operations and formal 374 -- abstract subprograms. 375 376 elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp)) 377 and then (not Is_Generic_Type (Tagged_Type) 378 or else not Comes_From_Source (Subp))) 379 or else 380 (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp)) 381 or else 382 (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration 383 and then 384 Present (Corresponding_Formal_Spec (Parent (Parent (Subp)))) 385 and then 386 Is_Abstract_Subprogram (Subp)) 387 then 388 return Tagged_Type; 389 390 else 391 return Empty; 392 end if; 393 end Check_Controlling_Type; 394 395 ---------------------------- 396 -- Check_Dispatching_Call -- 397 ---------------------------- 398 399 procedure Check_Dispatching_Call (N : Node_Id) is 400 Loc : constant Source_Ptr := Sloc (N); 401 Actual : Node_Id; 402 Formal : Entity_Id; 403 Control : Node_Id := Empty; 404 Func : Entity_Id; 405 Subp_Entity : Entity_Id; 406 Indeterm_Ancestor_Call : Boolean := False; 407 Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning 408 409 Static_Tag : Node_Id := Empty; 410 -- If a controlling formal has a statically tagged actual, the tag of 411 -- this actual is to be used for any tag-indeterminate actual. 412 413 procedure Check_Direct_Call; 414 -- In the case when the controlling actual is a class-wide type whose 415 -- root type's completion is a task or protected type, the call is in 416 -- fact direct. This routine detects the above case and modifies the 417 -- call accordingly. 418 419 procedure Check_Dispatching_Context (Call : Node_Id); 420 -- If the call is tag-indeterminate and the entity being called is 421 -- abstract, verify that the context is a call that will eventually 422 -- provide a tag for dispatching, or has provided one already. 423 424 ----------------------- 425 -- Check_Direct_Call -- 426 ----------------------- 427 428 procedure Check_Direct_Call is 429 Typ : Entity_Id := Etype (Control); 430 begin 431 -- Predefined primitives do not receive wrappers since they are built 432 -- from scratch for the corresponding record of synchronized types. 433 -- Equality is in general predefined, but is excluded from the check 434 -- when it is user-defined. 435 436 if Is_Predefined_Dispatching_Operation (Subp_Entity) 437 and then not Is_User_Defined_Equality (Subp_Entity) 438 then 439 return; 440 end if; 441 442 if Is_Class_Wide_Type (Typ) then 443 Typ := Root_Type (Typ); 444 end if; 445 446 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 447 Typ := Full_View (Typ); 448 end if; 449 450 if Is_Concurrent_Type (Typ) 451 and then 452 Present (Corresponding_Record_Type (Typ)) 453 then 454 Typ := Corresponding_Record_Type (Typ); 455 456 -- The concurrent record's list of primitives should contain a 457 -- wrapper for the entity of the call, retrieve it. 458 459 declare 460 Prim : Entity_Id; 461 Prim_Elmt : Elmt_Id; 462 Wrapper_Found : Boolean := False; 463 464 begin 465 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 466 while Present (Prim_Elmt) loop 467 Prim := Node (Prim_Elmt); 468 469 if Is_Primitive_Wrapper (Prim) 470 and then Wrapped_Entity (Prim) = Subp_Entity 471 then 472 Wrapper_Found := True; 473 exit; 474 end if; 475 476 Next_Elmt (Prim_Elmt); 477 end loop; 478 479 -- A primitive declared between two views should have a 480 -- corresponding wrapper. 481 482 pragma Assert (Wrapper_Found); 483 484 -- Modify the call by setting the proper entity 485 486 Set_Entity (Name (N), Prim); 487 end; 488 end if; 489 end Check_Direct_Call; 490 491 ------------------------------- 492 -- Check_Dispatching_Context -- 493 ------------------------------- 494 495 procedure Check_Dispatching_Context (Call : Node_Id) is 496 Subp : constant Entity_Id := Entity (Name (Call)); 497 498 procedure Abstract_Context_Error; 499 -- Error for abstract call dispatching on result is not dispatching 500 501 ---------------------------- 502 -- Abstract_Context_Error -- 503 ---------------------------- 504 505 procedure Abstract_Context_Error is 506 begin 507 if Ekind (Subp) = E_Function then 508 Error_Msg_N 509 ("call to abstract function must be dispatching", N); 510 511 -- This error can occur for a procedure in the case of a call to 512 -- an abstract formal procedure with a statically tagged operand. 513 514 else 515 Error_Msg_N 516 ("call to abstract procedure must be dispatching", N); 517 end if; 518 end Abstract_Context_Error; 519 520 -- Local variables 521 522 Scop : constant Entity_Id := Current_Scope_No_Loops; 523 Typ : constant Entity_Id := Etype (Subp); 524 Par : Node_Id; 525 526 -- Start of processing for Check_Dispatching_Context 527 528 begin 529 -- If the called subprogram is a private overriding, replace it 530 -- with its alias, which has the correct body. Verify that the 531 -- two subprograms have the same controlling type (this is not the 532 -- case for an inherited subprogram that has become abstract). 533 534 if Is_Abstract_Subprogram (Subp) 535 and then No (Controlling_Argument (Call)) 536 then 537 if Present (Alias (Subp)) 538 and then not Is_Abstract_Subprogram (Alias (Subp)) 539 and then No (DTC_Entity (Subp)) 540 and then Find_Dispatching_Type (Subp) = 541 Find_Dispatching_Type (Alias (Subp)) 542 then 543 -- Private overriding of inherited abstract operation, call is 544 -- legal. 545 546 Set_Entity (Name (N), Alias (Subp)); 547 return; 548 549 -- An obscure special case: a null procedure may have a class- 550 -- wide pre/postcondition that includes a call to an abstract 551 -- subp. Calls within the expression may not have been rewritten 552 -- as dispatching calls yet, because the null body appears in 553 -- the current declarative part. The expression will be properly 554 -- rewritten/reanalyzed when the postcondition procedure is built. 555 556 -- Similarly, if this is a pre/postcondition for an abstract 557 -- subprogram, it may call another abstract function which is 558 -- a primitive of an abstract type. The call is non-dispatching 559 -- but will be legal in overridings of the operation. 560 561 elsif (Is_Subprogram (Scop) 562 or else Chars (Scop) = Name_Postcondition) 563 and then 564 (Is_Abstract_Subprogram (Scop) 565 or else 566 (Nkind (Parent (Scop)) = N_Procedure_Specification 567 and then Null_Present (Parent (Scop)))) 568 then 569 null; 570 571 elsif Ekind (Current_Scope) = E_Function 572 and then Nkind (Unit_Declaration_Node (Scop)) = 573 N_Generic_Subprogram_Declaration 574 then 575 null; 576 577 else 578 -- We need to determine whether the context of the call 579 -- provides a tag to make the call dispatching. This requires 580 -- the call to be the actual in an enclosing call, and that 581 -- actual must be controlling. If the call is an operand of 582 -- equality, the other operand must not ve abstract. 583 584 if not Is_Tagged_Type (Typ) 585 and then not 586 (Ekind (Typ) = E_Anonymous_Access_Type 587 and then Is_Tagged_Type (Designated_Type (Typ))) 588 then 589 Abstract_Context_Error; 590 return; 591 end if; 592 593 Par := Parent (Call); 594 595 if Nkind (Par) = N_Parameter_Association then 596 Par := Parent (Par); 597 end if; 598 599 if Nkind (Par) = N_Qualified_Expression 600 or else Nkind (Par) = N_Unchecked_Type_Conversion 601 then 602 Par := Parent (Par); 603 end if; 604 605 if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) 606 and then Is_Entity_Name (Name (Par)) 607 then 608 declare 609 Enc_Subp : constant Entity_Id := Entity (Name (Par)); 610 A : Node_Id; 611 F : Entity_Id; 612 Control : Entity_Id; 613 Ret_Type : Entity_Id; 614 615 begin 616 -- Find controlling formal that can provide tag for the 617 -- tag-indeterminate actual. The corresponding actual 618 -- must be the corresponding class-wide type. 619 620 F := First_Formal (Enc_Subp); 621 A := First_Actual (Par); 622 623 -- Find controlling type of call. Dereference if function 624 -- returns an access type. 625 626 Ret_Type := Etype (Call); 627 if Is_Access_Type (Etype (Call)) then 628 Ret_Type := Designated_Type (Ret_Type); 629 end if; 630 631 while Present (F) loop 632 Control := Etype (A); 633 634 if Is_Access_Type (Control) then 635 Control := Designated_Type (Control); 636 end if; 637 638 if Is_Controlling_Formal (F) 639 and then not (Call = A or else Parent (Call) = A) 640 and then Control = Class_Wide_Type (Ret_Type) 641 then 642 return; 643 end if; 644 645 Next_Formal (F); 646 Next_Actual (A); 647 end loop; 648 649 if Nkind (Par) = N_Function_Call 650 and then Is_Tag_Indeterminate (Par) 651 then 652 -- The parent may be an actual of an enclosing call 653 654 Check_Dispatching_Context (Par); 655 return; 656 657 else 658 Error_Msg_N 659 ("call to abstract function must be dispatching", 660 Call); 661 return; 662 end if; 663 end; 664 665 -- For equality operators, one of the operands must be 666 -- statically or dynamically tagged. 667 668 elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then 669 if N = Right_Opnd (Par) 670 and then Is_Tag_Indeterminate (Left_Opnd (Par)) 671 then 672 Abstract_Context_Error; 673 674 elsif N = Left_Opnd (Par) 675 and then Is_Tag_Indeterminate (Right_Opnd (Par)) 676 then 677 Abstract_Context_Error; 678 end if; 679 680 return; 681 682 -- The left-hand side of an assignment provides the tag 683 684 elsif Nkind (Par) = N_Assignment_Statement then 685 return; 686 687 else 688 Abstract_Context_Error; 689 end if; 690 end if; 691 end if; 692 end Check_Dispatching_Context; 693 694 -- Start of processing for Check_Dispatching_Call 695 696 begin 697 -- Find a controlling argument, if any 698 699 if Present (Parameter_Associations (N)) then 700 Subp_Entity := Entity (Name (N)); 701 702 Actual := First_Actual (N); 703 Formal := First_Formal (Subp_Entity); 704 while Present (Actual) loop 705 Control := Find_Controlling_Arg (Actual); 706 exit when Present (Control); 707 708 -- Check for the case where the actual is a tag-indeterminate call 709 -- whose result type is different than the tagged type associated 710 -- with the containing call, but is an ancestor of the type. 711 712 if Is_Controlling_Formal (Formal) 713 and then Is_Tag_Indeterminate (Actual) 714 and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal)) 715 and then Is_Ancestor (Etype (Actual), Etype (Formal)) 716 then 717 Indeterm_Ancestor_Call := True; 718 Indeterm_Ctrl_Type := Etype (Formal); 719 720 -- If the formal is controlling but the actual is not, the type 721 -- of the actual is statically known, and may be used as the 722 -- controlling tag for some other tag-indeterminate actual. 723 724 elsif Is_Controlling_Formal (Formal) 725 and then Is_Entity_Name (Actual) 726 and then Is_Tagged_Type (Etype (Actual)) 727 then 728 Static_Tag := Actual; 729 end if; 730 731 Next_Actual (Actual); 732 Next_Formal (Formal); 733 end loop; 734 735 -- If the call doesn't have a controlling actual but does have an 736 -- indeterminate actual that requires dispatching treatment, then an 737 -- object is needed that will serve as the controlling argument for 738 -- a dispatching call on the indeterminate actual. This can occur 739 -- in the unusual situation of a default actual given by a tag- 740 -- indeterminate call and where the type of the call is an ancestor 741 -- of the type associated with a containing call to an inherited 742 -- operation (see AI-239). 743 744 -- Rather than create an object of the tagged type, which would 745 -- be problematic for various reasons (default initialization, 746 -- discriminants), the tag of the containing call's associated 747 -- tagged type is directly used to control the dispatching. 748 749 if No (Control) 750 and then Indeterm_Ancestor_Call 751 and then No (Static_Tag) 752 then 753 Control := 754 Make_Attribute_Reference (Loc, 755 Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), 756 Attribute_Name => Name_Tag); 757 758 Analyze (Control); 759 end if; 760 761 if Present (Control) then 762 763 -- Verify that no controlling arguments are statically tagged 764 765 if Debug_Flag_E then 766 Write_Str ("Found Dispatching call"); 767 Write_Int (Int (N)); 768 Write_Eol; 769 end if; 770 771 Actual := First_Actual (N); 772 while Present (Actual) loop 773 if Actual /= Control then 774 775 if not Is_Controlling_Actual (Actual) then 776 null; -- Can be anything 777 778 elsif Is_Dynamically_Tagged (Actual) then 779 null; -- Valid parameter 780 781 elsif Is_Tag_Indeterminate (Actual) then 782 783 -- The tag is inherited from the enclosing call (the node 784 -- we are currently analyzing). Explicitly expand the 785 -- actual, since the previous call to Expand (from 786 -- Resolve_Call) had no way of knowing about the 787 -- required dispatching. 788 789 Propagate_Tag (Control, Actual); 790 791 else 792 Error_Msg_N 793 ("controlling argument is not dynamically tagged", 794 Actual); 795 return; 796 end if; 797 end if; 798 799 Next_Actual (Actual); 800 end loop; 801 802 -- Mark call as a dispatching call 803 804 Set_Controlling_Argument (N, Control); 805 Check_Restriction (No_Dispatching_Calls, N); 806 807 -- The dispatching call may need to be converted into a direct 808 -- call in certain cases. 809 810 Check_Direct_Call; 811 812 -- If there is a statically tagged actual and a tag-indeterminate 813 -- call to a function of the ancestor (such as that provided by a 814 -- default), then treat this as a dispatching call and propagate 815 -- the tag to the tag-indeterminate call(s). 816 817 elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then 818 Control := 819 Make_Attribute_Reference (Loc, 820 Prefix => 821 New_Occurrence_Of (Etype (Static_Tag), Loc), 822 Attribute_Name => Name_Tag); 823 824 Analyze (Control); 825 826 Actual := First_Actual (N); 827 Formal := First_Formal (Subp_Entity); 828 while Present (Actual) loop 829 if Is_Tag_Indeterminate (Actual) 830 and then Is_Controlling_Formal (Formal) 831 then 832 Propagate_Tag (Control, Actual); 833 end if; 834 835 Next_Actual (Actual); 836 Next_Formal (Formal); 837 end loop; 838 839 Check_Dispatching_Context (N); 840 841 elsif Nkind (N) /= N_Function_Call then 842 843 -- The call is not dispatching, so check that there aren't any 844 -- tag-indeterminate abstract calls left among its actuals. 845 846 Actual := First_Actual (N); 847 while Present (Actual) loop 848 if Is_Tag_Indeterminate (Actual) then 849 850 -- Function call case 851 852 if Nkind (Original_Node (Actual)) = N_Function_Call then 853 Func := Entity (Name (Original_Node (Actual))); 854 855 -- If the actual is an attribute then it can't be abstract 856 -- (the only current case of a tag-indeterminate attribute 857 -- is the stream Input attribute). 858 859 elsif Nkind (Original_Node (Actual)) = N_Attribute_Reference 860 then 861 Func := Empty; 862 863 -- Ditto if it is an explicit dereference 864 865 elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference 866 then 867 Func := Empty; 868 869 -- Only other possibility is a qualified expression whose 870 -- constituent expression is itself a call. 871 872 else 873 Func := 874 Entity (Name (Original_Node 875 (Expression (Original_Node (Actual))))); 876 end if; 877 878 if Present (Func) and then Is_Abstract_Subprogram (Func) then 879 Error_Msg_N 880 ("call to abstract function must be dispatching", 881 Actual); 882 end if; 883 end if; 884 885 Next_Actual (Actual); 886 end loop; 887 888 Check_Dispatching_Context (N); 889 return; 890 891 elsif Nkind (Parent (N)) in N_Subexpr then 892 Check_Dispatching_Context (N); 893 894 elsif Nkind (Parent (N)) = N_Assignment_Statement 895 and then Is_Class_Wide_Type (Etype (Name (Parent (N)))) 896 then 897 return; 898 899 elsif Is_Abstract_Subprogram (Subp_Entity) then 900 Check_Dispatching_Context (N); 901 return; 902 end if; 903 904 else 905 -- If dispatching on result, the enclosing call, if any, will 906 -- determine the controlling argument. Otherwise this is the 907 -- primitive operation of the root type. 908 909 Check_Dispatching_Context (N); 910 end if; 911 end Check_Dispatching_Call; 912 913 --------------------------------- 914 -- Check_Dispatching_Operation -- 915 --------------------------------- 916 917 procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is 918 procedure Warn_On_Late_Primitive_After_Private_Extension 919 (Typ : Entity_Id; 920 Prim : Entity_Id); 921 -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim 922 -- if it is a public primitive defined after some private extension of 923 -- the tagged type. 924 925 ---------------------------------------------------- 926 -- Warn_On_Late_Primitive_After_Private_Extension -- 927 ---------------------------------------------------- 928 929 procedure Warn_On_Late_Primitive_After_Private_Extension 930 (Typ : Entity_Id; 931 Prim : Entity_Id) 932 is 933 E : Entity_Id; 934 935 begin 936 if Warn_On_Late_Primitives 937 and then Comes_From_Source (Prim) 938 and then Has_Private_Extension (Typ) 939 and then Is_Package_Or_Generic_Package (Current_Scope) 940 and then not In_Private_Part (Current_Scope) 941 then 942 E := Next_Entity (Typ); 943 944 while E /= Prim loop 945 if Ekind (E) = E_Record_Type_With_Private 946 and then Etype (E) = Typ 947 then 948 Error_Msg_Name_1 := Chars (Typ); 949 Error_Msg_Name_2 := Chars (E); 950 Error_Msg_Sloc := Sloc (E); 951 Error_Msg_N 952 ("?j?primitive of type % defined after private extension " 953 & "% #?", Prim); 954 Error_Msg_Name_1 := Chars (Prim); 955 Error_Msg_Name_2 := Chars (E); 956 Error_Msg_N 957 ("\spec of % should appear before declaration of type %!", 958 Prim); 959 exit; 960 end if; 961 962 Next_Entity (E); 963 end loop; 964 end if; 965 end Warn_On_Late_Primitive_After_Private_Extension; 966 967 -- Local variables 968 969 Body_Is_Last_Primitive : Boolean := False; 970 Has_Dispatching_Parent : Boolean := False; 971 Ovr_Subp : Entity_Id := Empty; 972 Tagged_Type : Entity_Id; 973 974 -- Start of processing for Check_Dispatching_Operation 975 976 begin 977 if not Ekind_In (Subp, E_Function, E_Procedure) then 978 return; 979 980 -- The Default_Initial_Condition procedure is not a primitive subprogram 981 -- even if it relates to a tagged type. This routine is not meant to be 982 -- inherited or overridden. 983 984 elsif Is_DIC_Procedure (Subp) then 985 return; 986 987 -- The "partial" and "full" type invariant procedures are not primitive 988 -- subprograms even if they relate to a tagged type. These routines are 989 -- not meant to be inherited or overridden. 990 991 elsif Is_Invariant_Procedure (Subp) 992 or else Is_Partial_Invariant_Procedure (Subp) 993 then 994 return; 995 end if; 996 997 Set_Is_Dispatching_Operation (Subp, False); 998 Tagged_Type := Find_Dispatching_Type (Subp); 999 1000 -- Ada 2005 (AI-345): Use the corresponding record (if available). 1001 -- Required because primitives of concurrent types are attached 1002 -- to the corresponding record (not to the concurrent type). 1003 1004 if Ada_Version >= Ada_2005 1005 and then Present (Tagged_Type) 1006 and then Is_Concurrent_Type (Tagged_Type) 1007 and then Present (Corresponding_Record_Type (Tagged_Type)) 1008 then 1009 Tagged_Type := Corresponding_Record_Type (Tagged_Type); 1010 end if; 1011 1012 -- (AI-345): The task body procedure is not a primitive of the tagged 1013 -- type 1014 1015 if Present (Tagged_Type) 1016 and then Is_Concurrent_Record_Type (Tagged_Type) 1017 and then Present (Corresponding_Concurrent_Type (Tagged_Type)) 1018 and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type)) 1019 and then Subp = Get_Task_Body_Procedure 1020 (Corresponding_Concurrent_Type (Tagged_Type)) 1021 then 1022 return; 1023 end if; 1024 1025 -- If Subp is derived from a dispatching operation then it should 1026 -- always be treated as dispatching. In this case various checks 1027 -- below will be bypassed. Makes sure that late declarations for 1028 -- inherited private subprograms are treated as dispatching, even 1029 -- if the associated tagged type is already frozen. 1030 1031 Has_Dispatching_Parent := 1032 Present (Alias (Subp)) 1033 and then Is_Dispatching_Operation (Alias (Subp)); 1034 1035 if No (Tagged_Type) then 1036 1037 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated 1038 -- with an abstract interface type unless the interface acts as a 1039 -- parent type in a derivation. If the interface type is a formal 1040 -- type then the operation is not primitive and therefore legal. 1041 1042 declare 1043 E : Entity_Id; 1044 Typ : Entity_Id; 1045 1046 begin 1047 E := First_Entity (Subp); 1048 while Present (E) loop 1049 1050 -- For an access parameter, check designated type 1051 1052 if Ekind (Etype (E)) = E_Anonymous_Access_Type then 1053 Typ := Designated_Type (Etype (E)); 1054 else 1055 Typ := Etype (E); 1056 end if; 1057 1058 if Comes_From_Source (Subp) 1059 and then Is_Interface (Typ) 1060 and then not Is_Class_Wide_Type (Typ) 1061 and then not Is_Derived_Type (Typ) 1062 and then not Is_Generic_Type (Typ) 1063 and then not In_Instance 1064 then 1065 Error_Msg_N ("??declaration of& is too late!", Subp); 1066 Error_Msg_NE -- CODEFIX?? 1067 ("\??spec should appear immediately after declaration of " 1068 & "& !", Subp, Typ); 1069 exit; 1070 end if; 1071 1072 Next_Entity (E); 1073 end loop; 1074 1075 -- In case of functions check also the result type 1076 1077 if Ekind (Subp) = E_Function then 1078 if Is_Access_Type (Etype (Subp)) then 1079 Typ := Designated_Type (Etype (Subp)); 1080 else 1081 Typ := Etype (Subp); 1082 end if; 1083 1084 -- The following should be better commented, especially since 1085 -- we just added several new conditions here ??? 1086 1087 if Comes_From_Source (Subp) 1088 and then Is_Interface (Typ) 1089 and then not Is_Class_Wide_Type (Typ) 1090 and then not Is_Derived_Type (Typ) 1091 and then not Is_Generic_Type (Typ) 1092 and then not In_Instance 1093 then 1094 Error_Msg_N ("??declaration of& is too late!", Subp); 1095 Error_Msg_NE 1096 ("\??spec should appear immediately after declaration of " 1097 & "& !", Subp, Typ); 1098 end if; 1099 end if; 1100 end; 1101 1102 return; 1103 1104 -- The subprograms build internally after the freezing point (such as 1105 -- init procs, interface thunks, type support subprograms, and Offset 1106 -- to top functions for accessing interface components in variable 1107 -- size tagged types) are not primitives. 1108 1109 elsif Is_Frozen (Tagged_Type) 1110 and then not Comes_From_Source (Subp) 1111 and then not Has_Dispatching_Parent 1112 then 1113 -- Complete decoration of internally built subprograms that override 1114 -- a dispatching primitive. These entities correspond with the 1115 -- following cases: 1116 1117 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander 1118 -- to override functions of nonabstract null extensions. These 1119 -- primitives were added to the list of primitives of the tagged 1120 -- type by Make_Controlling_Function_Wrappers. However, attribute 1121 -- Is_Dispatching_Operation must be set to true. 1122 1123 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface 1124 -- primitives. 1125 1126 -- 3. Subprograms associated with stream attributes (built by 1127 -- New_Stream_Subprogram) 1128 1129 -- 4. Wrapper built for inherited operations with inherited class- 1130 -- wide conditions, where the conditions include calls to other 1131 -- overridden primitives. The wrappers include checks on these 1132 -- modified conditions. (AI12-113). 1133 1134 if Present (Old_Subp) 1135 and then Present (Overridden_Operation (Subp)) 1136 and then Is_Dispatching_Operation (Old_Subp) 1137 then 1138 pragma Assert 1139 ((Ekind (Subp) = E_Function 1140 and then Is_Dispatching_Operation (Old_Subp) 1141 and then Is_Null_Extension (Base_Type (Etype (Subp)))) 1142 1143 or else 1144 (Ekind (Subp) = E_Procedure 1145 and then Is_Dispatching_Operation (Old_Subp) 1146 and then Present (Alias (Old_Subp)) 1147 and then Is_Null_Interface_Primitive 1148 (Ultimate_Alias (Old_Subp))) 1149 1150 or else Get_TSS_Name (Subp) = TSS_Stream_Read 1151 or else Get_TSS_Name (Subp) = TSS_Stream_Write 1152 1153 or else Present (Contract (Overridden_Operation (Subp)))); 1154 1155 Check_Controlling_Formals (Tagged_Type, Subp); 1156 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); 1157 Set_Is_Dispatching_Operation (Subp); 1158 end if; 1159 1160 return; 1161 1162 -- The operation may be a child unit, whose scope is the defining 1163 -- package, but which is not a primitive operation of the type. 1164 1165 elsif Is_Child_Unit (Subp) then 1166 return; 1167 1168 -- If the subprogram is not defined in a package spec, the only case 1169 -- where it can be a dispatching op is when it overrides an operation 1170 -- before the freezing point of the type. 1171 1172 elsif ((not Is_Package_Or_Generic_Package (Scope (Subp))) 1173 or else In_Package_Body (Scope (Subp))) 1174 and then not Has_Dispatching_Parent 1175 then 1176 if not Comes_From_Source (Subp) 1177 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type)) 1178 then 1179 null; 1180 1181 -- If the type is already frozen, the overriding is not allowed 1182 -- except when Old_Subp is not a dispatching operation (which can 1183 -- occur when Old_Subp was inherited by an untagged type). However, 1184 -- a body with no previous spec freezes the type *after* its 1185 -- declaration, and therefore is a legal overriding (unless the type 1186 -- has already been frozen). Only the first such body is legal. 1187 1188 elsif Present (Old_Subp) 1189 and then Is_Dispatching_Operation (Old_Subp) 1190 then 1191 if Comes_From_Source (Subp) 1192 and then 1193 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body 1194 or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub) 1195 then 1196 declare 1197 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); 1198 Decl_Item : Node_Id; 1199 1200 begin 1201 -- ??? The checks here for whether the type has been frozen 1202 -- prior to the new body are not complete. It's not simple 1203 -- to check frozenness at this point since the body has 1204 -- already caused the type to be prematurely frozen in 1205 -- Analyze_Declarations, but we're forced to recheck this 1206 -- here because of the odd rule interpretation that allows 1207 -- the overriding if the type wasn't frozen prior to the 1208 -- body. The freezing action should probably be delayed 1209 -- until after the spec is seen, but that's a tricky 1210 -- change to the delicate freezing code. 1211 1212 -- Look at each declaration following the type up until the 1213 -- new subprogram body. If any of the declarations is a body 1214 -- then the type has been frozen already so the overriding 1215 -- primitive is illegal. 1216 1217 Decl_Item := Next (Parent (Tagged_Type)); 1218 while Present (Decl_Item) 1219 and then (Decl_Item /= Subp_Body) 1220 loop 1221 if Comes_From_Source (Decl_Item) 1222 and then (Nkind (Decl_Item) in N_Proper_Body 1223 or else Nkind (Decl_Item) in N_Body_Stub) 1224 then 1225 Error_Msg_N ("overriding of& is too late!", Subp); 1226 Error_Msg_N 1227 ("\spec should appear immediately after the type!", 1228 Subp); 1229 exit; 1230 end if; 1231 1232 Next (Decl_Item); 1233 end loop; 1234 1235 -- If the subprogram doesn't follow in the list of 1236 -- declarations including the type then the type has 1237 -- definitely been frozen already and the body is illegal. 1238 1239 if No (Decl_Item) then 1240 Error_Msg_N ("overriding of& is too late!", Subp); 1241 Error_Msg_N 1242 ("\spec should appear immediately after the type!", 1243 Subp); 1244 1245 elsif Is_Frozen (Subp) then 1246 1247 -- The subprogram body declares a primitive operation. 1248 -- If the subprogram is already frozen, we must update 1249 -- its dispatching information explicitly here. The 1250 -- information is taken from the overridden subprogram. 1251 -- We must also generate a cross-reference entry because 1252 -- references to other primitives were already created 1253 -- when type was frozen. 1254 1255 Body_Is_Last_Primitive := True; 1256 1257 if Present (DTC_Entity (Old_Subp)) then 1258 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp)); 1259 Set_DT_Position_Value (Subp, DT_Position (Old_Subp)); 1260 1261 if not Restriction_Active (No_Dispatching_Calls) then 1262 if Building_Static_DT (Tagged_Type) then 1263 1264 -- If the static dispatch table has not been 1265 -- built then there is nothing else to do now; 1266 -- otherwise we notify that we cannot build the 1267 -- static dispatch table. 1268 1269 if Has_Dispatch_Table (Tagged_Type) then 1270 Error_Msg_N 1271 ("overriding of& is too late for building " 1272 & " static dispatch tables!", Subp); 1273 Error_Msg_N 1274 ("\spec should appear immediately after " 1275 & "the type!", Subp); 1276 end if; 1277 1278 -- No code required to register primitives in VM 1279 -- targets 1280 1281 elsif not Tagged_Type_Expansion then 1282 null; 1283 1284 else 1285 Insert_Actions_After (Subp_Body, 1286 Register_Primitive (Sloc (Subp_Body), 1287 Prim => Subp)); 1288 end if; 1289 1290 -- Indicate that this is an overriding operation, 1291 -- and replace the overridden entry in the list of 1292 -- primitive operations, which is used for xref 1293 -- generation subsequently. 1294 1295 Generate_Reference (Tagged_Type, Subp, 'P', False); 1296 Override_Dispatching_Operation 1297 (Tagged_Type, Old_Subp, Subp); 1298 end if; 1299 end if; 1300 end if; 1301 end; 1302 1303 else 1304 Error_Msg_N ("overriding of& is too late!", Subp); 1305 Error_Msg_N 1306 ("\subprogram spec should appear immediately after the type!", 1307 Subp); 1308 end if; 1309 1310 -- If the type is not frozen yet and we are not in the overriding 1311 -- case it looks suspiciously like an attempt to define a primitive 1312 -- operation, which requires the declaration to be in a package spec 1313 -- (3.2.3(6)). Only report cases where the type and subprogram are 1314 -- in the same declaration list (by checking the enclosing parent 1315 -- declarations), to avoid spurious warnings on subprograms in 1316 -- instance bodies when the type is declared in the instance spec 1317 -- but hasn't been frozen by the instance body. 1318 1319 elsif not Is_Frozen (Tagged_Type) 1320 and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp))) 1321 then 1322 Error_Msg_N 1323 ("??not dispatching (must be defined in a package spec)", Subp); 1324 return; 1325 1326 -- When the type is frozen, it is legitimate to define a new 1327 -- non-primitive operation. 1328 1329 else 1330 return; 1331 end if; 1332 1333 -- Now, we are sure that the scope is a package spec. If the subprogram 1334 -- is declared after the freezing point of the type that's an error 1335 1336 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then 1337 Error_Msg_N ("this primitive operation is declared too late", Subp); 1338 Error_Msg_NE 1339 ("??no primitive operations for& after this line", 1340 Freeze_Node (Tagged_Type), 1341 Tagged_Type); 1342 return; 1343 end if; 1344 1345 Check_Controlling_Formals (Tagged_Type, Subp); 1346 1347 Ovr_Subp := Old_Subp; 1348 1349 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be 1350 -- overridden by Subp. This only applies to source subprograms, and 1351 -- their declaration must carry an explicit overriding indicator. 1352 1353 if No (Ovr_Subp) 1354 and then Ada_Version >= Ada_2012 1355 and then Comes_From_Source (Subp) 1356 and then 1357 Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration 1358 then 1359 Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); 1360 1361 -- Verify that the proper overriding indicator has been supplied. 1362 1363 if Present (Ovr_Subp) 1364 and then 1365 not Must_Override (Specification (Unit_Declaration_Node (Subp))) 1366 then 1367 Error_Msg_NE ("missing overriding indicator for&", Subp, Subp); 1368 end if; 1369 end if; 1370 1371 -- Now it should be a correct primitive operation, put it in the list 1372 1373 if Present (Ovr_Subp) then 1374 1375 -- If the type has interfaces we complete this check after we set 1376 -- attribute Is_Dispatching_Operation. 1377 1378 Check_Subtype_Conformant (Subp, Ovr_Subp); 1379 1380 -- A primitive operation with the name of a primitive controlled 1381 -- operation does not override a non-visible overriding controlled 1382 -- operation, i.e. one declared in a private part when the full 1383 -- view of a type is controlled. Conversely, it will override a 1384 -- visible operation that may be declared in a partial view when 1385 -- the full view is controlled. 1386 1387 if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize) 1388 and then Is_Controlled (Tagged_Type) 1389 and then not Is_Visibly_Controlled (Tagged_Type) 1390 and then not Is_Inherited_Public_Operation (Ovr_Subp) 1391 then 1392 Set_Overridden_Operation (Subp, Empty); 1393 1394 -- If the subprogram specification carries an overriding 1395 -- indicator, no need for the warning: it is either redundant, 1396 -- or else an error will be reported. 1397 1398 if Nkind (Parent (Subp)) = N_Procedure_Specification 1399 and then 1400 (Must_Override (Parent (Subp)) 1401 or else Must_Not_Override (Parent (Subp))) 1402 then 1403 null; 1404 1405 -- Here we need the warning 1406 1407 else 1408 Error_Msg_NE 1409 ("operation does not override inherited&??", Subp, Subp); 1410 end if; 1411 1412 else 1413 Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp); 1414 1415 -- Ada 2005 (AI-251): In case of late overriding of a primitive 1416 -- that covers abstract interface subprograms we must register it 1417 -- in all the secondary dispatch tables associated with abstract 1418 -- interfaces. We do this now only if not building static tables, 1419 -- nor when the expander is inactive (we avoid trying to register 1420 -- primitives in semantics-only mode, since the type may not have 1421 -- an associated dispatch table). Otherwise the patch code is 1422 -- emitted after those tables are built, to prevent access before 1423 -- elaboration in gigi. 1424 1425 if Body_Is_Last_Primitive and then Expander_Active then 1426 declare 1427 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); 1428 Elmt : Elmt_Id; 1429 Prim : Node_Id; 1430 1431 begin 1432 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 1433 while Present (Elmt) loop 1434 Prim := Node (Elmt); 1435 1436 -- No code required to register primitives in VM targets 1437 1438 if Present (Alias (Prim)) 1439 and then Present (Interface_Alias (Prim)) 1440 and then Alias (Prim) = Subp 1441 and then not Building_Static_DT (Tagged_Type) 1442 and then Tagged_Type_Expansion 1443 then 1444 Insert_Actions_After (Subp_Body, 1445 Register_Primitive (Sloc (Subp_Body), Prim => Prim)); 1446 end if; 1447 1448 Next_Elmt (Elmt); 1449 end loop; 1450 1451 -- Redisplay the contents of the updated dispatch table 1452 1453 if Debug_Flag_ZZ then 1454 Write_Str ("Late overriding: "); 1455 Write_DT (Tagged_Type); 1456 end if; 1457 end; 1458 end if; 1459 end if; 1460 1461 -- If the tagged type is a concurrent type then we must be compiling 1462 -- with no code generation (we are either compiling a generic unit or 1463 -- compiling under -gnatc mode) because we have previously tested that 1464 -- no serious errors has been reported. In this case we do not add the 1465 -- primitive to the list of primitives of Tagged_Type but we leave the 1466 -- primitive decorated as a dispatching operation to be able to analyze 1467 -- and report errors associated with the Object.Operation notation. 1468 1469 elsif Is_Concurrent_Type (Tagged_Type) then 1470 pragma Assert (not Expander_Active); 1471 1472 -- Attach operation to list of primitives of the synchronized type 1473 -- itself, for ASIS use. 1474 1475 Append_Elmt (Subp, Direct_Primitive_Operations (Tagged_Type)); 1476 1477 -- If no old subprogram, then we add this as a dispatching operation, 1478 -- but we avoid doing this if an error was posted, to prevent annoying 1479 -- cascaded errors. 1480 1481 elsif not Error_Posted (Subp) then 1482 Add_Dispatching_Operation (Tagged_Type, Subp); 1483 end if; 1484 1485 Set_Is_Dispatching_Operation (Subp, True); 1486 1487 -- Ada 2005 (AI-251): If the type implements interfaces we must check 1488 -- subtype conformance against all the interfaces covered by this 1489 -- primitive. 1490 1491 if Present (Ovr_Subp) 1492 and then Has_Interfaces (Tagged_Type) 1493 then 1494 declare 1495 Ifaces_List : Elist_Id; 1496 Iface_Elmt : Elmt_Id; 1497 Iface_Prim_Elmt : Elmt_Id; 1498 Iface_Prim : Entity_Id; 1499 Ret_Typ : Entity_Id; 1500 1501 begin 1502 Collect_Interfaces (Tagged_Type, Ifaces_List); 1503 1504 Iface_Elmt := First_Elmt (Ifaces_List); 1505 while Present (Iface_Elmt) loop 1506 if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then 1507 Iface_Prim_Elmt := 1508 First_Elmt (Primitive_Operations (Node (Iface_Elmt))); 1509 while Present (Iface_Prim_Elmt) loop 1510 Iface_Prim := Node (Iface_Prim_Elmt); 1511 1512 if Is_Interface_Conformant 1513 (Tagged_Type, Iface_Prim, Subp) 1514 then 1515 -- Handle procedures, functions whose return type 1516 -- matches, or functions not returning interfaces 1517 1518 if Ekind (Subp) = E_Procedure 1519 or else Etype (Iface_Prim) = Etype (Subp) 1520 or else not Is_Interface (Etype (Iface_Prim)) 1521 then 1522 Check_Subtype_Conformant 1523 (New_Id => Subp, 1524 Old_Id => Iface_Prim, 1525 Err_Loc => Subp, 1526 Skip_Controlling_Formals => True); 1527 1528 -- Handle functions returning interfaces 1529 1530 elsif Implements_Interface 1531 (Etype (Subp), Etype (Iface_Prim)) 1532 then 1533 -- Temporarily force both entities to return the 1534 -- same type. Required because Subtype_Conformant 1535 -- does not handle this case. 1536 1537 Ret_Typ := Etype (Iface_Prim); 1538 Set_Etype (Iface_Prim, Etype (Subp)); 1539 1540 Check_Subtype_Conformant 1541 (New_Id => Subp, 1542 Old_Id => Iface_Prim, 1543 Err_Loc => Subp, 1544 Skip_Controlling_Formals => True); 1545 1546 Set_Etype (Iface_Prim, Ret_Typ); 1547 end if; 1548 end if; 1549 1550 Next_Elmt (Iface_Prim_Elmt); 1551 end loop; 1552 end if; 1553 1554 Next_Elmt (Iface_Elmt); 1555 end loop; 1556 end; 1557 end if; 1558 1559 if not Body_Is_Last_Primitive then 1560 Set_DT_Position_Value (Subp, No_Uint); 1561 1562 elsif Has_Controlled_Component (Tagged_Type) 1563 and then Nam_In (Chars (Subp), Name_Initialize, 1564 Name_Adjust, 1565 Name_Finalize, 1566 Name_Finalize_Address) 1567 then 1568 declare 1569 F_Node : constant Node_Id := Freeze_Node (Tagged_Type); 1570 Decl : Node_Id; 1571 Old_P : Entity_Id; 1572 Old_Bod : Node_Id; 1573 Old_Spec : Entity_Id; 1574 1575 C_Names : constant array (1 .. 4) of Name_Id := 1576 (Name_Initialize, 1577 Name_Adjust, 1578 Name_Finalize, 1579 Name_Finalize_Address); 1580 1581 D_Names : constant array (1 .. 4) of TSS_Name_Type := 1582 (TSS_Deep_Initialize, 1583 TSS_Deep_Adjust, 1584 TSS_Deep_Finalize, 1585 TSS_Finalize_Address); 1586 1587 begin 1588 -- Remove previous controlled function which was constructed and 1589 -- analyzed when the type was frozen. This requires removing the 1590 -- body of the redefined primitive, as well as its specification 1591 -- if needed (there is no spec created for Deep_Initialize, see 1592 -- exp_ch3.adb). We must also dismantle the exception information 1593 -- that may have been generated for it when front end zero-cost 1594 -- tables are enabled. 1595 1596 for J in D_Names'Range loop 1597 Old_P := TSS (Tagged_Type, D_Names (J)); 1598 1599 if Present (Old_P) 1600 and then Chars (Subp) = C_Names (J) 1601 then 1602 Old_Bod := Unit_Declaration_Node (Old_P); 1603 Remove (Old_Bod); 1604 Set_Is_Eliminated (Old_P); 1605 Set_Scope (Old_P, Scope (Current_Scope)); 1606 1607 if Nkind (Old_Bod) = N_Subprogram_Body 1608 and then Present (Corresponding_Spec (Old_Bod)) 1609 then 1610 Old_Spec := Corresponding_Spec (Old_Bod); 1611 Set_Has_Completion (Old_Spec, False); 1612 end if; 1613 end if; 1614 end loop; 1615 1616 Build_Late_Proc (Tagged_Type, Chars (Subp)); 1617 1618 -- The new operation is added to the actions of the freeze node 1619 -- for the type, but this node has already been analyzed, so we 1620 -- must retrieve and analyze explicitly the new body. 1621 1622 if Present (F_Node) 1623 and then Present (Actions (F_Node)) 1624 then 1625 Decl := Last (Actions (F_Node)); 1626 Analyze (Decl); 1627 end if; 1628 end; 1629 end if; 1630 1631 -- For similarity with record extensions, in Ada 9X the language should 1632 -- have disallowed adding visible operations to a tagged type after 1633 -- deriving a private extension from it. Report a warning if this 1634 -- primitive is defined after a private extension of Tagged_Type. 1635 1636 Warn_On_Late_Primitive_After_Private_Extension (Tagged_Type, Subp); 1637 end Check_Dispatching_Operation; 1638 1639 ------------------------------------------ 1640 -- Check_Operation_From_Incomplete_Type -- 1641 ------------------------------------------ 1642 1643 procedure Check_Operation_From_Incomplete_Type 1644 (Subp : Entity_Id; 1645 Typ : Entity_Id) 1646 is 1647 Full : constant Entity_Id := Full_View (Typ); 1648 Parent_Typ : constant Entity_Id := Etype (Full); 1649 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ); 1650 New_Prim : constant Elist_Id := Primitive_Operations (Full); 1651 Op1, Op2 : Elmt_Id; 1652 Prev : Elmt_Id := No_Elmt; 1653 1654 function Derives_From (Parent_Subp : Entity_Id) return Boolean; 1655 -- Check that Subp has profile of an operation derived from Parent_Subp. 1656 -- Subp must have a parameter or result type that is Typ or an access 1657 -- parameter or access result type that designates Typ. 1658 1659 ------------------ 1660 -- Derives_From -- 1661 ------------------ 1662 1663 function Derives_From (Parent_Subp : Entity_Id) return Boolean is 1664 F1, F2 : Entity_Id; 1665 1666 begin 1667 if Chars (Parent_Subp) /= Chars (Subp) then 1668 return False; 1669 end if; 1670 1671 -- Check that the type of controlling formals is derived from the 1672 -- parent subprogram's controlling formal type (or designated type 1673 -- if the formal type is an anonymous access type). 1674 1675 F1 := First_Formal (Parent_Subp); 1676 F2 := First_Formal (Subp); 1677 while Present (F1) and then Present (F2) loop 1678 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then 1679 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then 1680 return False; 1681 elsif Designated_Type (Etype (F1)) = Parent_Typ 1682 and then Designated_Type (Etype (F2)) /= Full 1683 then 1684 return False; 1685 end if; 1686 1687 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then 1688 return False; 1689 1690 elsif Etype (F1) = Parent_Typ and then Etype (F2) /= Full then 1691 return False; 1692 end if; 1693 1694 Next_Formal (F1); 1695 Next_Formal (F2); 1696 end loop; 1697 1698 -- Check that a controlling result type is derived from the parent 1699 -- subprogram's result type (or designated type if the result type 1700 -- is an anonymous access type). 1701 1702 if Ekind (Parent_Subp) = E_Function then 1703 if Ekind (Subp) /= E_Function then 1704 return False; 1705 1706 elsif Ekind (Etype (Parent_Subp)) = E_Anonymous_Access_Type then 1707 if Ekind (Etype (Subp)) /= E_Anonymous_Access_Type then 1708 return False; 1709 1710 elsif Designated_Type (Etype (Parent_Subp)) = Parent_Typ 1711 and then Designated_Type (Etype (Subp)) /= Full 1712 then 1713 return False; 1714 end if; 1715 1716 elsif Ekind (Etype (Subp)) = E_Anonymous_Access_Type then 1717 return False; 1718 1719 elsif Etype (Parent_Subp) = Parent_Typ 1720 and then Etype (Subp) /= Full 1721 then 1722 return False; 1723 end if; 1724 1725 elsif Ekind (Subp) = E_Function then 1726 return False; 1727 end if; 1728 1729 return No (F1) and then No (F2); 1730 end Derives_From; 1731 1732 -- Start of processing for Check_Operation_From_Incomplete_Type 1733 1734 begin 1735 -- The operation may override an inherited one, or may be a new one 1736 -- altogether. The inherited operation will have been hidden by the 1737 -- current one at the point of the type derivation, so it does not 1738 -- appear in the list of primitive operations of the type. We have to 1739 -- find the proper place of insertion in the list of primitive opera- 1740 -- tions by iterating over the list for the parent type. 1741 1742 Op1 := First_Elmt (Old_Prim); 1743 Op2 := First_Elmt (New_Prim); 1744 while Present (Op1) and then Present (Op2) loop 1745 if Derives_From (Node (Op1)) then 1746 if No (Prev) then 1747 1748 -- Avoid adding it to the list of primitives if already there 1749 1750 if Node (Op2) /= Subp then 1751 Prepend_Elmt (Subp, New_Prim); 1752 end if; 1753 1754 else 1755 Insert_Elmt_After (Subp, Prev); 1756 end if; 1757 1758 return; 1759 end if; 1760 1761 Prev := Op2; 1762 Next_Elmt (Op1); 1763 Next_Elmt (Op2); 1764 end loop; 1765 1766 -- Operation is a new primitive 1767 1768 Append_Elmt (Subp, New_Prim); 1769 end Check_Operation_From_Incomplete_Type; 1770 1771 --------------------------------------- 1772 -- Check_Operation_From_Private_View -- 1773 --------------------------------------- 1774 1775 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is 1776 Tagged_Type : Entity_Id; 1777 1778 begin 1779 if Is_Dispatching_Operation (Alias (Subp)) then 1780 Set_Scope (Subp, Current_Scope); 1781 Tagged_Type := Find_Dispatching_Type (Subp); 1782 1783 -- Add Old_Subp to primitive operations if not already present 1784 1785 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then 1786 Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); 1787 1788 -- If Old_Subp isn't already marked as dispatching then this is 1789 -- the case of an operation of an untagged private type fulfilled 1790 -- by a tagged type that overrides an inherited dispatching 1791 -- operation, so we set the necessary dispatching attributes here. 1792 1793 if not Is_Dispatching_Operation (Old_Subp) then 1794 1795 -- If the untagged type has no discriminants, and the full 1796 -- view is constrained, there will be a spurious mismatch of 1797 -- subtypes on the controlling arguments, because the tagged 1798 -- type is the internal base type introduced in the derivation. 1799 -- Use the original type to verify conformance, rather than the 1800 -- base type. 1801 1802 if not Comes_From_Source (Tagged_Type) 1803 and then Has_Discriminants (Tagged_Type) 1804 then 1805 declare 1806 Formal : Entity_Id; 1807 1808 begin 1809 Formal := First_Formal (Old_Subp); 1810 while Present (Formal) loop 1811 if Tagged_Type = Base_Type (Etype (Formal)) then 1812 Tagged_Type := Etype (Formal); 1813 end if; 1814 1815 Next_Formal (Formal); 1816 end loop; 1817 end; 1818 1819 if Tagged_Type = Base_Type (Etype (Old_Subp)) then 1820 Tagged_Type := Etype (Old_Subp); 1821 end if; 1822 end if; 1823 1824 Check_Controlling_Formals (Tagged_Type, Old_Subp); 1825 Set_Is_Dispatching_Operation (Old_Subp, True); 1826 Set_DT_Position_Value (Old_Subp, No_Uint); 1827 end if; 1828 1829 -- If the old subprogram is an explicit renaming of some other 1830 -- entity, it is not overridden by the inherited subprogram. 1831 -- Otherwise, update its alias and other attributes. 1832 1833 if Present (Alias (Old_Subp)) 1834 and then Nkind (Unit_Declaration_Node (Old_Subp)) /= 1835 N_Subprogram_Renaming_Declaration 1836 then 1837 Set_Alias (Old_Subp, Alias (Subp)); 1838 1839 -- The derived subprogram should inherit the abstractness of 1840 -- the parent subprogram (except in the case of a function 1841 -- returning the type). This sets the abstractness properly 1842 -- for cases where a private extension may have inherited an 1843 -- abstract operation, but the full type is derived from a 1844 -- descendant type and inherits a nonabstract version. 1845 1846 if Etype (Subp) /= Tagged_Type then 1847 Set_Is_Abstract_Subprogram 1848 (Old_Subp, Is_Abstract_Subprogram (Alias (Subp))); 1849 end if; 1850 end if; 1851 end if; 1852 end if; 1853 end Check_Operation_From_Private_View; 1854 1855 -------------------------- 1856 -- Find_Controlling_Arg -- 1857 -------------------------- 1858 1859 function Find_Controlling_Arg (N : Node_Id) return Node_Id is 1860 Orig_Node : constant Node_Id := Original_Node (N); 1861 Typ : Entity_Id; 1862 1863 begin 1864 if Nkind (Orig_Node) = N_Qualified_Expression then 1865 return Find_Controlling_Arg (Expression (Orig_Node)); 1866 end if; 1867 1868 -- Dispatching on result case. If expansion is disabled, the node still 1869 -- has the structure of a function call. However, if the function name 1870 -- is an operator and the call was given in infix form, the original 1871 -- node has no controlling result and we must examine the current node. 1872 1873 if Nkind (N) = N_Function_Call 1874 and then Present (Controlling_Argument (N)) 1875 and then Has_Controlling_Result (Entity (Name (N))) 1876 then 1877 return Controlling_Argument (N); 1878 1879 -- If expansion is enabled, the call may have been transformed into 1880 -- an indirect call, and we need to recover the original node. 1881 1882 elsif Nkind (Orig_Node) = N_Function_Call 1883 and then Present (Controlling_Argument (Orig_Node)) 1884 and then Has_Controlling_Result (Entity (Name (Orig_Node))) 1885 then 1886 return Controlling_Argument (Orig_Node); 1887 1888 -- Type conversions are dynamically tagged if the target type, or its 1889 -- designated type, are classwide. An interface conversion expands into 1890 -- a dereference, so test must be performed on the original node. 1891 1892 elsif Nkind (Orig_Node) = N_Type_Conversion 1893 and then Nkind (N) = N_Explicit_Dereference 1894 and then Is_Controlling_Actual (N) 1895 then 1896 declare 1897 Target_Type : constant Entity_Id := 1898 Entity (Subtype_Mark (Orig_Node)); 1899 1900 begin 1901 if Is_Class_Wide_Type (Target_Type) then 1902 return N; 1903 1904 elsif Is_Access_Type (Target_Type) 1905 and then Is_Class_Wide_Type (Designated_Type (Target_Type)) 1906 then 1907 return N; 1908 1909 else 1910 return Empty; 1911 end if; 1912 end; 1913 1914 -- Normal case 1915 1916 elsif Is_Controlling_Actual (N) 1917 or else 1918 (Nkind (Parent (N)) = N_Qualified_Expression 1919 and then Is_Controlling_Actual (Parent (N))) 1920 then 1921 Typ := Etype (N); 1922 1923 if Is_Access_Type (Typ) then 1924 1925 -- In the case of an Access attribute, use the type of the prefix, 1926 -- since in the case of an actual for an access parameter, the 1927 -- attribute's type may be of a specific designated type, even 1928 -- though the prefix type is class-wide. 1929 1930 if Nkind (N) = N_Attribute_Reference then 1931 Typ := Etype (Prefix (N)); 1932 1933 -- An allocator is dispatching if the type of qualified expression 1934 -- is class_wide, in which case this is the controlling type. 1935 1936 elsif Nkind (Orig_Node) = N_Allocator 1937 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression 1938 then 1939 Typ := Etype (Expression (Orig_Node)); 1940 else 1941 Typ := Designated_Type (Typ); 1942 end if; 1943 end if; 1944 1945 if Is_Class_Wide_Type (Typ) 1946 or else 1947 (Nkind (Parent (N)) = N_Qualified_Expression 1948 and then Is_Access_Type (Etype (N)) 1949 and then Is_Class_Wide_Type (Designated_Type (Etype (N)))) 1950 then 1951 return N; 1952 end if; 1953 end if; 1954 1955 return Empty; 1956 end Find_Controlling_Arg; 1957 1958 --------------------------- 1959 -- Find_Dispatching_Type -- 1960 --------------------------- 1961 1962 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is 1963 A_Formal : Entity_Id; 1964 Formal : Entity_Id; 1965 Ctrl_Type : Entity_Id; 1966 1967 begin 1968 if Ekind_In (Subp, E_Function, E_Procedure) 1969 and then Present (DTC_Entity (Subp)) 1970 then 1971 return Scope (DTC_Entity (Subp)); 1972 1973 -- For subprograms internally generated by derivations of tagged types 1974 -- use the alias subprogram as a reference to locate the dispatching 1975 -- type of Subp. 1976 1977 elsif not Comes_From_Source (Subp) 1978 and then Present (Alias (Subp)) 1979 and then Is_Dispatching_Operation (Alias (Subp)) 1980 then 1981 if Ekind (Alias (Subp)) = E_Function 1982 and then Has_Controlling_Result (Alias (Subp)) 1983 then 1984 return Check_Controlling_Type (Etype (Subp), Subp); 1985 1986 else 1987 Formal := First_Formal (Subp); 1988 A_Formal := First_Formal (Alias (Subp)); 1989 while Present (A_Formal) loop 1990 if Is_Controlling_Formal (A_Formal) then 1991 return Check_Controlling_Type (Etype (Formal), Subp); 1992 end if; 1993 1994 Next_Formal (Formal); 1995 Next_Formal (A_Formal); 1996 end loop; 1997 1998 pragma Assert (False); 1999 return Empty; 2000 end if; 2001 2002 -- General case 2003 2004 else 2005 Formal := First_Formal (Subp); 2006 while Present (Formal) loop 2007 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); 2008 2009 if Present (Ctrl_Type) then 2010 return Ctrl_Type; 2011 end if; 2012 2013 Next_Formal (Formal); 2014 end loop; 2015 2016 -- The subprogram may also be dispatching on result 2017 2018 if Present (Etype (Subp)) then 2019 return Check_Controlling_Type (Etype (Subp), Subp); 2020 end if; 2021 end if; 2022 2023 pragma Assert (not Is_Dispatching_Operation (Subp)); 2024 return Empty; 2025 end Find_Dispatching_Type; 2026 2027 -------------------------------------- 2028 -- Find_Hidden_Overridden_Primitive -- 2029 -------------------------------------- 2030 2031 function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id 2032 is 2033 Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S); 2034 Elmt : Elmt_Id; 2035 Orig_Prim : Entity_Id; 2036 Prim : Entity_Id; 2037 Vis_List : Elist_Id; 2038 2039 begin 2040 -- This Ada 2012 rule applies only for type extensions or private 2041 -- extensions, where the parent type is not in a parent unit, and 2042 -- where an operation is never declared but still inherited. 2043 2044 if No (Tag_Typ) 2045 or else not Is_Record_Type (Tag_Typ) 2046 or else Etype (Tag_Typ) = Tag_Typ 2047 or else In_Open_Scopes (Scope (Etype (Tag_Typ))) 2048 then 2049 return Empty; 2050 end if; 2051 2052 -- Collect the list of visible ancestor of the tagged type 2053 2054 Vis_List := Visible_Ancestors (Tag_Typ); 2055 2056 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 2057 while Present (Elmt) loop 2058 Prim := Node (Elmt); 2059 2060 -- Find an inherited hidden dispatching primitive with the name of S 2061 -- and a type-conformant profile. 2062 2063 if Present (Alias (Prim)) 2064 and then Is_Hidden (Alias (Prim)) 2065 and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ 2066 and then Primitive_Names_Match (S, Prim) 2067 and then Type_Conformant (S, Prim) 2068 then 2069 declare 2070 Vis_Ancestor : Elmt_Id; 2071 Elmt : Elmt_Id; 2072 2073 begin 2074 -- The original corresponding operation of Prim must be an 2075 -- operation of a visible ancestor of the dispatching type S, 2076 -- and the original corresponding operation of S2 must be 2077 -- visible. 2078 2079 Orig_Prim := Original_Corresponding_Operation (Prim); 2080 2081 if Orig_Prim /= Prim 2082 and then Is_Immediately_Visible (Orig_Prim) 2083 then 2084 Vis_Ancestor := First_Elmt (Vis_List); 2085 while Present (Vis_Ancestor) loop 2086 Elmt := 2087 First_Elmt (Primitive_Operations (Node (Vis_Ancestor))); 2088 while Present (Elmt) loop 2089 if Node (Elmt) = Orig_Prim then 2090 Set_Overridden_Operation (S, Prim); 2091 Set_Alias (Prim, Orig_Prim); 2092 return Prim; 2093 end if; 2094 2095 Next_Elmt (Elmt); 2096 end loop; 2097 2098 Next_Elmt (Vis_Ancestor); 2099 end loop; 2100 end if; 2101 end; 2102 end if; 2103 2104 Next_Elmt (Elmt); 2105 end loop; 2106 2107 return Empty; 2108 end Find_Hidden_Overridden_Primitive; 2109 2110 --------------------------------------- 2111 -- Find_Primitive_Covering_Interface -- 2112 --------------------------------------- 2113 2114 function Find_Primitive_Covering_Interface 2115 (Tagged_Type : Entity_Id; 2116 Iface_Prim : Entity_Id) return Entity_Id 2117 is 2118 E : Entity_Id; 2119 El : Elmt_Id; 2120 2121 begin 2122 pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) 2123 or else (Present (Alias (Iface_Prim)) 2124 and then 2125 Is_Interface 2126 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); 2127 2128 -- Search in the homonym chain. Done to speed up locating visible 2129 -- entities and required to catch primitives associated with the partial 2130 -- view of private types when processing the corresponding full view. 2131 2132 E := Current_Entity (Iface_Prim); 2133 while Present (E) loop 2134 if Is_Subprogram (E) 2135 and then Is_Dispatching_Operation (E) 2136 and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) 2137 then 2138 return E; 2139 end if; 2140 2141 E := Homonym (E); 2142 end loop; 2143 2144 -- Search in the list of primitives of the type. Required to locate 2145 -- the covering primitive if the covering primitive is not visible 2146 -- (for example, non-visible inherited primitive of private type). 2147 2148 El := First_Elmt (Primitive_Operations (Tagged_Type)); 2149 while Present (El) loop 2150 E := Node (El); 2151 2152 -- Keep separate the management of internal entities that link 2153 -- primitives with interface primitives from tagged type primitives. 2154 2155 if No (Interface_Alias (E)) then 2156 if Present (Alias (E)) then 2157 2158 -- This interface primitive has not been covered yet 2159 2160 if Alias (E) = Iface_Prim then 2161 return E; 2162 2163 -- The covering primitive was inherited 2164 2165 elsif Overridden_Operation (Ultimate_Alias (E)) 2166 = Iface_Prim 2167 then 2168 return E; 2169 end if; 2170 end if; 2171 2172 -- Check if E covers the interface primitive (includes case in 2173 -- which E is an inherited private primitive). 2174 2175 if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then 2176 return E; 2177 end if; 2178 2179 -- Use the internal entity that links the interface primitive with 2180 -- the covering primitive to locate the entity. 2181 2182 elsif Interface_Alias (E) = Iface_Prim then 2183 return Alias (E); 2184 end if; 2185 2186 Next_Elmt (El); 2187 end loop; 2188 2189 -- Not found 2190 2191 return Empty; 2192 end Find_Primitive_Covering_Interface; 2193 2194 --------------------------- 2195 -- Inherited_Subprograms -- 2196 --------------------------- 2197 2198 function Inherited_Subprograms 2199 (S : Entity_Id; 2200 No_Interfaces : Boolean := False; 2201 Interfaces_Only : Boolean := False; 2202 One_Only : Boolean := False) return Subprogram_List 2203 is 2204 Result : Subprogram_List (1 .. 6000); 2205 -- 6000 here is intended to be infinity. We could use an expandable 2206 -- table, but it would be awfully heavy, and there is no way that we 2207 -- could reasonably exceed this value. 2208 2209 N : Nat := 0; 2210 -- Number of entries in Result 2211 2212 Parent_Op : Entity_Id; 2213 -- Traverses the Overridden_Operation chain 2214 2215 procedure Store_IS (E : Entity_Id); 2216 -- Stores E in Result if not already stored 2217 2218 -------------- 2219 -- Store_IS -- 2220 -------------- 2221 2222 procedure Store_IS (E : Entity_Id) is 2223 begin 2224 for J in 1 .. N loop 2225 if E = Result (J) then 2226 return; 2227 end if; 2228 end loop; 2229 2230 N := N + 1; 2231 Result (N) := E; 2232 end Store_IS; 2233 2234 -- Start of processing for Inherited_Subprograms 2235 2236 begin 2237 pragma Assert (not (No_Interfaces and Interfaces_Only)); 2238 2239 if Present (S) and then Is_Dispatching_Operation (S) then 2240 2241 -- Deal with direct inheritance 2242 2243 if not Interfaces_Only then 2244 Parent_Op := S; 2245 loop 2246 Parent_Op := Overridden_Operation (Parent_Op); 2247 exit when No (Parent_Op) 2248 or else 2249 (No_Interfaces 2250 and then 2251 Is_Interface (Find_Dispatching_Type (Parent_Op))); 2252 2253 if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then 2254 Store_IS (Parent_Op); 2255 2256 if One_Only then 2257 goto Done; 2258 end if; 2259 end if; 2260 end loop; 2261 end if; 2262 2263 -- Now deal with interfaces 2264 2265 if not No_Interfaces then 2266 declare 2267 Tag_Typ : Entity_Id; 2268 Prim : Entity_Id; 2269 Elmt : Elmt_Id; 2270 2271 begin 2272 Tag_Typ := Find_Dispatching_Type (S); 2273 2274 -- In the presence of limited views there may be no visible 2275 -- dispatching type. Primitives will be inherited when non- 2276 -- limited view is frozen. 2277 2278 if No (Tag_Typ) then 2279 return Result (1 .. 0); 2280 end if; 2281 2282 if Is_Concurrent_Type (Tag_Typ) then 2283 Tag_Typ := Corresponding_Record_Type (Tag_Typ); 2284 end if; 2285 2286 -- Search primitive operations of dispatching type 2287 2288 if Present (Tag_Typ) 2289 and then Present (Primitive_Operations (Tag_Typ)) 2290 then 2291 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 2292 while Present (Elmt) loop 2293 Prim := Node (Elmt); 2294 2295 -- The following test eliminates some odd cases in which 2296 -- Ekind (Prim) is Void, to be investigated further ??? 2297 2298 if not Is_Subprogram_Or_Generic_Subprogram (Prim) then 2299 null; 2300 2301 -- For [generic] subprogram, look at interface alias 2302 2303 elsif Present (Interface_Alias (Prim)) 2304 and then Alias (Prim) = S 2305 then 2306 -- We have found a primitive covered by S 2307 2308 Store_IS (Interface_Alias (Prim)); 2309 2310 if One_Only then 2311 goto Done; 2312 end if; 2313 end if; 2314 2315 Next_Elmt (Elmt); 2316 end loop; 2317 end if; 2318 end; 2319 end if; 2320 end if; 2321 2322 <<Done>> 2323 2324 return Result (1 .. N); 2325 end Inherited_Subprograms; 2326 2327 --------------------------- 2328 -- Is_Dynamically_Tagged -- 2329 --------------------------- 2330 2331 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is 2332 begin 2333 if Nkind (N) = N_Error then 2334 return False; 2335 2336 elsif Present (Find_Controlling_Arg (N)) then 2337 return True; 2338 2339 -- Special cases: entities, and calls that dispatch on result 2340 2341 elsif Is_Entity_Name (N) then 2342 return Is_Class_Wide_Type (Etype (N)); 2343 2344 elsif Nkind (N) = N_Function_Call 2345 and then Is_Class_Wide_Type (Etype (N)) 2346 then 2347 return True; 2348 2349 -- Otherwise check whether call has controlling argument 2350 2351 else 2352 return False; 2353 end if; 2354 end Is_Dynamically_Tagged; 2355 2356 --------------------------------- 2357 -- Is_Null_Interface_Primitive -- 2358 --------------------------------- 2359 2360 function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is 2361 begin 2362 return Comes_From_Source (E) 2363 and then Is_Dispatching_Operation (E) 2364 and then Ekind (E) = E_Procedure 2365 and then Null_Present (Parent (E)) 2366 and then Is_Interface (Find_Dispatching_Type (E)); 2367 end Is_Null_Interface_Primitive; 2368 2369 ----------------------------------- 2370 -- Is_Inherited_Public_Operation -- 2371 ----------------------------------- 2372 2373 function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is 2374 Pack_Decl : Node_Id; 2375 Prim : Entity_Id := Op; 2376 Scop : Entity_Id := Prim; 2377 2378 begin 2379 -- Locate the ultimate non-hidden alias entity 2380 2381 while Present (Alias (Prim)) and then not Is_Hidden (Alias (Prim)) loop 2382 pragma Assert (Alias (Prim) /= Prim); 2383 Prim := Alias (Prim); 2384 Scop := Scope (Prim); 2385 end loop; 2386 2387 if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then 2388 Pack_Decl := Unit_Declaration_Node (Scop); 2389 2390 return 2391 Nkind (Pack_Decl) = N_Package_Declaration 2392 and then List_Containing (Unit_Declaration_Node (Prim)) = 2393 Visible_Declarations (Specification (Pack_Decl)); 2394 2395 else 2396 return False; 2397 end if; 2398 end Is_Inherited_Public_Operation; 2399 2400 ------------------------------ 2401 -- Is_Overriding_Subprogram -- 2402 ------------------------------ 2403 2404 function Is_Overriding_Subprogram (E : Entity_Id) return Boolean is 2405 Inherited : constant Subprogram_List := 2406 Inherited_Subprograms (E, One_Only => True); 2407 begin 2408 return Inherited'Length > 0; 2409 end Is_Overriding_Subprogram; 2410 2411 -------------------------- 2412 -- Is_Tag_Indeterminate -- 2413 -------------------------- 2414 2415 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is 2416 Nam : Entity_Id; 2417 Actual : Node_Id; 2418 Orig_Node : constant Node_Id := Original_Node (N); 2419 2420 begin 2421 if Nkind (Orig_Node) = N_Function_Call 2422 and then Is_Entity_Name (Name (Orig_Node)) 2423 then 2424 Nam := Entity (Name (Orig_Node)); 2425 2426 if not Has_Controlling_Result (Nam) then 2427 return False; 2428 2429 -- The function may have a controlling result, but if the return type 2430 -- is not visibly tagged, then this is not tag-indeterminate. 2431 2432 elsif Is_Access_Type (Etype (Nam)) 2433 and then not Is_Tagged_Type (Designated_Type (Etype (Nam))) 2434 then 2435 return False; 2436 2437 -- An explicit dereference means that the call has already been 2438 -- expanded and there is no tag to propagate. 2439 2440 elsif Nkind (N) = N_Explicit_Dereference then 2441 return False; 2442 2443 -- If there are no actuals, the call is tag-indeterminate 2444 2445 elsif No (Parameter_Associations (Orig_Node)) then 2446 return True; 2447 2448 else 2449 Actual := First_Actual (Orig_Node); 2450 while Present (Actual) loop 2451 if Is_Controlling_Actual (Actual) 2452 and then not Is_Tag_Indeterminate (Actual) 2453 then 2454 -- One operand is dispatching 2455 2456 return False; 2457 end if; 2458 2459 Next_Actual (Actual); 2460 end loop; 2461 2462 return True; 2463 end if; 2464 2465 elsif Nkind (Orig_Node) = N_Qualified_Expression then 2466 return Is_Tag_Indeterminate (Expression (Orig_Node)); 2467 2468 -- Case of a call to the Input attribute (possibly rewritten), which is 2469 -- always tag-indeterminate except when its prefix is a Class attribute. 2470 2471 elsif Nkind (Orig_Node) = N_Attribute_Reference 2472 and then 2473 Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input 2474 and then Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference 2475 then 2476 return True; 2477 2478 -- In Ada 2005, a function that returns an anonymous access type can be 2479 -- dispatching, and the dereference of a call to such a function can 2480 -- also be tag-indeterminate if the call itself is. 2481 2482 elsif Nkind (Orig_Node) = N_Explicit_Dereference 2483 and then Ada_Version >= Ada_2005 2484 then 2485 return Is_Tag_Indeterminate (Prefix (Orig_Node)); 2486 2487 else 2488 return False; 2489 end if; 2490 end Is_Tag_Indeterminate; 2491 2492 ------------------------------------ 2493 -- Override_Dispatching_Operation -- 2494 ------------------------------------ 2495 2496 procedure Override_Dispatching_Operation 2497 (Tagged_Type : Entity_Id; 2498 Prev_Op : Entity_Id; 2499 New_Op : Entity_Id; 2500 Is_Wrapper : Boolean := False) 2501 is 2502 Elmt : Elmt_Id; 2503 Prim : Node_Id; 2504 2505 begin 2506 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but 2507 -- we do it unconditionally in Ada 95 now, since this is our pragma). 2508 2509 if No_Return (Prev_Op) and then not No_Return (New_Op) then 2510 Error_Msg_N ("procedure & must have No_Return pragma", New_Op); 2511 Error_Msg_N ("\since overridden procedure has No_Return", New_Op); 2512 end if; 2513 2514 -- If there is no previous operation to override, the type declaration 2515 -- was malformed, and an error must have been emitted already. 2516 2517 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 2518 while Present (Elmt) and then Node (Elmt) /= Prev_Op loop 2519 Next_Elmt (Elmt); 2520 end loop; 2521 2522 if No (Elmt) then 2523 return; 2524 end if; 2525 2526 -- The location of entities that come from source in the list of 2527 -- primitives of the tagged type must follow their order of occurrence 2528 -- in the sources to fulfill the C++ ABI. If the overridden entity is a 2529 -- primitive of an interface that is not implemented by the parents of 2530 -- this tagged type (that is, it is an alias of an interface primitive 2531 -- generated by Derive_Interface_Progenitors), then we must append the 2532 -- new entity at the end of the list of primitives. 2533 2534 if Present (Alias (Prev_Op)) 2535 and then Etype (Tagged_Type) /= Tagged_Type 2536 and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) 2537 and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), 2538 Tagged_Type, Use_Full_View => True) 2539 and then not Implements_Interface 2540 (Etype (Tagged_Type), 2541 Find_Dispatching_Type (Alias (Prev_Op))) 2542 then 2543 Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); 2544 Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); 2545 2546 -- The new primitive replaces the overridden entity. Required to ensure 2547 -- that overriding primitive is assigned the same dispatch table slot. 2548 2549 else 2550 Replace_Elmt (Elmt, New_Op); 2551 end if; 2552 2553 if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then 2554 2555 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased 2556 -- entities of the overridden primitive to reference New_Op, and 2557 -- also propagate the proper value of Is_Abstract_Subprogram. Verify 2558 -- that the new operation is subtype conformant with the interface 2559 -- operations that it implements (for operations inherited from the 2560 -- parent itself, this check is made when building the derived type). 2561 2562 -- Note: This code is executed with internally generated wrappers of 2563 -- functions with controlling result and late overridings. 2564 2565 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 2566 while Present (Elmt) loop 2567 Prim := Node (Elmt); 2568 2569 if Prim = New_Op then 2570 null; 2571 2572 -- Note: The check on Is_Subprogram protects the frontend against 2573 -- reading attributes in entities that are not yet fully decorated 2574 2575 elsif Is_Subprogram (Prim) 2576 and then Present (Interface_Alias (Prim)) 2577 and then Alias (Prim) = Prev_Op 2578 then 2579 Set_Alias (Prim, New_Op); 2580 2581 -- No further decoration needed yet for internally generated 2582 -- wrappers of controlling functions since (at this stage) 2583 -- they are not yet decorated. 2584 2585 if not Is_Wrapper then 2586 Check_Subtype_Conformant (New_Op, Prim); 2587 2588 Set_Is_Abstract_Subprogram (Prim, 2589 Is_Abstract_Subprogram (New_Op)); 2590 2591 -- Ensure that this entity will be expanded to fill the 2592 -- corresponding entry in its dispatch table. 2593 2594 if not Is_Abstract_Subprogram (Prim) then 2595 Set_Has_Delayed_Freeze (Prim); 2596 end if; 2597 end if; 2598 end if; 2599 2600 Next_Elmt (Elmt); 2601 end loop; 2602 end if; 2603 2604 if (not Is_Package_Or_Generic_Package (Current_Scope)) 2605 or else not In_Private_Part (Current_Scope) 2606 then 2607 -- Not a private primitive 2608 2609 null; 2610 2611 else pragma Assert (Is_Inherited_Operation (Prev_Op)); 2612 2613 -- Make the overriding operation into an alias of the implicit one. 2614 -- In this fashion a call from outside ends up calling the new body 2615 -- even if non-dispatching, and a call from inside calls the over- 2616 -- riding operation because it hides the implicit one. To indicate 2617 -- that the body of Prev_Op is never called, set its dispatch table 2618 -- entity to Empty. If the overridden operation has a dispatching 2619 -- result, so does the overriding one. 2620 2621 Set_Alias (Prev_Op, New_Op); 2622 Set_DTC_Entity (Prev_Op, Empty); 2623 Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op)); 2624 return; 2625 end if; 2626 end Override_Dispatching_Operation; 2627 2628 ------------------- 2629 -- Propagate_Tag -- 2630 ------------------- 2631 2632 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is 2633 Call_Node : Node_Id; 2634 Arg : Node_Id; 2635 2636 begin 2637 if Nkind (Actual) = N_Function_Call then 2638 Call_Node := Actual; 2639 2640 elsif Nkind (Actual) = N_Identifier 2641 and then Nkind (Original_Node (Actual)) = N_Function_Call 2642 then 2643 -- Call rewritten as object declaration when stack-checking is 2644 -- enabled. Propagate tag to expression in declaration, which is 2645 -- original call. 2646 2647 Call_Node := Expression (Parent (Entity (Actual))); 2648 2649 -- Ada 2005: If this is a dereference of a call to a function with a 2650 -- dispatching access-result, the tag is propagated when the dereference 2651 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do. 2652 2653 elsif Nkind (Actual) = N_Explicit_Dereference 2654 and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call 2655 then 2656 return; 2657 2658 -- When expansion is suppressed, an unexpanded call to 'Input can occur, 2659 -- and in that case we can simply return. 2660 2661 elsif Nkind (Actual) = N_Attribute_Reference then 2662 pragma Assert (Attribute_Name (Actual) = Name_Input); 2663 2664 return; 2665 2666 -- Only other possibilities are parenthesized or qualified expression, 2667 -- or an expander-generated unchecked conversion of a function call to 2668 -- a stream Input attribute. 2669 2670 else 2671 Call_Node := Expression (Actual); 2672 end if; 2673 2674 -- No action needed if the call has been already expanded 2675 2676 if Is_Expanded_Dispatching_Call (Call_Node) then 2677 return; 2678 end if; 2679 2680 -- Do not set the Controlling_Argument if already set. This happens in 2681 -- the special case of _Input (see Exp_Attr, case Input). 2682 2683 if No (Controlling_Argument (Call_Node)) then 2684 Set_Controlling_Argument (Call_Node, Control); 2685 end if; 2686 2687 Arg := First_Actual (Call_Node); 2688 while Present (Arg) loop 2689 if Is_Tag_Indeterminate (Arg) then 2690 Propagate_Tag (Control, Arg); 2691 end if; 2692 2693 Next_Actual (Arg); 2694 end loop; 2695 2696 -- Expansion of dispatching calls is suppressed on VM targets, because 2697 -- the VM back-ends directly handle the generation of dispatching calls 2698 -- and would have to undo any expansion to an indirect call. 2699 2700 if Tagged_Type_Expansion then 2701 declare 2702 Call_Typ : constant Entity_Id := Etype (Call_Node); 2703 2704 begin 2705 Expand_Dispatching_Call (Call_Node); 2706 2707 -- If the controlling argument is an interface type and the type 2708 -- of Call_Node differs then we must add an implicit conversion to 2709 -- force displacement of the pointer to the object to reference 2710 -- the secondary dispatch table of the interface. 2711 2712 if Is_Interface (Etype (Control)) 2713 and then Etype (Control) /= Call_Typ 2714 then 2715 -- Cannot use Convert_To because the previous call to 2716 -- Expand_Dispatching_Call leaves decorated the Call_Node 2717 -- with the type of Control. 2718 2719 Rewrite (Call_Node, 2720 Make_Type_Conversion (Sloc (Call_Node), 2721 Subtype_Mark => 2722 New_Occurrence_Of (Etype (Control), Sloc (Call_Node)), 2723 Expression => Relocate_Node (Call_Node))); 2724 Set_Etype (Call_Node, Etype (Control)); 2725 Set_Analyzed (Call_Node); 2726 2727 Expand_Interface_Conversion (Call_Node); 2728 end if; 2729 end; 2730 2731 -- Expansion of a dispatching call results in an indirect call, which in 2732 -- turn causes current values to be killed (see Resolve_Call), so on VM 2733 -- targets we do the call here to ensure consistent warnings between VM 2734 -- and non-VM targets. 2735 2736 else 2737 Kill_Current_Values; 2738 end if; 2739 end Propagate_Tag; 2740 2741end Sem_Disp; 2742