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