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