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