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