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