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