1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ D I S P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Expander; use Expander; 33with Exp_Atag; use Exp_Atag; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_CG; use Exp_CG; 36with Exp_Dbug; use Exp_Dbug; 37with Exp_Tss; use Exp_Tss; 38with Exp_Util; use Exp_Util; 39with Freeze; use Freeze; 40with Ghost; use Ghost; 41with Itypes; use Itypes; 42with Layout; use Layout; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Namet; use Namet; 46with Opt; use Opt; 47with Output; use Output; 48with Restrict; use Restrict; 49with Rident; use Rident; 50with Rtsfind; use Rtsfind; 51with Sem; use Sem; 52with Sem_Aux; use Sem_Aux; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch7; use Sem_Ch7; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Disp; use Sem_Disp; 57with Sem_Eval; use Sem_Eval; 58with Sem_Res; use Sem_Res; 59with Sem_Type; use Sem_Type; 60with Sem_Util; use Sem_Util; 61with Sinfo; use Sinfo; 62with Sinput; use Sinput; 63with Snames; use Snames; 64with Stand; use Stand; 65with Stringt; use Stringt; 66with SCIL_LL; use SCIL_LL; 67with Tbuild; use Tbuild; 68 69package body Exp_Disp is 70 71 ----------------------- 72 -- Local Subprograms -- 73 ----------------------- 74 75 function Default_Prim_Op_Position (E : Entity_Id) return Uint; 76 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table 77 -- of the default primitive operations. 78 79 function Has_DT (Typ : Entity_Id) return Boolean; 80 pragma Inline (Has_DT); 81 -- Returns true if we generate a dispatch table for tagged type Typ 82 83 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; 84 -- Returns true if Prim is not a predefined dispatching primitive but it is 85 -- an alias of a predefined dispatching primitive (i.e. through a renaming) 86 87 function New_Value (From : Node_Id) return Node_Id; 88 -- From is the original Expression. New_Value is equivalent to a call to 89 -- Duplicate_Subexpr with an explicit dereference when From is an access 90 -- parameter. 91 92 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; 93 -- Check if the type has a private view or if the public view appears in 94 -- the visible part of a package spec. 95 96 function Prim_Op_Kind 97 (Prim : Entity_Id; 98 Typ : Entity_Id) return Node_Id; 99 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim 100 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind 101 -- enumeration value. 102 103 function Tagged_Kind (T : Entity_Id) return Node_Id; 104 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference 105 -- to an RE_Tagged_Kind enumeration value. 106 107 ---------------------- 108 -- Apply_Tag_Checks -- 109 ---------------------- 110 111 procedure Apply_Tag_Checks (Call_Node : Node_Id) is 112 Loc : constant Source_Ptr := Sloc (Call_Node); 113 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); 114 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); 115 Param_List : constant List_Id := Parameter_Associations (Call_Node); 116 117 Subp : Entity_Id; 118 CW_Typ : Entity_Id; 119 Param : Node_Id; 120 Typ : Entity_Id; 121 Eq_Prim_Op : Entity_Id := Empty; 122 123 begin 124 if No_Run_Time_Mode then 125 Error_Msg_CRT ("tagged types", Call_Node); 126 return; 127 end if; 128 129 -- Apply_Tag_Checks is called directly from the semantics, so we 130 -- need a check to see whether expansion is active before proceeding. 131 -- In addition, there is no need to expand the call when compiling 132 -- under restriction No_Dispatching_Calls; the semantic analyzer has 133 -- previously notified the violation of this restriction. 134 135 if not Expander_Active 136 or else Restriction_Active (No_Dispatching_Calls) 137 then 138 return; 139 end if; 140 141 -- Set subprogram. If this is an inherited operation that was 142 -- overridden, the body that is being called is its alias. 143 144 Subp := Entity (Name (Call_Node)); 145 146 if Present (Alias (Subp)) 147 and then Is_Inherited_Operation (Subp) 148 and then No (DTC_Entity (Subp)) 149 then 150 Subp := Alias (Subp); 151 end if; 152 153 -- Definition of the class-wide type and the tagged type 154 155 -- If the controlling argument is itself a tag rather than a tagged 156 -- object, then use the class-wide type associated with the subprogram's 157 -- controlling type. This case can occur when a call to an inherited 158 -- primitive has an actual that originated from a default parameter 159 -- given by a tag-indeterminate call and when there is no other 160 -- controlling argument providing the tag (AI-239 requires dispatching). 161 -- This capability of dispatching directly by tag is also needed by the 162 -- implementation of AI-260 (for the generic dispatching constructors). 163 164 if Ctrl_Typ = RTE (RE_Tag) 165 or else (RTE_Available (RE_Interface_Tag) 166 and then Ctrl_Typ = RTE (RE_Interface_Tag)) 167 then 168 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); 169 170 -- Class_Wide_Type is applied to the expressions used to initialize 171 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since 172 -- there are cases where the controlling type is resolved to a specific 173 -- type (such as for designated types of arguments such as CW'Access). 174 175 elsif Is_Access_Type (Ctrl_Typ) then 176 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); 177 178 else 179 CW_Typ := Class_Wide_Type (Ctrl_Typ); 180 end if; 181 182 Typ := Find_Specific_Type (CW_Typ); 183 184 if not Is_Limited_Type (Typ) then 185 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); 186 end if; 187 188 -- Dispatching call to C++ primitive 189 190 if Is_CPP_Class (Typ) then 191 null; 192 193 -- Dispatching call to Ada primitive 194 195 elsif Present (Param_List) then 196 197 -- Generate the Tag checks when appropriate 198 199 Param := First_Actual (Call_Node); 200 while Present (Param) loop 201 202 -- No tag check with itself 203 204 if Param = Ctrl_Arg then 205 null; 206 207 -- No tag check for parameter whose type is neither tagged nor 208 -- access to tagged (for access parameters) 209 210 elsif No (Find_Controlling_Arg (Param)) then 211 null; 212 213 -- No tag check for function dispatching on result if the 214 -- Tag given by the context is this one 215 216 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then 217 null; 218 219 -- "=" is the only dispatching operation allowed to get operands 220 -- with incompatible tags (it just returns false). We use 221 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node 222 -- because the value will be duplicated to check the tags. 223 224 elsif Subp = Eq_Prim_Op then 225 null; 226 227 -- No check in presence of suppress flags 228 229 elsif Tag_Checks_Suppressed (Etype (Param)) 230 or else (Is_Access_Type (Etype (Param)) 231 and then Tag_Checks_Suppressed 232 (Designated_Type (Etype (Param)))) 233 then 234 null; 235 236 -- Optimization: no tag checks if the parameters are identical 237 238 elsif Is_Entity_Name (Param) 239 and then Is_Entity_Name (Ctrl_Arg) 240 and then Entity (Param) = Entity (Ctrl_Arg) 241 then 242 null; 243 244 -- Now we need to generate the Tag check 245 246 else 247 -- Generate code for tag equality check 248 249 -- Perhaps should have Checks.Apply_Tag_Equality_Check??? 250 251 Insert_Action (Ctrl_Arg, 252 Make_Implicit_If_Statement (Call_Node, 253 Condition => 254 Make_Op_Ne (Loc, 255 Left_Opnd => 256 Make_Selected_Component (Loc, 257 Prefix => New_Value (Ctrl_Arg), 258 Selector_Name => 259 New_Occurrence_Of 260 (First_Tag_Component (Typ), Loc)), 261 262 Right_Opnd => 263 Make_Selected_Component (Loc, 264 Prefix => 265 Unchecked_Convert_To (Typ, New_Value (Param)), 266 Selector_Name => 267 New_Occurrence_Of 268 (First_Tag_Component (Typ), Loc))), 269 270 Then_Statements => 271 New_List (New_Constraint_Error (Loc)))); 272 end if; 273 274 Next_Actual (Param); 275 end loop; 276 end if; 277 end Apply_Tag_Checks; 278 279 ------------------------ 280 -- Building_Static_DT -- 281 ------------------------ 282 283 function Building_Static_DT (Typ : Entity_Id) return Boolean is 284 Root_Typ : Entity_Id := Root_Type (Typ); 285 Static_DT : Boolean; 286 287 begin 288 -- Handle private types 289 290 if Present (Full_View (Root_Typ)) then 291 Root_Typ := Full_View (Root_Typ); 292 end if; 293 294 Static_DT := 295 Building_Static_Dispatch_Tables 296 and then Is_Library_Level_Tagged_Type (Typ) 297 298 -- If the type is derived from a CPP class we cannot statically 299 -- build the dispatch tables because we must inherit primitives 300 -- from the CPP side. 301 302 and then not Is_CPP_Class (Root_Typ); 303 304 if not Static_DT then 305 Check_Restriction (Static_Dispatch_Tables, Typ); 306 end if; 307 308 return Static_DT; 309 end Building_Static_DT; 310 311 ---------------------------------- 312 -- Building_Static_Secondary_DT -- 313 ---------------------------------- 314 315 function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is 316 Full_Typ : Entity_Id := Typ; 317 Root_Typ : Entity_Id := Root_Type (Typ); 318 Static_DT : Boolean; 319 320 begin 321 -- Handle private types 322 323 if Present (Full_View (Typ)) then 324 Full_Typ := Full_View (Typ); 325 end if; 326 327 if Present (Full_View (Root_Typ)) then 328 Root_Typ := Full_View (Root_Typ); 329 end if; 330 331 Static_DT := 332 Building_Static_DT (Full_Typ) 333 and then not Is_Interface (Full_Typ) 334 and then Has_Interfaces (Full_Typ) 335 and then (Full_Typ = Root_Typ 336 or else not Is_Variable_Size_Record (Etype (Full_Typ))); 337 338 if not Static_DT 339 and then not Is_Interface (Full_Typ) 340 and then Has_Interfaces (Full_Typ) 341 then 342 Check_Restriction (Static_Dispatch_Tables, Typ); 343 end if; 344 345 return Static_DT; 346 end Building_Static_Secondary_DT; 347 348 ---------------------------------- 349 -- Build_Static_Dispatch_Tables -- 350 ---------------------------------- 351 352 procedure Build_Static_Dispatch_Tables (N : Entity_Id) is 353 Target_List : List_Id; 354 355 procedure Build_Dispatch_Tables (List : List_Id); 356 -- Build the static dispatch table of tagged types found in the list of 357 -- declarations. The generated nodes are added at the end of Target_List 358 359 procedure Build_Package_Dispatch_Tables (N : Node_Id); 360 -- Build static dispatch tables associated with package declaration N 361 362 --------------------------- 363 -- Build_Dispatch_Tables -- 364 --------------------------- 365 366 procedure Build_Dispatch_Tables (List : List_Id) is 367 D : Node_Id; 368 369 begin 370 D := First (List); 371 while Present (D) loop 372 373 -- Handle nested packages and package bodies recursively. The 374 -- generated code is placed on the Target_List established for 375 -- the enclosing compilation unit. 376 377 if Nkind (D) = N_Package_Declaration then 378 Build_Package_Dispatch_Tables (D); 379 380 elsif Nkind (D) = N_Package_Body then 381 Build_Dispatch_Tables (Declarations (D)); 382 383 elsif Nkind (D) = N_Package_Body_Stub 384 and then Present (Library_Unit (D)) 385 then 386 Build_Dispatch_Tables 387 (Declarations (Proper_Body (Unit (Library_Unit (D))))); 388 389 -- Handle full type declarations and derivations of library level 390 -- tagged types 391 392 elsif Nkind (D) in 393 N_Full_Type_Declaration | N_Derived_Type_Definition 394 and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) 395 and then Ekind (Defining_Entity (D)) /= E_Record_Subtype 396 and then not Is_Private_Type (Defining_Entity (D)) 397 then 398 -- We do not generate dispatch tables for the internal types 399 -- created for a type extension with unknown discriminants 400 -- The needed information is shared with the source type, 401 -- See Expand_N_Record_Extension. 402 403 if Is_Underlying_Record_View (Defining_Entity (D)) 404 or else 405 (not Comes_From_Source (Defining_Entity (D)) 406 and then 407 Has_Unknown_Discriminants (Etype (Defining_Entity (D))) 408 and then 409 not Comes_From_Source 410 (First_Subtype (Defining_Entity (D)))) 411 then 412 null; 413 else 414 Insert_List_After_And_Analyze (Last (Target_List), 415 Make_DT (Defining_Entity (D))); 416 end if; 417 418 -- Handle private types of library level tagged types. We must 419 -- exchange the private and full-view to ensure the correct 420 -- expansion. If the full view is a synchronized type ignore 421 -- the type because the table will be built for the corresponding 422 -- record type, that has its own declaration. 423 424 elsif (Nkind (D) = N_Private_Type_Declaration 425 or else Nkind (D) = N_Private_Extension_Declaration) 426 and then Present (Full_View (Defining_Entity (D))) 427 then 428 declare 429 E1 : constant Entity_Id := Defining_Entity (D); 430 E2 : constant Entity_Id := Full_View (E1); 431 432 begin 433 if Is_Library_Level_Tagged_Type (E2) 434 and then Ekind (E2) /= E_Record_Subtype 435 and then not Is_Concurrent_Type (E2) 436 then 437 Exchange_Declarations (E1); 438 Insert_List_After_And_Analyze (Last (Target_List), 439 Make_DT (E1)); 440 Exchange_Declarations (E2); 441 end if; 442 end; 443 end if; 444 445 Next (D); 446 end loop; 447 end Build_Dispatch_Tables; 448 449 ----------------------------------- 450 -- Build_Package_Dispatch_Tables -- 451 ----------------------------------- 452 453 procedure Build_Package_Dispatch_Tables (N : Node_Id) is 454 Spec : constant Node_Id := Specification (N); 455 Id : constant Entity_Id := Defining_Entity (N); 456 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 457 Priv_Decls : constant List_Id := Private_Declarations (Spec); 458 459 begin 460 Push_Scope (Id); 461 462 if Present (Priv_Decls) then 463 Build_Dispatch_Tables (Vis_Decls); 464 Build_Dispatch_Tables (Priv_Decls); 465 466 elsif Present (Vis_Decls) then 467 Build_Dispatch_Tables (Vis_Decls); 468 end if; 469 470 Pop_Scope; 471 end Build_Package_Dispatch_Tables; 472 473 -- Start of processing for Build_Static_Dispatch_Tables 474 475 begin 476 if not Expander_Active 477 or else not Tagged_Type_Expansion 478 then 479 return; 480 end if; 481 482 if Nkind (N) = N_Package_Declaration then 483 declare 484 Spec : constant Node_Id := Specification (N); 485 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 486 Priv_Decls : constant List_Id := Private_Declarations (Spec); 487 488 begin 489 if Present (Priv_Decls) 490 and then Is_Non_Empty_List (Priv_Decls) 491 then 492 Target_List := Priv_Decls; 493 494 elsif not Present (Vis_Decls) then 495 Target_List := New_List; 496 Set_Private_Declarations (Spec, Target_List); 497 else 498 Target_List := Vis_Decls; 499 end if; 500 501 Build_Package_Dispatch_Tables (N); 502 end; 503 504 else pragma Assert (Nkind (N) = N_Package_Body); 505 Target_List := Declarations (N); 506 Build_Dispatch_Tables (Target_List); 507 end if; 508 end Build_Static_Dispatch_Tables; 509 510 ------------------------------ 511 -- Convert_Tag_To_Interface -- 512 ------------------------------ 513 514 function Convert_Tag_To_Interface 515 (Typ : Entity_Id; 516 Expr : Node_Id) return Node_Id 517 is 518 Loc : constant Source_Ptr := Sloc (Expr); 519 Anon_Type : Entity_Id; 520 Result : Node_Id; 521 522 begin 523 pragma Assert (Is_Class_Wide_Type (Typ) 524 and then Is_Interface (Typ) 525 and then 526 ((Nkind (Expr) = N_Selected_Component 527 and then Is_Tag (Entity (Selector_Name (Expr)))) 528 or else 529 (Nkind (Expr) = N_Function_Call 530 and then RTE_Available (RE_Displace) 531 and then Entity (Name (Expr)) = RTE (RE_Displace)))); 532 533 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr); 534 Set_Directly_Designated_Type (Anon_Type, Typ); 535 Set_Etype (Anon_Type, Anon_Type); 536 Set_Can_Never_Be_Null (Anon_Type); 537 538 -- Decorate the size and alignment attributes of the anonymous access 539 -- type, as required by the back end. 540 541 Layout_Type (Anon_Type); 542 543 if Nkind (Expr) = N_Selected_Component 544 and then Is_Tag (Entity (Selector_Name (Expr))) 545 then 546 Result := 547 Make_Explicit_Dereference (Loc, 548 Unchecked_Convert_To (Anon_Type, 549 Make_Attribute_Reference (Loc, 550 Prefix => Expr, 551 Attribute_Name => Name_Address))); 552 else 553 Result := 554 Make_Explicit_Dereference (Loc, 555 Unchecked_Convert_To (Anon_Type, Expr)); 556 end if; 557 558 return Result; 559 end Convert_Tag_To_Interface; 560 561 ------------------- 562 -- CPP_Num_Prims -- 563 ------------------- 564 565 function CPP_Num_Prims (Typ : Entity_Id) return Nat is 566 CPP_Typ : Entity_Id; 567 Tag_Comp : Entity_Id; 568 569 begin 570 if not Is_Tagged_Type (Typ) 571 or else not Is_CPP_Class (Root_Type (Typ)) 572 then 573 return 0; 574 575 else 576 CPP_Typ := Enclosing_CPP_Parent (Typ); 577 Tag_Comp := First_Tag_Component (CPP_Typ); 578 579 -- If number of primitives already set in the tag component, use it 580 581 if Present (Tag_Comp) 582 and then DT_Entry_Count (Tag_Comp) /= No_Uint 583 then 584 return UI_To_Int (DT_Entry_Count (Tag_Comp)); 585 586 -- Otherwise, count the primitives of the enclosing CPP type 587 588 else 589 declare 590 Count : Nat := 0; 591 Elmt : Elmt_Id; 592 593 begin 594 Elmt := First_Elmt (Primitive_Operations (CPP_Typ)); 595 while Present (Elmt) loop 596 Count := Count + 1; 597 Next_Elmt (Elmt); 598 end loop; 599 600 return Count; 601 end; 602 end if; 603 end if; 604 end CPP_Num_Prims; 605 606 ------------------------------ 607 -- Default_Prim_Op_Position -- 608 ------------------------------ 609 610 function Default_Prim_Op_Position (E : Entity_Id) return Uint is 611 TSS_Name : TSS_Name_Type; 612 613 begin 614 Get_Name_String (Chars (E)); 615 TSS_Name := 616 TSS_Name_Type 617 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); 618 619 if Chars (E) = Name_uSize then 620 return Uint_1; 621 622 elsif TSS_Name = TSS_Stream_Read then 623 return Uint_2; 624 625 elsif TSS_Name = TSS_Stream_Write then 626 return Uint_3; 627 628 elsif TSS_Name = TSS_Stream_Input then 629 return Uint_4; 630 631 elsif TSS_Name = TSS_Stream_Output then 632 return Uint_5; 633 634 elsif Chars (E) = Name_Op_Eq then 635 return Uint_6; 636 637 elsif Chars (E) = Name_uAssign then 638 return Uint_7; 639 640 elsif TSS_Name = TSS_Deep_Adjust then 641 return Uint_8; 642 643 elsif TSS_Name = TSS_Deep_Finalize then 644 return Uint_9; 645 646 elsif TSS_Name = TSS_Put_Image then 647 return Uint_10; 648 649 -- In VM targets unconditionally allow obtaining the position associated 650 -- with predefined interface primitives since in these platforms any 651 -- tagged type has these primitives. 652 653 elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then 654 if Chars (E) = Name_uDisp_Asynchronous_Select then 655 return Uint_11; 656 657 elsif Chars (E) = Name_uDisp_Conditional_Select then 658 return Uint_12; 659 660 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then 661 return Uint_13; 662 663 elsif Chars (E) = Name_uDisp_Get_Task_Id then 664 return Uint_14; 665 666 elsif Chars (E) = Name_uDisp_Requeue then 667 return Uint_15; 668 669 elsif Chars (E) = Name_uDisp_Timed_Select then 670 return Uint_16; 671 end if; 672 end if; 673 674 raise Program_Error; 675 end Default_Prim_Op_Position; 676 677 ---------------------- 678 -- Elab_Flag_Needed -- 679 ---------------------- 680 681 function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is 682 begin 683 return Ada_Version >= Ada_2005 684 and then not Is_Interface (Typ) 685 and then Has_Interfaces (Typ) 686 and then not Building_Static_DT (Typ); 687 end Elab_Flag_Needed; 688 689 ----------------------------- 690 -- Expand_Dispatching_Call -- 691 ----------------------------- 692 693 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is 694 Loc : constant Source_Ptr := Sloc (Call_Node); 695 Call_Typ : constant Entity_Id := Etype (Call_Node); 696 697 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); 698 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); 699 Param_List : constant List_Id := Parameter_Associations (Call_Node); 700 701 Subp : Entity_Id; 702 CW_Typ : Entity_Id; 703 New_Call : Node_Id; 704 New_Call_Name : Node_Id; 705 New_Params : List_Id := No_List; 706 Param : Node_Id; 707 Res_Typ : Entity_Id; 708 Subp_Ptr_Typ : Entity_Id; 709 Subp_Typ : Entity_Id; 710 Typ : Entity_Id; 711 Eq_Prim_Op : Entity_Id := Empty; 712 Controlling_Tag : Node_Id; 713 714 procedure Build_Class_Wide_Check; 715 -- If the denoted subprogram has a class-wide precondition, generate a 716 -- check using that precondition before the dispatching call, because 717 -- this is the only class-wide precondition that applies to the call. 718 719 function New_Value (From : Node_Id) return Node_Id; 720 -- From is the original Expression. New_Value is equivalent to a call 721 -- to Duplicate_Subexpr with an explicit dereference when From is an 722 -- access parameter. 723 724 ---------------------------- 725 -- Build_Class_Wide_Check -- 726 ---------------------------- 727 728 procedure Build_Class_Wide_Check is 729 function Replace_Formals (N : Node_Id) return Traverse_Result; 730 -- Replace occurrences of the formals of the subprogram by the 731 -- corresponding actuals in the call, given that this check is 732 -- performed outside of the body of the subprogram. 733 734 -- If the dispatching call appears in the same scope as the 735 -- declaration of the dispatching subprogram (for example in 736 -- the expression of a local expression function), the spec 737 -- has not been analyzed yet, in which case we use the Chars 738 -- field to recognize intended occurrences of the formals. 739 740 --------------------- 741 -- Replace_Formals -- 742 --------------------- 743 744 function Replace_Formals (N : Node_Id) return Traverse_Result is 745 A : Node_Id; 746 F : Entity_Id; 747 begin 748 if Is_Entity_Name (N) then 749 F := First_Formal (Subp); 750 A := First_Actual (Call_Node); 751 752 if Present (Entity (N)) and then Is_Formal (Entity (N)) then 753 while Present (F) loop 754 if F = Entity (N) then 755 Rewrite (N, New_Copy_Tree (A)); 756 757 -- If the formal is class-wide, and thus not a 758 -- controlling argument, preserve its type because 759 -- it may appear in a nested call with a class-wide 760 -- parameter. 761 762 if Is_Class_Wide_Type (Etype (F)) then 763 Set_Etype (N, Etype (F)); 764 765 -- Conversely, if this is a controlling argument 766 -- (in a dispatching call in the condition) that is a 767 -- dereference, the source is an access-to-class-wide 768 -- type, so preserve the dispatching nature of the 769 -- call in the rewritten condition. 770 771 elsif Nkind (Parent (N)) = N_Explicit_Dereference 772 and then Is_Controlling_Actual (Parent (N)) 773 then 774 Set_Controlling_Argument (Parent (Parent (N)), 775 Parent (N)); 776 end if; 777 778 exit; 779 end if; 780 781 Next_Formal (F); 782 Next_Actual (A); 783 end loop; 784 785 -- If the node is not analyzed, recognize occurrences of a 786 -- formal by name, as would be done when resolving the aspect 787 -- expression in the context of the subprogram. 788 789 elsif not Analyzed (N) 790 and then Nkind (N) = N_Identifier 791 and then No (Entity (N)) 792 then 793 while Present (F) loop 794 if Chars (N) = Chars (F) then 795 Rewrite (N, New_Copy_Tree (A)); 796 return Skip; 797 end if; 798 799 Next_Formal (F); 800 Next_Actual (A); 801 end loop; 802 end if; 803 end if; 804 805 return OK; 806 end Replace_Formals; 807 808 procedure Update is new Traverse_Proc (Replace_Formals); 809 810 -- Local variables 811 812 Str_Loc : constant String := Build_Location_String (Loc); 813 814 Cond : Node_Id; 815 Msg : Node_Id; 816 Prec : Node_Id; 817 818 -- Start of processing for Build_Class_Wide_Check 819 820 begin 821 822 -- Locate class-wide precondition, if any 823 824 if Present (Contract (Subp)) 825 and then Present (Pre_Post_Conditions (Contract (Subp))) 826 then 827 Prec := Pre_Post_Conditions (Contract (Subp)); 828 829 while Present (Prec) loop 830 exit when Pragma_Name (Prec) = Name_Precondition 831 and then Class_Present (Prec); 832 Prec := Next_Pragma (Prec); 833 end loop; 834 835 if No (Prec) or else Is_Ignored (Prec) then 836 return; 837 end if; 838 839 -- The expression for the precondition is analyzed within the 840 -- generated pragma. The message text is the last parameter of 841 -- the generated pragma, indicating source of precondition. 842 843 Cond := 844 New_Copy_Tree 845 (Expression (First (Pragma_Argument_Associations (Prec)))); 846 Update (Cond); 847 848 -- Build message indicating the failed precondition and the 849 -- dispatching call that caused it. 850 851 Msg := Expression (Last (Pragma_Argument_Associations (Prec))); 852 Name_Len := 0; 853 Append (Global_Name_Buffer, Strval (Msg)); 854 Append (Global_Name_Buffer, " in dispatching call at "); 855 Append (Global_Name_Buffer, Str_Loc); 856 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); 857 858 Insert_Action (Call_Node, 859 Make_If_Statement (Loc, 860 Condition => Make_Op_Not (Loc, Cond), 861 Then_Statements => New_List ( 862 Make_Procedure_Call_Statement (Loc, 863 Name => 864 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), 865 Parameter_Associations => New_List (Msg))))); 866 end if; 867 end Build_Class_Wide_Check; 868 869 --------------- 870 -- New_Value -- 871 --------------- 872 873 function New_Value (From : Node_Id) return Node_Id is 874 Res : constant Node_Id := Duplicate_Subexpr (From); 875 begin 876 if Is_Access_Type (Etype (From)) then 877 return 878 Make_Explicit_Dereference (Sloc (From), 879 Prefix => Res); 880 else 881 return Res; 882 end if; 883 end New_Value; 884 885 -- Local variables 886 887 New_Node : Node_Id; 888 SCIL_Node : Node_Id := Empty; 889 SCIL_Related_Node : Node_Id := Call_Node; 890 891 -- Start of processing for Expand_Dispatching_Call 892 893 begin 894 if No_Run_Time_Mode then 895 Error_Msg_CRT ("tagged types", Call_Node); 896 return; 897 end if; 898 899 -- Expand_Dispatching_Call is called directly from the semantics, so we 900 -- only proceed if the expander is active. 901 902 if not Expander_Active 903 904 -- And there is no need to expand the call if we are compiling under 905 -- restriction No_Dispatching_Calls; the semantic analyzer has 906 -- previously notified the violation of this restriction. 907 908 or else Restriction_Active (No_Dispatching_Calls) 909 910 -- No action needed if the dispatching call has been already expanded 911 912 or else Is_Expanded_Dispatching_Call (Name (Call_Node)) 913 then 914 return; 915 end if; 916 917 -- Set subprogram. If this is an inherited operation that was 918 -- overridden, the body that is being called is its alias. 919 920 Subp := Entity (Name (Call_Node)); 921 922 if Present (Alias (Subp)) 923 and then Is_Inherited_Operation (Subp) 924 and then No (DTC_Entity (Subp)) 925 then 926 Subp := Alias (Subp); 927 end if; 928 929 Build_Class_Wide_Check; 930 931 -- Definition of the class-wide type and the tagged type 932 933 -- If the controlling argument is itself a tag rather than a tagged 934 -- object, then use the class-wide type associated with the subprogram's 935 -- controlling type. This case can occur when a call to an inherited 936 -- primitive has an actual that originated from a default parameter 937 -- given by a tag-indeterminate call and when there is no other 938 -- controlling argument providing the tag (AI-239 requires dispatching). 939 -- This capability of dispatching directly by tag is also needed by the 940 -- implementation of AI-260 (for the generic dispatching constructors). 941 942 if Ctrl_Typ = RTE (RE_Tag) 943 or else (RTE_Available (RE_Interface_Tag) 944 and then Ctrl_Typ = RTE (RE_Interface_Tag)) 945 then 946 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); 947 948 -- Class_Wide_Type is applied to the expressions used to initialize 949 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since 950 -- there are cases where the controlling type is resolved to a specific 951 -- type (such as for designated types of arguments such as CW'Access). 952 953 elsif Is_Access_Type (Ctrl_Typ) then 954 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); 955 956 else 957 CW_Typ := Class_Wide_Type (Ctrl_Typ); 958 end if; 959 960 Typ := Find_Specific_Type (CW_Typ); 961 962 if not Is_Limited_Type (Typ) then 963 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); 964 end if; 965 966 -- Dispatching call to C++ primitive. Create a new parameter list 967 -- with no tag checks. 968 969 New_Params := New_List; 970 971 if Is_CPP_Class (Typ) then 972 Param := First_Actual (Call_Node); 973 while Present (Param) loop 974 Append_To (New_Params, Relocate_Node (Param)); 975 Next_Actual (Param); 976 end loop; 977 978 -- Dispatching call to Ada primitive 979 980 elsif Present (Param_List) then 981 Apply_Tag_Checks (Call_Node); 982 983 Param := First_Actual (Call_Node); 984 while Present (Param) loop 985 986 -- Cases in which we may have generated run-time checks. Note that 987 -- we strip any qualification from Param before comparing with the 988 -- already-stripped controlling argument. 989 990 if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then 991 Append_To (New_Params, 992 Duplicate_Subexpr_Move_Checks (Param)); 993 994 elsif Nkind (Parent (Param)) /= N_Parameter_Association 995 or else not Is_Accessibility_Actual (Parent (Param)) 996 then 997 Append_To (New_Params, Relocate_Node (Param)); 998 end if; 999 1000 Next_Actual (Param); 1001 end loop; 1002 end if; 1003 1004 -- Generate the appropriate subprogram pointer type 1005 1006 if Etype (Subp) = Typ then 1007 Res_Typ := CW_Typ; 1008 else 1009 Res_Typ := Etype (Subp); 1010 end if; 1011 1012 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); 1013 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); 1014 Set_Etype (Subp_Typ, Res_Typ); 1015 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); 1016 Set_Convention (Subp_Typ, Convention (Subp)); 1017 1018 -- Notify gigi that the designated type is a dispatching primitive 1019 1020 Set_Is_Dispatch_Table_Entity (Subp_Typ); 1021 1022 -- Create a new list of parameters which is a copy of the old formal 1023 -- list including the creation of a new set of matching entities. 1024 1025 declare 1026 Old_Formal : Entity_Id := First_Formal (Subp); 1027 New_Formal : Entity_Id; 1028 Last_Formal : Entity_Id := Empty; 1029 1030 begin 1031 if Present (Old_Formal) then 1032 New_Formal := New_Copy (Old_Formal); 1033 Set_First_Entity (Subp_Typ, New_Formal); 1034 Param := First_Actual (Call_Node); 1035 1036 loop 1037 Set_Scope (New_Formal, Subp_Typ); 1038 1039 -- Change all the controlling argument types to be class-wide 1040 -- to avoid a recursion in dispatching. 1041 1042 if Is_Controlling_Formal (New_Formal) then 1043 Set_Etype (New_Formal, Etype (Param)); 1044 end if; 1045 1046 -- If the type of the formal is an itype, there was code here 1047 -- introduced in 1998 in revision 1.46, to create a new itype 1048 -- by copy. This seems useless, and in fact leads to semantic 1049 -- errors when the itype is the completion of a type derived 1050 -- from a private type. 1051 1052 Last_Formal := New_Formal; 1053 Next_Formal (Old_Formal); 1054 exit when No (Old_Formal); 1055 1056 Link_Entities (New_Formal, New_Copy (Old_Formal)); 1057 Next_Entity (New_Formal); 1058 Next_Actual (Param); 1059 end loop; 1060 1061 Unlink_Next_Entity (New_Formal); 1062 Set_Last_Entity (Subp_Typ, Last_Formal); 1063 end if; 1064 1065 -- Now that the explicit formals have been duplicated, any extra 1066 -- formals needed by the subprogram must be duplicated; we know 1067 -- that extra formals are available because they were added when 1068 -- the tagged type was frozen (see Expand_Freeze_Record_Type). 1069 1070 pragma Assert (Is_Frozen (Typ)); 1071 1072 -- Warning: The addition of the extra formals cannot be performed 1073 -- here invoking Create_Extra_Formals since we must ensure that all 1074 -- the extra formals of the pointer type and the target subprogram 1075 -- match (and for functions that return a tagged type the profile of 1076 -- the built subprogram type always returns a class-wide type, which 1077 -- may affect the addition of some extra formals). 1078 1079 if Present (Last_Formal) 1080 and then Present (Extra_Formal (Last_Formal)) 1081 then 1082 Old_Formal := Extra_Formal (Last_Formal); 1083 New_Formal := New_Copy (Old_Formal); 1084 Set_Scope (New_Formal, Subp_Typ); 1085 1086 Set_Extra_Formal (Last_Formal, New_Formal); 1087 Set_Extra_Formals (Subp_Typ, New_Formal); 1088 1089 if Ekind (Subp) = E_Function 1090 and then Present (Extra_Accessibility_Of_Result (Subp)) 1091 and then Extra_Accessibility_Of_Result (Subp) = Old_Formal 1092 then 1093 Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); 1094 end if; 1095 1096 Old_Formal := Extra_Formal (Old_Formal); 1097 while Present (Old_Formal) loop 1098 Set_Extra_Formal (New_Formal, New_Copy (Old_Formal)); 1099 New_Formal := Extra_Formal (New_Formal); 1100 Set_Scope (New_Formal, Subp_Typ); 1101 1102 if Ekind (Subp) = E_Function 1103 and then Present (Extra_Accessibility_Of_Result (Subp)) 1104 and then Extra_Accessibility_Of_Result (Subp) = Old_Formal 1105 then 1106 Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); 1107 end if; 1108 1109 Old_Formal := Extra_Formal (Old_Formal); 1110 end loop; 1111 end if; 1112 end; 1113 1114 -- Complete description of pointer type, including size information, as 1115 -- must be done with itypes to prevent order-of-elaboration anomalies 1116 -- in gigi. 1117 1118 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 1119 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); 1120 Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); 1121 Layout_Type (Subp_Ptr_Typ); 1122 1123 -- If the controlling argument is a value of type Ada.Tag or an abstract 1124 -- interface class-wide type then use it directly. Otherwise, the tag 1125 -- must be extracted from the controlling object. 1126 1127 if Ctrl_Typ = RTE (RE_Tag) 1128 or else (RTE_Available (RE_Interface_Tag) 1129 and then Ctrl_Typ = RTE (RE_Interface_Tag)) 1130 then 1131 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); 1132 1133 -- Extract the tag from an unchecked type conversion. Done to avoid 1134 -- the expansion of additional code just to obtain the value of such 1135 -- tag because the current management of interface type conversions 1136 -- generates in some cases this unchecked type conversion with the 1137 -- tag of the object (see Expand_Interface_Conversion). 1138 1139 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion 1140 and then 1141 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag) 1142 or else 1143 (RTE_Available (RE_Interface_Tag) 1144 and then 1145 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag))) 1146 then 1147 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg)); 1148 1149 -- Ada 2005 (AI-251): Abstract interface class-wide type 1150 1151 elsif Is_Interface (Ctrl_Typ) 1152 and then Is_Class_Wide_Type (Ctrl_Typ) 1153 then 1154 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); 1155 1156 elsif Is_Access_Type (Ctrl_Typ) then 1157 Controlling_Tag := 1158 Make_Selected_Component (Loc, 1159 Prefix => 1160 Make_Explicit_Dereference (Loc, 1161 Duplicate_Subexpr_Move_Checks (Ctrl_Arg)), 1162 Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc)); 1163 1164 else 1165 Controlling_Tag := 1166 Make_Selected_Component (Loc, 1167 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), 1168 Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc)); 1169 end if; 1170 1171 -- Handle dispatching calls to predefined primitives 1172 1173 if Is_Predefined_Dispatching_Operation (Subp) 1174 or else Is_Predefined_Dispatching_Alias (Subp) 1175 then 1176 Build_Get_Predefined_Prim_Op_Address (Loc, 1177 Tag_Node => Controlling_Tag, 1178 Position => DT_Position (Subp), 1179 New_Node => New_Node); 1180 1181 -- Handle dispatching calls to user-defined primitives 1182 1183 else 1184 Build_Get_Prim_Op_Address (Loc, 1185 Typ => Underlying_Type (Find_Dispatching_Type (Subp)), 1186 Tag_Node => Controlling_Tag, 1187 Position => DT_Position (Subp), 1188 New_Node => New_Node); 1189 end if; 1190 1191 New_Call_Name := 1192 Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); 1193 1194 -- Generate the SCIL node for this dispatching call. Done now because 1195 -- attribute SCIL_Controlling_Tag must be set after the new call name 1196 -- is built to reference the nodes that will see the SCIL backend 1197 -- (because Build_Get_Prim_Op_Address generates an unchecked type 1198 -- conversion which relocates the controlling tag node). 1199 1200 if Generate_SCIL then 1201 SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); 1202 Set_SCIL_Entity (SCIL_Node, Typ); 1203 Set_SCIL_Target_Prim (SCIL_Node, Subp); 1204 1205 -- Common case: the controlling tag is the tag of an object 1206 -- (for example, obj.tag) 1207 1208 if Nkind (Controlling_Tag) = N_Selected_Component then 1209 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); 1210 1211 -- Handle renaming of selected component 1212 1213 elsif Nkind (Controlling_Tag) = N_Identifier 1214 and then Nkind (Parent (Entity (Controlling_Tag))) = 1215 N_Object_Renaming_Declaration 1216 and then Nkind (Name (Parent (Entity (Controlling_Tag)))) = 1217 N_Selected_Component 1218 then 1219 Set_SCIL_Controlling_Tag (SCIL_Node, 1220 Name (Parent (Entity (Controlling_Tag)))); 1221 1222 -- If the controlling tag is an identifier, the SCIL node references 1223 -- the corresponding object or parameter declaration 1224 1225 elsif Nkind (Controlling_Tag) = N_Identifier 1226 and then Nkind (Parent (Entity (Controlling_Tag))) in 1227 N_Object_Declaration | N_Parameter_Specification 1228 then 1229 Set_SCIL_Controlling_Tag (SCIL_Node, 1230 Parent (Entity (Controlling_Tag))); 1231 1232 -- If the controlling tag is a dereference, the SCIL node references 1233 -- the corresponding object or parameter declaration 1234 1235 elsif Nkind (Controlling_Tag) = N_Explicit_Dereference 1236 and then Nkind (Prefix (Controlling_Tag)) = N_Identifier 1237 and then Nkind (Parent (Entity (Prefix (Controlling_Tag)))) in 1238 N_Object_Declaration | N_Parameter_Specification 1239 then 1240 Set_SCIL_Controlling_Tag (SCIL_Node, 1241 Parent (Entity (Prefix (Controlling_Tag)))); 1242 1243 -- For a direct reference of the tag of the type the SCIL node 1244 -- references the internal object declaration containing the tag 1245 -- of the type. 1246 1247 elsif Nkind (Controlling_Tag) = N_Attribute_Reference 1248 and then Attribute_Name (Controlling_Tag) = Name_Tag 1249 then 1250 Set_SCIL_Controlling_Tag (SCIL_Node, 1251 Parent 1252 (Node 1253 (First_Elmt 1254 (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); 1255 1256 -- Interfaces are not supported. For now we leave the SCIL node 1257 -- decorated with the Controlling_Tag. More work needed here??? 1258 1259 elsif Is_Interface (Etype (Controlling_Tag)) then 1260 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); 1261 1262 else 1263 pragma Assert (False); 1264 null; 1265 end if; 1266 end if; 1267 1268 if Nkind (Call_Node) = N_Function_Call then 1269 New_Call := 1270 Make_Function_Call (Loc, 1271 Name => New_Call_Name, 1272 Parameter_Associations => New_Params); 1273 1274 -- If this is a dispatching "=", we must first compare the tags so 1275 -- we generate: x.tag = y.tag and then x = y 1276 1277 if Subp = Eq_Prim_Op then 1278 Param := First_Actual (Call_Node); 1279 New_Call := 1280 Make_And_Then (Loc, 1281 Left_Opnd => 1282 Make_Op_Eq (Loc, 1283 Left_Opnd => 1284 Make_Selected_Component (Loc, 1285 Prefix => New_Value (Param), 1286 Selector_Name => 1287 New_Occurrence_Of (First_Tag_Component (Typ), 1288 Loc)), 1289 1290 Right_Opnd => 1291 Make_Selected_Component (Loc, 1292 Prefix => 1293 Unchecked_Convert_To (Typ, 1294 New_Value (Next_Actual (Param))), 1295 Selector_Name => 1296 New_Occurrence_Of 1297 (First_Tag_Component (Typ), Loc))), 1298 Right_Opnd => New_Call); 1299 1300 SCIL_Related_Node := Right_Opnd (New_Call); 1301 end if; 1302 1303 else 1304 New_Call := 1305 Make_Procedure_Call_Statement (Loc, 1306 Name => New_Call_Name, 1307 Parameter_Associations => New_Params); 1308 end if; 1309 1310 -- Register the dispatching call in the call graph nodes table 1311 1312 Register_CG_Node (Call_Node); 1313 1314 Rewrite (Call_Node, New_Call); 1315 1316 -- Associate the SCIL node of this dispatching call 1317 1318 if Generate_SCIL then 1319 Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); 1320 end if; 1321 1322 -- Suppress all checks during the analysis of the expanded code to avoid 1323 -- the generation of spurious warnings under ZFP run-time. 1324 1325 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); 1326 end Expand_Dispatching_Call; 1327 1328 --------------------------------- 1329 -- Expand_Interface_Conversion -- 1330 --------------------------------- 1331 1332 procedure Expand_Interface_Conversion (N : Node_Id) is 1333 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id; 1334 -- Return the underlying record type of Typ 1335 1336 ---------------------------- 1337 -- Underlying_Record_Type -- 1338 ---------------------------- 1339 1340 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is 1341 E : Entity_Id := Typ; 1342 1343 begin 1344 -- Handle access types 1345 1346 if Is_Access_Type (E) then 1347 E := Directly_Designated_Type (E); 1348 end if; 1349 1350 -- Handle class-wide types. This conversion can appear explicitly in 1351 -- the source code. Example: I'Class (Obj) 1352 1353 if Is_Class_Wide_Type (E) then 1354 E := Root_Type (E); 1355 end if; 1356 1357 -- If the target type is a tagged synchronized type, the dispatch 1358 -- table info is in the corresponding record type. 1359 1360 if Is_Concurrent_Type (E) then 1361 E := Corresponding_Record_Type (E); 1362 end if; 1363 1364 -- Handle private types 1365 1366 E := Underlying_Type (E); 1367 1368 -- Handle subtypes 1369 1370 return Base_Type (E); 1371 end Underlying_Record_Type; 1372 1373 -- Local variables 1374 1375 Loc : constant Source_Ptr := Sloc (N); 1376 Etyp : constant Entity_Id := Etype (N); 1377 Operand : constant Node_Id := Expression (N); 1378 Operand_Typ : Entity_Id := Etype (Operand); 1379 Func : Node_Id; 1380 Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N)); 1381 Iface_Tag : Entity_Id; 1382 Is_Static : Boolean; 1383 1384 -- Start of processing for Expand_Interface_Conversion 1385 1386 begin 1387 -- Freeze the entity associated with the target interface to have 1388 -- available the attribute Access_Disp_Table. 1389 1390 Freeze_Before (N, Iface_Typ); 1391 1392 -- Ada 2005 (AI-345): Handle synchronized interface type derivations 1393 1394 if Is_Concurrent_Type (Operand_Typ) then 1395 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); 1396 end if; 1397 1398 -- No displacement of the pointer to the object needed when the type of 1399 -- the operand is not an interface type and the interface is one of 1400 -- its parent types (since they share the primary dispatch table). 1401 1402 declare 1403 Opnd : Entity_Id := Operand_Typ; 1404 1405 begin 1406 if Is_Access_Type (Opnd) then 1407 Opnd := Designated_Type (Opnd); 1408 end if; 1409 1410 Opnd := Underlying_Record_Type (Opnd); 1411 1412 if not Is_Interface (Opnd) 1413 and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) 1414 then 1415 return; 1416 end if; 1417 1418 -- When the type of the operand and the target interface type match, 1419 -- it is generally safe to skip generating code to displace the 1420 -- pointer to the object to reference the secondary dispatch table 1421 -- associated with the target interface type. The exception to this 1422 -- general rule is when the underlying object of the type conversion 1423 -- is an object built by means of a dispatching constructor (since in 1424 -- such case the expansion of the constructor call is a direct call 1425 -- to an object primitive, i.e. without thunks, and the expansion of 1426 -- the constructor call adds an explicit conversion to the target 1427 -- interface type to force the displacement of the pointer to the 1428 -- object to reference the corresponding secondary dispatch table 1429 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)). 1430 1431 -- At this stage we cannot identify whether the underlying object is 1432 -- a BIP object and hence we cannot skip generating the code to try 1433 -- displacing the pointer to the object. However, under configurable 1434 -- runtime it is safe to skip generating code to displace the pointer 1435 -- to the object, because generic dispatching constructors are not 1436 -- supported. 1437 1438 if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then 1439 return; 1440 end if; 1441 end; 1442 1443 -- Evaluate if we can statically displace the pointer to the object 1444 1445 declare 1446 Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ); 1447 1448 begin 1449 Is_Static := 1450 not Is_Interface (Opnd_Typ) 1451 and then Interface_Present_In_Ancestor 1452 (Typ => Opnd_Typ, 1453 Iface => Iface_Typ) 1454 and then (Etype (Opnd_Typ) = Opnd_Typ 1455 or else not 1456 Is_Variable_Size_Record (Etype (Opnd_Typ))); 1457 end; 1458 1459 if not Tagged_Type_Expansion then 1460 return; 1461 1462 -- A static conversion to an interface type that is not class-wide is 1463 -- curious but legal if the interface operation is a null procedure. 1464 -- If the operation is abstract it will be rejected later. 1465 1466 elsif Is_Static 1467 and then Is_Interface (Etype (N)) 1468 and then not Is_Class_Wide_Type (Etype (N)) 1469 and then Comes_From_Source (N) 1470 then 1471 Rewrite (N, Unchecked_Convert_To (Etype (N), N)); 1472 Analyze (N); 1473 return; 1474 end if; 1475 1476 if not Is_Static then 1477 1478 -- Give error if configurable run-time and Displace not available 1479 1480 if not RTE_Available (RE_Displace) then 1481 Error_Msg_CRT ("dynamic interface conversion", N); 1482 return; 1483 end if; 1484 1485 -- Handle conversion of access-to-class-wide interface types. Target 1486 -- can be an access to an object or an access to another class-wide 1487 -- interface (see -1- and -2- in the following example): 1488 1489 -- type Iface1_Ref is access all Iface1'Class; 1490 -- type Iface2_Ref is access all Iface1'Class; 1491 1492 -- Acc1 : Iface1_Ref := new ... 1493 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1 1494 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 1495 1496 if Is_Access_Type (Operand_Typ) then 1497 Rewrite (N, 1498 Unchecked_Convert_To (Etype (N), 1499 Make_Function_Call (Loc, 1500 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 1501 Parameter_Associations => New_List ( 1502 1503 Unchecked_Convert_To (RTE (RE_Address), 1504 Relocate_Node (Expression (N))), 1505 1506 New_Occurrence_Of 1507 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), 1508 Loc))))); 1509 1510 Analyze (N); 1511 return; 1512 end if; 1513 1514 Rewrite (N, 1515 Make_Function_Call (Loc, 1516 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 1517 Parameter_Associations => New_List ( 1518 Make_Attribute_Reference (Loc, 1519 Prefix => Relocate_Node (Expression (N)), 1520 Attribute_Name => Name_Address), 1521 1522 New_Occurrence_Of 1523 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), 1524 Loc)))); 1525 1526 Analyze (N); 1527 1528 -- If target is a class-wide interface, change the type of the data 1529 -- returned by IW_Convert to indicate this is a dispatching call. 1530 1531 declare 1532 New_Itype : Entity_Id; 1533 1534 begin 1535 New_Itype := Create_Itype (E_Anonymous_Access_Type, N); 1536 Set_Etype (New_Itype, New_Itype); 1537 Set_Directly_Designated_Type (New_Itype, Etyp); 1538 1539 Rewrite (N, 1540 Make_Explicit_Dereference (Loc, 1541 Prefix => 1542 Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); 1543 Analyze (N); 1544 Freeze_Itype (New_Itype, N); 1545 1546 return; 1547 end; 1548 end if; 1549 1550 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); 1551 pragma Assert (Present (Iface_Tag)); 1552 1553 -- Keep separate access types to interfaces because one internal 1554 -- function is used to handle the null value (see following comments) 1555 1556 if not Is_Access_Type (Etype (N)) then 1557 1558 -- Statically displace the pointer to the object to reference the 1559 -- component containing the secondary dispatch table. 1560 1561 Rewrite (N, 1562 Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ), 1563 Make_Selected_Component (Loc, 1564 Prefix => Relocate_Node (Expression (N)), 1565 Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)))); 1566 1567 else 1568 -- Build internal function to handle the case in which the actual is 1569 -- null. If the actual is null returns null because no displacement 1570 -- is required; otherwise performs a type conversion that will be 1571 -- expanded in the code that returns the value of the displaced 1572 -- actual. That is: 1573 1574 -- function Func (O : Address) return Iface_Typ is 1575 -- type Op_Typ is access all Operand_Typ; 1576 -- Aux : Op_Typ := To_Op_Typ (O); 1577 -- begin 1578 -- if O = Null_Address then 1579 -- return null; 1580 -- else 1581 -- return Iface_Typ!(Aux.Iface_Tag'Address); 1582 -- end if; 1583 -- end Func; 1584 1585 declare 1586 Desig_Typ : Entity_Id; 1587 Fent : Entity_Id; 1588 New_Typ_Decl : Node_Id; 1589 Stats : List_Id; 1590 1591 begin 1592 Desig_Typ := Etype (Expression (N)); 1593 1594 if Is_Access_Type (Desig_Typ) then 1595 Desig_Typ := 1596 Available_View (Directly_Designated_Type (Desig_Typ)); 1597 end if; 1598 1599 if Is_Concurrent_Type (Desig_Typ) then 1600 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ)); 1601 end if; 1602 1603 New_Typ_Decl := 1604 Make_Full_Type_Declaration (Loc, 1605 Defining_Identifier => Make_Temporary (Loc, 'T'), 1606 Type_Definition => 1607 Make_Access_To_Object_Definition (Loc, 1608 All_Present => True, 1609 Null_Exclusion_Present => False, 1610 Constant_Present => False, 1611 Subtype_Indication => 1612 New_Occurrence_Of (Desig_Typ, Loc))); 1613 1614 Stats := New_List ( 1615 Make_Simple_Return_Statement (Loc, 1616 Unchecked_Convert_To (Etype (N), 1617 Make_Attribute_Reference (Loc, 1618 Prefix => 1619 Make_Selected_Component (Loc, 1620 Prefix => 1621 Unchecked_Convert_To 1622 (Defining_Identifier (New_Typ_Decl), 1623 Make_Identifier (Loc, Name_uO)), 1624 Selector_Name => 1625 New_Occurrence_Of (Iface_Tag, Loc)), 1626 Attribute_Name => Name_Address)))); 1627 1628 -- If the type is null-excluding, no need for the null branch. 1629 -- Otherwise we need to check for it and return null. 1630 1631 if not Can_Never_Be_Null (Etype (N)) then 1632 Stats := New_List ( 1633 Make_If_Statement (Loc, 1634 Condition => 1635 Make_Op_Eq (Loc, 1636 Left_Opnd => Make_Identifier (Loc, Name_uO), 1637 Right_Opnd => New_Occurrence_Of 1638 (RTE (RE_Null_Address), Loc)), 1639 1640 Then_Statements => New_List ( 1641 Make_Simple_Return_Statement (Loc, Make_Null (Loc))), 1642 Else_Statements => Stats)); 1643 end if; 1644 1645 Fent := Make_Temporary (Loc, 'F'); 1646 Func := 1647 Make_Subprogram_Body (Loc, 1648 Specification => 1649 Make_Function_Specification (Loc, 1650 Defining_Unit_Name => Fent, 1651 1652 Parameter_Specifications => New_List ( 1653 Make_Parameter_Specification (Loc, 1654 Defining_Identifier => 1655 Make_Defining_Identifier (Loc, Name_uO), 1656 Parameter_Type => 1657 New_Occurrence_Of (RTE (RE_Address), Loc))), 1658 1659 Result_Definition => 1660 New_Occurrence_Of (Etype (N), Loc)), 1661 1662 Declarations => New_List (New_Typ_Decl), 1663 1664 Handled_Statement_Sequence => 1665 Make_Handled_Sequence_Of_Statements (Loc, Stats)); 1666 1667 -- Place function body before the expression containing the 1668 -- conversion. We suppress all checks because the body of the 1669 -- internally generated function already takes care of the case 1670 -- in which the actual is null; therefore there is no need to 1671 -- double check that the pointer is not null when the program 1672 -- executes the alternative that performs the type conversion). 1673 1674 Insert_Action (N, Func, Suppress => All_Checks); 1675 1676 if Is_Access_Type (Etype (Expression (N))) then 1677 1678 -- Generate: Func (Address!(Expression)) 1679 1680 Rewrite (N, 1681 Make_Function_Call (Loc, 1682 Name => New_Occurrence_Of (Fent, Loc), 1683 Parameter_Associations => New_List ( 1684 Unchecked_Convert_To (RTE (RE_Address), 1685 Relocate_Node (Expression (N)))))); 1686 1687 else 1688 -- Generate: Func (Operand_Typ!(Expression)'Address) 1689 1690 Rewrite (N, 1691 Make_Function_Call (Loc, 1692 Name => New_Occurrence_Of (Fent, Loc), 1693 Parameter_Associations => New_List ( 1694 Make_Attribute_Reference (Loc, 1695 Prefix => Unchecked_Convert_To (Operand_Typ, 1696 Relocate_Node (Expression (N))), 1697 Attribute_Name => Name_Address)))); 1698 end if; 1699 end; 1700 end if; 1701 1702 Analyze (N); 1703 end Expand_Interface_Conversion; 1704 1705 ------------------------------ 1706 -- Expand_Interface_Actuals -- 1707 ------------------------------ 1708 1709 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is 1710 Actual : Node_Id; 1711 Actual_Dup : Node_Id; 1712 Actual_Typ : Entity_Id; 1713 Anon : Entity_Id; 1714 Conversion : Node_Id; 1715 Formal : Entity_Id; 1716 Formal_Typ : Entity_Id; 1717 Subp : Entity_Id; 1718 Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning 1719 Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning 1720 1721 begin 1722 -- This subprogram is called directly from the semantics, so we need a 1723 -- check to see whether expansion is active before proceeding. 1724 1725 if not Expander_Active then 1726 return; 1727 end if; 1728 1729 -- Call using access to subprogram with explicit dereference 1730 1731 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then 1732 Subp := Etype (Name (Call_Node)); 1733 1734 -- Call using selected component 1735 1736 elsif Nkind (Name (Call_Node)) = N_Selected_Component then 1737 Subp := Entity (Selector_Name (Name (Call_Node))); 1738 1739 -- Call using direct name 1740 1741 else 1742 Subp := Entity (Name (Call_Node)); 1743 end if; 1744 1745 -- Ada 2005 (AI-251): Look for interface type formals to force "this" 1746 -- displacement 1747 1748 Formal := First_Formal (Subp); 1749 Actual := First_Actual (Call_Node); 1750 while Present (Formal) loop 1751 Formal_Typ := Etype (Formal); 1752 1753 if Has_Non_Limited_View (Formal_Typ) then 1754 Formal_Typ := Non_Limited_View (Formal_Typ); 1755 end if; 1756 1757 if Ekind (Formal_Typ) = E_Record_Type_With_Private then 1758 Formal_Typ := Full_View (Formal_Typ); 1759 end if; 1760 1761 if Is_Access_Type (Formal_Typ) then 1762 Formal_DDT := Directly_Designated_Type (Formal_Typ); 1763 1764 if Has_Non_Limited_View (Formal_DDT) then 1765 Formal_DDT := Non_Limited_View (Formal_DDT); 1766 end if; 1767 end if; 1768 1769 Actual_Typ := Etype (Actual); 1770 1771 if Has_Non_Limited_View (Actual_Typ) then 1772 Actual_Typ := Non_Limited_View (Actual_Typ); 1773 end if; 1774 1775 if Is_Access_Type (Actual_Typ) then 1776 Actual_DDT := Directly_Designated_Type (Actual_Typ); 1777 1778 if Has_Non_Limited_View (Actual_DDT) then 1779 Actual_DDT := Non_Limited_View (Actual_DDT); 1780 end if; 1781 end if; 1782 1783 if Is_Interface (Formal_Typ) 1784 and then Is_Class_Wide_Type (Formal_Typ) 1785 then 1786 -- No need to displace the pointer if the type of the actual 1787 -- coincides with the type of the formal. 1788 1789 if Actual_Typ = Formal_Typ then 1790 null; 1791 1792 -- No need to displace the pointer if the interface type is a 1793 -- parent of the type of the actual because in this case the 1794 -- interface primitives are located in the primary dispatch table. 1795 1796 elsif Is_Ancestor (Formal_Typ, Actual_Typ, 1797 Use_Full_View => True) 1798 then 1799 null; 1800 1801 -- Implicit conversion to the class-wide formal type to force the 1802 -- displacement of the pointer. 1803 1804 else 1805 -- Normally, expansion of actuals for calls to build-in-place 1806 -- functions happens as part of Expand_Actuals, but in this 1807 -- case the call will be wrapped in a conversion and soon after 1808 -- expanded further to handle the displacement for a class-wide 1809 -- interface conversion, so if this is a BIP call then we need 1810 -- to handle it now. 1811 1812 if Is_Build_In_Place_Function_Call (Actual) then 1813 Make_Build_In_Place_Call_In_Anonymous_Context (Actual); 1814 end if; 1815 1816 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); 1817 Rewrite (Actual, Conversion); 1818 Analyze_And_Resolve (Actual, Formal_Typ); 1819 end if; 1820 1821 -- Access to class-wide interface type 1822 1823 elsif Is_Access_Type (Formal_Typ) 1824 and then Is_Interface (Formal_DDT) 1825 and then Is_Class_Wide_Type (Formal_DDT) 1826 and then Interface_Present_In_Ancestor 1827 (Typ => Actual_DDT, 1828 Iface => Etype (Formal_DDT)) 1829 then 1830 -- Handle attributes 'Access and 'Unchecked_Access 1831 1832 if Nkind (Actual) = N_Attribute_Reference 1833 and then 1834 (Attribute_Name (Actual) = Name_Access 1835 or else Attribute_Name (Actual) = Name_Unchecked_Access) 1836 then 1837 -- This case must have been handled by the analysis and 1838 -- expansion of 'Access. The only exception is when types 1839 -- match and no further expansion is required. 1840 1841 pragma Assert (Base_Type (Etype (Prefix (Actual))) 1842 = Base_Type (Formal_DDT)); 1843 null; 1844 1845 -- No need to displace the pointer if the type of the actual 1846 -- coincides with the type of the formal. 1847 1848 elsif Actual_DDT = Formal_DDT then 1849 null; 1850 1851 -- No need to displace the pointer if the interface type is 1852 -- a parent of the type of the actual because in this case the 1853 -- interface primitives are located in the primary dispatch table. 1854 1855 elsif Is_Ancestor (Formal_DDT, Actual_DDT, 1856 Use_Full_View => True) 1857 then 1858 null; 1859 1860 else 1861 Actual_Dup := Relocate_Node (Actual); 1862 1863 if From_Limited_With (Actual_Typ) then 1864 1865 -- If the type of the actual parameter comes from a limited 1866 -- with_clause and the nonlimited view is already available, 1867 -- we replace the anonymous access type by a duplicate 1868 -- declaration whose designated type is the nonlimited view. 1869 1870 if Has_Non_Limited_View (Actual_DDT) then 1871 Anon := New_Copy (Actual_Typ); 1872 1873 if Is_Itype (Anon) then 1874 Set_Scope (Anon, Current_Scope); 1875 end if; 1876 1877 Set_Directly_Designated_Type 1878 (Anon, Non_Limited_View (Actual_DDT)); 1879 Set_Etype (Actual_Dup, Anon); 1880 end if; 1881 end if; 1882 1883 Conversion := Convert_To (Formal_Typ, Actual_Dup); 1884 Rewrite (Actual, Conversion); 1885 Analyze_And_Resolve (Actual, Formal_Typ); 1886 end if; 1887 end if; 1888 1889 Next_Actual (Actual); 1890 Next_Formal (Formal); 1891 end loop; 1892 end Expand_Interface_Actuals; 1893 1894 ---------------------------- 1895 -- Expand_Interface_Thunk -- 1896 ---------------------------- 1897 1898 procedure Expand_Interface_Thunk 1899 (Prim : Node_Id; 1900 Thunk_Id : out Entity_Id; 1901 Thunk_Code : out Node_Id; 1902 Iface : Entity_Id) 1903 is 1904 Loc : constant Source_Ptr := Sloc (Prim); 1905 Actuals : constant List_Id := New_List; 1906 Decl : constant List_Id := New_List; 1907 Formals : constant List_Id := New_List; 1908 Target : constant Entity_Id := Ultimate_Alias (Prim); 1909 1910 Decl_1 : Node_Id; 1911 Decl_2 : Node_Id; 1912 Expr : Node_Id; 1913 Formal : Node_Id; 1914 Ftyp : Entity_Id; 1915 Iface_Formal : Node_Id := Empty; -- initialize to prevent warning 1916 Is_Predef_Op : constant Boolean := 1917 Is_Predefined_Dispatching_Operation (Prim) 1918 or else Is_Predefined_Dispatching_Operation (Target); 1919 New_Arg : Node_Id; 1920 Offset_To_Top : Node_Id; 1921 Target_Formal : Entity_Id; 1922 1923 begin 1924 Thunk_Id := Empty; 1925 Thunk_Code := Empty; 1926 1927 -- No thunk needed if the primitive has been eliminated 1928 1929 if Is_Eliminated (Target) then 1930 return; 1931 1932 -- In case of primitives that are functions without formals and a 1933 -- controlling result there is no need to build the thunk. 1934 1935 elsif not Present (First_Formal (Target)) then 1936 pragma Assert (Ekind (Target) = E_Function 1937 and then Has_Controlling_Result (Target)); 1938 return; 1939 end if; 1940 1941 -- Duplicate the formals of the Target primitive. In the thunk, the type 1942 -- of the controlling formal is the covered interface type (instead of 1943 -- the target tagged type). Done to avoid problems with discriminated 1944 -- tagged types because, if the controlling type has discriminants with 1945 -- default values, then the type conversions done inside the body of 1946 -- the thunk (after the displacement of the pointer to the base of the 1947 -- actual object) generate code that modify its contents. 1948 1949 -- Note: This special management is not done for predefined primitives 1950 -- because they don't have available the Interface_Alias attribute (see 1951 -- Sem_Ch3.Add_Internal_Interface_Entities). 1952 1953 if not Is_Predef_Op then 1954 Iface_Formal := First_Formal (Interface_Alias (Prim)); 1955 end if; 1956 1957 Formal := First_Formal (Target); 1958 while Present (Formal) loop 1959 Ftyp := Etype (Formal); 1960 1961 -- Use the interface type as the type of the controlling formal (see 1962 -- comment above). 1963 1964 if not Is_Controlling_Formal (Formal) then 1965 Ftyp := Etype (Formal); 1966 Expr := New_Copy_Tree (Expression (Parent (Formal))); 1967 1968 -- For predefined primitives the controlling type of the thunk is 1969 -- the interface type passed by the caller (since they don't have 1970 -- available the Interface_Alias attribute; see comment above). 1971 1972 elsif Is_Predef_Op then 1973 Ftyp := Iface; 1974 Expr := Empty; 1975 1976 else 1977 Ftyp := Etype (Iface_Formal); 1978 Expr := Empty; 1979 1980 -- Sanity check performed to ensure the proper controlling type 1981 -- when the thunk has exactly one controlling parameter and it 1982 -- comes first. In such case the GCC backend reuses the C++ 1983 -- thunks machinery which perform a computation equivalent to 1984 -- the code generated by the expander; for other cases the GCC 1985 -- backend translates the expanded code unmodified. However, as 1986 -- a generalization, the check is performed for all controlling 1987 -- types. 1988 1989 if Is_Access_Type (Ftyp) then 1990 pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface); 1991 null; 1992 else 1993 Ftyp := Base_Type (Ftyp); 1994 pragma Assert (Ftyp = Iface); 1995 end if; 1996 end if; 1997 1998 Append_To (Formals, 1999 Make_Parameter_Specification (Loc, 2000 Defining_Identifier => 2001 Make_Defining_Identifier (Sloc (Formal), 2002 Chars => Chars (Formal)), 2003 In_Present => In_Present (Parent (Formal)), 2004 Out_Present => Out_Present (Parent (Formal)), 2005 Parameter_Type => New_Occurrence_Of (Ftyp, Loc), 2006 Expression => Expr)); 2007 2008 if not Is_Predef_Op then 2009 Next_Formal (Iface_Formal); 2010 end if; 2011 2012 Next_Formal (Formal); 2013 end loop; 2014 2015 Target_Formal := First_Formal (Target); 2016 Formal := First (Formals); 2017 while Present (Formal) loop 2018 2019 -- If the parent is a constrained discriminated type, then the 2020 -- primitive operation will have been defined on a first subtype. 2021 -- For proper matching with controlling type, use base type. 2022 2023 if Ekind (Target_Formal) = E_In_Parameter 2024 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type 2025 then 2026 Ftyp := 2027 Base_Type (Directly_Designated_Type (Etype (Target_Formal))); 2028 else 2029 Ftyp := Base_Type (Etype (Target_Formal)); 2030 end if; 2031 2032 -- For concurrent types, the relevant information is found in the 2033 -- Corresponding_Record_Type, rather than the type entity itself. 2034 2035 if Is_Concurrent_Type (Ftyp) then 2036 Ftyp := Corresponding_Record_Type (Ftyp); 2037 end if; 2038 2039 if Ekind (Target_Formal) = E_In_Parameter 2040 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type 2041 and then Is_Controlling_Formal (Target_Formal) 2042 then 2043 -- Generate: 2044 -- type T is access all <<type of the target formal>> 2045 -- S : Storage_Offset := Storage_Offset!(Formal) 2046 -- + Offset_To_Top (address!(Formal)) 2047 2048 Decl_2 := 2049 Make_Full_Type_Declaration (Loc, 2050 Defining_Identifier => Make_Temporary (Loc, 'T'), 2051 Type_Definition => 2052 Make_Access_To_Object_Definition (Loc, 2053 All_Present => True, 2054 Null_Exclusion_Present => False, 2055 Constant_Present => False, 2056 Subtype_Indication => 2057 New_Occurrence_Of (Ftyp, Loc))); 2058 2059 New_Arg := 2060 Unchecked_Convert_To (RTE (RE_Address), 2061 New_Occurrence_Of (Defining_Identifier (Formal), Loc)); 2062 2063 if not RTE_Available (RE_Offset_To_Top) then 2064 Offset_To_Top := 2065 Build_Offset_To_Top (Loc, New_Arg); 2066 else 2067 Offset_To_Top := 2068 Make_Function_Call (Loc, 2069 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc), 2070 Parameter_Associations => New_List (New_Arg)); 2071 end if; 2072 2073 Decl_1 := 2074 Make_Object_Declaration (Loc, 2075 Defining_Identifier => Make_Temporary (Loc, 'S'), 2076 Constant_Present => True, 2077 Object_Definition => 2078 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), 2079 Expression => 2080 Make_Op_Add (Loc, 2081 Left_Opnd => 2082 Unchecked_Convert_To 2083 (RTE (RE_Storage_Offset), 2084 New_Occurrence_Of 2085 (Defining_Identifier (Formal), Loc)), 2086 Right_Opnd => 2087 Offset_To_Top)); 2088 2089 Append_To (Decl, Decl_2); 2090 Append_To (Decl, Decl_1); 2091 2092 -- Reference the new actual. Generate: 2093 -- T!(S) 2094 2095 Append_To (Actuals, 2096 Unchecked_Convert_To 2097 (Defining_Identifier (Decl_2), 2098 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc))); 2099 2100 elsif Is_Controlling_Formal (Target_Formal) then 2101 2102 -- Generate: 2103 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) 2104 -- + Offset_To_Top (Formal'Address) 2105 -- S2 : Addr_Ptr := Addr_Ptr!(S1) 2106 2107 New_Arg := 2108 Make_Attribute_Reference (Loc, 2109 Prefix => 2110 New_Occurrence_Of (Defining_Identifier (Formal), Loc), 2111 Attribute_Name => 2112 Name_Address); 2113 2114 if not RTE_Available (RE_Offset_To_Top) then 2115 Offset_To_Top := 2116 Build_Offset_To_Top (Loc, New_Arg); 2117 else 2118 Offset_To_Top := 2119 Make_Function_Call (Loc, 2120 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc), 2121 Parameter_Associations => New_List (New_Arg)); 2122 end if; 2123 2124 Decl_1 := 2125 Make_Object_Declaration (Loc, 2126 Defining_Identifier => Make_Temporary (Loc, 'S'), 2127 Constant_Present => True, 2128 Object_Definition => 2129 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), 2130 Expression => 2131 Make_Op_Add (Loc, 2132 Left_Opnd => 2133 Unchecked_Convert_To 2134 (RTE (RE_Storage_Offset), 2135 Make_Attribute_Reference (Loc, 2136 Prefix => 2137 New_Occurrence_Of 2138 (Defining_Identifier (Formal), Loc), 2139 Attribute_Name => Name_Address)), 2140 Right_Opnd => 2141 Offset_To_Top)); 2142 2143 Decl_2 := 2144 Make_Object_Declaration (Loc, 2145 Defining_Identifier => Make_Temporary (Loc, 'S'), 2146 Constant_Present => True, 2147 Object_Definition => 2148 New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc), 2149 Expression => 2150 Unchecked_Convert_To 2151 (RTE (RE_Addr_Ptr), 2152 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc))); 2153 2154 Append_To (Decl, Decl_1); 2155 Append_To (Decl, Decl_2); 2156 2157 -- Reference the new actual, generate: 2158 -- Target_Formal (S2.all) 2159 2160 Append_To (Actuals, 2161 Unchecked_Convert_To (Ftyp, 2162 Make_Explicit_Dereference (Loc, 2163 New_Occurrence_Of (Defining_Identifier (Decl_2), Loc)))); 2164 2165 -- Ensure proper matching of access types. Required to avoid 2166 -- reporting spurious errors. 2167 2168 elsif Is_Access_Type (Etype (Target_Formal)) then 2169 Append_To (Actuals, 2170 Unchecked_Convert_To (Base_Type (Etype (Target_Formal)), 2171 New_Occurrence_Of (Defining_Identifier (Formal), Loc))); 2172 2173 -- No special management required for this actual 2174 2175 else 2176 Append_To (Actuals, 2177 New_Occurrence_Of (Defining_Identifier (Formal), Loc)); 2178 end if; 2179 2180 Next_Formal (Target_Formal); 2181 Next (Formal); 2182 end loop; 2183 2184 Thunk_Id := Make_Temporary (Loc, 'T'); 2185 2186 -- Note: any change to this symbol name needs to be coordinated 2187 -- with GNATcoverage, as that tool relies on it to identify 2188 -- thunks and exclude them from source coverage analysis. 2189 2190 Set_Ekind (Thunk_Id, Ekind (Prim)); 2191 Set_Is_Thunk (Thunk_Id); 2192 Set_Convention (Thunk_Id, Convention (Prim)); 2193 Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target)); 2194 Set_Thunk_Entity (Thunk_Id, Target); 2195 2196 -- Procedure case 2197 2198 if Ekind (Target) = E_Procedure then 2199 Thunk_Code := 2200 Make_Subprogram_Body (Loc, 2201 Specification => 2202 Make_Procedure_Specification (Loc, 2203 Defining_Unit_Name => Thunk_Id, 2204 Parameter_Specifications => Formals), 2205 Declarations => Decl, 2206 Handled_Statement_Sequence => 2207 Make_Handled_Sequence_Of_Statements (Loc, 2208 Statements => New_List ( 2209 Make_Procedure_Call_Statement (Loc, 2210 Name => New_Occurrence_Of (Target, Loc), 2211 Parameter_Associations => Actuals)))); 2212 2213 -- Function case 2214 2215 else pragma Assert (Ekind (Target) = E_Function); 2216 declare 2217 Result_Def : Node_Id; 2218 Call_Node : Node_Id; 2219 2220 begin 2221 Call_Node := 2222 Make_Function_Call (Loc, 2223 Name => New_Occurrence_Of (Target, Loc), 2224 Parameter_Associations => Actuals); 2225 2226 if not Is_Interface (Etype (Prim)) then 2227 Result_Def := New_Copy (Result_Definition (Parent (Target))); 2228 2229 -- Thunk of function returning a class-wide interface object. No 2230 -- extra displacement needed since the displacement is generated 2231 -- in the return statement of Prim. Example: 2232 2233 -- type Iface is interface ... 2234 -- function F (O : Iface) return Iface'Class; 2235 2236 -- type T is new ... and Iface with ... 2237 -- function F (O : T) return Iface'Class; 2238 2239 elsif Is_Class_Wide_Type (Etype (Prim)) then 2240 Result_Def := New_Occurrence_Of (Etype (Prim), Loc); 2241 2242 -- Thunk of function returning an interface object. Displacement 2243 -- needed. Example: 2244 2245 -- type Iface is interface ... 2246 -- function F (O : Iface) return Iface; 2247 2248 -- type T is new ... and Iface with ... 2249 -- function F (O : T) return T; 2250 2251 else 2252 Result_Def := 2253 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc); 2254 2255 -- Adding implicit conversion to force the displacement of 2256 -- the pointer to the object to reference the corresponding 2257 -- secondary dispatch table. 2258 2259 Call_Node := 2260 Make_Type_Conversion (Loc, 2261 Subtype_Mark => 2262 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc), 2263 Expression => Relocate_Node (Call_Node)); 2264 end if; 2265 2266 Thunk_Code := 2267 Make_Subprogram_Body (Loc, 2268 Specification => 2269 Make_Function_Specification (Loc, 2270 Defining_Unit_Name => Thunk_Id, 2271 Parameter_Specifications => Formals, 2272 Result_Definition => Result_Def), 2273 Declarations => Decl, 2274 Handled_Statement_Sequence => 2275 Make_Handled_Sequence_Of_Statements (Loc, 2276 Statements => New_List ( 2277 Make_Simple_Return_Statement (Loc, Call_Node)))); 2278 end; 2279 end if; 2280 end Expand_Interface_Thunk; 2281 2282 -------------------------- 2283 -- Has_CPP_Constructors -- 2284 -------------------------- 2285 2286 function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is 2287 E : Entity_Id; 2288 2289 begin 2290 -- Look for the constructor entities 2291 2292 E := Next_Entity (Typ); 2293 while Present (E) loop 2294 if Ekind (E) = E_Function and then Is_Constructor (E) then 2295 return True; 2296 end if; 2297 2298 Next_Entity (E); 2299 end loop; 2300 2301 return False; 2302 end Has_CPP_Constructors; 2303 2304 ------------ 2305 -- Has_DT -- 2306 ------------ 2307 2308 function Has_DT (Typ : Entity_Id) return Boolean is 2309 begin 2310 return not Is_Interface (Typ) 2311 and then not Restriction_Active (No_Dispatching_Calls); 2312 end Has_DT; 2313 2314 ---------------------------------- 2315 -- Is_Expanded_Dispatching_Call -- 2316 ---------------------------------- 2317 2318 function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is 2319 begin 2320 return Nkind (N) in N_Subprogram_Call 2321 and then Nkind (Name (N)) = N_Explicit_Dereference 2322 and then Is_Dispatch_Table_Entity (Etype (Name (N))); 2323 end Is_Expanded_Dispatching_Call; 2324 2325 ------------------------------------- 2326 -- Is_Predefined_Dispatching_Alias -- 2327 ------------------------------------- 2328 2329 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean 2330 is 2331 begin 2332 return not Is_Predefined_Dispatching_Operation (Prim) 2333 and then Present (Alias (Prim)) 2334 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); 2335 end Is_Predefined_Dispatching_Alias; 2336 2337 ---------------------------------------- 2338 -- Make_Disp_Asynchronous_Select_Body -- 2339 ---------------------------------------- 2340 2341 -- For interface types, generate: 2342 2343 -- procedure _Disp_Asynchronous_Select 2344 -- (T : in out <Typ>; 2345 -- S : Integer; 2346 -- P : System.Address; 2347 -- B : out System.Storage_Elements.Dummy_Communication_Block; 2348 -- F : out Boolean) 2349 -- is 2350 -- begin 2351 -- F := False; 2352 -- C := Ada.Tags.POK_Function; 2353 -- end _Disp_Asynchronous_Select; 2354 2355 -- For protected types, generate: 2356 2357 -- procedure _Disp_Asynchronous_Select 2358 -- (T : in out <Typ>; 2359 -- S : Integer; 2360 -- P : System.Address; 2361 -- B : out System.Storage_Elements.Dummy_Communication_Block; 2362 -- F : out Boolean) 2363 -- is 2364 -- I : Integer := 2365 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); 2366 -- Bnn : System.Tasking.Protected_Objects.Operations. 2367 -- Communication_Block; 2368 -- begin 2369 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call 2370 -- (T._object'Access, 2371 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), 2372 -- P, 2373 -- System.Tasking.Asynchronous_Call, 2374 -- Bnn); 2375 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn); 2376 -- end _Disp_Asynchronous_Select; 2377 2378 -- For task types, generate: 2379 2380 -- procedure _Disp_Asynchronous_Select 2381 -- (T : in out <Typ>; 2382 -- S : Integer; 2383 -- P : System.Address; 2384 -- B : out System.Storage_Elements.Dummy_Communication_Block; 2385 -- F : out Boolean) 2386 -- is 2387 -- I : Integer := 2388 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); 2389 -- begin 2390 -- System.Tasking.Rendezvous.Task_Entry_Call 2391 -- (T._task_id, 2392 -- System.Tasking.Task_Entry_Index (I), 2393 -- P, 2394 -- System.Tasking.Asynchronous_Call, 2395 -- F); 2396 -- end _Disp_Asynchronous_Select; 2397 2398 function Make_Disp_Asynchronous_Select_Body 2399 (Typ : Entity_Id) return Node_Id 2400 is 2401 Com_Block : Entity_Id; 2402 Conc_Typ : Entity_Id := Empty; 2403 Decls : constant List_Id := New_List; 2404 Loc : constant Source_Ptr := Sloc (Typ); 2405 Obj_Ref : Node_Id; 2406 Stmts : constant List_Id := New_List; 2407 Tag_Node : Node_Id; 2408 2409 begin 2410 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 2411 2412 -- Null body is generated for interface types 2413 2414 if Is_Interface (Typ) then 2415 return 2416 Make_Subprogram_Body (Loc, 2417 Specification => 2418 Make_Disp_Asynchronous_Select_Spec (Typ), 2419 Declarations => New_List, 2420 Handled_Statement_Sequence => 2421 Make_Handled_Sequence_Of_Statements (Loc, 2422 New_List ( 2423 Make_Assignment_Statement (Loc, 2424 Name => Make_Identifier (Loc, Name_uF), 2425 Expression => New_Occurrence_Of (Standard_False, Loc))))); 2426 end if; 2427 2428 if Is_Concurrent_Record_Type (Typ) then 2429 Conc_Typ := Corresponding_Concurrent_Type (Typ); 2430 2431 -- Generate: 2432 -- I : Integer := 2433 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S); 2434 2435 -- where I will be used to capture the entry index of the primitive 2436 -- wrapper at position S. 2437 2438 if Tagged_Type_Expansion then 2439 Tag_Node := 2440 Unchecked_Convert_To (RTE (RE_Tag), 2441 New_Occurrence_Of 2442 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); 2443 else 2444 Tag_Node := 2445 Make_Attribute_Reference (Loc, 2446 Prefix => New_Occurrence_Of (Typ, Loc), 2447 Attribute_Name => Name_Tag); 2448 end if; 2449 2450 Append_To (Decls, 2451 Make_Object_Declaration (Loc, 2452 Defining_Identifier => 2453 Make_Defining_Identifier (Loc, Name_uI), 2454 Object_Definition => 2455 New_Occurrence_Of (Standard_Integer, Loc), 2456 Expression => 2457 Make_Function_Call (Loc, 2458 Name => 2459 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 2460 Parameter_Associations => 2461 New_List (Tag_Node, Make_Identifier (Loc, Name_uS))))); 2462 2463 if Ekind (Conc_Typ) = E_Protected_Type then 2464 2465 -- Generate: 2466 -- Bnn : Communication_Block; 2467 2468 Com_Block := Make_Temporary (Loc, 'B'); 2469 Append_To (Decls, 2470 Make_Object_Declaration (Loc, 2471 Defining_Identifier => Com_Block, 2472 Object_Definition => 2473 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 2474 2475 -- Build T._object'Access for calls below 2476 2477 Obj_Ref := 2478 Make_Attribute_Reference (Loc, 2479 Attribute_Name => Name_Unchecked_Access, 2480 Prefix => 2481 Make_Selected_Component (Loc, 2482 Prefix => Make_Identifier (Loc, Name_uT), 2483 Selector_Name => Make_Identifier (Loc, Name_uObject))); 2484 2485 case Corresponding_Runtime_Package (Conc_Typ) is 2486 when System_Tasking_Protected_Objects_Entries => 2487 2488 -- Generate: 2489 -- Protected_Entry_Call 2490 -- (T._object'Access, -- Object 2491 -- Protected_Entry_Index! (I), -- E 2492 -- P, -- Uninterpreted_Data 2493 -- Asynchronous_Call, -- Mode 2494 -- Bnn); -- Communication_Block 2495 2496 -- where T is the protected object, I is the entry index, P 2497 -- is the wrapped parameters and B is the name of the 2498 -- communication block. 2499 2500 Append_To (Stmts, 2501 Make_Procedure_Call_Statement (Loc, 2502 Name => 2503 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 2504 Parameter_Associations => 2505 New_List ( 2506 Obj_Ref, 2507 2508 Make_Unchecked_Type_Conversion (Loc, -- entry index 2509 Subtype_Mark => 2510 New_Occurrence_Of 2511 (RTE (RE_Protected_Entry_Index), Loc), 2512 Expression => Make_Identifier (Loc, Name_uI)), 2513 2514 Make_Identifier (Loc, Name_uP), -- parameter block 2515 New_Occurrence_Of -- Asynchronous_Call 2516 (RTE (RE_Asynchronous_Call), Loc), 2517 New_Occurrence_Of -- comm block 2518 (Com_Block, Loc)))); 2519 2520 when others => 2521 raise Program_Error; 2522 end case; 2523 2524 -- Generate: 2525 -- B := Dummy_Communication_Block (Bnn); 2526 2527 Append_To (Stmts, 2528 Make_Assignment_Statement (Loc, 2529 Name => Make_Identifier (Loc, Name_uB), 2530 Expression => 2531 Make_Unchecked_Type_Conversion (Loc, 2532 Subtype_Mark => 2533 New_Occurrence_Of 2534 (RTE (RE_Dummy_Communication_Block), Loc), 2535 Expression => New_Occurrence_Of (Com_Block, Loc)))); 2536 2537 -- Generate: 2538 -- F := False; 2539 2540 Append_To (Stmts, 2541 Make_Assignment_Statement (Loc, 2542 Name => Make_Identifier (Loc, Name_uF), 2543 Expression => New_Occurrence_Of (Standard_False, Loc))); 2544 2545 else 2546 pragma Assert (Ekind (Conc_Typ) = E_Task_Type); 2547 2548 -- Generate: 2549 -- Task_Entry_Call 2550 -- (T._task_id, -- Acceptor 2551 -- Task_Entry_Index! (I), -- E 2552 -- P, -- Uninterpreted_Data 2553 -- Asynchronous_Call, -- Mode 2554 -- F); -- Rendezvous_Successful 2555 2556 -- where T is the task object, I is the entry index, P is the 2557 -- wrapped parameters and F is the status flag. 2558 2559 Append_To (Stmts, 2560 Make_Procedure_Call_Statement (Loc, 2561 Name => 2562 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 2563 Parameter_Associations => 2564 New_List ( 2565 Make_Selected_Component (Loc, -- T._task_id 2566 Prefix => Make_Identifier (Loc, Name_uT), 2567 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 2568 2569 Make_Unchecked_Type_Conversion (Loc, -- entry index 2570 Subtype_Mark => 2571 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 2572 Expression => Make_Identifier (Loc, Name_uI)), 2573 2574 Make_Identifier (Loc, Name_uP), -- parameter block 2575 New_Occurrence_Of -- Asynchronous_Call 2576 (RTE (RE_Asynchronous_Call), Loc), 2577 Make_Identifier (Loc, Name_uF)))); -- status flag 2578 end if; 2579 2580 else 2581 -- Ensure that the statements list is non-empty 2582 2583 Append_To (Stmts, 2584 Make_Assignment_Statement (Loc, 2585 Name => Make_Identifier (Loc, Name_uF), 2586 Expression => New_Occurrence_Of (Standard_False, Loc))); 2587 end if; 2588 2589 return 2590 Make_Subprogram_Body (Loc, 2591 Specification => 2592 Make_Disp_Asynchronous_Select_Spec (Typ), 2593 Declarations => Decls, 2594 Handled_Statement_Sequence => 2595 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 2596 end Make_Disp_Asynchronous_Select_Body; 2597 2598 ---------------------------------------- 2599 -- Make_Disp_Asynchronous_Select_Spec -- 2600 ---------------------------------------- 2601 2602 function Make_Disp_Asynchronous_Select_Spec 2603 (Typ : Entity_Id) return Node_Id 2604 is 2605 Loc : constant Source_Ptr := Sloc (Typ); 2606 B_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 2607 Def_Id : constant Entity_Id := 2608 Make_Defining_Identifier (Loc, 2609 Name_uDisp_Asynchronous_Select); 2610 Params : constant List_Id := New_List; 2611 2612 begin 2613 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 2614 2615 -- T : in out Typ; -- Object parameter 2616 -- S : Integer; -- Primitive operation slot 2617 -- P : Address; -- Wrapped parameters 2618 -- B : out Dummy_Communication_Block; -- Communication block dummy 2619 -- F : out Boolean; -- Status flag 2620 2621 -- The B parameter may be left uninitialized 2622 2623 Set_Warnings_Off (B_Id); 2624 2625 Append_List_To (Params, New_List ( 2626 2627 Make_Parameter_Specification (Loc, 2628 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), 2629 Parameter_Type => New_Occurrence_Of (Typ, Loc), 2630 In_Present => True, 2631 Out_Present => True), 2632 2633 Make_Parameter_Specification (Loc, 2634 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), 2635 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), 2636 2637 Make_Parameter_Specification (Loc, 2638 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), 2639 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), 2640 2641 Make_Parameter_Specification (Loc, 2642 Defining_Identifier => B_Id, 2643 Parameter_Type => 2644 New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc), 2645 Out_Present => True), 2646 2647 Make_Parameter_Specification (Loc, 2648 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), 2649 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 2650 Out_Present => True))); 2651 2652 return 2653 Make_Procedure_Specification (Loc, 2654 Defining_Unit_Name => Def_Id, 2655 Parameter_Specifications => Params); 2656 end Make_Disp_Asynchronous_Select_Spec; 2657 2658 --------------------------------------- 2659 -- Make_Disp_Conditional_Select_Body -- 2660 --------------------------------------- 2661 2662 -- For interface types, generate: 2663 2664 -- procedure _Disp_Conditional_Select 2665 -- (T : in out <Typ>; 2666 -- S : Integer; 2667 -- P : System.Address; 2668 -- C : out Ada.Tags.Prim_Op_Kind; 2669 -- F : out Boolean) 2670 -- is 2671 -- begin 2672 -- F := False; 2673 -- C := Ada.Tags.POK_Function; 2674 -- end _Disp_Conditional_Select; 2675 2676 -- For protected types, generate: 2677 2678 -- procedure _Disp_Conditional_Select 2679 -- (T : in out <Typ>; 2680 -- S : Integer; 2681 -- P : System.Address; 2682 -- C : out Ada.Tags.Prim_Op_Kind; 2683 -- F : out Boolean) 2684 -- is 2685 -- I : Integer; 2686 -- Bnn : System.Tasking.Protected_Objects.Operations. 2687 -- Communication_Block; 2688 2689 -- begin 2690 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S)); 2691 2692 -- if C = Ada.Tags.POK_Procedure 2693 -- or else C = Ada.Tags.POK_Protected_Procedure 2694 -- or else C = Ada.Tags.POK_Task_Procedure 2695 -- then 2696 -- F := True; 2697 -- return; 2698 -- end if; 2699 2700 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); 2701 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call 2702 -- (T.object'Access, 2703 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), 2704 -- P, 2705 -- System.Tasking.Conditional_Call, 2706 -- Bnn); 2707 -- F := not Cancelled (Bnn); 2708 -- end _Disp_Conditional_Select; 2709 2710 -- For task types, generate: 2711 2712 -- procedure _Disp_Conditional_Select 2713 -- (T : in out <Typ>; 2714 -- S : Integer; 2715 -- P : System.Address; 2716 -- C : out Ada.Tags.Prim_Op_Kind; 2717 -- F : out Boolean) 2718 -- is 2719 -- I : Integer; 2720 2721 -- begin 2722 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); 2723 -- System.Tasking.Rendezvous.Task_Entry_Call 2724 -- (T._task_id, 2725 -- System.Tasking.Task_Entry_Index (I), 2726 -- P, 2727 -- System.Tasking.Conditional_Call, 2728 -- F); 2729 -- end _Disp_Conditional_Select; 2730 2731 function Make_Disp_Conditional_Select_Body 2732 (Typ : Entity_Id) return Node_Id 2733 is 2734 Loc : constant Source_Ptr := Sloc (Typ); 2735 Blk_Nam : Entity_Id; 2736 Conc_Typ : Entity_Id := Empty; 2737 Decls : constant List_Id := New_List; 2738 Obj_Ref : Node_Id; 2739 Stmts : constant List_Id := New_List; 2740 Tag_Node : Node_Id; 2741 2742 begin 2743 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 2744 2745 -- Null body is generated for interface types 2746 2747 if Is_Interface (Typ) then 2748 return 2749 Make_Subprogram_Body (Loc, 2750 Specification => 2751 Make_Disp_Conditional_Select_Spec (Typ), 2752 Declarations => No_List, 2753 Handled_Statement_Sequence => 2754 Make_Handled_Sequence_Of_Statements (Loc, 2755 New_List (Make_Assignment_Statement (Loc, 2756 Name => Make_Identifier (Loc, Name_uF), 2757 Expression => New_Occurrence_Of (Standard_False, Loc))))); 2758 end if; 2759 2760 if Is_Concurrent_Record_Type (Typ) then 2761 Conc_Typ := Corresponding_Concurrent_Type (Typ); 2762 2763 -- Generate: 2764 -- I : Integer; 2765 2766 -- where I will be used to capture the entry index of the primitive 2767 -- wrapper at position S. 2768 2769 Append_To (Decls, 2770 Make_Object_Declaration (Loc, 2771 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), 2772 Object_Definition => 2773 New_Occurrence_Of (Standard_Integer, Loc))); 2774 2775 -- Generate: 2776 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S); 2777 2778 -- if C = POK_Procedure 2779 -- or else C = POK_Protected_Procedure 2780 -- or else C = POK_Task_Procedure; 2781 -- then 2782 -- F := True; 2783 -- return; 2784 -- end if; 2785 2786 Build_Common_Dispatching_Select_Statements (Typ, Stmts); 2787 2788 -- Generate: 2789 -- Bnn : Communication_Block; 2790 2791 -- where Bnn is the name of the communication block used in the 2792 -- call to Protected_Entry_Call. 2793 2794 Blk_Nam := Make_Temporary (Loc, 'B'); 2795 Append_To (Decls, 2796 Make_Object_Declaration (Loc, 2797 Defining_Identifier => Blk_Nam, 2798 Object_Definition => 2799 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 2800 2801 -- Generate: 2802 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S); 2803 2804 -- I is the entry index and S is the dispatch table slot 2805 2806 if Tagged_Type_Expansion then 2807 Tag_Node := 2808 Unchecked_Convert_To (RTE (RE_Tag), 2809 New_Occurrence_Of 2810 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); 2811 2812 else 2813 Tag_Node := 2814 Make_Attribute_Reference (Loc, 2815 Prefix => New_Occurrence_Of (Typ, Loc), 2816 Attribute_Name => Name_Tag); 2817 end if; 2818 2819 Append_To (Stmts, 2820 Make_Assignment_Statement (Loc, 2821 Name => Make_Identifier (Loc, Name_uI), 2822 Expression => 2823 Make_Function_Call (Loc, 2824 Name => 2825 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 2826 Parameter_Associations => New_List ( 2827 Tag_Node, 2828 Make_Identifier (Loc, Name_uS))))); 2829 2830 if Ekind (Conc_Typ) = E_Protected_Type then 2831 2832 Obj_Ref := -- T._object'Access 2833 Make_Attribute_Reference (Loc, 2834 Attribute_Name => Name_Unchecked_Access, 2835 Prefix => 2836 Make_Selected_Component (Loc, 2837 Prefix => Make_Identifier (Loc, Name_uT), 2838 Selector_Name => Make_Identifier (Loc, Name_uObject))); 2839 2840 case Corresponding_Runtime_Package (Conc_Typ) is 2841 when System_Tasking_Protected_Objects_Entries => 2842 -- Generate: 2843 2844 -- Protected_Entry_Call 2845 -- (T._object'Access, -- Object 2846 -- Protected_Entry_Index! (I), -- E 2847 -- P, -- Uninterpreted_Data 2848 -- Conditional_Call, -- Mode 2849 -- Bnn); -- Block 2850 2851 -- where T is the protected object, I is the entry index, P 2852 -- are the wrapped parameters and Bnn is the name of the 2853 -- communication block. 2854 2855 Append_To (Stmts, 2856 Make_Procedure_Call_Statement (Loc, 2857 Name => 2858 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 2859 Parameter_Associations => New_List ( 2860 Obj_Ref, 2861 2862 Make_Unchecked_Type_Conversion (Loc, -- entry index 2863 Subtype_Mark => 2864 New_Occurrence_Of 2865 (RTE (RE_Protected_Entry_Index), Loc), 2866 Expression => Make_Identifier (Loc, Name_uI)), 2867 2868 Make_Identifier (Loc, Name_uP), -- parameter block 2869 2870 New_Occurrence_Of -- Conditional_Call 2871 (RTE (RE_Conditional_Call), Loc), 2872 New_Occurrence_Of -- Bnn 2873 (Blk_Nam, Loc)))); 2874 2875 when System_Tasking_Protected_Objects_Single_Entry => 2876 2877 -- If we are compiling for a restricted run-time, the call 2878 -- uses the simpler form. 2879 2880 Append_To (Stmts, 2881 Make_Procedure_Call_Statement (Loc, 2882 Name => 2883 New_Occurrence_Of 2884 (RTE (RE_Protected_Single_Entry_Call), Loc), 2885 Parameter_Associations => New_List ( 2886 Obj_Ref, 2887 2888 Make_Attribute_Reference (Loc, 2889 Prefix => Make_Identifier (Loc, Name_uP), 2890 Attribute_Name => Name_Address), 2891 2892 New_Occurrence_Of 2893 (RTE (RE_Conditional_Call), Loc)))); 2894 when others => 2895 raise Program_Error; 2896 end case; 2897 2898 -- Generate: 2899 -- F := not Cancelled (Bnn); 2900 2901 -- where F is the success flag. The status of Cancelled is negated 2902 -- in order to match the behavior of the version for task types. 2903 2904 Append_To (Stmts, 2905 Make_Assignment_Statement (Loc, 2906 Name => Make_Identifier (Loc, Name_uF), 2907 Expression => 2908 Make_Op_Not (Loc, 2909 Right_Opnd => 2910 Make_Function_Call (Loc, 2911 Name => 2912 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 2913 Parameter_Associations => New_List ( 2914 New_Occurrence_Of (Blk_Nam, Loc)))))); 2915 else 2916 pragma Assert (Ekind (Conc_Typ) = E_Task_Type); 2917 2918 -- Generate: 2919 -- Task_Entry_Call 2920 -- (T._task_id, -- Acceptor 2921 -- Task_Entry_Index! (I), -- E 2922 -- P, -- Uninterpreted_Data 2923 -- Conditional_Call, -- Mode 2924 -- F); -- Rendezvous_Successful 2925 2926 -- where T is the task object, I is the entry index, P are the 2927 -- wrapped parameters and F is the status flag. 2928 2929 Append_To (Stmts, 2930 Make_Procedure_Call_Statement (Loc, 2931 Name => 2932 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 2933 Parameter_Associations => New_List ( 2934 2935 Make_Selected_Component (Loc, -- T._task_id 2936 Prefix => Make_Identifier (Loc, Name_uT), 2937 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 2938 2939 Make_Unchecked_Type_Conversion (Loc, -- entry index 2940 Subtype_Mark => 2941 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 2942 Expression => Make_Identifier (Loc, Name_uI)), 2943 2944 Make_Identifier (Loc, Name_uP), -- parameter block 2945 New_Occurrence_Of -- Conditional_Call 2946 (RTE (RE_Conditional_Call), Loc), 2947 Make_Identifier (Loc, Name_uF)))); -- status flag 2948 end if; 2949 2950 else 2951 -- Initialize out parameters 2952 2953 Append_To (Stmts, 2954 Make_Assignment_Statement (Loc, 2955 Name => Make_Identifier (Loc, Name_uF), 2956 Expression => New_Occurrence_Of (Standard_False, Loc))); 2957 Append_To (Stmts, 2958 Make_Assignment_Statement (Loc, 2959 Name => Make_Identifier (Loc, Name_uC), 2960 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc))); 2961 end if; 2962 2963 return 2964 Make_Subprogram_Body (Loc, 2965 Specification => 2966 Make_Disp_Conditional_Select_Spec (Typ), 2967 Declarations => Decls, 2968 Handled_Statement_Sequence => 2969 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 2970 end Make_Disp_Conditional_Select_Body; 2971 2972 --------------------------------------- 2973 -- Make_Disp_Conditional_Select_Spec -- 2974 --------------------------------------- 2975 2976 function Make_Disp_Conditional_Select_Spec 2977 (Typ : Entity_Id) return Node_Id 2978 is 2979 Loc : constant Source_Ptr := Sloc (Typ); 2980 Def_Id : constant Node_Id := 2981 Make_Defining_Identifier (Loc, 2982 Name_uDisp_Conditional_Select); 2983 Params : constant List_Id := New_List; 2984 2985 begin 2986 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 2987 2988 -- T : in out Typ; -- Object parameter 2989 -- S : Integer; -- Primitive operation slot 2990 -- P : Address; -- Wrapped parameters 2991 -- C : out Prim_Op_Kind; -- Call kind 2992 -- F : out Boolean; -- Status flag 2993 2994 Append_List_To (Params, New_List ( 2995 2996 Make_Parameter_Specification (Loc, 2997 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), 2998 Parameter_Type => New_Occurrence_Of (Typ, Loc), 2999 In_Present => True, 3000 Out_Present => True), 3001 3002 Make_Parameter_Specification (Loc, 3003 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), 3004 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), 3005 3006 Make_Parameter_Specification (Loc, 3007 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), 3008 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), 3009 3010 Make_Parameter_Specification (Loc, 3011 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), 3012 Parameter_Type => 3013 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), 3014 Out_Present => True), 3015 3016 Make_Parameter_Specification (Loc, 3017 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), 3018 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 3019 Out_Present => True))); 3020 3021 return 3022 Make_Procedure_Specification (Loc, 3023 Defining_Unit_Name => Def_Id, 3024 Parameter_Specifications => Params); 3025 end Make_Disp_Conditional_Select_Spec; 3026 3027 ------------------------------------- 3028 -- Make_Disp_Get_Prim_Op_Kind_Body -- 3029 ------------------------------------- 3030 3031 function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is 3032 Loc : constant Source_Ptr := Sloc (Typ); 3033 Tag_Node : Node_Id; 3034 3035 begin 3036 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3037 3038 if Is_Interface (Typ) then 3039 return 3040 Make_Subprogram_Body (Loc, 3041 Specification => 3042 Make_Disp_Get_Prim_Op_Kind_Spec (Typ), 3043 Declarations => New_List, 3044 Handled_Statement_Sequence => 3045 Make_Handled_Sequence_Of_Statements (Loc, 3046 New_List (Make_Null_Statement (Loc)))); 3047 end if; 3048 3049 -- Generate: 3050 -- C := get_prim_op_kind (tag! (<type>VP), S); 3051 3052 -- where C is the out parameter capturing the call kind and S is the 3053 -- dispatch table slot number. 3054 3055 if Tagged_Type_Expansion then 3056 Tag_Node := 3057 Unchecked_Convert_To (RTE (RE_Tag), 3058 New_Occurrence_Of 3059 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); 3060 3061 else 3062 Tag_Node := 3063 Make_Attribute_Reference (Loc, 3064 Prefix => New_Occurrence_Of (Typ, Loc), 3065 Attribute_Name => Name_Tag); 3066 end if; 3067 3068 return 3069 Make_Subprogram_Body (Loc, 3070 Specification => 3071 Make_Disp_Get_Prim_Op_Kind_Spec (Typ), 3072 Declarations => New_List, 3073 Handled_Statement_Sequence => 3074 Make_Handled_Sequence_Of_Statements (Loc, 3075 New_List ( 3076 Make_Assignment_Statement (Loc, 3077 Name => Make_Identifier (Loc, Name_uC), 3078 Expression => 3079 Make_Function_Call (Loc, 3080 Name => 3081 New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), 3082 Parameter_Associations => New_List ( 3083 Tag_Node, 3084 Make_Identifier (Loc, Name_uS))))))); 3085 end Make_Disp_Get_Prim_Op_Kind_Body; 3086 3087 ------------------------------------- 3088 -- Make_Disp_Get_Prim_Op_Kind_Spec -- 3089 ------------------------------------- 3090 3091 function Make_Disp_Get_Prim_Op_Kind_Spec 3092 (Typ : Entity_Id) return Node_Id 3093 is 3094 Loc : constant Source_Ptr := Sloc (Typ); 3095 Def_Id : constant Node_Id := 3096 Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind); 3097 Params : constant List_Id := New_List; 3098 3099 begin 3100 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3101 3102 -- T : in out Typ; -- Object parameter 3103 -- S : Integer; -- Primitive operation slot 3104 -- C : out Prim_Op_Kind; -- Call kind 3105 3106 Append_List_To (Params, New_List ( 3107 3108 Make_Parameter_Specification (Loc, 3109 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), 3110 Parameter_Type => New_Occurrence_Of (Typ, Loc), 3111 In_Present => True, 3112 Out_Present => True), 3113 3114 Make_Parameter_Specification (Loc, 3115 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), 3116 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), 3117 3118 Make_Parameter_Specification (Loc, 3119 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), 3120 Parameter_Type => 3121 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), 3122 Out_Present => True))); 3123 3124 return 3125 Make_Procedure_Specification (Loc, 3126 Defining_Unit_Name => Def_Id, 3127 Parameter_Specifications => Params); 3128 end Make_Disp_Get_Prim_Op_Kind_Spec; 3129 3130 -------------------------------- 3131 -- Make_Disp_Get_Task_Id_Body -- 3132 -------------------------------- 3133 3134 function Make_Disp_Get_Task_Id_Body 3135 (Typ : Entity_Id) return Node_Id 3136 is 3137 Loc : constant Source_Ptr := Sloc (Typ); 3138 Ret : Node_Id; 3139 3140 begin 3141 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3142 3143 if Is_Concurrent_Record_Type (Typ) 3144 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type 3145 then 3146 -- Generate: 3147 -- return To_Address (_T._task_id); 3148 3149 Ret := 3150 Make_Simple_Return_Statement (Loc, 3151 Expression => 3152 Make_Unchecked_Type_Conversion (Loc, 3153 Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc), 3154 Expression => 3155 Make_Selected_Component (Loc, 3156 Prefix => Make_Identifier (Loc, Name_uT), 3157 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)))); 3158 3159 -- A null body is constructed for non-task types 3160 3161 else 3162 -- Generate: 3163 -- return Null_Address; 3164 3165 Ret := 3166 Make_Simple_Return_Statement (Loc, 3167 Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 3168 end if; 3169 3170 return 3171 Make_Subprogram_Body (Loc, 3172 Specification => Make_Disp_Get_Task_Id_Spec (Typ), 3173 Declarations => New_List, 3174 Handled_Statement_Sequence => 3175 Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret))); 3176 end Make_Disp_Get_Task_Id_Body; 3177 3178 -------------------------------- 3179 -- Make_Disp_Get_Task_Id_Spec -- 3180 -------------------------------- 3181 3182 function Make_Disp_Get_Task_Id_Spec 3183 (Typ : Entity_Id) return Node_Id 3184 is 3185 Loc : constant Source_Ptr := Sloc (Typ); 3186 3187 begin 3188 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3189 3190 return 3191 Make_Function_Specification (Loc, 3192 Defining_Unit_Name => 3193 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), 3194 Parameter_Specifications => New_List ( 3195 Make_Parameter_Specification (Loc, 3196 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), 3197 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 3198 Result_Definition => 3199 New_Occurrence_Of (RTE (RE_Address), Loc)); 3200 end Make_Disp_Get_Task_Id_Spec; 3201 3202 ---------------------------- 3203 -- Make_Disp_Requeue_Body -- 3204 ---------------------------- 3205 3206 function Make_Disp_Requeue_Body 3207 (Typ : Entity_Id) return Node_Id 3208 is 3209 Loc : constant Source_Ptr := Sloc (Typ); 3210 Conc_Typ : Entity_Id := Empty; 3211 Stmts : constant List_Id := New_List; 3212 3213 begin 3214 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3215 3216 -- Null body is generated for interface types and non-concurrent 3217 -- tagged types. 3218 3219 if Is_Interface (Typ) 3220 or else not Is_Concurrent_Record_Type (Typ) 3221 then 3222 return 3223 Make_Subprogram_Body (Loc, 3224 Specification => Make_Disp_Requeue_Spec (Typ), 3225 Declarations => No_List, 3226 Handled_Statement_Sequence => 3227 Make_Handled_Sequence_Of_Statements (Loc, 3228 New_List (Make_Null_Statement (Loc)))); 3229 end if; 3230 3231 Conc_Typ := Corresponding_Concurrent_Type (Typ); 3232 3233 if Ekind (Conc_Typ) = E_Protected_Type then 3234 3235 -- Generate statements: 3236 -- if F then 3237 -- System.Tasking.Protected_Objects.Operations. 3238 -- Requeue_Protected_Entry 3239 -- (Protection_Entries_Access (P), 3240 -- O._object'Unchecked_Access, 3241 -- Protected_Entry_Index (I), 3242 -- A); 3243 -- else 3244 -- System.Tasking.Protected_Objects.Operations. 3245 -- Requeue_Task_To_Protected_Entry 3246 -- (O._object'Unchecked_Access, 3247 -- Protected_Entry_Index (I), 3248 -- A); 3249 -- end if; 3250 3251 if Restriction_Active (No_Entry_Queue) then 3252 Append_To (Stmts, Make_Null_Statement (Loc)); 3253 else 3254 Append_To (Stmts, 3255 Make_If_Statement (Loc, 3256 Condition => Make_Identifier (Loc, Name_uF), 3257 3258 Then_Statements => 3259 New_List ( 3260 3261 -- Call to Requeue_Protected_Entry 3262 3263 Make_Procedure_Call_Statement (Loc, 3264 Name => 3265 New_Occurrence_Of 3266 (RTE (RE_Requeue_Protected_Entry), Loc), 3267 Parameter_Associations => 3268 New_List ( 3269 3270 Make_Unchecked_Type_Conversion (Loc, -- PEA (P) 3271 Subtype_Mark => 3272 New_Occurrence_Of ( 3273 RTE (RE_Protection_Entries_Access), Loc), 3274 Expression => 3275 Make_Identifier (Loc, Name_uP)), 3276 3277 Make_Attribute_Reference (Loc, -- O._object'Acc 3278 Attribute_Name => 3279 Name_Unchecked_Access, 3280 Prefix => 3281 Make_Selected_Component (Loc, 3282 Prefix => 3283 Make_Identifier (Loc, Name_uO), 3284 Selector_Name => 3285 Make_Identifier (Loc, Name_uObject))), 3286 3287 Make_Unchecked_Type_Conversion (Loc, -- entry index 3288 Subtype_Mark => 3289 New_Occurrence_Of 3290 (RTE (RE_Protected_Entry_Index), Loc), 3291 Expression => Make_Identifier (Loc, Name_uI)), 3292 3293 Make_Identifier (Loc, Name_uA)))), -- abort status 3294 3295 Else_Statements => 3296 New_List ( 3297 3298 -- Call to Requeue_Task_To_Protected_Entry 3299 3300 Make_Procedure_Call_Statement (Loc, 3301 Name => 3302 New_Occurrence_Of 3303 (RTE (RE_Requeue_Task_To_Protected_Entry), Loc), 3304 Parameter_Associations => 3305 New_List ( 3306 3307 Make_Attribute_Reference (Loc, -- O._object'Acc 3308 Attribute_Name => Name_Unchecked_Access, 3309 Prefix => 3310 Make_Selected_Component (Loc, 3311 Prefix => 3312 Make_Identifier (Loc, Name_uO), 3313 Selector_Name => 3314 Make_Identifier (Loc, Name_uObject))), 3315 3316 Make_Unchecked_Type_Conversion (Loc, -- entry index 3317 Subtype_Mark => 3318 New_Occurrence_Of 3319 (RTE (RE_Protected_Entry_Index), Loc), 3320 Expression => Make_Identifier (Loc, Name_uI)), 3321 3322 Make_Identifier (Loc, Name_uA)))))); -- abort status 3323 end if; 3324 3325 else 3326 pragma Assert (Is_Task_Type (Conc_Typ)); 3327 3328 -- Generate: 3329 -- if F then 3330 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry 3331 -- (Protection_Entries_Access (P), 3332 -- O._task_id, 3333 -- Task_Entry_Index (I), 3334 -- A); 3335 -- else 3336 -- System.Tasking.Rendezvous.Requeue_Task_Entry 3337 -- (O._task_id, 3338 -- Task_Entry_Index (I), 3339 -- A); 3340 -- end if; 3341 3342 Append_To (Stmts, 3343 Make_If_Statement (Loc, 3344 Condition => Make_Identifier (Loc, Name_uF), 3345 3346 Then_Statements => New_List ( 3347 3348 -- Call to Requeue_Protected_To_Task_Entry 3349 3350 Make_Procedure_Call_Statement (Loc, 3351 Name => 3352 New_Occurrence_Of 3353 (RTE (RE_Requeue_Protected_To_Task_Entry), Loc), 3354 3355 Parameter_Associations => New_List ( 3356 3357 Make_Unchecked_Type_Conversion (Loc, -- PEA (P) 3358 Subtype_Mark => 3359 New_Occurrence_Of 3360 (RTE (RE_Protection_Entries_Access), Loc), 3361 Expression => Make_Identifier (Loc, Name_uP)), 3362 3363 Make_Selected_Component (Loc, -- O._task_id 3364 Prefix => Make_Identifier (Loc, Name_uO), 3365 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 3366 3367 Make_Unchecked_Type_Conversion (Loc, -- entry index 3368 Subtype_Mark => 3369 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 3370 Expression => Make_Identifier (Loc, Name_uI)), 3371 3372 Make_Identifier (Loc, Name_uA)))), -- abort status 3373 3374 Else_Statements => New_List ( 3375 3376 -- Call to Requeue_Task_Entry 3377 3378 Make_Procedure_Call_Statement (Loc, 3379 Name => 3380 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc), 3381 3382 Parameter_Associations => New_List ( 3383 3384 Make_Selected_Component (Loc, -- O._task_id 3385 Prefix => Make_Identifier (Loc, Name_uO), 3386 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 3387 3388 Make_Unchecked_Type_Conversion (Loc, -- entry index 3389 Subtype_Mark => 3390 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 3391 Expression => Make_Identifier (Loc, Name_uI)), 3392 3393 Make_Identifier (Loc, Name_uA)))))); -- abort status 3394 end if; 3395 3396 -- Even though no declarations are needed in both cases, we allocate 3397 -- a list for entities added by Freeze. 3398 3399 return 3400 Make_Subprogram_Body (Loc, 3401 Specification => Make_Disp_Requeue_Spec (Typ), 3402 Declarations => New_List, 3403 Handled_Statement_Sequence => 3404 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 3405 end Make_Disp_Requeue_Body; 3406 3407 ---------------------------- 3408 -- Make_Disp_Requeue_Spec -- 3409 ---------------------------- 3410 3411 function Make_Disp_Requeue_Spec 3412 (Typ : Entity_Id) return Node_Id 3413 is 3414 Loc : constant Source_Ptr := Sloc (Typ); 3415 3416 begin 3417 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3418 3419 -- O : in out Typ; - Object parameter 3420 -- F : Boolean; - Protected (True) / task (False) flag 3421 -- P : Address; - Protection_Entries_Access value 3422 -- I : Entry_Index - Index of entry call 3423 -- A : Boolean - Abort flag 3424 3425 -- Note that the Protection_Entries_Access value is represented as a 3426 -- System.Address in order to avoid dragging in the tasking runtime 3427 -- when compiling sources without tasking constructs. 3428 3429 return 3430 Make_Procedure_Specification (Loc, 3431 Defining_Unit_Name => 3432 Make_Defining_Identifier (Loc, Name_uDisp_Requeue), 3433 3434 Parameter_Specifications => New_List ( 3435 3436 Make_Parameter_Specification (Loc, -- O 3437 Defining_Identifier => 3438 Make_Defining_Identifier (Loc, Name_uO), 3439 Parameter_Type => 3440 New_Occurrence_Of (Typ, Loc), 3441 In_Present => True, 3442 Out_Present => True), 3443 3444 Make_Parameter_Specification (Loc, -- F 3445 Defining_Identifier => 3446 Make_Defining_Identifier (Loc, Name_uF), 3447 Parameter_Type => 3448 New_Occurrence_Of (Standard_Boolean, Loc)), 3449 3450 Make_Parameter_Specification (Loc, -- P 3451 Defining_Identifier => 3452 Make_Defining_Identifier (Loc, Name_uP), 3453 Parameter_Type => 3454 New_Occurrence_Of (RTE (RE_Address), Loc)), 3455 3456 Make_Parameter_Specification (Loc, -- I 3457 Defining_Identifier => 3458 Make_Defining_Identifier (Loc, Name_uI), 3459 Parameter_Type => 3460 New_Occurrence_Of (Standard_Integer, Loc)), 3461 3462 Make_Parameter_Specification (Loc, -- A 3463 Defining_Identifier => 3464 Make_Defining_Identifier (Loc, Name_uA), 3465 Parameter_Type => 3466 New_Occurrence_Of (Standard_Boolean, Loc)))); 3467 end Make_Disp_Requeue_Spec; 3468 3469 --------------------------------- 3470 -- Make_Disp_Timed_Select_Body -- 3471 --------------------------------- 3472 3473 -- For interface types, generate: 3474 3475 -- procedure _Disp_Timed_Select 3476 -- (T : in out <Typ>; 3477 -- S : Integer; 3478 -- P : System.Address; 3479 -- D : Duration; 3480 -- M : Integer; 3481 -- C : out Ada.Tags.Prim_Op_Kind; 3482 -- F : out Boolean) 3483 -- is 3484 -- begin 3485 -- F := False; 3486 -- C := Ada.Tags.POK_Function; 3487 -- end _Disp_Timed_Select; 3488 3489 -- For protected types, generate: 3490 3491 -- procedure _Disp_Timed_Select 3492 -- (T : in out <Typ>; 3493 -- S : Integer; 3494 -- P : System.Address; 3495 -- D : Duration; 3496 -- M : Integer; 3497 -- C : out Ada.Tags.Prim_Op_Kind; 3498 -- F : out Boolean) 3499 -- is 3500 -- I : Integer; 3501 3502 -- begin 3503 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S); 3504 3505 -- if C = Ada.Tags.POK_Procedure 3506 -- or else C = Ada.Tags.POK_Protected_Procedure 3507 -- or else C = Ada.Tags.POK_Task_Procedure 3508 -- then 3509 -- F := True; 3510 -- return; 3511 -- end if; 3512 3513 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); 3514 -- System.Tasking.Protected_Objects.Operations. 3515 -- Timed_Protected_Entry_Call 3516 -- (T._object'Access, 3517 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), 3518 -- P, 3519 -- D, 3520 -- M, 3521 -- F); 3522 -- end _Disp_Timed_Select; 3523 3524 -- For task types, generate: 3525 3526 -- procedure _Disp_Timed_Select 3527 -- (T : in out <Typ>; 3528 -- S : Integer; 3529 -- P : System.Address; 3530 -- D : Duration; 3531 -- M : Integer; 3532 -- C : out Ada.Tags.Prim_Op_Kind; 3533 -- F : out Boolean) 3534 -- is 3535 -- I : Integer; 3536 3537 -- begin 3538 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); 3539 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call 3540 -- (T._task_id, 3541 -- System.Tasking.Task_Entry_Index (I), 3542 -- P, 3543 -- D, 3544 -- M, 3545 -- F); 3546 -- end _Disp_Time_Select; 3547 3548 function Make_Disp_Timed_Select_Body 3549 (Typ : Entity_Id) return Node_Id 3550 is 3551 Loc : constant Source_Ptr := Sloc (Typ); 3552 Conc_Typ : Entity_Id := Empty; 3553 Decls : constant List_Id := New_List; 3554 Obj_Ref : Node_Id; 3555 Stmts : constant List_Id := New_List; 3556 Tag_Node : Node_Id; 3557 3558 begin 3559 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3560 3561 -- Null body is generated for interface types 3562 3563 if Is_Interface (Typ) then 3564 return 3565 Make_Subprogram_Body (Loc, 3566 Specification => Make_Disp_Timed_Select_Spec (Typ), 3567 Declarations => New_List, 3568 Handled_Statement_Sequence => 3569 Make_Handled_Sequence_Of_Statements (Loc, 3570 New_List ( 3571 Make_Assignment_Statement (Loc, 3572 Name => Make_Identifier (Loc, Name_uF), 3573 Expression => New_Occurrence_Of (Standard_False, Loc))))); 3574 end if; 3575 3576 if Is_Concurrent_Record_Type (Typ) then 3577 Conc_Typ := Corresponding_Concurrent_Type (Typ); 3578 3579 -- Generate: 3580 -- I : Integer; 3581 3582 -- where I will be used to capture the entry index of the primitive 3583 -- wrapper at position S. 3584 3585 Append_To (Decls, 3586 Make_Object_Declaration (Loc, 3587 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), 3588 Object_Definition => 3589 New_Occurrence_Of (Standard_Integer, Loc))); 3590 3591 -- Generate: 3592 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); 3593 3594 -- if C = POK_Procedure 3595 -- or else C = POK_Protected_Procedure 3596 -- or else C = POK_Task_Procedure; 3597 -- then 3598 -- F := True; 3599 -- return; 3600 -- end if; 3601 3602 Build_Common_Dispatching_Select_Statements (Typ, Stmts); 3603 3604 -- Generate: 3605 -- I := Get_Entry_Index (tag! (<type>VP), S); 3606 3607 -- I is the entry index and S is the dispatch table slot 3608 3609 if Tagged_Type_Expansion then 3610 Tag_Node := 3611 Unchecked_Convert_To (RTE (RE_Tag), 3612 New_Occurrence_Of 3613 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); 3614 3615 else 3616 Tag_Node := 3617 Make_Attribute_Reference (Loc, 3618 Prefix => New_Occurrence_Of (Typ, Loc), 3619 Attribute_Name => Name_Tag); 3620 end if; 3621 3622 Append_To (Stmts, 3623 Make_Assignment_Statement (Loc, 3624 Name => Make_Identifier (Loc, Name_uI), 3625 Expression => 3626 Make_Function_Call (Loc, 3627 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 3628 Parameter_Associations => New_List ( 3629 Tag_Node, 3630 Make_Identifier (Loc, Name_uS))))); 3631 3632 -- Protected case 3633 3634 if Ekind (Conc_Typ) = E_Protected_Type then 3635 3636 -- Build T._object'Access 3637 3638 Obj_Ref := 3639 Make_Attribute_Reference (Loc, 3640 Attribute_Name => Name_Unchecked_Access, 3641 Prefix => 3642 Make_Selected_Component (Loc, 3643 Prefix => Make_Identifier (Loc, Name_uT), 3644 Selector_Name => Make_Identifier (Loc, Name_uObject))); 3645 3646 -- Normal case, No_Entry_Queue restriction not active. In this 3647 -- case we generate: 3648 3649 -- Timed_Protected_Entry_Call 3650 -- (T._object'access, 3651 -- Protected_Entry_Index! (I), 3652 -- P, D, M, F); 3653 3654 -- where T is the protected object, I is the entry index, P are 3655 -- the wrapped parameters, D is the delay amount, M is the delay 3656 -- mode and F is the status flag. 3657 3658 -- Historically, there was also an implementation for single 3659 -- entry protected types (in s-tposen). However, it was removed 3660 -- by also testing for no No_Select_Statements restriction in 3661 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the 3662 -- implementation of s-tposen.adb and provided consistency between 3663 -- all versions of System.Tasking.Protected_Objects.Single_Entry 3664 -- (s-tposen*.adb). 3665 3666 case Corresponding_Runtime_Package (Conc_Typ) is 3667 when System_Tasking_Protected_Objects_Entries => 3668 Append_To (Stmts, 3669 Make_Procedure_Call_Statement (Loc, 3670 Name => 3671 New_Occurrence_Of 3672 (RTE (RE_Timed_Protected_Entry_Call), Loc), 3673 Parameter_Associations => New_List ( 3674 Obj_Ref, 3675 3676 Make_Unchecked_Type_Conversion (Loc, -- entry index 3677 Subtype_Mark => 3678 New_Occurrence_Of 3679 (RTE (RE_Protected_Entry_Index), Loc), 3680 Expression => Make_Identifier (Loc, Name_uI)), 3681 3682 Make_Identifier (Loc, Name_uP), -- parameter block 3683 Make_Identifier (Loc, Name_uD), -- delay 3684 Make_Identifier (Loc, Name_uM), -- delay mode 3685 Make_Identifier (Loc, Name_uF)))); -- status flag 3686 3687 when others => 3688 raise Program_Error; 3689 end case; 3690 3691 -- Task case 3692 3693 else 3694 pragma Assert (Ekind (Conc_Typ) = E_Task_Type); 3695 3696 -- Generate: 3697 -- Timed_Task_Entry_Call ( 3698 -- T._task_id, 3699 -- Task_Entry_Index! (I), 3700 -- P, 3701 -- D, 3702 -- M, 3703 -- F); 3704 3705 -- where T is the task object, I is the entry index, P are the 3706 -- wrapped parameters, D is the delay amount, M is the delay 3707 -- mode and F is the status flag. 3708 3709 Append_To (Stmts, 3710 Make_Procedure_Call_Statement (Loc, 3711 Name => 3712 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 3713 3714 Parameter_Associations => New_List ( 3715 Make_Selected_Component (Loc, -- T._task_id 3716 Prefix => Make_Identifier (Loc, Name_uT), 3717 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 3718 3719 Make_Unchecked_Type_Conversion (Loc, -- entry index 3720 Subtype_Mark => 3721 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 3722 Expression => Make_Identifier (Loc, Name_uI)), 3723 3724 Make_Identifier (Loc, Name_uP), -- parameter block 3725 Make_Identifier (Loc, Name_uD), -- delay 3726 Make_Identifier (Loc, Name_uM), -- delay mode 3727 Make_Identifier (Loc, Name_uF)))); -- status flag 3728 end if; 3729 3730 else 3731 -- Initialize out parameters 3732 3733 Append_To (Stmts, 3734 Make_Assignment_Statement (Loc, 3735 Name => Make_Identifier (Loc, Name_uF), 3736 Expression => New_Occurrence_Of (Standard_False, Loc))); 3737 Append_To (Stmts, 3738 Make_Assignment_Statement (Loc, 3739 Name => Make_Identifier (Loc, Name_uC), 3740 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc))); 3741 end if; 3742 3743 return 3744 Make_Subprogram_Body (Loc, 3745 Specification => Make_Disp_Timed_Select_Spec (Typ), 3746 Declarations => Decls, 3747 Handled_Statement_Sequence => 3748 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 3749 end Make_Disp_Timed_Select_Body; 3750 3751 --------------------------------- 3752 -- Make_Disp_Timed_Select_Spec -- 3753 --------------------------------- 3754 3755 function Make_Disp_Timed_Select_Spec 3756 (Typ : Entity_Id) return Node_Id 3757 is 3758 Loc : constant Source_Ptr := Sloc (Typ); 3759 Def_Id : constant Node_Id := 3760 Make_Defining_Identifier (Loc, 3761 Name_uDisp_Timed_Select); 3762 Params : constant List_Id := New_List; 3763 3764 begin 3765 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 3766 3767 -- T : in out Typ; -- Object parameter 3768 -- S : Integer; -- Primitive operation slot 3769 -- P : Address; -- Wrapped parameters 3770 -- D : Duration; -- Delay 3771 -- M : Integer; -- Delay Mode 3772 -- C : out Prim_Op_Kind; -- Call kind 3773 -- F : out Boolean; -- Status flag 3774 3775 Append_List_To (Params, New_List ( 3776 3777 Make_Parameter_Specification (Loc, 3778 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), 3779 Parameter_Type => New_Occurrence_Of (Typ, Loc), 3780 In_Present => True, 3781 Out_Present => True), 3782 3783 Make_Parameter_Specification (Loc, 3784 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), 3785 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), 3786 3787 Make_Parameter_Specification (Loc, 3788 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), 3789 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), 3790 3791 Make_Parameter_Specification (Loc, 3792 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD), 3793 Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)), 3794 3795 Make_Parameter_Specification (Loc, 3796 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM), 3797 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), 3798 3799 Make_Parameter_Specification (Loc, 3800 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), 3801 Parameter_Type => 3802 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), 3803 Out_Present => True))); 3804 3805 Append_To (Params, 3806 Make_Parameter_Specification (Loc, 3807 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), 3808 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 3809 Out_Present => True)); 3810 3811 return 3812 Make_Procedure_Specification (Loc, 3813 Defining_Unit_Name => Def_Id, 3814 Parameter_Specifications => Params); 3815 end Make_Disp_Timed_Select_Spec; 3816 3817 ------------- 3818 -- Make_DT -- 3819 ------------- 3820 3821 -- The frontend supports two models for expanding dispatch tables 3822 -- associated with library-level defined tagged types: statically and 3823 -- non-statically allocated dispatch tables. In the former case the object 3824 -- containing the dispatch table is constant and it is initialized by means 3825 -- of a positional aggregate. In the latter case, the object containing 3826 -- the dispatch table is a variable which is initialized by means of 3827 -- assignments. 3828 3829 -- In case of locally defined tagged types, the object containing the 3830 -- object containing the dispatch table is always a variable (instead of a 3831 -- constant). This is currently required to give support to late overriding 3832 -- of primitives. For example: 3833 3834 -- procedure Example is 3835 -- package Pkg is 3836 -- type T1 is tagged null record; 3837 -- procedure Prim (O : T1); 3838 -- end Pkg; 3839 3840 -- type T2 is new Pkg.T1 with null record; 3841 -- procedure Prim (X : T2) is -- late overriding 3842 -- begin 3843 -- ... 3844 -- ... 3845 -- end; 3846 3847 -- WARNING: This routine manages Ghost regions. Return statements must be 3848 -- replaced by gotos which jump to the end of the routine and restore the 3849 -- Ghost mode. 3850 3851 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is 3852 Loc : constant Source_Ptr := Sloc (Typ); 3853 3854 Max_Predef_Prims : constant Int := 3855 UI_To_Int 3856 (Intval 3857 (Expression 3858 (Parent (RTE (RE_Max_Predef_Prims))))); 3859 3860 DT_Decl : constant Elist_Id := New_Elmt_List; 3861 DT_Aggr : constant Elist_Id := New_Elmt_List; 3862 -- Entities marked with attribute Is_Dispatch_Table_Entity 3863 3864 Dummy_Object : Entity_Id := Empty; 3865 -- Extra nonexistent object of type Typ internally used to compute the 3866 -- offset to the components that reference secondary dispatch tables. 3867 -- Used to compute the offset of components located at fixed position. 3868 3869 procedure Check_Premature_Freezing 3870 (Subp : Entity_Id; 3871 Tagged_Type : Entity_Id; 3872 Typ : Entity_Id); 3873 -- Verify that all untagged types in the profile of a subprogram are 3874 -- frozen at the point the subprogram is frozen. This enforces the rule 3875 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram 3876 -- is frozen, enough must be known about it to build the activation 3877 -- record for it, which requires at least that the size of all 3878 -- parameters be known. Controlling arguments are by-reference, 3879 -- and therefore the rule only applies to untagged types. Typical 3880 -- violation of the rule involves an object declaration that freezes a 3881 -- tagged type, when one of its primitive operations has a type in its 3882 -- profile whose full view has not been analyzed yet. More complex cases 3883 -- involve composite types that have one private unfrozen subcomponent. 3884 -- Move this check to sem??? 3885 3886 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); 3887 -- Export the dispatch table DT of tagged type Typ. Required to generate 3888 -- forward references and statically allocate the table. For primary 3889 -- dispatch tables Index is 0; for secondary dispatch tables the value 3890 -- of index must match the Suffix_Index value assigned to the table by 3891 -- Make_Tags when generating its unique external name, and it is used to 3892 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ 3893 -- the external name generated by Import_DT. 3894 3895 procedure Make_Secondary_DT 3896 (Typ : Entity_Id; 3897 Iface : Entity_Id; 3898 Iface_Comp : Node_Id; 3899 Suffix_Index : Int; 3900 Num_Iface_Prims : Nat; 3901 Iface_DT_Ptr : Entity_Id; 3902 Predef_Prims_Ptr : Entity_Id; 3903 Build_Thunks : Boolean; 3904 Result : List_Id); 3905 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch 3906 -- Table of Typ associated with Iface. Each abstract interface of Typ 3907 -- has two secondary dispatch tables: one containing pointers to thunks 3908 -- and another containing pointers to the primitives covering the 3909 -- interface primitives. The former secondary table is generated when 3910 -- Build_Thunks is True, and provides common support for dispatching 3911 -- calls through interface types; the latter secondary table is 3912 -- generated when Build_Thunks is False, and provides support for 3913 -- Generic Dispatching Constructors that dispatch calls through 3914 -- interface types. When constructing this latter table the value of 3915 -- Suffix_Index is -1 to indicate that there is no need to export such 3916 -- table when building statically allocated dispatch tables; a positive 3917 -- value of Suffix_Index must match the Suffix_Index value assigned to 3918 -- this secondary dispatch table by Make_Tags when its unique external 3919 -- name was generated. 3920 3921 function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat; 3922 -- Returns the number of predefined primitives of Typ 3923 3924 ------------------------------ 3925 -- Check_Premature_Freezing -- 3926 ------------------------------ 3927 3928 procedure Check_Premature_Freezing 3929 (Subp : Entity_Id; 3930 Tagged_Type : Entity_Id; 3931 Typ : Entity_Id) 3932 is 3933 Comp : Entity_Id; 3934 3935 function Is_Actual_For_Formal_Incomplete_Type 3936 (T : Entity_Id) return Boolean; 3937 -- In Ada 2012, if a nested generic has an incomplete formal type, 3938 -- the actual may be (and usually is) a private type whose completion 3939 -- appears later. It is safe to build the dispatch table in this 3940 -- case, gigi will have full views available. 3941 3942 ------------------------------------------ 3943 -- Is_Actual_For_Formal_Incomplete_Type -- 3944 ------------------------------------------ 3945 3946 function Is_Actual_For_Formal_Incomplete_Type 3947 (T : Entity_Id) return Boolean 3948 is 3949 Gen_Par : Entity_Id; 3950 F : Node_Id; 3951 3952 begin 3953 if not Is_Generic_Instance (Current_Scope) 3954 or else not Used_As_Generic_Actual (T) 3955 then 3956 return False; 3957 else 3958 Gen_Par := Generic_Parent (Parent (Current_Scope)); 3959 end if; 3960 3961 F := 3962 First 3963 (Generic_Formal_Declarations 3964 (Unit_Declaration_Node (Gen_Par))); 3965 while Present (F) loop 3966 if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then 3967 return True; 3968 end if; 3969 3970 Next (F); 3971 end loop; 3972 3973 return False; 3974 end Is_Actual_For_Formal_Incomplete_Type; 3975 3976 -- Start of processing for Check_Premature_Freezing 3977 3978 begin 3979 -- Note that if the type is a (subtype of) a generic actual, the 3980 -- actual will have been frozen by the instantiation. 3981 3982 if Present (N) 3983 and then Is_Private_Type (Typ) 3984 and then No (Full_View (Typ)) 3985 and then not Is_Generic_Type (Typ) 3986 and then not Is_Tagged_Type (Typ) 3987 and then not Is_Frozen (Typ) 3988 and then not Is_Generic_Actual_Type (Typ) 3989 then 3990 Error_Msg_Sloc := Sloc (Subp); 3991 Error_Msg_NE 3992 ("declaration must appear after completion of type &", N, Typ); 3993 Error_Msg_NE 3994 ("\which is an untagged type in the profile of " 3995 & "primitive operation & declared#", N, Subp); 3996 3997 else 3998 Comp := Private_Component (Typ); 3999 4000 if not Is_Tagged_Type (Typ) 4001 and then Present (Comp) 4002 and then not Is_Frozen (Comp) 4003 and then not Is_Actual_For_Formal_Incomplete_Type (Comp) 4004 then 4005 Error_Msg_Sloc := Sloc (Subp); 4006 Error_Msg_Node_2 := Subp; 4007 Error_Msg_Name_1 := Chars (Tagged_Type); 4008 Error_Msg_NE 4009 ("declaration must appear after completion of type &", 4010 N, Comp); 4011 Error_Msg_NE 4012 ("\which is a component of untagged type& in the profile " 4013 & "of primitive & of type % that is frozen by the " 4014 & "declaration ", N, Typ); 4015 end if; 4016 end if; 4017 end Check_Premature_Freezing; 4018 4019 --------------- 4020 -- Export_DT -- 4021 --------------- 4022 4023 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0) 4024 is 4025 Count : Nat; 4026 Elmt : Elmt_Id; 4027 4028 begin 4029 Set_Is_Statically_Allocated (DT); 4030 Set_Is_True_Constant (DT); 4031 Set_Is_Exported (DT); 4032 4033 Count := 0; 4034 Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ)); 4035 while Count /= Index loop 4036 Next_Elmt (Elmt); 4037 Count := Count + 1; 4038 end loop; 4039 4040 pragma Assert (Related_Type (Node (Elmt)) = Typ); 4041 4042 Get_External_Name (Node (Elmt)); 4043 Set_Interface_Name (DT, 4044 Make_String_Literal (Loc, 4045 Strval => String_From_Name_Buffer)); 4046 4047 -- Ensure proper Sprint output of this implicit importation 4048 4049 Set_Is_Internal (DT); 4050 Set_Is_Public (DT); 4051 end Export_DT; 4052 4053 ----------------------- 4054 -- Make_Secondary_DT -- 4055 ----------------------- 4056 4057 procedure Make_Secondary_DT 4058 (Typ : Entity_Id; 4059 Iface : Entity_Id; 4060 Iface_Comp : Node_Id; 4061 Suffix_Index : Int; 4062 Num_Iface_Prims : Nat; 4063 Iface_DT_Ptr : Entity_Id; 4064 Predef_Prims_Ptr : Entity_Id; 4065 Build_Thunks : Boolean; 4066 Result : List_Id) 4067 is 4068 Loc : constant Source_Ptr := Sloc (Typ); 4069 Exporting_Table : constant Boolean := 4070 Building_Static_DT (Typ) 4071 and then Suffix_Index > 0; 4072 Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); 4073 Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); 4074 DT_Constr_List : List_Id; 4075 DT_Aggr_List : List_Id; 4076 Empty_DT : Boolean := False; 4077 Nb_Prim : Nat; 4078 New_Node : Node_Id; 4079 OSD : Entity_Id; 4080 OSD_Aggr_List : List_Id; 4081 Prim : Entity_Id; 4082 Prim_Elmt : Elmt_Id; 4083 Prim_Ops_Aggr_List : List_Id; 4084 4085 begin 4086 -- Handle cases in which we do not generate statically allocated 4087 -- dispatch tables. 4088 4089 if not Building_Static_DT (Typ) then 4090 Set_Ekind (Predef_Prims, E_Variable); 4091 Set_Ekind (Iface_DT, E_Variable); 4092 4093 -- Statically allocated dispatch tables and related entities are 4094 -- constants. 4095 4096 else 4097 Set_Ekind (Predef_Prims, E_Constant); 4098 Set_Is_Statically_Allocated (Predef_Prims); 4099 Set_Is_True_Constant (Predef_Prims); 4100 4101 Set_Ekind (Iface_DT, E_Constant); 4102 Set_Is_Statically_Allocated (Iface_DT); 4103 Set_Is_True_Constant (Iface_DT); 4104 end if; 4105 4106 -- Calculate the number of slots of the dispatch table. If the number 4107 -- of primitives of Typ is 0 we reserve a dummy single entry for its 4108 -- DT because at run time the pointer to this dummy entry will be 4109 -- used as the tag. 4110 4111 if Num_Iface_Prims = 0 then 4112 Empty_DT := True; 4113 Nb_Prim := 1; 4114 else 4115 Nb_Prim := Num_Iface_Prims; 4116 end if; 4117 4118 -- Generate: 4119 4120 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := 4121 -- (predef-prim-op-thunk-1'address, 4122 -- predef-prim-op-thunk-2'address, 4123 -- ... 4124 -- predef-prim-op-thunk-n'address); 4125 4126 -- Create the thunks associated with the predefined primitives and 4127 -- save their entity to fill the aggregate. 4128 4129 declare 4130 Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); 4131 Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; 4132 Decl : Node_Id; 4133 Thunk_Id : Entity_Id; 4134 Thunk_Code : Node_Id; 4135 4136 begin 4137 Prim_Ops_Aggr_List := New_List; 4138 Prim_Table := (others => Empty); 4139 4140 if Building_Static_DT (Typ) then 4141 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 4142 while Present (Prim_Elmt) loop 4143 Prim := Node (Prim_Elmt); 4144 4145 if Is_Predefined_Dispatching_Operation (Prim) 4146 and then not Is_Abstract_Subprogram (Prim) 4147 and then not Is_Eliminated (Prim) 4148 and then not Generate_SCIL 4149 and then not Present (Prim_Table 4150 (UI_To_Int (DT_Position (Prim)))) 4151 then 4152 if not Build_Thunks then 4153 Prim_Table (UI_To_Int (DT_Position (Prim))) := 4154 Alias (Prim); 4155 4156 else 4157 Expand_Interface_Thunk 4158 (Prim, Thunk_Id, Thunk_Code, Iface); 4159 4160 if Present (Thunk_Id) then 4161 Append_To (Result, Thunk_Code); 4162 Prim_Table (UI_To_Int (DT_Position (Prim))) := 4163 Thunk_Id; 4164 end if; 4165 end if; 4166 end if; 4167 4168 Next_Elmt (Prim_Elmt); 4169 end loop; 4170 end if; 4171 4172 for J in Prim_Table'Range loop 4173 if Present (Prim_Table (J)) then 4174 New_Node := 4175 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 4176 Make_Attribute_Reference (Loc, 4177 Prefix => New_Occurrence_Of (Prim_Table (J), Loc), 4178 Attribute_Name => Name_Unrestricted_Access)); 4179 else 4180 New_Node := Make_Null (Loc); 4181 end if; 4182 4183 Append_To (Prim_Ops_Aggr_List, New_Node); 4184 end loop; 4185 4186 New_Node := 4187 Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); 4188 4189 -- Remember aggregates initializing dispatch tables 4190 4191 Append_Elmt (New_Node, DT_Aggr); 4192 4193 Decl := 4194 Make_Subtype_Declaration (Loc, 4195 Defining_Identifier => Make_Temporary (Loc, 'S'), 4196 Subtype_Indication => 4197 New_Occurrence_Of (RTE (RE_Address_Array), Loc)); 4198 4199 Append_To (Result, Decl); 4200 4201 Append_To (Result, 4202 Make_Object_Declaration (Loc, 4203 Defining_Identifier => Predef_Prims, 4204 Constant_Present => Building_Static_DT (Typ), 4205 Aliased_Present => True, 4206 Object_Definition => New_Occurrence_Of 4207 (Defining_Identifier (Decl), Loc), 4208 Expression => New_Node)); 4209 end; 4210 4211 -- Generate 4212 4213 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := 4214 -- (OSD_Table => (1 => <value>, 4215 -- ... 4216 -- N => <value>)); 4217 -- for OSD'Alignment use Address'Alignment; 4218 4219 -- Iface_DT : Dispatch_Table (Nb_Prims) := 4220 -- ([ Signature => <sig-value> ], 4221 -- Tag_Kind => <tag_kind-value>, 4222 -- Predef_Prims => Predef_Prims'Address, 4223 -- Offset_To_Top => 0, 4224 -- OSD => OSD'Address, 4225 -- Prims_Ptr => (prim-op-1'address, 4226 -- prim-op-2'address, 4227 -- ... 4228 -- prim-op-n'address)); 4229 4230 -- Stage 3: Initialize the discriminant and the record components 4231 4232 DT_Constr_List := New_List; 4233 DT_Aggr_List := New_List; 4234 4235 -- Nb_Prim 4236 4237 Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim)); 4238 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim)); 4239 4240 -- Signature 4241 4242 if RTE_Record_Component_Available (RE_Signature) then 4243 Append_To (DT_Aggr_List, 4244 New_Occurrence_Of (RTE (RE_Secondary_DT), Loc)); 4245 end if; 4246 4247 -- Tag_Kind 4248 4249 if RTE_Record_Component_Available (RE_Tag_Kind) then 4250 Append_To (DT_Aggr_List, Tagged_Kind (Typ)); 4251 end if; 4252 4253 -- Predef_Prims 4254 4255 Append_To (DT_Aggr_List, 4256 Make_Attribute_Reference (Loc, 4257 Prefix => New_Occurrence_Of (Predef_Prims, Loc), 4258 Attribute_Name => Name_Address)); 4259 4260 -- Interface component located at variable offset; the value of 4261 -- Offset_To_Top will be set by the init subprogram. 4262 4263 if No (Dummy_Object) 4264 or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) 4265 then 4266 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); 4267 4268 -- Interface component located at fixed offset 4269 4270 else 4271 Append_To (DT_Aggr_List, 4272 Make_Op_Minus (Loc, 4273 Make_Attribute_Reference (Loc, 4274 Prefix => 4275 Make_Selected_Component (Loc, 4276 Prefix => 4277 New_Occurrence_Of (Dummy_Object, Loc), 4278 Selector_Name => 4279 New_Occurrence_Of (Iface_Comp, Loc)), 4280 Attribute_Name => Name_Position))); 4281 end if; 4282 4283 -- Generate the Object Specific Data table required to dispatch calls 4284 -- through synchronized interfaces. 4285 4286 if Empty_DT 4287 or else Is_Abstract_Type (Typ) 4288 or else Is_Controlled (Typ) 4289 or else Restriction_Active (No_Dispatching_Calls) 4290 or else not Is_Limited_Type (Typ) 4291 or else not Has_Interfaces (Typ) 4292 or else not Build_Thunks 4293 or else not RTE_Record_Component_Available (RE_OSD_Table) 4294 then 4295 -- No OSD table required 4296 4297 Append_To (DT_Aggr_List, 4298 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 4299 4300 else 4301 OSD_Aggr_List := New_List; 4302 4303 declare 4304 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; 4305 Prim : Entity_Id; 4306 Prim_Alias : Entity_Id; 4307 Prim_Elmt : Elmt_Id; 4308 E : Entity_Id; 4309 Count : Nat := 0; 4310 Pos : Nat; 4311 4312 begin 4313 Prim_Table := (others => Empty); 4314 Prim_Alias := Empty; 4315 4316 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 4317 while Present (Prim_Elmt) loop 4318 Prim := Node (Prim_Elmt); 4319 4320 if Present (Interface_Alias (Prim)) 4321 and then Find_Dispatching_Type 4322 (Interface_Alias (Prim)) = Iface 4323 then 4324 Prim_Alias := Interface_Alias (Prim); 4325 E := Ultimate_Alias (Prim); 4326 Pos := UI_To_Int (DT_Position (Prim_Alias)); 4327 4328 if Present (Prim_Table (Pos)) then 4329 pragma Assert (Prim_Table (Pos) = E); 4330 null; 4331 4332 else 4333 Prim_Table (Pos) := E; 4334 4335 Append_To (OSD_Aggr_List, 4336 Make_Component_Association (Loc, 4337 Choices => New_List ( 4338 Make_Integer_Literal (Loc, 4339 DT_Position (Prim_Alias))), 4340 Expression => 4341 Make_Integer_Literal (Loc, 4342 DT_Position (Alias (Prim))))); 4343 4344 Count := Count + 1; 4345 end if; 4346 end if; 4347 4348 Next_Elmt (Prim_Elmt); 4349 end loop; 4350 pragma Assert (Count = Nb_Prim); 4351 end; 4352 4353 OSD := Make_Temporary (Loc, 'I'); 4354 4355 Append_To (Result, 4356 Make_Object_Declaration (Loc, 4357 Defining_Identifier => OSD, 4358 Constant_Present => True, 4359 Object_Definition => 4360 Make_Subtype_Indication (Loc, 4361 Subtype_Mark => 4362 New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), 4363 Constraint => 4364 Make_Index_Or_Discriminant_Constraint (Loc, 4365 Constraints => New_List ( 4366 Make_Integer_Literal (Loc, Nb_Prim)))), 4367 4368 Expression => 4369 Make_Aggregate (Loc, 4370 Component_Associations => New_List ( 4371 Make_Component_Association (Loc, 4372 Choices => New_List ( 4373 New_Occurrence_Of 4374 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), 4375 Expression => 4376 Make_Integer_Literal (Loc, Nb_Prim)), 4377 4378 Make_Component_Association (Loc, 4379 Choices => New_List ( 4380 New_Occurrence_Of 4381 (RTE_Record_Component (RE_OSD_Table), Loc)), 4382 Expression => Make_Aggregate (Loc, 4383 Component_Associations => OSD_Aggr_List)))))); 4384 4385 Append_To (Result, 4386 Make_Attribute_Definition_Clause (Loc, 4387 Name => New_Occurrence_Of (OSD, Loc), 4388 Chars => Name_Alignment, 4389 Expression => 4390 Make_Attribute_Reference (Loc, 4391 Prefix => 4392 New_Occurrence_Of (RTE (RE_Integer_Address), Loc), 4393 Attribute_Name => Name_Alignment))); 4394 4395 -- In secondary dispatch tables the Typeinfo component contains 4396 -- the address of the Object Specific Data (see a-tags.ads). 4397 4398 Append_To (DT_Aggr_List, 4399 Make_Attribute_Reference (Loc, 4400 Prefix => New_Occurrence_Of (OSD, Loc), 4401 Attribute_Name => Name_Address)); 4402 end if; 4403 4404 -- Initialize the table of primitive operations 4405 4406 Prim_Ops_Aggr_List := New_List; 4407 4408 if Empty_DT then 4409 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); 4410 4411 elsif Is_Abstract_Type (Typ) 4412 or else not Building_Static_DT (Typ) 4413 then 4414 for J in 1 .. Nb_Prim loop 4415 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); 4416 end loop; 4417 4418 else 4419 declare 4420 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); 4421 E : Entity_Id; 4422 Prim_Pos : Nat; 4423 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; 4424 Thunk_Code : Node_Id; 4425 Thunk_Id : Entity_Id; 4426 4427 begin 4428 Prim_Table := (others => Empty); 4429 4430 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 4431 while Present (Prim_Elmt) loop 4432 Prim := Node (Prim_Elmt); 4433 E := Ultimate_Alias (Prim); 4434 Prim_Pos := UI_To_Int (DT_Position (E)); 4435 4436 -- Do not reference predefined primitives because they are 4437 -- located in a separate dispatch table; skip abstract and 4438 -- eliminated primitives; skip primitives located in the C++ 4439 -- part of the dispatch table because their slot is set by 4440 -- the IC routine. 4441 4442 if not Is_Predefined_Dispatching_Operation (Prim) 4443 and then Present (Interface_Alias (Prim)) 4444 and then not Is_Abstract_Subprogram (Alias (Prim)) 4445 and then not Is_Eliminated (Alias (Prim)) 4446 and then (not Is_CPP_Class (Root_Type (Typ)) 4447 or else Prim_Pos > CPP_Nb_Prims) 4448 and then Find_Dispatching_Type 4449 (Interface_Alias (Prim)) = Iface 4450 4451 -- Generate the code of the thunk only if the abstract 4452 -- interface type is not an immediate ancestor of 4453 -- Tagged_Type. Otherwise the DT associated with the 4454 -- interface is the primary DT. 4455 4456 and then not Is_Ancestor (Iface, Typ, 4457 Use_Full_View => True) 4458 then 4459 if not Build_Thunks then 4460 Prim_Pos := 4461 UI_To_Int (DT_Position (Interface_Alias (Prim))); 4462 Prim_Table (Prim_Pos) := Alias (Prim); 4463 4464 else 4465 Expand_Interface_Thunk 4466 (Prim, Thunk_Id, Thunk_Code, Iface); 4467 4468 if Present (Thunk_Id) then 4469 Prim_Pos := 4470 UI_To_Int (DT_Position (Interface_Alias (Prim))); 4471 4472 Prim_Table (Prim_Pos) := Thunk_Id; 4473 Append_To (Result, Thunk_Code); 4474 end if; 4475 end if; 4476 end if; 4477 4478 Next_Elmt (Prim_Elmt); 4479 end loop; 4480 4481 for J in Prim_Table'Range loop 4482 if Present (Prim_Table (J)) then 4483 New_Node := 4484 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 4485 Make_Attribute_Reference (Loc, 4486 Prefix => New_Occurrence_Of (Prim_Table (J), Loc), 4487 Attribute_Name => Name_Unrestricted_Access)); 4488 4489 else 4490 New_Node := Make_Null (Loc); 4491 end if; 4492 4493 Append_To (Prim_Ops_Aggr_List, New_Node); 4494 end loop; 4495 end; 4496 end if; 4497 4498 New_Node := 4499 Make_Aggregate (Loc, 4500 Expressions => Prim_Ops_Aggr_List); 4501 4502 Append_To (DT_Aggr_List, New_Node); 4503 4504 -- Remember aggregates initializing dispatch tables 4505 4506 Append_Elmt (New_Node, DT_Aggr); 4507 4508 -- Note: Secondary dispatch tables are declared constant only if 4509 -- we can compute their offset field by means of the extra dummy 4510 -- object; otherwise they cannot be declared constant and the 4511 -- Offset_To_Top component is initialized by the IP routine. 4512 4513 Append_To (Result, 4514 Make_Object_Declaration (Loc, 4515 Defining_Identifier => Iface_DT, 4516 Aliased_Present => True, 4517 Constant_Present => Building_Static_Secondary_DT (Typ), 4518 4519 Object_Definition => 4520 Make_Subtype_Indication (Loc, 4521 Subtype_Mark => New_Occurrence_Of 4522 (RTE (RE_Dispatch_Table_Wrapper), Loc), 4523 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, 4524 Constraints => DT_Constr_List)), 4525 4526 Expression => 4527 Make_Aggregate (Loc, 4528 Expressions => DT_Aggr_List))); 4529 4530 if Exporting_Table then 4531 Export_DT (Typ, Iface_DT, Suffix_Index); 4532 4533 -- Generate code to create the pointer to the dispatch table 4534 4535 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address); 4536 4537 -- Note: This declaration is not added here if the table is exported 4538 -- because in such case Make_Tags has already added this declaration. 4539 4540 else 4541 Append_To (Result, 4542 Make_Object_Declaration (Loc, 4543 Defining_Identifier => Iface_DT_Ptr, 4544 Constant_Present => True, 4545 4546 Object_Definition => 4547 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc), 4548 4549 Expression => 4550 Unchecked_Convert_To (RTE (RE_Interface_Tag), 4551 Make_Attribute_Reference (Loc, 4552 Prefix => 4553 Make_Selected_Component (Loc, 4554 Prefix => New_Occurrence_Of (Iface_DT, Loc), 4555 Selector_Name => 4556 New_Occurrence_Of 4557 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 4558 Attribute_Name => Name_Address)))); 4559 end if; 4560 4561 Append_To (Result, 4562 Make_Object_Declaration (Loc, 4563 Defining_Identifier => Predef_Prims_Ptr, 4564 Constant_Present => True, 4565 4566 Object_Definition => 4567 New_Occurrence_Of (RTE (RE_Address), Loc), 4568 4569 Expression => 4570 Make_Attribute_Reference (Loc, 4571 Prefix => 4572 Make_Selected_Component (Loc, 4573 Prefix => New_Occurrence_Of (Iface_DT, Loc), 4574 Selector_Name => 4575 New_Occurrence_Of 4576 (RTE_Record_Component (RE_Predef_Prims), Loc)), 4577 Attribute_Name => Name_Address))); 4578 4579 -- Remember entities containing dispatch tables 4580 4581 Append_Elmt (Predef_Prims, DT_Decl); 4582 Append_Elmt (Iface_DT, DT_Decl); 4583 end Make_Secondary_DT; 4584 4585 -------------------------------- 4586 -- Number_Of_Predefined_Prims -- 4587 -------------------------------- 4588 4589 function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat is 4590 Nb_Predef_Prims : Nat := 0; 4591 4592 begin 4593 if not Generate_SCIL then 4594 declare 4595 Prim : Entity_Id; 4596 Prim_Elmt : Elmt_Id; 4597 Pos : Nat; 4598 4599 begin 4600 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 4601 while Present (Prim_Elmt) loop 4602 Prim := Node (Prim_Elmt); 4603 4604 if Is_Predefined_Dispatching_Operation (Prim) 4605 and then not Is_Abstract_Subprogram (Prim) 4606 then 4607 Pos := UI_To_Int (DT_Position (Prim)); 4608 4609 if Pos > Nb_Predef_Prims then 4610 Nb_Predef_Prims := Pos; 4611 end if; 4612 end if; 4613 4614 Next_Elmt (Prim_Elmt); 4615 end loop; 4616 end; 4617 end if; 4618 4619 pragma Assert (Nb_Predef_Prims <= Max_Predef_Prims); 4620 return Nb_Predef_Prims; 4621 end Number_Of_Predefined_Prims; 4622 4623 -- Local variables 4624 4625 Elab_Code : constant List_Id := New_List; 4626 Result : constant List_Id := New_List; 4627 Tname : constant Name_Id := Chars (Typ); 4628 4629 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply 4630 -- we initialize the Expanded_Name and the External_Tag of this tagged 4631 -- type with an empty string. This is useful to avoid exposing entity 4632 -- names at binary level. It can be done when both pragmas apply because 4633 -- (1) Discard_Names allows initializing Expanded_Name with an 4634 -- implementation defined value (Ada RM Section C.5 (7/2)). 4635 -- (2) External_Tag (combined with Internal_Tag) is used for object 4636 -- streaming and No_Tagged_Streams inhibits the generation of 4637 -- streams. 4638 4639 Discard_Names : constant Boolean := 4640 Present (No_Tagged_Streams_Pragma (Typ)) 4641 and then (Global_Discard_Names 4642 or else Einfo.Discard_Names (Typ)); 4643 4644 -- The following name entries are used by Make_DT to generate a number 4645 -- of entities related to a tagged type. These entities may be generated 4646 -- in a scope other than that of the tagged type declaration, and if 4647 -- the entities for two tagged types with the same name happen to be 4648 -- generated in the same scope, we have to take care to use different 4649 -- names. This is achieved by means of a unique serial number appended 4650 -- to each generated entity name. 4651 4652 Name_DT : constant Name_Id := 4653 New_External_Name (Tname, 'T', Suffix_Index => -1); 4654 Name_Exname : constant Name_Id := 4655 New_External_Name (Tname, 'E', Suffix_Index => -1); 4656 Name_HT_Link : constant Name_Id := 4657 New_External_Name (Tname, 'H', Suffix_Index => -1); 4658 Name_Predef_Prims : constant Name_Id := 4659 New_External_Name (Tname, 'R', Suffix_Index => -1); 4660 Name_SSD : constant Name_Id := 4661 New_External_Name (Tname, 'S', Suffix_Index => -1); 4662 Name_TSD : constant Name_Id := 4663 New_External_Name (Tname, 'B', Suffix_Index => -1); 4664 4665 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 4666 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 4667 -- Save the Ghost-related attributes to restore on exit 4668 4669 AI : Elmt_Id; 4670 AI_Tag_Elmt : Elmt_Id; 4671 AI_Tag_Comp : Elmt_Id; 4672 DT : Entity_Id; 4673 DT_Aggr_List : List_Id; 4674 DT_Constr_List : List_Id; 4675 DT_Ptr : Entity_Id; 4676 Exname : Entity_Id; 4677 HT_Link : Entity_Id; 4678 ITable : Node_Id; 4679 I_Depth : Nat := 0; 4680 Iface_Table_Node : Node_Id; 4681 Name_ITable : Name_Id; 4682 Nb_Prim : Nat := 0; 4683 New_Node : Node_Id; 4684 Num_Ifaces : Nat := 0; 4685 Parent_Typ : Entity_Id; 4686 Predef_Prims : Entity_Id; 4687 Prim : Entity_Id; 4688 Prim_Elmt : Elmt_Id; 4689 Prim_Ops_Aggr_List : List_Id; 4690 SSD : Entity_Id; 4691 Suffix_Index : Int; 4692 Typ_Comps : Elist_Id; 4693 Typ_Ifaces : Elist_Id; 4694 TSD : Entity_Id; 4695 TSD_Aggr_List : List_Id; 4696 TSD_Tags_List : List_Id; 4697 4698 -- Start of processing for Make_DT 4699 4700 begin 4701 pragma Assert (Is_Frozen (Typ)); 4702 4703 -- The tagged type being processed may be subject to pragma Ghost. Set 4704 -- the mode now to ensure that any nodes generated during dispatch table 4705 -- creation are properly marked as Ghost. 4706 4707 Set_Ghost_Mode (Typ); 4708 4709 -- Handle cases in which there is no need to build the dispatch table 4710 4711 if Has_Dispatch_Table (Typ) 4712 or else No (Access_Disp_Table (Typ)) 4713 or else Is_CPP_Class (Typ) 4714 then 4715 goto Leave; 4716 4717 elsif No_Run_Time_Mode then 4718 Error_Msg_CRT ("tagged types", Typ); 4719 goto Leave; 4720 4721 elsif not RTE_Available (RE_Tag) then 4722 Append_To (Result, 4723 Make_Object_Declaration (Loc, 4724 Defining_Identifier => 4725 Node (First_Elmt (Access_Disp_Table (Typ))), 4726 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 4727 Constant_Present => True, 4728 Expression => 4729 Unchecked_Convert_To (RTE (RE_Tag), 4730 New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); 4731 4732 Analyze_List (Result, Suppress => All_Checks); 4733 Error_Msg_CRT ("tagged types", Typ); 4734 goto Leave; 4735 end if; 4736 4737 -- Ensure that the value of Max_Predef_Prims defined in a-tags is 4738 -- correct. Valid values are 10 under configurable runtime or 16 4739 -- with full runtime. 4740 4741 if RTE_Available (RE_Interface_Data) then 4742 if Max_Predef_Prims /= 16 then 4743 Error_Msg_N ("run-time library configuration error", Typ); 4744 goto Leave; 4745 end if; 4746 else 4747 if Max_Predef_Prims /= 10 then 4748 Error_Msg_N ("run-time library configuration error", Typ); 4749 Error_Msg_CRT ("tagged types", Typ); 4750 goto Leave; 4751 end if; 4752 end if; 4753 4754 DT := Make_Defining_Identifier (Loc, Name_DT); 4755 Exname := Make_Defining_Identifier (Loc, Name_Exname); 4756 HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link); 4757 Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims); 4758 SSD := Make_Defining_Identifier (Loc, Name_SSD); 4759 TSD := Make_Defining_Identifier (Loc, Name_TSD); 4760 4761 -- Initialize Parent_Typ handling private types 4762 4763 Parent_Typ := Etype (Typ); 4764 4765 if Present (Full_View (Parent_Typ)) then 4766 Parent_Typ := Full_View (Parent_Typ); 4767 end if; 4768 4769 -- Ensure that all the primitives are frozen. This is only required when 4770 -- building static dispatch tables --- the primitives must be frozen to 4771 -- be referenced (otherwise we have problems with the backend). It is 4772 -- not a requirement with nonstatic dispatch tables because in this case 4773 -- we generate now an empty dispatch table; the extra code required to 4774 -- register the primitives in the slots will be generated later --- when 4775 -- each primitive is frozen (see Freeze_Subprogram). 4776 4777 if Building_Static_DT (Typ) then 4778 declare 4779 Saved_FLLTT : constant Boolean := 4780 Freezing_Library_Level_Tagged_Type; 4781 4782 Formal : Entity_Id; 4783 Frnodes : List_Id; 4784 Prim : Entity_Id; 4785 Prim_Elmt : Elmt_Id; 4786 4787 begin 4788 Freezing_Library_Level_Tagged_Type := True; 4789 4790 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 4791 while Present (Prim_Elmt) loop 4792 Prim := Node (Prim_Elmt); 4793 Frnodes := Freeze_Entity (Prim, Typ); 4794 4795 -- We disable this check for abstract subprograms, given that 4796 -- they cannot be called directly and thus the state of their 4797 -- untagged formals is of no concern. The RM is unclear in any 4798 -- case concerning the need for this check, and this topic may 4799 -- go back to the ARG. 4800 4801 if not Is_Abstract_Subprogram (Prim) then 4802 Formal := First_Formal (Prim); 4803 while Present (Formal) loop 4804 Check_Premature_Freezing (Prim, Typ, Etype (Formal)); 4805 Next_Formal (Formal); 4806 end loop; 4807 4808 Check_Premature_Freezing (Prim, Typ, Etype (Prim)); 4809 end if; 4810 4811 if Present (Frnodes) then 4812 Append_List_To (Result, Frnodes); 4813 end if; 4814 4815 Next_Elmt (Prim_Elmt); 4816 end loop; 4817 4818 Freezing_Library_Level_Tagged_Type := Saved_FLLTT; 4819 end; 4820 end if; 4821 4822 if not Is_Interface (Typ) and then Has_Interfaces (Typ) then 4823 declare 4824 Cannot_Have_Null_Disc : Boolean := False; 4825 Dummy_Object_Typ : constant Entity_Id := Typ; 4826 Name_Dummy_Object : constant Name_Id := 4827 New_External_Name (Tname, 4828 'P', Suffix_Index => -1); 4829 begin 4830 Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object); 4831 4832 -- Define the extra object imported and constant to avoid linker 4833 -- errors (since this object is never declared). Required because 4834 -- we implement RM 13.3(19) for exported and imported (variable) 4835 -- objects by making them volatile. 4836 4837 Set_Is_Imported (Dummy_Object); 4838 Set_Ekind (Dummy_Object, E_Constant); 4839 Set_Is_True_Constant (Dummy_Object); 4840 Set_Related_Type (Dummy_Object, Typ); 4841 4842 -- The scope must be set now to call Get_External_Name 4843 4844 Set_Scope (Dummy_Object, Current_Scope); 4845 4846 Get_External_Name (Dummy_Object); 4847 Set_Interface_Name (Dummy_Object, 4848 Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); 4849 4850 -- Ensure proper Sprint output of this implicit importation 4851 4852 Set_Is_Internal (Dummy_Object); 4853 4854 if not Has_Discriminants (Dummy_Object_Typ) then 4855 Append_To (Result, 4856 Make_Object_Declaration (Loc, 4857 Defining_Identifier => Dummy_Object, 4858 Constant_Present => True, 4859 Object_Definition => New_Occurrence_Of 4860 (Dummy_Object_Typ, Loc))); 4861 else 4862 declare 4863 Constr_List : constant List_Id := New_List; 4864 Discrim : Node_Id; 4865 4866 begin 4867 Discrim := First_Discriminant (Dummy_Object_Typ); 4868 while Present (Discrim) loop 4869 if Is_Discrete_Type (Etype (Discrim)) then 4870 Append_To (Constr_List, 4871 Make_Attribute_Reference (Loc, 4872 Prefix => 4873 New_Occurrence_Of (Etype (Discrim), Loc), 4874 Attribute_Name => Name_First)); 4875 4876 else 4877 pragma Assert (Is_Access_Type (Etype (Discrim))); 4878 Cannot_Have_Null_Disc := 4879 Cannot_Have_Null_Disc 4880 or else Can_Never_Be_Null (Etype (Discrim)); 4881 Append_To (Constr_List, Make_Null (Loc)); 4882 end if; 4883 4884 Next_Discriminant (Discrim); 4885 end loop; 4886 4887 Append_To (Result, 4888 Make_Object_Declaration (Loc, 4889 Defining_Identifier => Dummy_Object, 4890 Constant_Present => True, 4891 Object_Definition => 4892 Make_Subtype_Indication (Loc, 4893 Subtype_Mark => 4894 New_Occurrence_Of (Dummy_Object_Typ, Loc), 4895 Constraint => 4896 Make_Index_Or_Discriminant_Constraint (Loc, 4897 Constraints => Constr_List)))); 4898 end; 4899 end if; 4900 4901 -- Given that the dummy object will not be declared at run time, 4902 -- analyze its declaration with expansion disabled and warnings 4903 -- and error messages ignored. 4904 4905 Expander_Mode_Save_And_Set (False); 4906 Ignore_Errors_Enable := Ignore_Errors_Enable + 1; 4907 Analyze (Last (Result), Suppress => All_Checks); 4908 Ignore_Errors_Enable := Ignore_Errors_Enable - 1; 4909 Expander_Mode_Restore; 4910 end; 4911 end if; 4912 4913 -- Ada 2005 (AI-251): Build the secondary dispatch tables 4914 4915 if Has_Interfaces (Typ) then 4916 Collect_Interface_Components (Typ, Typ_Comps); 4917 4918 -- Each secondary dispatch table is assigned an unique positive 4919 -- suffix index; such value also corresponds with the location of 4920 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags). 4921 4922 -- Note: This value must be kept sync with the Suffix_Index values 4923 -- generated by Make_Tags 4924 4925 Suffix_Index := 1; 4926 AI_Tag_Elmt := 4927 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); 4928 4929 AI_Tag_Comp := First_Elmt (Typ_Comps); 4930 while Present (AI_Tag_Comp) loop 4931 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P')); 4932 4933 -- Build the secondary table containing pointers to thunks 4934 4935 Make_Secondary_DT 4936 (Typ => Typ, 4937 Iface => 4938 Base_Type (Related_Type (Node (AI_Tag_Comp))), 4939 Iface_Comp => Node (AI_Tag_Comp), 4940 Suffix_Index => Suffix_Index, 4941 Num_Iface_Prims => 4942 UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), 4943 Iface_DT_Ptr => Node (AI_Tag_Elmt), 4944 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), 4945 Build_Thunks => True, 4946 Result => Result); 4947 4948 -- Skip secondary dispatch table referencing thunks to predefined 4949 -- primitives. 4950 4951 Next_Elmt (AI_Tag_Elmt); 4952 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y')); 4953 4954 -- Secondary dispatch table referencing user-defined primitives 4955 -- covered by this interface. 4956 4957 Next_Elmt (AI_Tag_Elmt); 4958 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D')); 4959 4960 -- Build the secondary table containing pointers to primitives 4961 -- (used to give support to Generic Dispatching Constructors). 4962 4963 Make_Secondary_DT 4964 (Typ => Typ, 4965 Iface => Base_Type 4966 (Related_Type (Node (AI_Tag_Comp))), 4967 Iface_Comp => Node (AI_Tag_Comp), 4968 Suffix_Index => -1, 4969 Num_Iface_Prims => UI_To_Int 4970 (DT_Entry_Count (Node (AI_Tag_Comp))), 4971 Iface_DT_Ptr => Node (AI_Tag_Elmt), 4972 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), 4973 Build_Thunks => False, 4974 Result => Result); 4975 4976 -- Skip secondary dispatch table referencing predefined primitives 4977 4978 Next_Elmt (AI_Tag_Elmt); 4979 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z')); 4980 4981 Suffix_Index := Suffix_Index + 1; 4982 Next_Elmt (AI_Tag_Elmt); 4983 Next_Elmt (AI_Tag_Comp); 4984 end loop; 4985 end if; 4986 4987 -- Get the _tag entity and number of primitives of its dispatch table 4988 4989 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); 4990 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); 4991 4992 if Generate_SCIL then 4993 Nb_Prim := 0; 4994 end if; 4995 4996 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); 4997 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); 4998 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); 4999 Set_Is_Statically_Allocated (Predef_Prims, 5000 Is_Library_Level_Tagged_Type (Typ)); 5001 5002 -- In case of locally defined tagged type we declare the object 5003 -- containing the dispatch table by means of a variable. Its 5004 -- initialization is done later by means of an assignment. This is 5005 -- required to generate its External_Tag. 5006 5007 if not Building_Static_DT (Typ) then 5008 5009 -- Generate: 5010 -- DT : No_Dispatch_Table_Wrapper; 5011 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); 5012 5013 if not Has_DT (Typ) then 5014 Append_To (Result, 5015 Make_Object_Declaration (Loc, 5016 Defining_Identifier => DT, 5017 Aliased_Present => True, 5018 Constant_Present => False, 5019 Object_Definition => 5020 New_Occurrence_Of 5021 (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); 5022 5023 Append_To (Result, 5024 Make_Object_Declaration (Loc, 5025 Defining_Identifier => DT_Ptr, 5026 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 5027 Constant_Present => True, 5028 Expression => 5029 Unchecked_Convert_To (RTE (RE_Tag), 5030 Make_Attribute_Reference (Loc, 5031 Prefix => 5032 Make_Selected_Component (Loc, 5033 Prefix => New_Occurrence_Of (DT, Loc), 5034 Selector_Name => 5035 New_Occurrence_Of 5036 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), 5037 Attribute_Name => Name_Address)))); 5038 5039 Set_Is_Statically_Allocated (DT_Ptr, 5040 Is_Library_Level_Tagged_Type (Typ)); 5041 5042 -- Generate the SCIL node for the previous object declaration 5043 -- because it has a tag initialization. 5044 5045 if Generate_SCIL then 5046 New_Node := 5047 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); 5048 Set_SCIL_Entity (New_Node, Typ); 5049 Set_SCIL_Node (Last (Result), New_Node); 5050 5051 goto Leave_SCIL; 5052 5053 -- Gnat2scil has its own implementation of dispatch tables, 5054 -- different than what is being implemented here. Generating 5055 -- further dispatch table initialization code would just 5056 -- cause gnat2scil to generate useless Scil which CodePeer 5057 -- would waste time and space analyzing, so we skip it. 5058 end if; 5059 5060 -- Generate: 5061 -- DT : Dispatch_Table_Wrapper (Nb_Prim); 5062 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); 5063 5064 else 5065 -- If the tagged type has no primitives we add a dummy slot 5066 -- whose address will be the tag of this type. 5067 5068 if Nb_Prim = 0 then 5069 DT_Constr_List := 5070 New_List (Make_Integer_Literal (Loc, 1)); 5071 else 5072 DT_Constr_List := 5073 New_List (Make_Integer_Literal (Loc, Nb_Prim)); 5074 end if; 5075 5076 Append_To (Result, 5077 Make_Object_Declaration (Loc, 5078 Defining_Identifier => DT, 5079 Aliased_Present => True, 5080 Constant_Present => False, 5081 Object_Definition => 5082 Make_Subtype_Indication (Loc, 5083 Subtype_Mark => 5084 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), 5085 Constraint => 5086 Make_Index_Or_Discriminant_Constraint (Loc, 5087 Constraints => DT_Constr_List)))); 5088 5089 Append_To (Result, 5090 Make_Object_Declaration (Loc, 5091 Defining_Identifier => DT_Ptr, 5092 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 5093 Constant_Present => True, 5094 Expression => 5095 Unchecked_Convert_To (RTE (RE_Tag), 5096 Make_Attribute_Reference (Loc, 5097 Prefix => 5098 Make_Selected_Component (Loc, 5099 Prefix => New_Occurrence_Of (DT, Loc), 5100 Selector_Name => 5101 New_Occurrence_Of 5102 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 5103 Attribute_Name => Name_Address)))); 5104 5105 Set_Is_Statically_Allocated (DT_Ptr, 5106 Is_Library_Level_Tagged_Type (Typ)); 5107 5108 -- Generate the SCIL node for the previous object declaration 5109 -- because it has a tag initialization. 5110 5111 if Generate_SCIL then 5112 New_Node := 5113 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); 5114 Set_SCIL_Entity (New_Node, Typ); 5115 Set_SCIL_Node (Last (Result), New_Node); 5116 5117 goto Leave_SCIL; 5118 5119 -- Gnat2scil has its own implementation of dispatch tables, 5120 -- different than what is being implemented here. Generating 5121 -- further dispatch table initialization code would just 5122 -- cause gnat2scil to generate useless Scil which CodePeer 5123 -- would waste time and space analyzing, so we skip it. 5124 end if; 5125 5126 Append_To (Result, 5127 Make_Object_Declaration (Loc, 5128 Defining_Identifier => 5129 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), 5130 Constant_Present => True, 5131 Object_Definition => 5132 New_Occurrence_Of (RTE (RE_Address), Loc), 5133 Expression => 5134 Make_Attribute_Reference (Loc, 5135 Prefix => 5136 Make_Selected_Component (Loc, 5137 Prefix => New_Occurrence_Of (DT, Loc), 5138 Selector_Name => 5139 New_Occurrence_Of 5140 (RTE_Record_Component (RE_Predef_Prims), Loc)), 5141 Attribute_Name => Name_Address))); 5142 end if; 5143 end if; 5144 5145 -- Generate: Expanded_Name : constant String := ""; 5146 5147 if Discard_Names then 5148 Append_To (Result, 5149 Make_Object_Declaration (Loc, 5150 Defining_Identifier => Exname, 5151 Constant_Present => True, 5152 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 5153 Expression => 5154 Make_String_Literal (Loc, ""))); 5155 5156 -- Generate: Exname : constant String := full_qualified_name (typ); 5157 -- The type itself may be an anonymous parent type, so use the first 5158 -- subtype to have a user-recognizable name. 5159 5160 else 5161 Append_To (Result, 5162 Make_Object_Declaration (Loc, 5163 Defining_Identifier => Exname, 5164 Constant_Present => True, 5165 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 5166 Expression => 5167 Make_String_Literal (Loc, 5168 Fully_Qualified_Name_String (First_Subtype (Typ))))); 5169 end if; 5170 5171 Set_Is_Statically_Allocated (Exname); 5172 Set_Is_True_Constant (Exname); 5173 5174 -- Declare the object used by Ada.Tags.Register_Tag 5175 5176 if RTE_Available (RE_Register_Tag) then 5177 Append_To (Result, 5178 Make_Object_Declaration (Loc, 5179 Defining_Identifier => HT_Link, 5180 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 5181 Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc))); 5182 end if; 5183 5184 -- Generate code to create the storage for the type specific data object 5185 -- with enough space to store the tags of the ancestors plus the tags 5186 -- of all the implemented interfaces (as described in a-tags.adb). 5187 5188 -- TSD : Type_Specific_Data (I_Depth) := 5189 -- (Idepth => I_Depth, 5190 -- Access_Level => Type_Access_Level (Typ), 5191 -- Alignment => Typ'Alignment, 5192 -- Expanded_Name => Cstring_Ptr!(Exname'Address)) 5193 -- External_Tag => Cstring_Ptr!(Exname'Address)) 5194 -- HT_Link => HT_Link'Address, 5195 -- Transportable => <<boolean-value>>, 5196 -- Is_Abstract => <<boolean-value>>, 5197 -- Needs_Finalization => <<boolean-value>>, 5198 -- [ Size_Func => Size_Prim'Access, ] 5199 -- [ Interfaces_Table => <<access-value>>, ] 5200 -- [ SSD => SSD_Table'Address ] 5201 -- Tags_Table => (0 => null, 5202 -- 1 => Parent'Tag 5203 -- ...); 5204 5205 TSD_Aggr_List := New_List; 5206 5207 -- Idepth: Count ancestors to compute the inheritance depth. For private 5208 -- extensions, always go to the full view in order to compute the real 5209 -- inheritance depth. 5210 5211 declare 5212 Current_Typ : Entity_Id; 5213 Parent_Typ : Entity_Id; 5214 5215 begin 5216 I_Depth := 0; 5217 Current_Typ := Typ; 5218 loop 5219 Parent_Typ := Etype (Current_Typ); 5220 5221 if Is_Private_Type (Parent_Typ) then 5222 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5223 end if; 5224 5225 exit when Parent_Typ = Current_Typ; 5226 5227 I_Depth := I_Depth + 1; 5228 Current_Typ := Parent_Typ; 5229 end loop; 5230 end; 5231 5232 Append_To (TSD_Aggr_List, 5233 Make_Integer_Literal (Loc, I_Depth)); 5234 5235 -- Access_Level 5236 5237 Append_To (TSD_Aggr_List, 5238 Make_Integer_Literal (Loc, Type_Access_Level (Typ))); 5239 5240 -- Alignment 5241 5242 -- For CPP types we cannot rely on the value of 'Alignment provided 5243 -- by the backend to initialize this TSD field. 5244 5245 if Convention (Typ) = Convention_CPP 5246 or else Is_CPP_Class (Root_Type (Typ)) 5247 then 5248 Append_To (TSD_Aggr_List, 5249 Make_Integer_Literal (Loc, 0)); 5250 else 5251 Append_To (TSD_Aggr_List, 5252 Make_Attribute_Reference (Loc, 5253 Prefix => New_Occurrence_Of (Typ, Loc), 5254 Attribute_Name => Name_Alignment)); 5255 end if; 5256 5257 -- Expanded_Name 5258 5259 Append_To (TSD_Aggr_List, 5260 Unchecked_Convert_To (RTE (RE_Cstring_Ptr), 5261 Make_Attribute_Reference (Loc, 5262 Prefix => New_Occurrence_Of (Exname, Loc), 5263 Attribute_Name => Name_Address))); 5264 5265 -- External_Tag of a local tagged type 5266 5267 -- <typ>A : constant String := 5268 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; 5269 5270 -- The reason we generate this strange name is that we do not want to 5271 -- enter local tagged types in the global hash table used to compute 5272 -- the Internal_Tag attribute for two reasons: 5273 5274 -- 1. It is hard to avoid a tasking race condition for entering the 5275 -- entry into the hash table. 5276 5277 -- 2. It would cause a storage leak, unless we rig up considerable 5278 -- mechanism to remove the entry from the hash table on exit. 5279 5280 -- So what we do is to generate the above external tag name, where the 5281 -- hex address is the address of the local dispatch table (i.e. exactly 5282 -- the value we want if Internal_Tag is computed from this string). 5283 5284 -- Of course this value will only be valid if the tagged type is still 5285 -- in scope, but it clearly must be erroneous to compute the internal 5286 -- tag of a tagged type that is out of scope. 5287 5288 -- We don't do this processing if an explicit external tag has been 5289 -- specified. That's an odd case for which we have already issued a 5290 -- warning, where we will not be able to compute the internal tag. 5291 5292 if not Discard_Names 5293 and then not Is_Library_Level_Entity (Typ) 5294 and then not Has_External_Tag_Rep_Clause (Typ) 5295 then 5296 declare 5297 Exname : constant Entity_Id := 5298 Make_Defining_Identifier (Loc, 5299 Chars => New_External_Name (Tname, 'A')); 5300 Full_Name : constant String_Id := 5301 Fully_Qualified_Name_String (First_Subtype (Typ)); 5302 Str1_Id : String_Id; 5303 Str2_Id : String_Id; 5304 5305 begin 5306 -- Generate: 5307 -- Str1 = "Internal tag at 16#"; 5308 5309 Start_String; 5310 Store_String_Chars ("Internal tag at 16#"); 5311 Str1_Id := End_String; 5312 5313 -- Generate: 5314 -- Str2 = "#: <type-full-name>"; 5315 5316 Start_String; 5317 Store_String_Chars ("#: "); 5318 Store_String_Chars (Full_Name); 5319 Str2_Id := End_String; 5320 5321 -- Generate: 5322 -- Exname : constant String := 5323 -- Str1 & Address_Image (Tag) & Str2; 5324 5325 if RTE_Available (RE_Address_Image) then 5326 Append_To (Result, 5327 Make_Object_Declaration (Loc, 5328 Defining_Identifier => Exname, 5329 Constant_Present => True, 5330 Object_Definition => New_Occurrence_Of 5331 (Standard_String, Loc), 5332 Expression => 5333 Make_Op_Concat (Loc, 5334 Left_Opnd => Make_String_Literal (Loc, Str1_Id), 5335 Right_Opnd => 5336 Make_Op_Concat (Loc, 5337 Left_Opnd => 5338 Make_Function_Call (Loc, 5339 Name => 5340 New_Occurrence_Of 5341 (RTE (RE_Address_Image), Loc), 5342 Parameter_Associations => New_List ( 5343 Unchecked_Convert_To (RTE (RE_Address), 5344 New_Occurrence_Of (DT_Ptr, Loc)))), 5345 Right_Opnd => 5346 Make_String_Literal (Loc, Str2_Id))))); 5347 5348 -- Generate: 5349 -- Exname : constant String := Str1 & Str2; 5350 5351 else 5352 Append_To (Result, 5353 Make_Object_Declaration (Loc, 5354 Defining_Identifier => Exname, 5355 Constant_Present => True, 5356 Object_Definition => 5357 New_Occurrence_Of (Standard_String, Loc), 5358 Expression => 5359 Make_Op_Concat (Loc, 5360 Left_Opnd => Make_String_Literal (Loc, Str1_Id), 5361 Right_Opnd => Make_String_Literal (Loc, Str2_Id)))); 5362 end if; 5363 5364 New_Node := 5365 Unchecked_Convert_To (RTE (RE_Cstring_Ptr), 5366 Make_Attribute_Reference (Loc, 5367 Prefix => New_Occurrence_Of (Exname, Loc), 5368 Attribute_Name => Name_Address)); 5369 end; 5370 5371 -- External tag of a library-level tagged type: Check for a definition 5372 -- of External_Tag. The clause is considered only if it applies to this 5373 -- specific tagged type, as opposed to one of its ancestors. 5374 -- If the type is an unconstrained type extension, we are building the 5375 -- dispatch table of its anonymous base type, so the external tag, if 5376 -- any was specified, must be retrieved from the first subtype. Go to 5377 -- the full view in case the clause is in the private part. 5378 5379 else 5380 declare 5381 Def : constant Node_Id := Get_Attribute_Definition_Clause 5382 (Underlying_Type (First_Subtype (Typ)), 5383 Attribute_External_Tag); 5384 5385 Old_Val : String_Id; 5386 New_Val : String_Id; 5387 E : Entity_Id; 5388 5389 begin 5390 if not Present (Def) 5391 or else Entity (Name (Def)) /= First_Subtype (Typ) 5392 then 5393 New_Node := 5394 Unchecked_Convert_To (RTE (RE_Cstring_Ptr), 5395 Make_Attribute_Reference (Loc, 5396 Prefix => New_Occurrence_Of (Exname, Loc), 5397 Attribute_Name => Name_Address)); 5398 else 5399 Old_Val := Strval (Expr_Value_S (Expression (Def))); 5400 5401 -- For the rep clause "for <typ>'external_tag use y" generate: 5402 5403 -- <typ>A : constant string := y; 5404 -- 5405 -- <typ>A'Address is used to set the External_Tag component 5406 -- of the TSD 5407 5408 -- Create a new nul terminated string if it is not already 5409 5410 if String_Length (Old_Val) > 0 5411 and then 5412 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 5413 then 5414 New_Val := Old_Val; 5415 else 5416 Start_String (Old_Val); 5417 Store_String_Char (Get_Char_Code (ASCII.NUL)); 5418 New_Val := End_String; 5419 end if; 5420 5421 E := Make_Defining_Identifier (Loc, 5422 New_External_Name (Chars (Typ), 'A')); 5423 5424 Append_To (Result, 5425 Make_Object_Declaration (Loc, 5426 Defining_Identifier => E, 5427 Constant_Present => True, 5428 Object_Definition => 5429 New_Occurrence_Of (Standard_String, Loc), 5430 Expression => 5431 Make_String_Literal (Loc, New_Val))); 5432 5433 New_Node := 5434 Unchecked_Convert_To (RTE (RE_Cstring_Ptr), 5435 Make_Attribute_Reference (Loc, 5436 Prefix => New_Occurrence_Of (E, Loc), 5437 Attribute_Name => Name_Address)); 5438 end if; 5439 end; 5440 end if; 5441 5442 Append_To (TSD_Aggr_List, New_Node); 5443 5444 -- HT_Link 5445 5446 if RTE_Available (RE_Register_Tag) then 5447 Append_To (TSD_Aggr_List, 5448 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 5449 Make_Attribute_Reference (Loc, 5450 Prefix => New_Occurrence_Of (HT_Link, Loc), 5451 Attribute_Name => Name_Address))); 5452 5453 elsif RTE_Record_Component_Available (RE_HT_Link) then 5454 Append_To (TSD_Aggr_List, 5455 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 5456 New_Occurrence_Of (RTE (RE_Null_Address), Loc))); 5457 end if; 5458 5459 -- Transportable: Set for types that can be used in remote calls 5460 -- with respect to E.4(18) legality rules. 5461 5462 declare 5463 Transportable : Entity_Id; 5464 5465 begin 5466 Transportable := 5467 Boolean_Literals 5468 (Is_Pure (Typ) 5469 or else Is_Shared_Passive (Typ) 5470 or else 5471 ((Is_Remote_Types (Typ) 5472 or else Is_Remote_Call_Interface (Typ)) 5473 and then Original_View_In_Visible_Part (Typ)) 5474 or else not Comes_From_Source (Typ)); 5475 5476 Append_To (TSD_Aggr_List, 5477 New_Occurrence_Of (Transportable, Loc)); 5478 end; 5479 5480 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not 5481 -- available in the HIE runtime. 5482 5483 if RTE_Record_Component_Available (RE_Is_Abstract) then 5484 declare 5485 Is_Abstract : Entity_Id; 5486 begin 5487 Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ)); 5488 Append_To (TSD_Aggr_List, 5489 New_Occurrence_Of (Is_Abstract, Loc)); 5490 end; 5491 end if; 5492 5493 -- Needs_Finalization: Set if the type is controlled or has controlled 5494 -- components. 5495 5496 declare 5497 Needs_Fin : Entity_Id; 5498 begin 5499 Needs_Fin := Boolean_Literals (Needs_Finalization (Typ)); 5500 Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc)); 5501 end; 5502 5503 -- Size_Func 5504 5505 if RTE_Record_Component_Available (RE_Size_Func) then 5506 5507 -- Initialize this field to Null_Address if we are not building 5508 -- static dispatch tables static or if the size function is not 5509 -- available. In the former case we cannot initialize this field 5510 -- until the function is frozen and registered in the dispatch 5511 -- table (see Register_Primitive). 5512 5513 if not Building_Static_DT (Typ) or else not Has_DT (Typ) then 5514 Append_To (TSD_Aggr_List, 5515 Unchecked_Convert_To (RTE (RE_Size_Ptr), 5516 New_Occurrence_Of (RTE (RE_Null_Address), Loc))); 5517 5518 else 5519 declare 5520 Prim_Elmt : Elmt_Id; 5521 Prim : Entity_Id; 5522 Size_Comp : Node_Id := Empty; 5523 5524 begin 5525 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 5526 while Present (Prim_Elmt) loop 5527 Prim := Node (Prim_Elmt); 5528 5529 if Chars (Prim) = Name_uSize then 5530 Prim := Ultimate_Alias (Prim); 5531 5532 if Is_Abstract_Subprogram (Prim) then 5533 Size_Comp := 5534 Unchecked_Convert_To (RTE (RE_Size_Ptr), 5535 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 5536 else 5537 Size_Comp := 5538 Unchecked_Convert_To (RTE (RE_Size_Ptr), 5539 Make_Attribute_Reference (Loc, 5540 Prefix => New_Occurrence_Of (Prim, Loc), 5541 Attribute_Name => Name_Unrestricted_Access)); 5542 end if; 5543 5544 exit; 5545 end if; 5546 5547 Next_Elmt (Prim_Elmt); 5548 end loop; 5549 5550 pragma Assert (Present (Size_Comp)); 5551 Append_To (TSD_Aggr_List, Size_Comp); 5552 end; 5553 end if; 5554 end if; 5555 5556 -- Interfaces_Table (required for AI-405) 5557 5558 if RTE_Record_Component_Available (RE_Interfaces_Table) then 5559 5560 -- Count the number of interface types implemented by Typ 5561 5562 Collect_Interfaces (Typ, Typ_Ifaces); 5563 5564 AI := First_Elmt (Typ_Ifaces); 5565 while Present (AI) loop 5566 Num_Ifaces := Num_Ifaces + 1; 5567 Next_Elmt (AI); 5568 end loop; 5569 5570 if Num_Ifaces = 0 then 5571 Iface_Table_Node := Make_Null (Loc); 5572 5573 -- Generate the Interface_Table object 5574 5575 else 5576 declare 5577 TSD_Ifaces_List : constant List_Id := New_List; 5578 Elmt : Elmt_Id; 5579 Offset_To_Top : Node_Id; 5580 Sec_DT_Tag : Node_Id; 5581 5582 Dummy_Object_Ifaces_List : Elist_Id := No_Elist; 5583 Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist; 5584 Dummy_Object_Ifaces_Tag_List : Elist_Id := No_Elist; 5585 -- Interfaces information of the dummy object 5586 5587 begin 5588 -- Collect interfaces information if we need to compute the 5589 -- offset to the top using the dummy object. 5590 5591 if Present (Dummy_Object) then 5592 Collect_Interfaces_Info (Typ, 5593 Ifaces_List => Dummy_Object_Ifaces_List, 5594 Components_List => Dummy_Object_Ifaces_Comp_List, 5595 Tags_List => Dummy_Object_Ifaces_Tag_List); 5596 end if; 5597 5598 AI := First_Elmt (Typ_Ifaces); 5599 while Present (AI) loop 5600 if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then 5601 Sec_DT_Tag := New_Occurrence_Of (DT_Ptr, Loc); 5602 5603 else 5604 Elmt := 5605 Next_Elmt 5606 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); 5607 pragma Assert (Has_Thunks (Node (Elmt))); 5608 5609 while Is_Tag (Node (Elmt)) 5610 and then not 5611 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)), 5612 Use_Full_View => True) 5613 loop 5614 pragma Assert (Has_Thunks (Node (Elmt))); 5615 Next_Elmt (Elmt); 5616 pragma Assert (Has_Thunks (Node (Elmt))); 5617 Next_Elmt (Elmt); 5618 pragma Assert (not Has_Thunks (Node (Elmt))); 5619 Next_Elmt (Elmt); 5620 pragma Assert (not Has_Thunks (Node (Elmt))); 5621 Next_Elmt (Elmt); 5622 end loop; 5623 5624 pragma Assert (Ekind (Node (Elmt)) = E_Constant 5625 and then not 5626 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); 5627 5628 Sec_DT_Tag := 5629 New_Occurrence_Of 5630 (Node (Next_Elmt (Next_Elmt (Elmt))), Loc); 5631 end if; 5632 5633 -- Use the dummy object to compute Offset_To_Top of 5634 -- components located at fixed position. 5635 5636 if Present (Dummy_Object) then 5637 declare 5638 Iface : constant Node_Id := Node (AI); 5639 Iface_Comp : Node_Id := Empty; 5640 Iface_Comp_Elmt : Elmt_Id; 5641 Iface_Elmt : Elmt_Id; 5642 5643 begin 5644 Iface_Elmt := 5645 First_Elmt (Dummy_Object_Ifaces_List); 5646 Iface_Comp_Elmt := 5647 First_Elmt (Dummy_Object_Ifaces_Comp_List); 5648 5649 while Present (Iface_Elmt) loop 5650 if Node (Iface_Elmt) = Iface then 5651 Iface_Comp := Node (Iface_Comp_Elmt); 5652 exit; 5653 end if; 5654 5655 Next_Elmt (Iface_Elmt); 5656 Next_Elmt (Iface_Comp_Elmt); 5657 end loop; 5658 5659 pragma Assert (Present (Iface_Comp)); 5660 5661 if not 5662 Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) 5663 then 5664 Offset_To_Top := 5665 Make_Op_Minus (Loc, 5666 Make_Attribute_Reference (Loc, 5667 Prefix => 5668 Make_Selected_Component (Loc, 5669 Prefix => 5670 New_Occurrence_Of (Dummy_Object, Loc), 5671 Selector_Name => 5672 New_Occurrence_Of (Iface_Comp, Loc)), 5673 Attribute_Name => Name_Position)); 5674 else 5675 Offset_To_Top := Make_Integer_Literal (Loc, 0); 5676 end if; 5677 end; 5678 else 5679 Offset_To_Top := Make_Integer_Literal (Loc, 0); 5680 end if; 5681 5682 Append_To (TSD_Ifaces_List, 5683 Make_Aggregate (Loc, 5684 Expressions => New_List ( 5685 5686 -- Iface_Tag 5687 5688 Unchecked_Convert_To (RTE (RE_Tag), 5689 New_Occurrence_Of 5690 (Node (First_Elmt (Access_Disp_Table (Node (AI)))), 5691 Loc)), 5692 5693 -- Static_Offset_To_Top 5694 5695 New_Occurrence_Of (Standard_True, Loc), 5696 5697 -- Offset_To_Top_Value 5698 5699 Offset_To_Top, 5700 5701 -- Offset_To_Top_Func 5702 5703 Make_Null (Loc), 5704 5705 -- Secondary_DT 5706 5707 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)))); 5708 5709 Next_Elmt (AI); 5710 end loop; 5711 5712 Name_ITable := New_External_Name (Tname, 'I'); 5713 ITable := Make_Defining_Identifier (Loc, Name_ITable); 5714 Set_Is_Statically_Allocated (ITable, 5715 Is_Library_Level_Tagged_Type (Typ)); 5716 5717 -- The table of interfaces is constant if we are building a 5718 -- static dispatch table; otherwise is not constant because 5719 -- its slots are filled at run time by the IP routine. 5720 5721 Append_To (Result, 5722 Make_Object_Declaration (Loc, 5723 Defining_Identifier => ITable, 5724 Aliased_Present => True, 5725 Constant_Present => Building_Static_Secondary_DT (Typ), 5726 Object_Definition => 5727 Make_Subtype_Indication (Loc, 5728 Subtype_Mark => 5729 New_Occurrence_Of (RTE (RE_Interface_Data), Loc), 5730 Constraint => 5731 Make_Index_Or_Discriminant_Constraint (Loc, 5732 Constraints => New_List ( 5733 Make_Integer_Literal (Loc, Num_Ifaces)))), 5734 5735 Expression => 5736 Make_Aggregate (Loc, 5737 Expressions => New_List ( 5738 Make_Integer_Literal (Loc, Num_Ifaces), 5739 Make_Aggregate (Loc, TSD_Ifaces_List))))); 5740 5741 Iface_Table_Node := 5742 Make_Attribute_Reference (Loc, 5743 Prefix => New_Occurrence_Of (ITable, Loc), 5744 Attribute_Name => Name_Unchecked_Access); 5745 end; 5746 end if; 5747 5748 Append_To (TSD_Aggr_List, Iface_Table_Node); 5749 end if; 5750 5751 -- Generate the Select Specific Data table for synchronized types that 5752 -- implement synchronized interfaces. The size of the table is 5753 -- constrained by the number of non-predefined primitive operations. 5754 5755 if RTE_Record_Component_Available (RE_SSD) then 5756 if Ada_Version >= Ada_2005 5757 and then Has_DT (Typ) 5758 and then Is_Concurrent_Record_Type (Typ) 5759 and then Has_Interfaces (Typ) 5760 and then Nb_Prim > 0 5761 and then not Is_Abstract_Type (Typ) 5762 and then not Is_Controlled (Typ) 5763 and then not Restriction_Active (No_Dispatching_Calls) 5764 and then not Restriction_Active (No_Select_Statements) 5765 then 5766 Append_To (Result, 5767 Make_Object_Declaration (Loc, 5768 Defining_Identifier => SSD, 5769 Aliased_Present => True, 5770 Object_Definition => 5771 Make_Subtype_Indication (Loc, 5772 Subtype_Mark => New_Occurrence_Of ( 5773 RTE (RE_Select_Specific_Data), Loc), 5774 Constraint => 5775 Make_Index_Or_Discriminant_Constraint (Loc, 5776 Constraints => New_List ( 5777 Make_Integer_Literal (Loc, Nb_Prim)))))); 5778 5779 Append_To (Result, 5780 Make_Attribute_Definition_Clause (Loc, 5781 Name => New_Occurrence_Of (SSD, Loc), 5782 Chars => Name_Alignment, 5783 Expression => 5784 Make_Attribute_Reference (Loc, 5785 Prefix => 5786 New_Occurrence_Of (RTE (RE_Integer_Address), Loc), 5787 Attribute_Name => Name_Alignment))); 5788 5789 -- This table is initialized by Make_Select_Specific_Data_Table, 5790 -- which calls Set_Entry_Index and Set_Prim_Op_Kind. 5791 5792 Append_To (TSD_Aggr_List, 5793 Make_Attribute_Reference (Loc, 5794 Prefix => New_Occurrence_Of (SSD, Loc), 5795 Attribute_Name => Name_Unchecked_Access)); 5796 else 5797 Append_To (TSD_Aggr_List, Make_Null (Loc)); 5798 end if; 5799 end if; 5800 5801 -- Initialize the table of ancestor tags. In case of interface types 5802 -- this table is not needed. 5803 5804 TSD_Tags_List := New_List; 5805 5806 -- If we are not statically allocating the dispatch table then we must 5807 -- fill position 0 with null because we still have not generated the 5808 -- tag of Typ. 5809 5810 if not Building_Static_DT (Typ) 5811 or else Is_Interface (Typ) 5812 then 5813 Append_To (TSD_Tags_List, 5814 Unchecked_Convert_To (RTE (RE_Tag), 5815 New_Occurrence_Of (RTE (RE_Null_Address), Loc))); 5816 5817 -- Otherwise we can safely reference the tag 5818 5819 else 5820 Append_To (TSD_Tags_List, 5821 New_Occurrence_Of (DT_Ptr, Loc)); 5822 end if; 5823 5824 -- Fill the rest of the table with the tags of the ancestors 5825 5826 declare 5827 Current_Typ : Entity_Id; 5828 Parent_Typ : Entity_Id; 5829 Pos : Nat; 5830 5831 begin 5832 Pos := 1; 5833 Current_Typ := Typ; 5834 5835 loop 5836 Parent_Typ := Etype (Current_Typ); 5837 5838 if Is_Private_Type (Parent_Typ) then 5839 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5840 end if; 5841 5842 exit when Parent_Typ = Current_Typ; 5843 5844 if Is_CPP_Class (Parent_Typ) then 5845 5846 -- The tags defined in the C++ side will be inherited when 5847 -- the object is constructed (Exp_Ch3.Build_Init_Procedure) 5848 5849 Append_To (TSD_Tags_List, 5850 Unchecked_Convert_To (RTE (RE_Tag), 5851 New_Occurrence_Of (RTE (RE_Null_Address), Loc))); 5852 else 5853 Append_To (TSD_Tags_List, 5854 New_Occurrence_Of 5855 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), 5856 Loc)); 5857 end if; 5858 5859 Pos := Pos + 1; 5860 Current_Typ := Parent_Typ; 5861 end loop; 5862 5863 pragma Assert (Pos = I_Depth + 1); 5864 end; 5865 5866 Append_To (TSD_Aggr_List, 5867 Make_Aggregate (Loc, 5868 Expressions => TSD_Tags_List)); 5869 5870 -- Build the TSD object 5871 5872 Append_To (Result, 5873 Make_Object_Declaration (Loc, 5874 Defining_Identifier => TSD, 5875 Aliased_Present => True, 5876 Constant_Present => Building_Static_DT (Typ), 5877 Object_Definition => 5878 Make_Subtype_Indication (Loc, 5879 Subtype_Mark => New_Occurrence_Of ( 5880 RTE (RE_Type_Specific_Data), Loc), 5881 Constraint => 5882 Make_Index_Or_Discriminant_Constraint (Loc, 5883 Constraints => New_List ( 5884 Make_Integer_Literal (Loc, I_Depth)))), 5885 5886 Expression => Make_Aggregate (Loc, 5887 Expressions => TSD_Aggr_List))); 5888 5889 Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); 5890 5891 -- Initialize or declare the dispatch table object 5892 5893 if not Has_DT (Typ) then 5894 DT_Constr_List := New_List; 5895 DT_Aggr_List := New_List; 5896 5897 -- Typeinfo 5898 5899 New_Node := 5900 Make_Attribute_Reference (Loc, 5901 Prefix => New_Occurrence_Of (TSD, Loc), 5902 Attribute_Name => Name_Address); 5903 5904 Append_To (DT_Constr_List, New_Node); 5905 Append_To (DT_Aggr_List, New_Copy (New_Node)); 5906 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); 5907 5908 -- In case of locally defined tagged types we have already declared 5909 -- and uninitialized object for the dispatch table, which is now 5910 -- initialized by means of the following assignment: 5911 5912 -- DT := (TSD'Address, 0); 5913 5914 if not Building_Static_DT (Typ) then 5915 Append_To (Result, 5916 Make_Assignment_Statement (Loc, 5917 Name => New_Occurrence_Of (DT, Loc), 5918 Expression => Make_Aggregate (Loc, DT_Aggr_List))); 5919 5920 -- In case of library level tagged types we declare and export now 5921 -- the constant object containing the dummy dispatch table. There 5922 -- is no need to declare the tag here because it has been previously 5923 -- declared by Make_Tags 5924 5925 -- DT : aliased constant No_Dispatch_Table := 5926 -- (NDT_TSD => TSD'Address; 5927 -- NDT_Prims_Ptr => 0); 5928 5929 else 5930 Append_To (Result, 5931 Make_Object_Declaration (Loc, 5932 Defining_Identifier => DT, 5933 Aliased_Present => True, 5934 Constant_Present => True, 5935 Object_Definition => 5936 New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc), 5937 Expression => Make_Aggregate (Loc, DT_Aggr_List))); 5938 5939 Export_DT (Typ, DT); 5940 end if; 5941 5942 -- Common case: Typ has a dispatch table 5943 5944 -- Generate: 5945 5946 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := 5947 -- (predef-prim-op-1'address, 5948 -- predef-prim-op-2'address, 5949 -- ... 5950 -- predef-prim-op-n'address); 5951 5952 -- DT : Dispatch_Table (Nb_Prims) := 5953 -- (Signature => <sig-value>, 5954 -- Tag_Kind => <tag_kind-value>, 5955 -- Predef_Prims => Predef_Prims'First'Address, 5956 -- Offset_To_Top => 0, 5957 -- TSD => TSD'Address; 5958 -- Prims_Ptr => (prim-op-1'address, 5959 -- prim-op-2'address, 5960 -- ... 5961 -- prim-op-n'address)); 5962 -- for DT'Alignment use Address'Alignment 5963 5964 else 5965 declare 5966 Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); 5967 Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; 5968 Decl : Node_Id; 5969 E : Entity_Id; 5970 5971 begin 5972 Prim_Ops_Aggr_List := New_List; 5973 Prim_Table := (others => Empty); 5974 5975 if Building_Static_DT (Typ) then 5976 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 5977 while Present (Prim_Elmt) loop 5978 Prim := Node (Prim_Elmt); 5979 5980 if Is_Predefined_Dispatching_Operation (Prim) 5981 and then not Is_Abstract_Subprogram (Prim) 5982 and then not Is_Eliminated (Prim) 5983 and then not Generate_SCIL 5984 and then not Present (Prim_Table 5985 (UI_To_Int (DT_Position (Prim)))) 5986 then 5987 E := Ultimate_Alias (Prim); 5988 pragma Assert (not Is_Abstract_Subprogram (E)); 5989 Prim_Table (UI_To_Int (DT_Position (Prim))) := E; 5990 end if; 5991 5992 Next_Elmt (Prim_Elmt); 5993 end loop; 5994 end if; 5995 5996 for J in Prim_Table'Range loop 5997 if Present (Prim_Table (J)) then 5998 New_Node := 5999 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 6000 Make_Attribute_Reference (Loc, 6001 Prefix => 6002 New_Occurrence_Of (Prim_Table (J), Loc), 6003 Attribute_Name => Name_Unrestricted_Access)); 6004 else 6005 New_Node := Make_Null (Loc); 6006 end if; 6007 6008 Append_To (Prim_Ops_Aggr_List, New_Node); 6009 end loop; 6010 6011 New_Node := 6012 Make_Aggregate (Loc, 6013 Expressions => Prim_Ops_Aggr_List); 6014 6015 Decl := 6016 Make_Subtype_Declaration (Loc, 6017 Defining_Identifier => Make_Temporary (Loc, 'S'), 6018 Subtype_Indication => 6019 New_Occurrence_Of (RTE (RE_Address_Array), Loc)); 6020 6021 Append_To (Result, Decl); 6022 6023 Append_To (Result, 6024 Make_Object_Declaration (Loc, 6025 Defining_Identifier => Predef_Prims, 6026 Aliased_Present => True, 6027 Constant_Present => Building_Static_DT (Typ), 6028 Object_Definition => 6029 New_Occurrence_Of (Defining_Identifier (Decl), Loc), 6030 Expression => New_Node)); 6031 6032 -- Remember aggregates initializing dispatch tables 6033 6034 Append_Elmt (New_Node, DT_Aggr); 6035 end; 6036 6037 -- Stage 1: Initialize the discriminant and the record components 6038 6039 DT_Constr_List := New_List; 6040 DT_Aggr_List := New_List; 6041 6042 -- Num_Prims. If the tagged type has no primitives we add a dummy 6043 -- slot whose address will be the tag of this type. 6044 6045 if Nb_Prim = 0 then 6046 New_Node := Make_Integer_Literal (Loc, 1); 6047 else 6048 New_Node := Make_Integer_Literal (Loc, Nb_Prim); 6049 end if; 6050 6051 Append_To (DT_Constr_List, New_Node); 6052 Append_To (DT_Aggr_List, New_Copy (New_Node)); 6053 6054 -- Signature 6055 6056 if RTE_Record_Component_Available (RE_Signature) then 6057 Append_To (DT_Aggr_List, 6058 New_Occurrence_Of (RTE (RE_Primary_DT), Loc)); 6059 end if; 6060 6061 -- Tag_Kind 6062 6063 if RTE_Record_Component_Available (RE_Tag_Kind) then 6064 Append_To (DT_Aggr_List, Tagged_Kind (Typ)); 6065 end if; 6066 6067 -- Predef_Prims 6068 6069 Append_To (DT_Aggr_List, 6070 Make_Attribute_Reference (Loc, 6071 Prefix => New_Occurrence_Of (Predef_Prims, Loc), 6072 Attribute_Name => Name_Address)); 6073 6074 -- Offset_To_Top 6075 6076 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); 6077 6078 -- Typeinfo 6079 6080 Append_To (DT_Aggr_List, 6081 Make_Attribute_Reference (Loc, 6082 Prefix => New_Occurrence_Of (TSD, Loc), 6083 Attribute_Name => Name_Address)); 6084 6085 -- Stage 2: Initialize the table of user-defined primitive operations 6086 6087 Prim_Ops_Aggr_List := New_List; 6088 6089 if Nb_Prim = 0 then 6090 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); 6091 6092 elsif not Building_Static_DT (Typ) then 6093 for J in 1 .. Nb_Prim loop 6094 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); 6095 end loop; 6096 6097 else 6098 declare 6099 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); 6100 E : Entity_Id; 6101 Prim : Entity_Id; 6102 Prim_Elmt : Elmt_Id; 6103 Prim_Pos : Nat; 6104 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; 6105 6106 begin 6107 Prim_Table := (others => Empty); 6108 6109 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 6110 while Present (Prim_Elmt) loop 6111 Prim := Node (Prim_Elmt); 6112 6113 -- Retrieve the ultimate alias of the primitive for proper 6114 -- handling of renamings and eliminated primitives. 6115 6116 E := Ultimate_Alias (Prim); 6117 6118 -- If the alias is not a primitive operation then Prim does 6119 -- not rename another primitive, but rather an operation 6120 -- declared elsewhere (e.g. in another scope) and therefore 6121 -- Prim is a new primitive. 6122 6123 if No (Find_Dispatching_Type (E)) then 6124 E := Prim; 6125 end if; 6126 6127 Prim_Pos := UI_To_Int (DT_Position (E)); 6128 6129 -- Skip predefined primitives because they are located in a 6130 -- separate dispatch table. 6131 6132 if not Is_Predefined_Dispatching_Operation (Prim) 6133 and then not Is_Predefined_Dispatching_Operation (E) 6134 6135 -- Skip entities with attribute Interface_Alias because 6136 -- those are only required to build secondary dispatch 6137 -- tables. 6138 6139 and then not Present (Interface_Alias (Prim)) 6140 6141 -- Skip abstract and eliminated primitives 6142 6143 and then not Is_Abstract_Subprogram (E) 6144 and then not Is_Eliminated (E) 6145 6146 -- For derivations of CPP types skip primitives located in 6147 -- the C++ part of the dispatch table because their slots 6148 -- are initialized by the IC routine. 6149 6150 and then (not Is_CPP_Class (Root_Type (Typ)) 6151 or else Prim_Pos > CPP_Nb_Prims) 6152 6153 -- Skip ignored Ghost subprograms as those will be removed 6154 -- from the executable. 6155 6156 and then not Is_Ignored_Ghost_Entity (E) 6157 then 6158 pragma Assert 6159 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); 6160 6161 Prim_Table (UI_To_Int (DT_Position (Prim))) := E; 6162 end if; 6163 6164 Next_Elmt (Prim_Elmt); 6165 end loop; 6166 6167 for J in Prim_Table'Range loop 6168 if Present (Prim_Table (J)) then 6169 New_Node := 6170 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 6171 Make_Attribute_Reference (Loc, 6172 Prefix => 6173 New_Occurrence_Of (Prim_Table (J), Loc), 6174 Attribute_Name => Name_Unrestricted_Access)); 6175 else 6176 New_Node := Make_Null (Loc); 6177 end if; 6178 6179 Append_To (Prim_Ops_Aggr_List, New_Node); 6180 end loop; 6181 end; 6182 end if; 6183 6184 New_Node := 6185 Make_Aggregate (Loc, 6186 Expressions => Prim_Ops_Aggr_List); 6187 6188 Append_To (DT_Aggr_List, New_Node); 6189 6190 -- Remember aggregates initializing dispatch tables 6191 6192 Append_Elmt (New_Node, DT_Aggr); 6193 6194 -- In case of locally defined tagged types we have already declared 6195 -- and uninitialized object for the dispatch table, which is now 6196 -- initialized by means of an assignment. 6197 6198 if not Building_Static_DT (Typ) then 6199 Append_To (Result, 6200 Make_Assignment_Statement (Loc, 6201 Name => New_Occurrence_Of (DT, Loc), 6202 Expression => Make_Aggregate (Loc, DT_Aggr_List))); 6203 6204 -- In case of library level tagged types we declare now and export 6205 -- the constant object containing the dispatch table. 6206 6207 else 6208 Append_To (Result, 6209 Make_Object_Declaration (Loc, 6210 Defining_Identifier => DT, 6211 Aliased_Present => True, 6212 Constant_Present => True, 6213 Object_Definition => 6214 Make_Subtype_Indication (Loc, 6215 Subtype_Mark => New_Occurrence_Of 6216 (RTE (RE_Dispatch_Table_Wrapper), Loc), 6217 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, 6218 Constraints => DT_Constr_List)), 6219 Expression => Make_Aggregate (Loc, DT_Aggr_List))); 6220 6221 Export_DT (Typ, DT); 6222 end if; 6223 end if; 6224 6225 -- Initialize the table of ancestor tags if not building static 6226 -- dispatch table 6227 6228 if not Building_Static_DT (Typ) 6229 and then not Is_Interface (Typ) 6230 and then not Is_CPP_Class (Typ) 6231 then 6232 Append_To (Result, 6233 Make_Assignment_Statement (Loc, 6234 Name => 6235 Make_Indexed_Component (Loc, 6236 Prefix => 6237 Make_Selected_Component (Loc, 6238 Prefix => New_Occurrence_Of (TSD, Loc), 6239 Selector_Name => 6240 New_Occurrence_Of 6241 (RTE_Record_Component (RE_Tags_Table), Loc)), 6242 Expressions => 6243 New_List (Make_Integer_Literal (Loc, 0))), 6244 6245 Expression => 6246 New_Occurrence_Of 6247 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); 6248 end if; 6249 6250 -- Inherit the dispatch tables of the parent. There is no need to 6251 -- inherit anything from the parent when building static dispatch tables 6252 -- because the whole dispatch table (including inherited primitives) has 6253 -- been already built. 6254 6255 if Building_Static_DT (Typ) then 6256 null; 6257 6258 -- If the ancestor is a CPP_Class type we inherit the dispatch tables 6259 -- in the init proc, and we don't need to fill them in here. 6260 6261 elsif Is_CPP_Class (Parent_Typ) then 6262 null; 6263 6264 -- Otherwise we fill in the dispatch tables here 6265 6266 else 6267 if Typ /= Parent_Typ 6268 and then not Is_Interface (Typ) 6269 and then not Restriction_Active (No_Dispatching_Calls) 6270 then 6271 -- Inherit the dispatch table 6272 6273 if not Is_Interface (Typ) 6274 and then not Is_Interface (Parent_Typ) 6275 and then not Is_CPP_Class (Parent_Typ) 6276 then 6277 declare 6278 Nb_Prims : constant Int := 6279 UI_To_Int (DT_Entry_Count 6280 (First_Tag_Component (Parent_Typ))); 6281 6282 begin 6283 Append_To (Elab_Code, 6284 Build_Inherit_Predefined_Prims (Loc, 6285 Old_Tag_Node => 6286 New_Occurrence_Of 6287 (Node 6288 (Next_Elmt 6289 (First_Elmt 6290 (Access_Disp_Table (Parent_Typ)))), Loc), 6291 New_Tag_Node => 6292 New_Occurrence_Of 6293 (Node 6294 (Next_Elmt 6295 (First_Elmt 6296 (Access_Disp_Table (Typ)))), Loc), 6297 Num_Predef_Prims => 6298 Number_Of_Predefined_Prims (Parent_Typ))); 6299 6300 if Nb_Prims /= 0 then 6301 Append_To (Elab_Code, 6302 Build_Inherit_Prims (Loc, 6303 Typ => Typ, 6304 Old_Tag_Node => 6305 New_Occurrence_Of 6306 (Node 6307 (First_Elmt 6308 (Access_Disp_Table (Parent_Typ))), Loc), 6309 New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), 6310 Num_Prims => Nb_Prims)); 6311 end if; 6312 end; 6313 end if; 6314 6315 -- Inherit the secondary dispatch tables of the ancestor 6316 6317 if not Is_CPP_Class (Parent_Typ) then 6318 declare 6319 Sec_DT_Ancestor : Elmt_Id := 6320 Next_Elmt 6321 (Next_Elmt 6322 (First_Elmt 6323 (Access_Disp_Table 6324 (Parent_Typ)))); 6325 Sec_DT_Typ : Elmt_Id := 6326 Next_Elmt 6327 (Next_Elmt 6328 (First_Elmt 6329 (Access_Disp_Table (Typ)))); 6330 6331 procedure Copy_Secondary_DTs (Typ : Entity_Id); 6332 -- Local procedure required to climb through the ancestors 6333 -- and copy the contents of all their secondary dispatch 6334 -- tables. 6335 6336 ------------------------ 6337 -- Copy_Secondary_DTs -- 6338 ------------------------ 6339 6340 procedure Copy_Secondary_DTs (Typ : Entity_Id) is 6341 E : Entity_Id; 6342 Iface : Elmt_Id; 6343 6344 begin 6345 -- Climb to the ancestor (if any) handling private types 6346 6347 if Present (Full_View (Etype (Typ))) then 6348 if Full_View (Etype (Typ)) /= Typ then 6349 Copy_Secondary_DTs (Full_View (Etype (Typ))); 6350 end if; 6351 6352 elsif Etype (Typ) /= Typ then 6353 Copy_Secondary_DTs (Etype (Typ)); 6354 end if; 6355 6356 if Present (Interfaces (Typ)) 6357 and then not Is_Empty_Elmt_List (Interfaces (Typ)) 6358 then 6359 Iface := First_Elmt (Interfaces (Typ)); 6360 E := First_Entity (Typ); 6361 while Present (E) 6362 and then Present (Node (Sec_DT_Ancestor)) 6363 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant 6364 loop 6365 if Is_Tag (E) and then Chars (E) /= Name_uTag then 6366 declare 6367 Num_Prims : constant Int := 6368 UI_To_Int (DT_Entry_Count (E)); 6369 6370 begin 6371 if not Is_Interface (Etype (Typ)) then 6372 6373 -- Inherit first secondary dispatch table 6374 6375 Append_To (Elab_Code, 6376 Build_Inherit_Predefined_Prims (Loc, 6377 Old_Tag_Node => 6378 Unchecked_Convert_To (RTE (RE_Tag), 6379 New_Occurrence_Of 6380 (Node 6381 (Next_Elmt (Sec_DT_Ancestor)), 6382 Loc)), 6383 New_Tag_Node => 6384 Unchecked_Convert_To (RTE (RE_Tag), 6385 New_Occurrence_Of 6386 (Node (Next_Elmt (Sec_DT_Typ)), 6387 Loc)), 6388 Num_Predef_Prims => 6389 Number_Of_Predefined_Prims 6390 (Parent_Typ))); 6391 6392 if Num_Prims /= 0 then 6393 Append_To (Elab_Code, 6394 Build_Inherit_Prims (Loc, 6395 Typ => Node (Iface), 6396 Old_Tag_Node => 6397 Unchecked_Convert_To 6398 (RTE (RE_Tag), 6399 New_Occurrence_Of 6400 (Node (Sec_DT_Ancestor), 6401 Loc)), 6402 New_Tag_Node => 6403 Unchecked_Convert_To 6404 (RTE (RE_Tag), 6405 New_Occurrence_Of 6406 (Node (Sec_DT_Typ), Loc)), 6407 Num_Prims => Num_Prims)); 6408 end if; 6409 end if; 6410 6411 Next_Elmt (Sec_DT_Ancestor); 6412 Next_Elmt (Sec_DT_Typ); 6413 6414 -- Skip the secondary dispatch table of 6415 -- predefined primitives 6416 6417 Next_Elmt (Sec_DT_Ancestor); 6418 Next_Elmt (Sec_DT_Typ); 6419 6420 if not Is_Interface (Etype (Typ)) then 6421 6422 -- Inherit second secondary dispatch table 6423 6424 Append_To (Elab_Code, 6425 Build_Inherit_Predefined_Prims (Loc, 6426 Old_Tag_Node => 6427 Unchecked_Convert_To (RTE (RE_Tag), 6428 New_Occurrence_Of 6429 (Node 6430 (Next_Elmt (Sec_DT_Ancestor)), 6431 Loc)), 6432 New_Tag_Node => 6433 Unchecked_Convert_To (RTE (RE_Tag), 6434 New_Occurrence_Of 6435 (Node (Next_Elmt (Sec_DT_Typ)), 6436 Loc)), 6437 Num_Predef_Prims => 6438 Number_Of_Predefined_Prims 6439 (Parent_Typ))); 6440 6441 if Num_Prims /= 0 then 6442 Append_To (Elab_Code, 6443 Build_Inherit_Prims (Loc, 6444 Typ => Node (Iface), 6445 Old_Tag_Node => 6446 Unchecked_Convert_To 6447 (RTE (RE_Tag), 6448 New_Occurrence_Of 6449 (Node (Sec_DT_Ancestor), 6450 Loc)), 6451 New_Tag_Node => 6452 Unchecked_Convert_To 6453 (RTE (RE_Tag), 6454 New_Occurrence_Of 6455 (Node (Sec_DT_Typ), Loc)), 6456 Num_Prims => Num_Prims)); 6457 end if; 6458 end if; 6459 end; 6460 6461 Next_Elmt (Sec_DT_Ancestor); 6462 Next_Elmt (Sec_DT_Typ); 6463 6464 -- Skip the secondary dispatch table of 6465 -- predefined primitives 6466 6467 Next_Elmt (Sec_DT_Ancestor); 6468 Next_Elmt (Sec_DT_Typ); 6469 6470 Next_Elmt (Iface); 6471 end if; 6472 6473 Next_Entity (E); 6474 end loop; 6475 end if; 6476 end Copy_Secondary_DTs; 6477 6478 begin 6479 if Present (Node (Sec_DT_Ancestor)) 6480 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant 6481 then 6482 -- Handle private types 6483 6484 if Present (Full_View (Typ)) then 6485 Copy_Secondary_DTs (Full_View (Typ)); 6486 else 6487 Copy_Secondary_DTs (Typ); 6488 end if; 6489 end if; 6490 end; 6491 end if; 6492 end if; 6493 end if; 6494 6495 -- Generate code to check if the external tag of this type is the same 6496 -- as the external tag of some other declaration. 6497 6498 -- Check_TSD (TSD'Unrestricted_Access); 6499 6500 -- This check is a consequence of AI05-0113-1/06, so it officially 6501 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is 6502 -- a desirable check to add in Ada 95 mode, but we hesitate to make 6503 -- this change, as it would be incompatible, and could conceivably 6504 -- cause a problem in existing Ada 95 code. 6505 6506 -- We check for No_Run_Time_Mode here, because we do not want to pick 6507 -- up the RE_Check_TSD entity and call it in No_Run_Time mode. 6508 6509 -- We cannot perform this check if the generation of its expanded name 6510 -- was discarded. 6511 6512 if not No_Run_Time_Mode 6513 and then not Discard_Names 6514 and then Ada_Version >= Ada_2005 6515 and then RTE_Available (RE_Check_TSD) 6516 and then not Duplicated_Tag_Checks_Suppressed (Typ) 6517 then 6518 Append_To (Elab_Code, 6519 Make_Procedure_Call_Statement (Loc, 6520 Name => 6521 New_Occurrence_Of (RTE (RE_Check_TSD), Loc), 6522 Parameter_Associations => New_List ( 6523 Make_Attribute_Reference (Loc, 6524 Prefix => New_Occurrence_Of (TSD, Loc), 6525 Attribute_Name => Name_Unchecked_Access)))); 6526 end if; 6527 6528 -- Generate code to register the Tag in the External_Tag hash table for 6529 -- the pure Ada type only. 6530 6531 -- Register_Tag (Dt_Ptr); 6532 6533 -- Skip this action in the following cases: 6534 -- 1) if Register_Tag is not available. 6535 -- 2) in No_Run_Time mode. 6536 -- 3) if Typ is not defined at the library level (this is required 6537 -- to avoid adding concurrency control to the hash table used 6538 -- by the run-time to register the tags). 6539 6540 if not No_Run_Time_Mode 6541 and then Is_Library_Level_Entity (Typ) 6542 and then RTE_Available (RE_Register_Tag) 6543 then 6544 Append_To (Elab_Code, 6545 Make_Procedure_Call_Statement (Loc, 6546 Name => 6547 New_Occurrence_Of (RTE (RE_Register_Tag), Loc), 6548 Parameter_Associations => 6549 New_List (New_Occurrence_Of (DT_Ptr, Loc)))); 6550 end if; 6551 6552 if not Is_Empty_List (Elab_Code) then 6553 Append_List_To (Result, Elab_Code); 6554 end if; 6555 6556 -- Populate the two auxiliary tables used for dispatching asynchronous, 6557 -- conditional and timed selects for synchronized types that implement 6558 -- a limited interface. Skip this step in Ravenscar profile or when 6559 -- general dispatching is forbidden. 6560 6561 if Ada_Version >= Ada_2005 6562 and then Is_Concurrent_Record_Type (Typ) 6563 and then Has_Interfaces (Typ) 6564 and then not Restriction_Active (No_Dispatching_Calls) 6565 and then not Restriction_Active (No_Select_Statements) 6566 then 6567 Append_List_To (Result, 6568 Make_Select_Specific_Data_Table (Typ)); 6569 end if; 6570 6571 -- Remember entities containing dispatch tables 6572 6573 Append_Elmt (Predef_Prims, DT_Decl); 6574 Append_Elmt (DT, DT_Decl); 6575 6576 Analyze_List (Result, Suppress => All_Checks); 6577 Set_Has_Dispatch_Table (Typ); 6578 6579 -- Mark entities containing dispatch tables. Required by the backend to 6580 -- handle them properly. 6581 6582 if Has_DT (Typ) then 6583 declare 6584 Elmt : Elmt_Id; 6585 6586 begin 6587 -- Object declarations 6588 6589 Elmt := First_Elmt (DT_Decl); 6590 while Present (Elmt) loop 6591 Set_Is_Dispatch_Table_Entity (Node (Elmt)); 6592 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype 6593 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); 6594 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); 6595 Next_Elmt (Elmt); 6596 end loop; 6597 6598 -- Aggregates initializing dispatch tables 6599 6600 Elmt := First_Elmt (DT_Aggr); 6601 while Present (Elmt) loop 6602 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); 6603 Next_Elmt (Elmt); 6604 end loop; 6605 end; 6606 end if; 6607 6608 <<Leave_SCIL>> 6609 6610 -- Register the tagged type in the call graph nodes table 6611 6612 Register_CG_Node (Typ); 6613 6614 <<Leave>> 6615 Restore_Ghost_Region (Saved_GM, Saved_IGR); 6616 6617 return Result; 6618 end Make_DT; 6619 6620 ------------------------------------- 6621 -- Make_Select_Specific_Data_Table -- 6622 ------------------------------------- 6623 6624 function Make_Select_Specific_Data_Table 6625 (Typ : Entity_Id) return List_Id 6626 is 6627 Assignments : constant List_Id := New_List; 6628 Loc : constant Source_Ptr := Sloc (Typ); 6629 6630 Conc_Typ : Entity_Id; 6631 Decls : List_Id := No_List; 6632 Prim : Entity_Id; 6633 Prim_Als : Entity_Id; 6634 Prim_Elmt : Elmt_Id; 6635 Prim_Pos : Uint; 6636 Nb_Prim : Nat := 0; 6637 6638 type Examined_Array is array (Int range <>) of Boolean; 6639 6640 function Find_Entry_Index (E : Entity_Id) return Uint; 6641 -- Given an entry, find its index in the visible declarations of the 6642 -- corresponding concurrent type of Typ. 6643 6644 ---------------------- 6645 -- Find_Entry_Index -- 6646 ---------------------- 6647 6648 function Find_Entry_Index (E : Entity_Id) return Uint is 6649 Index : Uint := Uint_1; 6650 Subp_Decl : Entity_Id; 6651 6652 begin 6653 if Present (Decls) 6654 and then not Is_Empty_List (Decls) 6655 then 6656 Subp_Decl := First (Decls); 6657 while Present (Subp_Decl) loop 6658 if Nkind (Subp_Decl) = N_Entry_Declaration then 6659 if Defining_Identifier (Subp_Decl) = E then 6660 return Index; 6661 end if; 6662 6663 Index := Index + 1; 6664 end if; 6665 6666 Next (Subp_Decl); 6667 end loop; 6668 end if; 6669 6670 return Uint_0; 6671 end Find_Entry_Index; 6672 6673 -- Local variables 6674 6675 Tag_Node : Node_Id; 6676 6677 -- Start of processing for Make_Select_Specific_Data_Table 6678 6679 begin 6680 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 6681 6682 if Present (Corresponding_Concurrent_Type (Typ)) then 6683 Conc_Typ := Corresponding_Concurrent_Type (Typ); 6684 6685 if Present (Full_View (Conc_Typ)) then 6686 Conc_Typ := Full_View (Conc_Typ); 6687 end if; 6688 6689 if Ekind (Conc_Typ) = E_Protected_Type then 6690 Decls := Visible_Declarations (Protected_Definition ( 6691 Parent (Conc_Typ))); 6692 else 6693 pragma Assert (Ekind (Conc_Typ) = E_Task_Type); 6694 Decls := Visible_Declarations (Task_Definition ( 6695 Parent (Conc_Typ))); 6696 end if; 6697 end if; 6698 6699 -- Count the non-predefined primitive operations 6700 6701 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 6702 while Present (Prim_Elmt) loop 6703 Prim := Node (Prim_Elmt); 6704 6705 if not (Is_Predefined_Dispatching_Operation (Prim) 6706 or else Is_Predefined_Dispatching_Alias (Prim)) 6707 then 6708 Nb_Prim := Nb_Prim + 1; 6709 end if; 6710 6711 Next_Elmt (Prim_Elmt); 6712 end loop; 6713 6714 declare 6715 Examined : Examined_Array (1 .. Nb_Prim) := (others => False); 6716 6717 begin 6718 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 6719 while Present (Prim_Elmt) loop 6720 Prim := Node (Prim_Elmt); 6721 6722 -- Look for primitive overriding an abstract interface subprogram 6723 6724 if Present (Interface_Alias (Prim)) 6725 and then not 6726 Is_Ancestor 6727 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, 6728 Use_Full_View => True) 6729 and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) 6730 then 6731 Prim_Pos := DT_Position (Alias (Prim)); 6732 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); 6733 Examined (UI_To_Int (Prim_Pos)) := True; 6734 6735 -- Set the primitive operation kind regardless of subprogram 6736 -- type. Generate: 6737 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); 6738 6739 if Tagged_Type_Expansion then 6740 Tag_Node := 6741 New_Occurrence_Of 6742 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); 6743 6744 else 6745 Tag_Node := 6746 Make_Attribute_Reference (Loc, 6747 Prefix => New_Occurrence_Of (Typ, Loc), 6748 Attribute_Name => Name_Tag); 6749 end if; 6750 6751 Append_To (Assignments, 6752 Make_Procedure_Call_Statement (Loc, 6753 Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc), 6754 Parameter_Associations => New_List ( 6755 Tag_Node, 6756 Make_Integer_Literal (Loc, Prim_Pos), 6757 Prim_Op_Kind (Alias (Prim), Typ)))); 6758 6759 -- Retrieve the root of the alias chain 6760 6761 Prim_Als := Ultimate_Alias (Prim); 6762 6763 -- In the case of an entry wrapper, set the entry index 6764 6765 if Ekind (Prim) = E_Procedure 6766 and then Is_Primitive_Wrapper (Prim_Als) 6767 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry 6768 then 6769 -- Generate: 6770 -- Ada.Tags.Set_Entry_Index 6771 -- (DT_Ptr, <position>, <index>); 6772 6773 if Tagged_Type_Expansion then 6774 Tag_Node := 6775 New_Occurrence_Of 6776 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); 6777 else 6778 Tag_Node := 6779 Make_Attribute_Reference (Loc, 6780 Prefix => New_Occurrence_Of (Typ, Loc), 6781 Attribute_Name => Name_Tag); 6782 end if; 6783 6784 Append_To (Assignments, 6785 Make_Procedure_Call_Statement (Loc, 6786 Name => 6787 New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc), 6788 Parameter_Associations => New_List ( 6789 Tag_Node, 6790 Make_Integer_Literal (Loc, Prim_Pos), 6791 Make_Integer_Literal (Loc, 6792 Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); 6793 end if; 6794 end if; 6795 6796 Next_Elmt (Prim_Elmt); 6797 end loop; 6798 end; 6799 6800 return Assignments; 6801 end Make_Select_Specific_Data_Table; 6802 6803 --------------- 6804 -- Make_Tags -- 6805 --------------- 6806 6807 function Make_Tags (Typ : Entity_Id) return List_Id is 6808 Loc : constant Source_Ptr := Sloc (Typ); 6809 Result : constant List_Id := New_List; 6810 6811 procedure Import_DT 6812 (Tag_Typ : Entity_Id; 6813 DT : Entity_Id; 6814 Is_Secondary_DT : Boolean); 6815 -- Import the dispatch table DT of tagged type Tag_Typ. Required to 6816 -- generate forward references and statically allocate the table. For 6817 -- primary dispatch tables that require no dispatch table generate: 6818 6819 -- DT : static aliased constant Non_Dispatch_Table_Wrapper; 6820 -- pragma Import (Ada, DT); 6821 6822 -- Otherwise generate: 6823 6824 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); 6825 -- pragma Import (Ada, DT); 6826 6827 --------------- 6828 -- Import_DT -- 6829 --------------- 6830 6831 procedure Import_DT 6832 (Tag_Typ : Entity_Id; 6833 DT : Entity_Id; 6834 Is_Secondary_DT : Boolean) 6835 is 6836 DT_Constr_List : List_Id; 6837 Nb_Prim : Nat; 6838 6839 begin 6840 Set_Is_Imported (DT); 6841 Set_Ekind (DT, E_Constant); 6842 Set_Related_Type (DT, Typ); 6843 6844 -- The scope must be set now to call Get_External_Name 6845 6846 Set_Scope (DT, Current_Scope); 6847 6848 Get_External_Name (DT); 6849 Set_Interface_Name (DT, 6850 Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); 6851 6852 -- Ensure proper Sprint output of this implicit importation 6853 6854 Set_Is_Internal (DT); 6855 6856 -- Save this entity to allow Make_DT to generate its exportation 6857 6858 Append_Elmt (DT, Dispatch_Table_Wrappers (Typ)); 6859 6860 -- No dispatch table required 6861 6862 if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then 6863 Append_To (Result, 6864 Make_Object_Declaration (Loc, 6865 Defining_Identifier => DT, 6866 Aliased_Present => True, 6867 Constant_Present => True, 6868 Object_Definition => 6869 New_Occurrence_Of 6870 (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); 6871 6872 else 6873 -- Calculate the number of primitives of the dispatch table and 6874 -- the size of the Type_Specific_Data record. 6875 6876 Nb_Prim := 6877 UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ))); 6878 6879 -- If the tagged type has no primitives we add a dummy slot whose 6880 -- address will be the tag of this type. 6881 6882 if Nb_Prim = 0 then 6883 DT_Constr_List := 6884 New_List (Make_Integer_Literal (Loc, 1)); 6885 else 6886 DT_Constr_List := 6887 New_List (Make_Integer_Literal (Loc, Nb_Prim)); 6888 end if; 6889 6890 Append_To (Result, 6891 Make_Object_Declaration (Loc, 6892 Defining_Identifier => DT, 6893 Aliased_Present => True, 6894 Constant_Present => True, 6895 Object_Definition => 6896 Make_Subtype_Indication (Loc, 6897 Subtype_Mark => 6898 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), 6899 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, 6900 Constraints => DT_Constr_List)))); 6901 end if; 6902 end Import_DT; 6903 6904 -- Local variables 6905 6906 Tname : constant Name_Id := Chars (Typ); 6907 AI_Tag_Comp : Elmt_Id; 6908 DT : Node_Id := Empty; 6909 DT_Ptr : Node_Id; 6910 Predef_Prims_Ptr : Node_Id; 6911 Iface_DT : Node_Id := Empty; 6912 Iface_DT_Ptr : Node_Id; 6913 New_Node : Node_Id; 6914 Suffix_Index : Int; 6915 Typ_Name : Name_Id; 6916 Typ_Comps : Elist_Id; 6917 6918 -- Start of processing for Make_Tags 6919 6920 begin 6921 pragma Assert (No (Access_Disp_Table (Typ))); 6922 Set_Access_Disp_Table (Typ, New_Elmt_List); 6923 6924 -- If the elaboration of this tagged type needs a boolean flag then 6925 -- define now its entity. It is initialized to True to indicate that 6926 -- elaboration is still pending; set to False by the IP routine. 6927 6928 -- TypFxx : boolean := True; 6929 6930 if Elab_Flag_Needed (Typ) then 6931 Set_Access_Disp_Table_Elab_Flag (Typ, 6932 Make_Defining_Identifier (Loc, 6933 Chars => New_External_Name (Tname, 'F'))); 6934 6935 Append_To (Result, 6936 Make_Object_Declaration (Loc, 6937 Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ), 6938 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 6939 Expression => New_Occurrence_Of (Standard_True, Loc))); 6940 end if; 6941 6942 -- 1) Generate the primary tag entities 6943 6944 -- Primary dispatch table containing user-defined primitives 6945 6946 DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); 6947 Set_Etype (DT_Ptr, RTE (RE_Tag)); 6948 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); 6949 6950 -- Minimum decoration 6951 6952 Set_Ekind (DT_Ptr, E_Variable); 6953 Set_Related_Type (DT_Ptr, Typ); 6954 6955 -- Notify back end that the types are associated with a dispatch table 6956 6957 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); 6958 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); 6959 6960 -- For CPP types there is no need to build the dispatch tables since 6961 -- they are imported from the C++ side. If the CPP type has an IP then 6962 -- we declare now the variable that will store the copy of the C++ tag. 6963 -- If the CPP type is an interface, we need the variable as well because 6964 -- it becomes the pointer to the corresponding secondary table. 6965 6966 if Is_CPP_Class (Typ) then 6967 if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then 6968 Append_To (Result, 6969 Make_Object_Declaration (Loc, 6970 Defining_Identifier => DT_Ptr, 6971 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 6972 Expression => 6973 Unchecked_Convert_To (RTE (RE_Tag), 6974 New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); 6975 6976 Set_Is_Statically_Allocated (DT_Ptr, 6977 Is_Library_Level_Tagged_Type (Typ)); 6978 end if; 6979 6980 -- Ada types 6981 6982 else 6983 -- Primary dispatch table containing predefined primitives 6984 6985 Predef_Prims_Ptr := 6986 Make_Defining_Identifier (Loc, 6987 Chars => New_External_Name (Tname, 'Y')); 6988 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); 6989 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); 6990 6991 -- Import the forward declaration of the Dispatch Table wrapper 6992 -- record (Make_DT will take care of exporting it). 6993 6994 if Building_Static_DT (Typ) then 6995 Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); 6996 6997 DT := 6998 Make_Defining_Identifier (Loc, 6999 Chars => New_External_Name (Tname, 'T')); 7000 7001 Import_DT (Typ, DT, Is_Secondary_DT => False); 7002 7003 if Has_DT (Typ) then 7004 Append_To (Result, 7005 Make_Object_Declaration (Loc, 7006 Defining_Identifier => DT_Ptr, 7007 Constant_Present => True, 7008 Object_Definition => 7009 New_Occurrence_Of (RTE (RE_Tag), Loc), 7010 Expression => 7011 Unchecked_Convert_To (RTE (RE_Tag), 7012 Make_Attribute_Reference (Loc, 7013 Prefix => 7014 Make_Selected_Component (Loc, 7015 Prefix => New_Occurrence_Of (DT, Loc), 7016 Selector_Name => 7017 New_Occurrence_Of 7018 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 7019 Attribute_Name => Name_Address)))); 7020 7021 -- Generate the SCIL node for the previous object declaration 7022 -- because it has a tag initialization. 7023 7024 if Generate_SCIL then 7025 New_Node := 7026 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); 7027 Set_SCIL_Entity (New_Node, Typ); 7028 Set_SCIL_Node (Last (Result), New_Node); 7029 end if; 7030 7031 Append_To (Result, 7032 Make_Object_Declaration (Loc, 7033 Defining_Identifier => Predef_Prims_Ptr, 7034 Constant_Present => True, 7035 Object_Definition => 7036 New_Occurrence_Of (RTE (RE_Address), Loc), 7037 Expression => 7038 Make_Attribute_Reference (Loc, 7039 Prefix => 7040 Make_Selected_Component (Loc, 7041 Prefix => New_Occurrence_Of (DT, Loc), 7042 Selector_Name => 7043 New_Occurrence_Of 7044 (RTE_Record_Component (RE_Predef_Prims), Loc)), 7045 Attribute_Name => Name_Address))); 7046 7047 -- No dispatch table required 7048 7049 else 7050 Append_To (Result, 7051 Make_Object_Declaration (Loc, 7052 Defining_Identifier => DT_Ptr, 7053 Constant_Present => True, 7054 Object_Definition => 7055 New_Occurrence_Of (RTE (RE_Tag), Loc), 7056 Expression => 7057 Unchecked_Convert_To (RTE (RE_Tag), 7058 Make_Attribute_Reference (Loc, 7059 Prefix => 7060 Make_Selected_Component (Loc, 7061 Prefix => New_Occurrence_Of (DT, Loc), 7062 Selector_Name => 7063 New_Occurrence_Of 7064 (RTE_Record_Component (RE_NDT_Prims_Ptr), 7065 Loc)), 7066 Attribute_Name => Name_Address)))); 7067 end if; 7068 7069 Set_Is_True_Constant (DT_Ptr); 7070 Set_Is_Statically_Allocated (DT_Ptr); 7071 end if; 7072 end if; 7073 7074 -- 2) Generate the secondary tag entities 7075 7076 -- Collect the components associated with secondary dispatch tables 7077 7078 if Has_Interfaces (Typ) then 7079 Collect_Interface_Components (Typ, Typ_Comps); 7080 7081 -- For each interface type we build a unique external name associated 7082 -- with its secondary dispatch table. This name is used to declare an 7083 -- object that references this secondary dispatch table, whose value 7084 -- will be used for the elaboration of Typ objects, and also for the 7085 -- elaboration of objects of types derived from Typ that do not 7086 -- override the primitives of this interface type. 7087 7088 Suffix_Index := 1; 7089 7090 -- Note: The value of Suffix_Index must be in sync with the values of 7091 -- Suffix_Index in secondary dispatch tables generated by Make_DT. 7092 7093 if Is_CPP_Class (Typ) then 7094 AI_Tag_Comp := First_Elmt (Typ_Comps); 7095 while Present (AI_Tag_Comp) loop 7096 Get_Secondary_DT_External_Name 7097 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); 7098 Typ_Name := Name_Find; 7099 7100 -- Declare variables to store copy of the C++ secondary tags 7101 7102 Iface_DT_Ptr := 7103 Make_Defining_Identifier (Loc, 7104 Chars => New_External_Name (Typ_Name, 'P')); 7105 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); 7106 Set_Ekind (Iface_DT_Ptr, E_Variable); 7107 Set_Is_Tag (Iface_DT_Ptr); 7108 7109 Set_Has_Thunks (Iface_DT_Ptr); 7110 Set_Related_Type 7111 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); 7112 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 7113 7114 Append_To (Result, 7115 Make_Object_Declaration (Loc, 7116 Defining_Identifier => Iface_DT_Ptr, 7117 Object_Definition => New_Occurrence_Of 7118 (RTE (RE_Interface_Tag), Loc), 7119 Expression => 7120 Unchecked_Convert_To (RTE (RE_Interface_Tag), 7121 New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); 7122 7123 Set_Is_Statically_Allocated (Iface_DT_Ptr, 7124 Is_Library_Level_Tagged_Type (Typ)); 7125 7126 Next_Elmt (AI_Tag_Comp); 7127 end loop; 7128 7129 -- This is not a CPP_Class type 7130 7131 else 7132 AI_Tag_Comp := First_Elmt (Typ_Comps); 7133 while Present (AI_Tag_Comp) loop 7134 Get_Secondary_DT_External_Name 7135 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); 7136 Typ_Name := Name_Find; 7137 7138 if Building_Static_DT (Typ) then 7139 Iface_DT := 7140 Make_Defining_Identifier (Loc, 7141 Chars => New_External_Name (Typ_Name, 'T')); 7142 Import_DT 7143 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)), 7144 DT => Iface_DT, 7145 Is_Secondary_DT => True); 7146 end if; 7147 7148 -- Secondary dispatch table referencing thunks to user-defined 7149 -- primitives covered by this interface. 7150 7151 Iface_DT_Ptr := 7152 Make_Defining_Identifier (Loc, 7153 Chars => New_External_Name (Typ_Name, 'P')); 7154 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); 7155 Set_Ekind (Iface_DT_Ptr, E_Constant); 7156 Set_Is_Tag (Iface_DT_Ptr); 7157 Set_Has_Thunks (Iface_DT_Ptr); 7158 Set_Is_Statically_Allocated (Iface_DT_Ptr, 7159 Is_Library_Level_Tagged_Type (Typ)); 7160 Set_Is_True_Constant (Iface_DT_Ptr); 7161 Set_Related_Type 7162 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); 7163 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 7164 7165 if Building_Static_DT (Typ) then 7166 Append_To (Result, 7167 Make_Object_Declaration (Loc, 7168 Defining_Identifier => Iface_DT_Ptr, 7169 Constant_Present => True, 7170 Object_Definition => New_Occurrence_Of 7171 (RTE (RE_Interface_Tag), Loc), 7172 Expression => 7173 Unchecked_Convert_To (RTE (RE_Interface_Tag), 7174 Make_Attribute_Reference (Loc, 7175 Prefix => 7176 Make_Selected_Component (Loc, 7177 Prefix => 7178 New_Occurrence_Of (Iface_DT, Loc), 7179 Selector_Name => 7180 New_Occurrence_Of 7181 (RTE_Record_Component (RE_Prims_Ptr), 7182 Loc)), 7183 Attribute_Name => Name_Address)))); 7184 end if; 7185 7186 -- Secondary dispatch table referencing thunks to predefined 7187 -- primitives. 7188 7189 Iface_DT_Ptr := 7190 Make_Defining_Identifier (Loc, 7191 Chars => New_External_Name (Typ_Name, 'Y')); 7192 Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); 7193 Set_Ekind (Iface_DT_Ptr, E_Constant); 7194 Set_Is_Tag (Iface_DT_Ptr); 7195 Set_Has_Thunks (Iface_DT_Ptr); 7196 Set_Is_Statically_Allocated (Iface_DT_Ptr, 7197 Is_Library_Level_Tagged_Type (Typ)); 7198 Set_Is_True_Constant (Iface_DT_Ptr); 7199 Set_Related_Type 7200 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); 7201 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 7202 7203 -- Secondary dispatch table referencing user-defined primitives 7204 -- covered by this interface. 7205 7206 Iface_DT_Ptr := 7207 Make_Defining_Identifier (Loc, 7208 Chars => New_External_Name (Typ_Name, 'D')); 7209 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); 7210 Set_Ekind (Iface_DT_Ptr, E_Constant); 7211 Set_Is_Tag (Iface_DT_Ptr); 7212 Set_Is_Statically_Allocated (Iface_DT_Ptr, 7213 Is_Library_Level_Tagged_Type (Typ)); 7214 Set_Is_True_Constant (Iface_DT_Ptr); 7215 Set_Related_Type 7216 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); 7217 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 7218 7219 -- Secondary dispatch table referencing predefined primitives 7220 7221 Iface_DT_Ptr := 7222 Make_Defining_Identifier (Loc, 7223 Chars => New_External_Name (Typ_Name, 'Z')); 7224 Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); 7225 Set_Ekind (Iface_DT_Ptr, E_Constant); 7226 Set_Is_Tag (Iface_DT_Ptr); 7227 Set_Is_Statically_Allocated (Iface_DT_Ptr, 7228 Is_Library_Level_Tagged_Type (Typ)); 7229 Set_Is_True_Constant (Iface_DT_Ptr); 7230 Set_Related_Type 7231 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); 7232 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 7233 7234 Next_Elmt (AI_Tag_Comp); 7235 end loop; 7236 end if; 7237 end if; 7238 7239 -- 3) At the end of Access_Disp_Table, if the type has user-defined 7240 -- primitives, we add the entity of an access type declaration that 7241 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls 7242 -- through the primary dispatch table. 7243 7244 if DT_Entry_Count (First_Tag_Component (Typ)) = 0 then 7245 Analyze_List (Result); 7246 7247 -- Generate: 7248 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims); 7249 -- type Typ_DT_Acc is access Typ_DT; 7250 7251 else 7252 declare 7253 Name_DT_Prims : constant Name_Id := 7254 New_External_Name (Tname, 'G'); 7255 Name_DT_Prims_Acc : constant Name_Id := 7256 New_External_Name (Tname, 'H'); 7257 DT_Prims : constant Entity_Id := 7258 Make_Defining_Identifier (Loc, 7259 Name_DT_Prims); 7260 DT_Prims_Acc : constant Entity_Id := 7261 Make_Defining_Identifier (Loc, 7262 Name_DT_Prims_Acc); 7263 begin 7264 Append_To (Result, 7265 Make_Subtype_Declaration (Loc, 7266 Defining_Identifier => DT_Prims, 7267 Subtype_Indication => 7268 Make_Subtype_Indication (Loc, 7269 Subtype_Mark => 7270 New_Occurrence_Of (RTE (RE_Address_Array), Loc), 7271 Constraint => 7272 Make_Index_Or_Discriminant_Constraint (Loc, New_List ( 7273 Make_Range (Loc, 7274 Low_Bound => Make_Integer_Literal (Loc, 1), 7275 High_Bound => 7276 Make_Integer_Literal (Loc, 7277 DT_Entry_Count 7278 (First_Tag_Component (Typ))))))))); 7279 7280 Append_To (Result, 7281 Make_Full_Type_Declaration (Loc, 7282 Defining_Identifier => DT_Prims_Acc, 7283 Type_Definition => 7284 Make_Access_To_Object_Definition (Loc, 7285 Subtype_Indication => 7286 New_Occurrence_Of (DT_Prims, Loc)))); 7287 7288 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); 7289 7290 -- Analyze the resulting list and suppress the generation of the 7291 -- Init_Proc associated with the above array declaration because 7292 -- this type is never used in object declarations. It is only used 7293 -- to simplify the expansion associated with dispatching calls. 7294 7295 Analyze_List (Result); 7296 Set_Suppress_Initialization (Base_Type (DT_Prims)); 7297 7298 -- Disable backend optimizations based on assumptions about the 7299 -- aliasing status of objects designated by the access to the 7300 -- dispatch table. Required to handle dispatch tables imported 7301 -- from C++. 7302 7303 Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc)); 7304 7305 -- Add the freezing nodes of these declarations; required to avoid 7306 -- generating these freezing nodes in wrong scopes (for example in 7307 -- the IC routine of a derivation of Typ). 7308 7309 -- What is an "IC routine"? Is "init_proc" meant here??? 7310 7311 Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); 7312 Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ)); 7313 7314 -- Mark entity of dispatch table. Required by the back end to 7315 -- handle them properly. 7316 7317 Set_Is_Dispatch_Table_Entity (DT_Prims); 7318 end; 7319 end if; 7320 7321 -- Mark entities of dispatch table. Required by the back end to handle 7322 -- them properly. 7323 7324 if Present (DT) then 7325 Set_Is_Dispatch_Table_Entity (DT); 7326 Set_Is_Dispatch_Table_Entity (Etype (DT)); 7327 end if; 7328 7329 if Present (Iface_DT) then 7330 Set_Is_Dispatch_Table_Entity (Iface_DT); 7331 Set_Is_Dispatch_Table_Entity (Etype (Iface_DT)); 7332 end if; 7333 7334 if Is_CPP_Class (Root_Type (Typ)) then 7335 Set_Ekind (DT_Ptr, E_Variable); 7336 else 7337 Set_Ekind (DT_Ptr, E_Constant); 7338 end if; 7339 7340 Set_Is_Tag (DT_Ptr); 7341 Set_Related_Type (DT_Ptr, Typ); 7342 7343 return Result; 7344 end Make_Tags; 7345 7346 --------------- 7347 -- New_Value -- 7348 --------------- 7349 7350 function New_Value (From : Node_Id) return Node_Id is 7351 Res : constant Node_Id := Duplicate_Subexpr (From); 7352 begin 7353 if Is_Access_Type (Etype (From)) then 7354 return Make_Explicit_Dereference (Sloc (From), Prefix => Res); 7355 else 7356 return Res; 7357 end if; 7358 end New_Value; 7359 7360 ----------------------------------- 7361 -- Original_View_In_Visible_Part -- 7362 ----------------------------------- 7363 7364 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is 7365 Scop : constant Entity_Id := Scope (Typ); 7366 7367 begin 7368 -- The scope must be a package 7369 7370 if not Is_Package_Or_Generic_Package (Scop) then 7371 return False; 7372 end if; 7373 7374 -- A type with a private declaration has a private view declared in 7375 -- the visible part. 7376 7377 if Has_Private_Declaration (Typ) then 7378 return True; 7379 end if; 7380 7381 return List_Containing (Parent (Typ)) = 7382 Visible_Declarations (Package_Specification (Scop)); 7383 end Original_View_In_Visible_Part; 7384 7385 ------------------ 7386 -- Prim_Op_Kind -- 7387 ------------------ 7388 7389 function Prim_Op_Kind 7390 (Prim : Entity_Id; 7391 Typ : Entity_Id) return Node_Id 7392 is 7393 Full_Typ : Entity_Id := Typ; 7394 Loc : constant Source_Ptr := Sloc (Prim); 7395 Prim_Op : Entity_Id; 7396 7397 begin 7398 -- Retrieve the original primitive operation 7399 7400 Prim_Op := Ultimate_Alias (Prim); 7401 7402 if Ekind (Typ) = E_Record_Type 7403 and then Present (Corresponding_Concurrent_Type (Typ)) 7404 then 7405 Full_Typ := Corresponding_Concurrent_Type (Typ); 7406 end if; 7407 7408 -- When a private tagged type is completed by a concurrent type, 7409 -- retrieve the full view. 7410 7411 if Is_Private_Type (Full_Typ) then 7412 Full_Typ := Full_View (Full_Typ); 7413 end if; 7414 7415 if Ekind (Prim_Op) = E_Function then 7416 7417 -- Protected function 7418 7419 if Ekind (Full_Typ) = E_Protected_Type then 7420 return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc); 7421 7422 -- Task function 7423 7424 elsif Ekind (Full_Typ) = E_Task_Type then 7425 return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc); 7426 7427 -- Regular function 7428 7429 else 7430 return New_Occurrence_Of (RTE (RE_POK_Function), Loc); 7431 end if; 7432 7433 else 7434 pragma Assert (Ekind (Prim_Op) = E_Procedure); 7435 7436 if Ekind (Full_Typ) = E_Protected_Type then 7437 7438 -- Protected entry 7439 7440 if Is_Primitive_Wrapper (Prim_Op) 7441 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry 7442 then 7443 return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc); 7444 7445 -- Protected procedure 7446 7447 else 7448 return 7449 New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc); 7450 end if; 7451 7452 elsif Ekind (Full_Typ) = E_Task_Type then 7453 7454 -- Task entry 7455 7456 if Is_Primitive_Wrapper (Prim_Op) 7457 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry 7458 then 7459 return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc); 7460 7461 -- Task "procedure". These are the internally Expander-generated 7462 -- procedures (task body for instance). 7463 7464 else 7465 return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc); 7466 end if; 7467 7468 -- Regular procedure 7469 7470 else 7471 return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc); 7472 end if; 7473 end if; 7474 end Prim_Op_Kind; 7475 7476 ------------------------ 7477 -- Register_Primitive -- 7478 ------------------------ 7479 7480 function Register_Primitive 7481 (Loc : Source_Ptr; 7482 Prim : Entity_Id) return List_Id 7483 is 7484 DT_Ptr : Entity_Id; 7485 Iface_Prim : Entity_Id; 7486 Iface_Typ : Entity_Id; 7487 Iface_DT_Ptr : Entity_Id; 7488 Iface_DT_Elmt : Elmt_Id; 7489 L : constant List_Id := New_List; 7490 Pos : Uint; 7491 Tag : Entity_Id; 7492 Tag_Typ : Entity_Id; 7493 Thunk_Id : Entity_Id; 7494 Thunk_Code : Node_Id; 7495 7496 begin 7497 pragma Assert (not Restriction_Active (No_Dispatching_Calls)); 7498 7499 -- Do not register in the dispatch table eliminated primitives 7500 7501 if not RTE_Available (RE_Tag) 7502 or else Is_Eliminated (Ultimate_Alias (Prim)) 7503 or else Generate_SCIL 7504 then 7505 return L; 7506 end if; 7507 7508 if not Present (Interface_Alias (Prim)) then 7509 Tag_Typ := Scope (DTC_Entity (Prim)); 7510 Pos := DT_Position (Prim); 7511 Tag := First_Tag_Component (Tag_Typ); 7512 7513 if Is_Predefined_Dispatching_Operation (Prim) 7514 or else Is_Predefined_Dispatching_Alias (Prim) 7515 then 7516 DT_Ptr := 7517 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); 7518 7519 Append_To (L, 7520 Build_Set_Predefined_Prim_Op_Address (Loc, 7521 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), 7522 Position => Pos, 7523 Address_Node => 7524 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7525 Make_Attribute_Reference (Loc, 7526 Prefix => New_Occurrence_Of (Prim, Loc), 7527 Attribute_Name => Name_Unrestricted_Access)))); 7528 7529 -- Register copy of the pointer to the 'size primitive in the TSD 7530 7531 if Chars (Prim) = Name_uSize 7532 and then RTE_Record_Component_Available (RE_Size_Func) 7533 then 7534 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); 7535 Append_To (L, 7536 Build_Set_Size_Function (Loc, 7537 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), 7538 Size_Func => Prim)); 7539 end if; 7540 7541 else 7542 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); 7543 7544 -- Skip registration of primitives located in the C++ part of the 7545 -- dispatch table. Their slot is set by the IC routine. 7546 7547 if not Is_CPP_Class (Root_Type (Tag_Typ)) 7548 or else Pos > CPP_Num_Prims (Tag_Typ) 7549 then 7550 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); 7551 Append_To (L, 7552 Build_Set_Prim_Op_Address (Loc, 7553 Typ => Tag_Typ, 7554 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), 7555 Position => Pos, 7556 Address_Node => 7557 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7558 Make_Attribute_Reference (Loc, 7559 Prefix => New_Occurrence_Of (Prim, Loc), 7560 Attribute_Name => Name_Unrestricted_Access)))); 7561 end if; 7562 end if; 7563 7564 -- Ada 2005 (AI-251): Primitive associated with an interface type 7565 7566 -- Generate the code of the thunk only if the interface type is not an 7567 -- immediate ancestor of Typ; otherwise the dispatch table associated 7568 -- with the interface is the primary dispatch table and we have nothing 7569 -- else to do here. 7570 7571 else 7572 Tag_Typ := Find_Dispatching_Type (Alias (Prim)); 7573 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim)); 7574 7575 pragma Assert (Is_Interface (Iface_Typ)); 7576 7577 -- No action needed for interfaces that are ancestors of Typ because 7578 -- their primitives are located in the primary dispatch table. 7579 7580 if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then 7581 return L; 7582 7583 -- No action needed for primitives located in the C++ part of the 7584 -- dispatch table. Their slot is set by the IC routine. 7585 7586 elsif Is_CPP_Class (Root_Type (Tag_Typ)) 7587 and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ) 7588 and then not Is_Predefined_Dispatching_Operation (Prim) 7589 and then not Is_Predefined_Dispatching_Alias (Prim) 7590 then 7591 return L; 7592 end if; 7593 7594 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ); 7595 7596 if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) 7597 and then Present (Thunk_Code) 7598 then 7599 -- Generate the code necessary to fill the appropriate entry of 7600 -- the secondary dispatch table of Prim's controlling type with 7601 -- Thunk_Id's address. 7602 7603 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); 7604 Iface_DT_Ptr := Node (Iface_DT_Elmt); 7605 pragma Assert (Has_Thunks (Iface_DT_Ptr)); 7606 7607 Iface_Prim := Interface_Alias (Prim); 7608 Pos := DT_Position (Iface_Prim); 7609 Tag := First_Tag_Component (Iface_Typ); 7610 7611 Prepend_To (L, Thunk_Code); 7612 7613 if Is_Predefined_Dispatching_Operation (Prim) 7614 or else Is_Predefined_Dispatching_Alias (Prim) 7615 then 7616 Append_To (L, 7617 Build_Set_Predefined_Prim_Op_Address (Loc, 7618 Tag_Node => 7619 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc), 7620 Position => Pos, 7621 Address_Node => 7622 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7623 Make_Attribute_Reference (Loc, 7624 Prefix => New_Occurrence_Of (Thunk_Id, Loc), 7625 Attribute_Name => Name_Unrestricted_Access)))); 7626 7627 Next_Elmt (Iface_DT_Elmt); 7628 Next_Elmt (Iface_DT_Elmt); 7629 Iface_DT_Ptr := Node (Iface_DT_Elmt); 7630 pragma Assert (not Has_Thunks (Iface_DT_Ptr)); 7631 7632 Append_To (L, 7633 Build_Set_Predefined_Prim_Op_Address (Loc, 7634 Tag_Node => 7635 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc), 7636 Position => Pos, 7637 Address_Node => 7638 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7639 Make_Attribute_Reference (Loc, 7640 Prefix => 7641 New_Occurrence_Of (Alias (Prim), Loc), 7642 Attribute_Name => Name_Unrestricted_Access)))); 7643 7644 else 7645 pragma Assert (Pos /= Uint_0 7646 and then Pos <= DT_Entry_Count (Tag)); 7647 7648 Append_To (L, 7649 Build_Set_Prim_Op_Address (Loc, 7650 Typ => Iface_Typ, 7651 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc), 7652 Position => Pos, 7653 Address_Node => 7654 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7655 Make_Attribute_Reference (Loc, 7656 Prefix => New_Occurrence_Of (Thunk_Id, Loc), 7657 Attribute_Name => Name_Unrestricted_Access)))); 7658 7659 Next_Elmt (Iface_DT_Elmt); 7660 Next_Elmt (Iface_DT_Elmt); 7661 Iface_DT_Ptr := Node (Iface_DT_Elmt); 7662 pragma Assert (not Has_Thunks (Iface_DT_Ptr)); 7663 7664 Append_To (L, 7665 Build_Set_Prim_Op_Address (Loc, 7666 Typ => Iface_Typ, 7667 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc), 7668 Position => Pos, 7669 Address_Node => 7670 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7671 Make_Attribute_Reference (Loc, 7672 Prefix => 7673 New_Occurrence_Of (Ultimate_Alias (Prim), Loc), 7674 Attribute_Name => Name_Unrestricted_Access)))); 7675 7676 end if; 7677 end if; 7678 end if; 7679 7680 return L; 7681 end Register_Primitive; 7682 7683 ------------------------- 7684 -- Set_All_DT_Position -- 7685 ------------------------- 7686 7687 procedure Set_All_DT_Position (Typ : Entity_Id) is 7688 7689 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean; 7690 -- Returns True if Prim is located in the dispatch table of 7691 -- predefined primitives 7692 7693 procedure Validate_Position (Prim : Entity_Id); 7694 -- Check that position assigned to Prim is completely safe (it has not 7695 -- been assigned to a previously defined primitive operation of Typ). 7696 7697 ------------------------ 7698 -- In_Predef_Prims_DT -- 7699 ------------------------ 7700 7701 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is 7702 begin 7703 -- Predefined primitives 7704 7705 if Is_Predefined_Dispatching_Operation (Prim) then 7706 return True; 7707 7708 -- Renamings of predefined primitives 7709 7710 elsif Present (Alias (Prim)) 7711 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)) 7712 then 7713 if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then 7714 return True; 7715 7716 -- An overriding operation that is a user-defined renaming of 7717 -- predefined equality inherits its slot from the overridden 7718 -- operation. Otherwise it is treated as a predefined op and 7719 -- occupies the same predefined slot as equality. A call to it is 7720 -- transformed into a call to its alias, which is the predefined 7721 -- equality op. A dispatching call thus uses the proper slot if 7722 -- operation is further inherited and called with class-wide 7723 -- arguments. 7724 7725 else 7726 return 7727 not Comes_From_Source (Prim) 7728 or else No (Overridden_Operation (Prim)); 7729 end if; 7730 7731 -- User-defined primitives 7732 7733 else 7734 return False; 7735 end if; 7736 end In_Predef_Prims_DT; 7737 7738 ----------------------- 7739 -- Validate_Position -- 7740 ----------------------- 7741 7742 procedure Validate_Position (Prim : Entity_Id) is 7743 Op_Elmt : Elmt_Id; 7744 Op : Entity_Id; 7745 7746 begin 7747 -- Aliased primitives are safe 7748 7749 if Present (Alias (Prim)) then 7750 return; 7751 end if; 7752 7753 Op_Elmt := First_Elmt (Primitive_Operations (Typ)); 7754 while Present (Op_Elmt) loop 7755 Op := Node (Op_Elmt); 7756 7757 -- No need to check against itself 7758 7759 if Op = Prim then 7760 null; 7761 7762 -- Primitive operations covering abstract interfaces are 7763 -- allocated later 7764 7765 elsif Present (Interface_Alias (Op)) then 7766 null; 7767 7768 -- Predefined dispatching operations are completely safe. They 7769 -- are allocated at fixed positions in a separate table. 7770 7771 elsif Is_Predefined_Dispatching_Operation (Op) 7772 or else Is_Predefined_Dispatching_Alias (Op) 7773 then 7774 null; 7775 7776 -- Aliased subprograms are safe 7777 7778 elsif Present (Alias (Op)) then 7779 null; 7780 7781 elsif DT_Position (Op) = DT_Position (Prim) 7782 and then not Is_Predefined_Dispatching_Operation (Op) 7783 and then not Is_Predefined_Dispatching_Operation (Prim) 7784 and then not Is_Predefined_Dispatching_Alias (Op) 7785 and then not Is_Predefined_Dispatching_Alias (Prim) 7786 then 7787 -- Handle aliased subprograms 7788 7789 declare 7790 Op_1 : Entity_Id; 7791 Op_2 : Entity_Id; 7792 7793 begin 7794 Op_1 := Op; 7795 loop 7796 if Present (Overridden_Operation (Op_1)) then 7797 Op_1 := Overridden_Operation (Op_1); 7798 elsif Present (Alias (Op_1)) then 7799 Op_1 := Alias (Op_1); 7800 else 7801 exit; 7802 end if; 7803 end loop; 7804 7805 Op_2 := Prim; 7806 loop 7807 if Present (Overridden_Operation (Op_2)) then 7808 Op_2 := Overridden_Operation (Op_2); 7809 elsif Present (Alias (Op_2)) then 7810 Op_2 := Alias (Op_2); 7811 else 7812 exit; 7813 end if; 7814 end loop; 7815 7816 if Op_1 /= Op_2 then 7817 raise Program_Error; 7818 end if; 7819 end; 7820 end if; 7821 7822 Next_Elmt (Op_Elmt); 7823 end loop; 7824 end Validate_Position; 7825 7826 -- Local variables 7827 7828 Parent_Typ : constant Entity_Id := Etype (Typ); 7829 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); 7830 The_Tag : constant Entity_Id := First_Tag_Component (Typ); 7831 7832 Adjusted : Boolean := False; 7833 Finalized : Boolean := False; 7834 7835 Count_Prim : Nat; 7836 DT_Length : Nat; 7837 Nb_Prim : Nat; 7838 Prim : Entity_Id; 7839 Prim_Elmt : Elmt_Id; 7840 7841 -- Start of processing for Set_All_DT_Position 7842 7843 begin 7844 pragma Assert (Present (First_Tag_Component (Typ))); 7845 7846 -- Set the DT_Position for each primitive operation. Perform some sanity 7847 -- checks to avoid building inconsistent dispatch tables. 7848 7849 -- First stage: Set DTC entity of all the primitive operations. This is 7850 -- required to properly read the DT_Position attribute in latter stages. 7851 7852 Prim_Elmt := First_Prim; 7853 Count_Prim := 0; 7854 while Present (Prim_Elmt) loop 7855 Prim := Node (Prim_Elmt); 7856 7857 -- Predefined primitives have a separate dispatch table 7858 7859 if not In_Predef_Prims_DT (Prim) then 7860 Count_Prim := Count_Prim + 1; 7861 end if; 7862 7863 Set_DTC_Entity_Value (Typ, Prim); 7864 7865 -- Clear any previous value of the DT_Position attribute. In this 7866 -- way we ensure that the final position of all the primitives is 7867 -- established by the following stages of this algorithm. 7868 7869 Set_DT_Position_Value (Prim, No_Uint); 7870 7871 Next_Elmt (Prim_Elmt); 7872 end loop; 7873 7874 declare 7875 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := 7876 (others => False); 7877 7878 E : Entity_Id; 7879 7880 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); 7881 -- Called if Typ is declared in a nested package or a public child 7882 -- package to handle inherited primitives that were inherited by Typ 7883 -- in the visible part, but whose declaration was deferred because 7884 -- the parent operation was private and not visible at that point. 7885 7886 procedure Set_Fixed_Prim (Pos : Nat); 7887 -- Sets to true an element of the Fixed_Prim table to indicate 7888 -- that this entry of the dispatch table of Typ is occupied. 7889 7890 ------------------------------------------ 7891 -- Handle_Inherited_Private_Subprograms -- 7892 ------------------------------------------ 7893 7894 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is 7895 Op_List : Elist_Id; 7896 Op_Elmt : Elmt_Id; 7897 Op_Elmt_2 : Elmt_Id; 7898 Prim_Op : Entity_Id; 7899 Parent_Subp : Entity_Id; 7900 7901 begin 7902 Op_List := Primitive_Operations (Typ); 7903 7904 Op_Elmt := First_Elmt (Op_List); 7905 while Present (Op_Elmt) loop 7906 Prim_Op := Node (Op_Elmt); 7907 7908 -- Search primitives that are implicit operations with an 7909 -- internal name whose parent operation has a normal name. 7910 7911 if Present (Alias (Prim_Op)) 7912 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ 7913 and then not Comes_From_Source (Prim_Op) 7914 and then Is_Internal_Name (Chars (Prim_Op)) 7915 and then not Is_Internal_Name (Chars (Alias (Prim_Op))) 7916 then 7917 Parent_Subp := Alias (Prim_Op); 7918 7919 -- Check if the type has an explicit overriding for this 7920 -- primitive. 7921 7922 Op_Elmt_2 := Next_Elmt (Op_Elmt); 7923 while Present (Op_Elmt_2) loop 7924 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) 7925 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) 7926 then 7927 Set_DT_Position_Value (Prim_Op, 7928 DT_Position (Parent_Subp)); 7929 Set_DT_Position_Value (Node (Op_Elmt_2), 7930 DT_Position (Parent_Subp)); 7931 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); 7932 7933 goto Next_Primitive; 7934 end if; 7935 7936 Next_Elmt (Op_Elmt_2); 7937 end loop; 7938 end if; 7939 7940 <<Next_Primitive>> 7941 Next_Elmt (Op_Elmt); 7942 end loop; 7943 end Handle_Inherited_Private_Subprograms; 7944 7945 -------------------- 7946 -- Set_Fixed_Prim -- 7947 -------------------- 7948 7949 procedure Set_Fixed_Prim (Pos : Nat) is 7950 begin 7951 pragma Assert (Pos <= Count_Prim); 7952 Fixed_Prim (Pos) := True; 7953 exception 7954 when Constraint_Error => 7955 raise Program_Error; 7956 end Set_Fixed_Prim; 7957 7958 begin 7959 -- In case of nested packages and public child package it may be 7960 -- necessary a special management on inherited subprograms so that 7961 -- the dispatch table is properly filled. 7962 7963 if Ekind (Scope (Scope (Typ))) = E_Package 7964 and then Scope (Scope (Typ)) /= Standard_Standard 7965 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) 7966 or else 7967 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration 7968 and then Is_Generic_Type (Typ))) 7969 and then In_Open_Scopes (Scope (Etype (Typ))) 7970 and then Is_Base_Type (Typ) 7971 then 7972 Handle_Inherited_Private_Subprograms (Typ); 7973 end if; 7974 7975 -- Second stage: Register fixed entries 7976 7977 Nb_Prim := 0; 7978 Prim_Elmt := First_Prim; 7979 while Present (Prim_Elmt) loop 7980 Prim := Node (Prim_Elmt); 7981 7982 -- Predefined primitives have a separate table and all its 7983 -- entries are at predefined fixed positions. 7984 7985 if In_Predef_Prims_DT (Prim) then 7986 if Is_Predefined_Dispatching_Operation (Prim) then 7987 Set_DT_Position_Value (Prim, 7988 Default_Prim_Op_Position (Prim)); 7989 7990 else pragma Assert (Present (Alias (Prim))); 7991 Set_DT_Position_Value (Prim, 7992 Default_Prim_Op_Position (Ultimate_Alias (Prim))); 7993 end if; 7994 7995 -- Overriding primitives of ancestor abstract interfaces 7996 7997 elsif Present (Interface_Alias (Prim)) 7998 and then Is_Ancestor 7999 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, 8000 Use_Full_View => True) 8001 then 8002 pragma Assert (DT_Position (Prim) = No_Uint 8003 and then Present (DTC_Entity (Interface_Alias (Prim)))); 8004 8005 E := Interface_Alias (Prim); 8006 Set_DT_Position_Value (Prim, DT_Position (E)); 8007 8008 pragma Assert 8009 (DT_Position (Alias (Prim)) = No_Uint 8010 or else DT_Position (Alias (Prim)) = DT_Position (E)); 8011 Set_DT_Position_Value (Alias (Prim), DT_Position (E)); 8012 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); 8013 8014 -- Overriding primitives must use the same entry as the overridden 8015 -- primitive. Note that the Alias of the operation is set when the 8016 -- operation is declared by a renaming, in which case it is not 8017 -- overriding. If it renames another primitive it will use the 8018 -- same dispatch table slot, but if it renames an operation in a 8019 -- nested package it's a new primitive and will have its own slot. 8020 8021 elsif not Present (Interface_Alias (Prim)) 8022 and then Present (Alias (Prim)) 8023 and then Chars (Prim) = Chars (Alias (Prim)) 8024 and then Nkind (Unit_Declaration_Node (Prim)) /= 8025 N_Subprogram_Renaming_Declaration 8026 then 8027 declare 8028 Par_Type : constant Entity_Id := 8029 Find_Dispatching_Type (Alias (Prim)); 8030 8031 begin 8032 if Present (Par_Type) 8033 and then Par_Type /= Typ 8034 and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True) 8035 and then Present (DTC_Entity (Alias (Prim))) 8036 then 8037 E := Alias (Prim); 8038 Set_DT_Position_Value (Prim, DT_Position (E)); 8039 8040 if not Is_Predefined_Dispatching_Alias (E) then 8041 Set_Fixed_Prim (UI_To_Int (DT_Position (E))); 8042 end if; 8043 end if; 8044 end; 8045 end if; 8046 8047 Next_Elmt (Prim_Elmt); 8048 end loop; 8049 8050 -- Third stage: Fix the position of all the new primitives. Entries 8051 -- associated with primitives covering interfaces are handled in a 8052 -- latter round. 8053 8054 Prim_Elmt := First_Prim; 8055 while Present (Prim_Elmt) loop 8056 Prim := Node (Prim_Elmt); 8057 8058 -- Skip primitives previously set entries 8059 8060 if DT_Position (Prim) /= No_Uint then 8061 null; 8062 8063 -- Primitives covering interface primitives are handled later 8064 8065 elsif Present (Interface_Alias (Prim)) then 8066 null; 8067 8068 else 8069 -- Take the next available position in the DT 8070 8071 loop 8072 Nb_Prim := Nb_Prim + 1; 8073 pragma Assert (Nb_Prim <= Count_Prim); 8074 exit when not Fixed_Prim (Nb_Prim); 8075 end loop; 8076 8077 Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim)); 8078 Set_Fixed_Prim (Nb_Prim); 8079 end if; 8080 8081 Next_Elmt (Prim_Elmt); 8082 end loop; 8083 end; 8084 8085 -- Fourth stage: Complete the decoration of primitives covering 8086 -- interfaces (that is, propagate the DT_Position attribute from 8087 -- the aliased primitive) 8088 8089 Prim_Elmt := First_Prim; 8090 while Present (Prim_Elmt) loop 8091 Prim := Node (Prim_Elmt); 8092 8093 if DT_Position (Prim) = No_Uint 8094 and then Present (Interface_Alias (Prim)) 8095 then 8096 pragma Assert (Present (Alias (Prim)) 8097 and then Find_Dispatching_Type (Alias (Prim)) = Typ); 8098 8099 -- Check if this entry will be placed in the primary DT 8100 8101 if Is_Ancestor 8102 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, 8103 Use_Full_View => True) 8104 then 8105 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); 8106 Set_DT_Position_Value (Prim, DT_Position (Alias (Prim))); 8107 8108 -- Otherwise it will be placed in the secondary DT 8109 8110 else 8111 pragma Assert 8112 (DT_Position (Interface_Alias (Prim)) /= No_Uint); 8113 Set_DT_Position_Value (Prim, 8114 DT_Position (Interface_Alias (Prim))); 8115 end if; 8116 end if; 8117 8118 Next_Elmt (Prim_Elmt); 8119 end loop; 8120 8121 -- Generate listing showing the contents of the dispatch tables. This 8122 -- action is done before some further static checks because in case of 8123 -- critical errors caused by a wrong dispatch table we need to see the 8124 -- contents of such table. 8125 8126 if Debug_Flag_ZZ then 8127 Write_DT (Typ); 8128 end if; 8129 8130 -- Final stage: Ensure that the table is correct plus some further 8131 -- verifications concerning the primitives. 8132 8133 Prim_Elmt := First_Prim; 8134 DT_Length := 0; 8135 while Present (Prim_Elmt) loop 8136 Prim := Node (Prim_Elmt); 8137 8138 -- At this point all the primitives MUST have a position in the 8139 -- dispatch table. 8140 8141 if DT_Position (Prim) = No_Uint then 8142 raise Program_Error; 8143 end if; 8144 8145 -- Calculate real size of the dispatch table 8146 8147 if not In_Predef_Prims_DT (Prim) 8148 and then UI_To_Int (DT_Position (Prim)) > DT_Length 8149 then 8150 DT_Length := UI_To_Int (DT_Position (Prim)); 8151 end if; 8152 8153 -- Ensure that the assigned position to non-predefined dispatching 8154 -- operations in the dispatch table is correct. 8155 8156 if not Is_Predefined_Dispatching_Operation (Prim) 8157 and then not Is_Predefined_Dispatching_Alias (Prim) 8158 then 8159 Validate_Position (Prim); 8160 end if; 8161 8162 if Chars (Prim) = Name_Finalize then 8163 Finalized := True; 8164 end if; 8165 8166 if Chars (Prim) = Name_Adjust then 8167 Adjusted := True; 8168 end if; 8169 8170 -- An abstract operation cannot be declared in the private part for a 8171 -- visible abstract type, because it can't be overridden outside this 8172 -- package hierarchy. For explicit declarations this is checked at 8173 -- the point of declaration, but for inherited operations it must be 8174 -- done when building the dispatch table. 8175 8176 -- Ada 2005 (AI-251): Primitives associated with interfaces are 8177 -- excluded from this check because interfaces must be visible in 8178 -- the public and private part (RM 7.3 (7.3/2)) 8179 8180 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate 8181 -- legacy Ada code. 8182 8183 if not Relaxed_RM_Semantics 8184 and then Is_Abstract_Type (Typ) 8185 and then Is_Abstract_Subprogram (Prim) 8186 and then Present (Alias (Prim)) 8187 and then not Is_Interface 8188 (Find_Dispatching_Type (Ultimate_Alias (Prim))) 8189 and then not Present (Interface_Alias (Prim)) 8190 and then Is_Derived_Type (Typ) 8191 and then In_Private_Part (Current_Scope) 8192 and then 8193 List_Containing (Parent (Prim)) = 8194 Private_Declarations (Package_Specification (Current_Scope)) 8195 and then Original_View_In_Visible_Part (Typ) 8196 then 8197 -- We exclude Input and Output stream operations because 8198 -- Limited_Controlled inherits useless Input and Output stream 8199 -- operations from Root_Controlled, which can never be overridden. 8200 -- Move this check to sem??? 8201 8202 if not Is_TSS (Prim, TSS_Stream_Input) 8203 and then 8204 not Is_TSS (Prim, TSS_Stream_Output) 8205 then 8206 Error_Msg_NE 8207 ("abstract inherited private operation&" & 8208 " must be overridden (RM 3.9.3(10))", 8209 Parent (Typ), Prim); 8210 end if; 8211 end if; 8212 8213 Next_Elmt (Prim_Elmt); 8214 end loop; 8215 8216 -- Additional check 8217 8218 if Is_Controlled (Typ) then 8219 if not Finalized then 8220 Error_Msg_N 8221 ("controlled type has no explicit Finalize method??", Typ); 8222 8223 elsif not Adjusted then 8224 Error_Msg_N 8225 ("controlled type has no explicit Adjust method??", Typ); 8226 end if; 8227 end if; 8228 8229 -- Set the final size of the Dispatch Table 8230 8231 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); 8232 8233 -- The derived type must have at least as many components as its parent 8234 -- (for root types Etype points to itself and the test cannot fail). 8235 8236 if DT_Entry_Count (The_Tag) < 8237 DT_Entry_Count (First_Tag_Component (Parent_Typ)) 8238 then 8239 raise Program_Error; 8240 end if; 8241 end Set_All_DT_Position; 8242 8243 -------------------------- 8244 -- Set_CPP_Constructors -- 8245 -------------------------- 8246 8247 procedure Set_CPP_Constructors (Typ : Entity_Id) is 8248 8249 function Gen_Parameters_Profile (E : Entity_Id) return List_Id; 8250 -- Duplicate the parameters profile of the imported C++ constructor 8251 -- adding the "this" pointer to the object as the additional first 8252 -- parameter under the usual form _Init : in out Typ. 8253 8254 ---------------------------- 8255 -- Gen_Parameters_Profile -- 8256 ---------------------------- 8257 8258 function Gen_Parameters_Profile (E : Entity_Id) return List_Id is 8259 Loc : constant Source_Ptr := Sloc (E); 8260 Parms : List_Id; 8261 P : Node_Id; 8262 8263 begin 8264 Parms := 8265 New_List ( 8266 Make_Parameter_Specification (Loc, 8267 Defining_Identifier => 8268 Make_Defining_Identifier (Loc, Name_uInit), 8269 In_Present => True, 8270 Out_Present => True, 8271 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 8272 8273 if Present (Parameter_Specifications (Parent (E))) then 8274 P := First (Parameter_Specifications (Parent (E))); 8275 while Present (P) loop 8276 Append_To (Parms, 8277 Make_Parameter_Specification (Loc, 8278 Defining_Identifier => 8279 Make_Defining_Identifier (Loc, 8280 Chars => Chars (Defining_Identifier (P))), 8281 Parameter_Type => New_Copy_Tree (Parameter_Type (P)), 8282 Expression => New_Copy_Tree (Expression (P)))); 8283 Next (P); 8284 end loop; 8285 end if; 8286 8287 return Parms; 8288 end Gen_Parameters_Profile; 8289 8290 -- Local variables 8291 8292 Loc : Source_Ptr; 8293 E : Entity_Id; 8294 Found : Boolean := False; 8295 IP : Entity_Id; 8296 IP_Body : Node_Id; 8297 P : Node_Id; 8298 Parms : List_Id; 8299 8300 Covers_Default_Constructor : Entity_Id := Empty; 8301 8302 -- Start of processing for Set_CPP_Constructor 8303 8304 begin 8305 pragma Assert (Is_CPP_Class (Typ)); 8306 8307 -- Look for the constructor entities 8308 8309 E := Next_Entity (Typ); 8310 while Present (E) loop 8311 if Ekind (E) = E_Function 8312 and then Is_Constructor (E) 8313 then 8314 Found := True; 8315 Loc := Sloc (E); 8316 Parms := Gen_Parameters_Profile (E); 8317 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); 8318 8319 -- Case 1: Constructor of untagged type 8320 8321 -- If the C++ class has no virtual methods then the matching Ada 8322 -- type is an untagged record type. In such case there is no need 8323 -- to generate a wrapper of the C++ constructor because the _tag 8324 -- component is not available. 8325 8326 if not Is_Tagged_Type (Typ) then 8327 Discard_Node 8328 (Make_Subprogram_Declaration (Loc, 8329 Specification => 8330 Make_Procedure_Specification (Loc, 8331 Defining_Unit_Name => IP, 8332 Parameter_Specifications => Parms))); 8333 8334 Set_Init_Proc (Typ, IP); 8335 Set_Is_Imported (IP); 8336 Set_Is_Constructor (IP); 8337 Set_Interface_Name (IP, Interface_Name (E)); 8338 Set_Convention (IP, Convention_CPP); 8339 Set_Is_Public (IP); 8340 Set_Has_Completion (IP); 8341 8342 -- Case 2: Constructor of a tagged type 8343 8344 -- In this case we generate the IP routine as a wrapper of the 8345 -- C++ constructor because IP must also save a copy of the _tag 8346 -- generated in the C++ side. The copy of the _tag is used by 8347 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. 8348 8349 -- Generate: 8350 -- procedure IP (_init : in out Typ; ...) is 8351 -- procedure ConstructorP (_init : in out Typ; ...); 8352 -- pragma Import (ConstructorP); 8353 -- begin 8354 -- ConstructorP (_init, ...); 8355 -- if Typ._tag = null then 8356 -- Typ._tag := _init._tag; 8357 -- end if; 8358 -- end IP; 8359 8360 else 8361 declare 8362 Body_Stmts : constant List_Id := New_List; 8363 Constructor_Id : Entity_Id; 8364 Constructor_Decl_Node : Node_Id; 8365 Init_Tags_List : List_Id; 8366 8367 begin 8368 Constructor_Id := Make_Temporary (Loc, 'P'); 8369 8370 Constructor_Decl_Node := 8371 Make_Subprogram_Declaration (Loc, 8372 Make_Procedure_Specification (Loc, 8373 Defining_Unit_Name => Constructor_Id, 8374 Parameter_Specifications => Parms)); 8375 8376 Set_Is_Imported (Constructor_Id); 8377 Set_Is_Constructor (Constructor_Id); 8378 Set_Interface_Name (Constructor_Id, Interface_Name (E)); 8379 Set_Convention (Constructor_Id, Convention_CPP); 8380 Set_Is_Public (Constructor_Id); 8381 Set_Has_Completion (Constructor_Id); 8382 8383 -- Build the init procedure as a wrapper of this constructor 8384 8385 Parms := Gen_Parameters_Profile (E); 8386 8387 -- Invoke the C++ constructor 8388 8389 declare 8390 Actuals : constant List_Id := New_List; 8391 8392 begin 8393 P := First (Parms); 8394 while Present (P) loop 8395 Append_To (Actuals, 8396 New_Occurrence_Of (Defining_Identifier (P), Loc)); 8397 Next (P); 8398 end loop; 8399 8400 Append_To (Body_Stmts, 8401 Make_Procedure_Call_Statement (Loc, 8402 Name => New_Occurrence_Of (Constructor_Id, Loc), 8403 Parameter_Associations => Actuals)); 8404 end; 8405 8406 -- Initialize copies of C++ primary and secondary tags 8407 8408 Init_Tags_List := New_List; 8409 8410 declare 8411 Tag_Elmt : Elmt_Id; 8412 Tag_Comp : Node_Id; 8413 8414 begin 8415 Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); 8416 Tag_Comp := First_Tag_Component (Typ); 8417 8418 while Present (Tag_Elmt) 8419 and then Is_Tag (Node (Tag_Elmt)) 8420 loop 8421 -- Skip the following assertion with primary tags 8422 -- because Related_Type is not set on primary tag 8423 -- components. 8424 8425 pragma Assert 8426 (Tag_Comp = First_Tag_Component (Typ) 8427 or else Related_Type (Node (Tag_Elmt)) 8428 = Related_Type (Tag_Comp)); 8429 8430 Append_To (Init_Tags_List, 8431 Make_Assignment_Statement (Loc, 8432 Name => 8433 New_Occurrence_Of (Node (Tag_Elmt), Loc), 8434 Expression => 8435 Make_Selected_Component (Loc, 8436 Prefix => 8437 Make_Identifier (Loc, Name_uInit), 8438 Selector_Name => 8439 New_Occurrence_Of (Tag_Comp, Loc)))); 8440 8441 Tag_Comp := Next_Tag_Component (Tag_Comp); 8442 Next_Elmt (Tag_Elmt); 8443 end loop; 8444 end; 8445 8446 Append_To (Body_Stmts, 8447 Make_If_Statement (Loc, 8448 Condition => 8449 Make_Op_Eq (Loc, 8450 Left_Opnd => 8451 New_Occurrence_Of 8452 (Node (First_Elmt (Access_Disp_Table (Typ))), 8453 Loc), 8454 Right_Opnd => 8455 Unchecked_Convert_To (RTE (RE_Tag), 8456 New_Occurrence_Of (RTE (RE_Null_Address), Loc))), 8457 Then_Statements => Init_Tags_List)); 8458 8459 IP_Body := 8460 Make_Subprogram_Body (Loc, 8461 Specification => 8462 Make_Procedure_Specification (Loc, 8463 Defining_Unit_Name => IP, 8464 Parameter_Specifications => Parms), 8465 Declarations => New_List (Constructor_Decl_Node), 8466 Handled_Statement_Sequence => 8467 Make_Handled_Sequence_Of_Statements (Loc, 8468 Statements => Body_Stmts, 8469 Exception_Handlers => No_List)); 8470 8471 Discard_Node (IP_Body); 8472 Set_Init_Proc (Typ, IP); 8473 end; 8474 end if; 8475 8476 -- If this constructor has parameters and all its parameters have 8477 -- defaults then it covers the default constructor. The semantic 8478 -- analyzer ensures that only one constructor with defaults covers 8479 -- the default constructor. 8480 8481 if Present (Parameter_Specifications (Parent (E))) 8482 and then Needs_No_Actuals (E) 8483 then 8484 Covers_Default_Constructor := IP; 8485 end if; 8486 end if; 8487 8488 Next_Entity (E); 8489 end loop; 8490 8491 -- If there are no constructors, mark the type as abstract since we 8492 -- won't be able to declare objects of that type. 8493 8494 if not Found then 8495 Set_Is_Abstract_Type (Typ); 8496 end if; 8497 8498 -- Handle constructor that has all its parameters with defaults and 8499 -- hence it covers the default constructor. We generate a wrapper IP 8500 -- which calls the covering constructor. 8501 8502 if Present (Covers_Default_Constructor) then 8503 declare 8504 Body_Stmts : List_Id; 8505 8506 begin 8507 Loc := Sloc (Covers_Default_Constructor); 8508 8509 Body_Stmts := New_List ( 8510 Make_Procedure_Call_Statement (Loc, 8511 Name => 8512 New_Occurrence_Of (Covers_Default_Constructor, Loc), 8513 Parameter_Associations => New_List ( 8514 Make_Identifier (Loc, Name_uInit)))); 8515 8516 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); 8517 8518 IP_Body := 8519 Make_Subprogram_Body (Loc, 8520 Specification => 8521 Make_Procedure_Specification (Loc, 8522 Defining_Unit_Name => IP, 8523 Parameter_Specifications => New_List ( 8524 Make_Parameter_Specification (Loc, 8525 Defining_Identifier => 8526 Make_Defining_Identifier (Loc, Name_uInit), 8527 Parameter_Type => New_Occurrence_Of (Typ, Loc)))), 8528 8529 Declarations => No_List, 8530 8531 Handled_Statement_Sequence => 8532 Make_Handled_Sequence_Of_Statements (Loc, 8533 Statements => Body_Stmts, 8534 Exception_Handlers => No_List)); 8535 8536 Discard_Node (IP_Body); 8537 Set_Init_Proc (Typ, IP); 8538 end; 8539 end if; 8540 8541 -- If the CPP type has constructors then it must import also the default 8542 -- C++ constructor. It is required for default initialization of objects 8543 -- of the type. It is also required to elaborate objects of Ada types 8544 -- that are defined as derivations of this CPP type. 8545 8546 if Has_CPP_Constructors (Typ) 8547 and then No (Init_Proc (Typ)) 8548 then 8549 Error_Msg_N ("??default constructor must be imported from C++", Typ); 8550 end if; 8551 end Set_CPP_Constructors; 8552 8553 --------------------------- 8554 -- Set_DT_Position_Value -- 8555 --------------------------- 8556 8557 procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is 8558 begin 8559 Set_DT_Position (Prim, Value); 8560 8561 -- Propagate the value to the wrapped subprogram (if one is present) 8562 8563 if Ekind (Prim) in E_Function | E_Procedure 8564 and then Is_Primitive_Wrapper (Prim) 8565 and then Present (Wrapped_Entity (Prim)) 8566 and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) 8567 then 8568 Set_DT_Position (Wrapped_Entity (Prim), Value); 8569 end if; 8570 end Set_DT_Position_Value; 8571 8572 -------------------------- 8573 -- Set_DTC_Entity_Value -- 8574 -------------------------- 8575 8576 procedure Set_DTC_Entity_Value 8577 (Tagged_Type : Entity_Id; 8578 Prim : Entity_Id) 8579 is 8580 begin 8581 if Present (Interface_Alias (Prim)) 8582 and then Is_Interface 8583 (Find_Dispatching_Type (Interface_Alias (Prim))) 8584 then 8585 Set_DTC_Entity (Prim, 8586 Find_Interface_Tag 8587 (T => Tagged_Type, 8588 Iface => Find_Dispatching_Type (Interface_Alias (Prim)))); 8589 else 8590 Set_DTC_Entity (Prim, 8591 First_Tag_Component (Tagged_Type)); 8592 end if; 8593 8594 -- Propagate the value to the wrapped subprogram (if one is present) 8595 8596 if Ekind (Prim) in E_Function | E_Procedure 8597 and then Is_Primitive_Wrapper (Prim) 8598 and then Present (Wrapped_Entity (Prim)) 8599 and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) 8600 then 8601 Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim)); 8602 end if; 8603 end Set_DTC_Entity_Value; 8604 8605 ----------------- 8606 -- Tagged_Kind -- 8607 ----------------- 8608 8609 function Tagged_Kind (T : Entity_Id) return Node_Id is 8610 Conc_Typ : Entity_Id; 8611 Loc : constant Source_Ptr := Sloc (T); 8612 8613 begin 8614 pragma Assert 8615 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); 8616 8617 -- Abstract kinds 8618 8619 if Is_Abstract_Type (T) then 8620 if Is_Limited_Record (T) then 8621 return New_Occurrence_Of 8622 (RTE (RE_TK_Abstract_Limited_Tagged), Loc); 8623 else 8624 return New_Occurrence_Of 8625 (RTE (RE_TK_Abstract_Tagged), Loc); 8626 end if; 8627 8628 -- Concurrent kinds 8629 8630 elsif Is_Concurrent_Record_Type (T) then 8631 Conc_Typ := Corresponding_Concurrent_Type (T); 8632 8633 if Present (Full_View (Conc_Typ)) then 8634 Conc_Typ := Full_View (Conc_Typ); 8635 end if; 8636 8637 if Ekind (Conc_Typ) = E_Protected_Type then 8638 return New_Occurrence_Of (RTE (RE_TK_Protected), Loc); 8639 else 8640 pragma Assert (Ekind (Conc_Typ) = E_Task_Type); 8641 return New_Occurrence_Of (RTE (RE_TK_Task), Loc); 8642 end if; 8643 8644 -- Regular tagged kinds 8645 8646 else 8647 if Is_Limited_Record (T) then 8648 return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc); 8649 else 8650 return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc); 8651 end if; 8652 end if; 8653 end Tagged_Kind; 8654 8655 -------------- 8656 -- Write_DT -- 8657 -------------- 8658 8659 procedure Write_DT (Typ : Entity_Id) is 8660 Elmt : Elmt_Id; 8661 Prim : Node_Id; 8662 8663 begin 8664 -- Protect this procedure against wrong usage. Required because it will 8665 -- be used directly from GDB 8666 8667 if not (Typ <= Last_Node_Id) 8668 or else not Is_Tagged_Type (Typ) 8669 then 8670 Write_Str ("wrong usage: Write_DT must be used with tagged types"); 8671 Write_Eol; 8672 return; 8673 end if; 8674 8675 Write_Int (Int (Typ)); 8676 Write_Str (": "); 8677 Write_Name (Chars (Typ)); 8678 8679 if Is_Interface (Typ) then 8680 Write_Str (" is interface"); 8681 end if; 8682 8683 Write_Eol; 8684 8685 Elmt := First_Elmt (Primitive_Operations (Typ)); 8686 while Present (Elmt) loop 8687 Prim := Node (Elmt); 8688 Write_Str (" - "); 8689 8690 -- Indicate if this primitive will be allocated in the primary 8691 -- dispatch table or in a secondary dispatch table associated 8692 -- with an abstract interface type 8693 8694 if Present (DTC_Entity (Prim)) then 8695 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then 8696 Write_Str ("[P] "); 8697 else 8698 Write_Str ("[s] "); 8699 end if; 8700 end if; 8701 8702 -- Output the node of this primitive operation and its name 8703 8704 Write_Int (Int (Prim)); 8705 Write_Str (": "); 8706 8707 if Is_Predefined_Dispatching_Operation (Prim) then 8708 Write_Str ("(predefined) "); 8709 end if; 8710 8711 -- Prefix the name of the primitive with its corresponding tagged 8712 -- type to facilitate seeing inherited primitives. 8713 8714 if Present (Alias (Prim)) then 8715 Write_Name 8716 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); 8717 else 8718 Write_Name (Chars (Typ)); 8719 end if; 8720 8721 Write_Str ("."); 8722 Write_Name (Chars (Prim)); 8723 8724 -- Indicate if this primitive has an aliased primitive 8725 8726 if Present (Alias (Prim)) then 8727 Write_Str (" (alias = "); 8728 Write_Int (Int (Alias (Prim))); 8729 8730 -- If the DTC_Entity attribute is already set we can also output 8731 -- the name of the interface covered by this primitive (if any). 8732 8733 if Ekind (Alias (Prim)) in E_Function | E_Procedure 8734 and then Present (DTC_Entity (Alias (Prim))) 8735 and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) 8736 then 8737 Write_Str (" from interface "); 8738 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); 8739 end if; 8740 8741 if Present (Interface_Alias (Prim)) then 8742 Write_Str (", AI_Alias of "); 8743 8744 if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then 8745 Write_Str ("null primitive "); 8746 end if; 8747 8748 Write_Name 8749 (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); 8750 Write_Char (':'); 8751 Write_Int (Int (Interface_Alias (Prim))); 8752 end if; 8753 8754 Write_Str (")"); 8755 end if; 8756 8757 -- Display the final position of this primitive in its associated 8758 -- (primary or secondary) dispatch table. 8759 8760 if Present (DTC_Entity (Prim)) 8761 and then DT_Position (Prim) /= No_Uint 8762 then 8763 Write_Str (" at #"); 8764 Write_Int (UI_To_Int (DT_Position (Prim))); 8765 end if; 8766 8767 if Is_Abstract_Subprogram (Prim) then 8768 Write_Str (" is abstract;"); 8769 8770 -- Check if this is a null primitive 8771 8772 elsif Comes_From_Source (Prim) 8773 and then Ekind (Prim) = E_Procedure 8774 and then Null_Present (Parent (Prim)) 8775 then 8776 Write_Str (" is null;"); 8777 end if; 8778 8779 if Is_Eliminated (Ultimate_Alias (Prim)) then 8780 Write_Str (" (eliminated)"); 8781 end if; 8782 8783 if Is_Imported (Prim) 8784 and then Convention (Prim) = Convention_CPP 8785 then 8786 Write_Str (" (C++)"); 8787 end if; 8788 8789 Write_Eol; 8790 8791 Next_Elmt (Elmt); 8792 end loop; 8793 end Write_DT; 8794 8795end Exp_Disp; 8796