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