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