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