------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ D I S P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; with Exp_Ch6; use Exp_Ch6; with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; with Itypes; use Itypes; with Layout; use Layout; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Strub; use Strub; with SCIL_LL; use SCIL_LL; with Tbuild; use Tbuild; package body Exp_Disp is ----------------------- -- Local Subprograms -- ----------------------- function Default_Prim_Op_Position (E : Entity_Id) return Uint; -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. procedure Expand_Interface_Thunk (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out List_Id; Iface : Entity_Id); -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- generate additional subprograms (thunks) associated with each primitive -- Prim to have a layout compatible with the C++ ABI. The thunk displaces -- the pointers to the actuals that depend on the controlling type before -- transferring control to the target subprogram. If there is no need to -- generate the thunk, then Thunk_Id is set to Empty. Otherwise Thunk_Id -- is set to the defining identifier of the thunk and Thunk_Code to the -- code generated for the thunk respectively. procedure Expand_Secondary_Stack_Thunk (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id); -- When a primitive function of a tagged type can dispatch on result and -- the tagged type is not returned on the secondary stack, we generate an -- additional function (thunk) that calls the primitive function with the -- same actuals and move its result onto the secondary stack. This thunk -- is intended to be put into the slot of the primitive function in the -- dispatch table, so as to be invoked in lieu of the primitive function -- in dispatching calls. If there is no need to generate the thunk, then -- Thunk_Id is set to Empty. Otherwise Thunk_Id is set to the defining -- identifier of the thunk and Thunk_Code to the code generated for the -- thunk respectively. function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; -- Returns true if Prim is not a predefined dispatching primitive but it is -- an alias of a predefined dispatching primitive (i.e. through a renaming) function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call to -- Duplicate_Subexpr with an explicit dereference when From is an access -- parameter. function Prim_Op_Kind (Prim : Entity_Id; Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind -- enumeration value. function Tagged_Kind (T : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- to an RE_Tagged_Kind enumeration value. ---------------------- -- Apply_Tag_Checks -- ---------------------- procedure Apply_Tag_Checks (Call_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (Call_Node); Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); Param_List : constant List_Id := Parameter_Associations (Call_Node); Subp : Entity_Id; CW_Typ : Entity_Id; Param : Node_Id; Typ : Entity_Id; Eq_Prim_Op : Entity_Id := Empty; begin if No_Run_Time_Mode then Error_Msg_CRT ("tagged types", Call_Node); return; end if; -- Apply_Tag_Checks is called directly from the semantics, so we -- need a check to see whether expansion is active before proceeding. -- In addition, there is no need to expand the call when compiling -- under restriction No_Dispatching_Calls; the semantic analyzer has -- previously notified the violation of this restriction. if not Expander_Active or else Restriction_Active (No_Dispatching_Calls) then return; end if; -- Set subprogram. If this is an inherited operation that was -- overridden, the body that is being called is its alias. Subp := Entity (Name (Call_Node)); if Present (Alias (Subp)) and then Is_Inherited_Operation (Subp) and then No (DTC_Entity (Subp)) then Subp := Alias (Subp); end if; -- Definition of the class-wide type and the tagged type -- If the controlling argument is itself a tag rather than a tagged -- object, then use the class-wide type associated with the subprogram's -- controlling type. This case can occur when a call to an inherited -- primitive has an actual that originated from a default parameter -- given by a tag-indeterminate call and when there is no other -- controlling argument providing the tag (AI-239 requires dispatching). -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). if Is_RTE (Ctrl_Typ, RE_Tag) or else Is_RTE (Ctrl_Typ, RE_Interface_Tag) then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); -- Class_Wide_Type is applied to the expressions used to initialize -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since -- there are cases where the controlling type is resolved to a specific -- type (such as for designated types of arguments such as CW'Access). elsif Is_Access_Type (Ctrl_Typ) then CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); else CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; Typ := Find_Specific_Type (CW_Typ); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; -- Dispatching call to C++ primitive if Is_CPP_Class (Typ) then null; -- Dispatching call to Ada primitive elsif Present (Param_List) then -- Generate the Tag checks when appropriate Param := First_Actual (Call_Node); while Present (Param) loop -- No tag check with itself if Param = Ctrl_Arg then null; -- No tag check for parameter whose type is neither tagged nor -- access to tagged (for access parameters) elsif No (Find_Controlling_Arg (Param)) then null; -- No tag check for function dispatching on result if the -- Tag given by the context is this one elsif Find_Controlling_Arg (Param) = Ctrl_Arg then null; -- "=" is the only dispatching operation allowed to get operands -- with incompatible tags (it just returns false). We use -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node -- because the value will be duplicated to check the tags. elsif Subp = Eq_Prim_Op then null; -- No check in presence of suppress flags elsif Tag_Checks_Suppressed (Etype (Param)) or else (Is_Access_Type (Etype (Param)) and then Tag_Checks_Suppressed (Designated_Type (Etype (Param)))) then null; -- Optimization: no tag checks if the parameters are identical elsif Is_Entity_Name (Param) and then Is_Entity_Name (Ctrl_Arg) and then Entity (Param) = Entity (Ctrl_Arg) then null; -- Now we need to generate the Tag check else -- Generate code for tag equality check -- Perhaps should have Checks.Apply_Tag_Equality_Check??? Insert_Action (Ctrl_Arg, Make_Implicit_If_Statement (Call_Node, Condition => Make_Op_Ne (Loc, Left_Opnd => Make_Selected_Component (Loc, Prefix => New_Value (Ctrl_Arg), Selector_Name => New_Occurrence_Of (First_Tag_Component (Typ), Loc)), Right_Opnd => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, New_Value (Param)), Selector_Name => New_Occurrence_Of (First_Tag_Component (Typ), Loc))), Then_Statements => New_List (New_Constraint_Error (Loc)))); end if; Next_Actual (Param); end loop; end if; end Apply_Tag_Checks; ------------------------ -- Building_Static_DT -- ------------------------ function Building_Static_DT (Typ : Entity_Id) return Boolean is Root_Typ : Entity_Id := Root_Type (Typ); Static_DT : Boolean; begin -- Handle private types if Present (Full_View (Root_Typ)) then Root_Typ := Full_View (Root_Typ); end if; Static_DT := Building_Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) -- If the type is derived from a CPP class we cannot statically -- build the dispatch tables because we must inherit primitives -- from the CPP side. and then not Is_CPP_Class (Root_Typ); if not Static_DT then Check_Restriction (Static_Dispatch_Tables, Typ); end if; return Static_DT; end Building_Static_DT; ---------------------------------- -- Building_Static_Secondary_DT -- ---------------------------------- function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is Full_Typ : Entity_Id := Typ; Root_Typ : Entity_Id := Root_Type (Typ); Static_DT : Boolean; begin -- Handle private types if Present (Full_View (Typ)) then Full_Typ := Full_View (Typ); end if; if Present (Full_View (Root_Typ)) then Root_Typ := Full_View (Root_Typ); end if; Static_DT := Building_Static_DT (Full_Typ) and then not Is_Interface (Full_Typ) and then Has_Interfaces (Full_Typ) and then (Full_Typ = Root_Typ or else not Is_Variable_Size_Record (Etype (Full_Typ))); if not Static_DT and then not Is_Interface (Full_Typ) and then Has_Interfaces (Full_Typ) then Check_Restriction (Static_Dispatch_Tables, Typ); end if; return Static_DT; end Building_Static_Secondary_DT; ---------------------------------- -- Build_Static_Dispatch_Tables -- ---------------------------------- procedure Build_Static_Dispatch_Tables (N : Node_Id) is Target_List : List_Id; procedure Build_Dispatch_Tables (List : List_Id); -- Build the static dispatch table of tagged types found in the list of -- declarations. The generated nodes are added at the end of Target_List procedure Build_Package_Dispatch_Tables (N : Node_Id); -- Build static dispatch tables associated with package declaration N procedure Make_And_Insert_Dispatch_Table (Typ : Entity_Id); -- Build the dispatch table of the tagged type Typ and insert it at the -- end of Target_List after wrapping it in the Actions list of a freeze -- node, so that it is skipped by Sem_Elab (Expand_Freeze_Record_Type -- does the same for nonstatic dispatch tables). --------------------------- -- Build_Dispatch_Tables -- --------------------------- procedure Build_Dispatch_Tables (List : List_Id) is D : Node_Id; begin D := First (List); while Present (D) loop -- Handle nested packages and package bodies recursively. The -- generated code is placed on the Target_List established for -- the enclosing compilation unit. if Nkind (D) = N_Package_Declaration then Build_Package_Dispatch_Tables (D); elsif Nkind (D) = N_Package_Body then Build_Dispatch_Tables (Declarations (D)); elsif Nkind (D) = N_Package_Body_Stub and then Present (Library_Unit (D)) then Build_Dispatch_Tables (Declarations (Proper_Body (Unit (Library_Unit (D))))); -- Handle full type declarations and derivations of library level -- tagged types elsif Nkind (D) in N_Full_Type_Declaration | N_Derived_Type_Definition and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) and then Ekind (Defining_Entity (D)) /= E_Record_Subtype and then not Is_Private_Type (Defining_Entity (D)) then -- We do not generate dispatch tables for the internal types -- created for a type extension with unknown discriminants -- The needed information is shared with the source type, -- See Expand_N_Record_Extension. if Is_Underlying_Record_View (Defining_Entity (D)) or else (not Comes_From_Source (Defining_Entity (D)) and then Has_Unknown_Discriminants (Etype (Defining_Entity (D))) and then not Comes_From_Source (First_Subtype (Defining_Entity (D)))) then null; else Make_And_Insert_Dispatch_Table (Defining_Entity (D)); end if; -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct -- expansion. If the full view is a synchronized type ignore -- the type because the table will be built for the corresponding -- record type, that has its own declaration. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) then declare E1 : constant Entity_Id := Defining_Entity (D); E2 : constant Entity_Id := Full_View (E1); begin if Is_Library_Level_Tagged_Type (E2) and then Ekind (E2) /= E_Record_Subtype and then not Is_Concurrent_Type (E2) then Exchange_Declarations (E1); Make_And_Insert_Dispatch_Table (E1); Exchange_Declarations (E2); end if; end; end if; Next (D); end loop; end Build_Dispatch_Tables; ----------------------------------- -- Build_Package_Dispatch_Tables -- ----------------------------------- procedure Build_Package_Dispatch_Tables (N : Node_Id) is Spec : constant Node_Id := Specification (N); Id : constant Entity_Id := Defining_Entity (N); Vis_Decls : constant List_Id := Visible_Declarations (Spec); Priv_Decls : constant List_Id := Private_Declarations (Spec); begin Push_Scope (Id); if Present (Priv_Decls) then Build_Dispatch_Tables (Vis_Decls); Build_Dispatch_Tables (Priv_Decls); elsif Present (Vis_Decls) then Build_Dispatch_Tables (Vis_Decls); end if; Pop_Scope; end Build_Package_Dispatch_Tables; ------------------------------------ -- Make_And_Insert_Dispatch_Table -- ------------------------------------ procedure Make_And_Insert_Dispatch_Table (Typ : Entity_Id) is F_Typ : constant Entity_Id := Create_Itype (E_Class_Wide_Type, Typ); -- The code generator discards freeze nodes of CW types after -- evaluating their side effects, so create an artificial one. F_Nod : constant Node_Id := Make_Freeze_Entity (Sloc (Typ)); begin Set_Is_Frozen (F_Typ); Set_Entity (F_Nod, F_Typ); Set_Actions (F_Nod, Make_DT (Typ)); Insert_After_And_Analyze (Last (Target_List), F_Nod); end Make_And_Insert_Dispatch_Table; -- Start of processing for Build_Static_Dispatch_Tables begin if Nkind (N) = N_Package_Declaration then declare Spec : constant Node_Id := Specification (N); Vis_Decls : constant List_Id := Visible_Declarations (Spec); Priv_Decls : constant List_Id := Private_Declarations (Spec); begin if Present (Priv_Decls) and then Is_Non_Empty_List (Priv_Decls) then Target_List := Priv_Decls; elsif not Present (Vis_Decls) then Target_List := New_List; Set_Private_Declarations (Spec, Target_List); else Target_List := Vis_Decls; end if; Build_Package_Dispatch_Tables (N); end; else pragma Assert (Nkind (N) = N_Package_Body); declare Spec_Id : constant Entity_Id := Corresponding_Spec (N); begin Push_Scope (Spec_Id); Target_List := Declarations (N); Build_Dispatch_Tables (Target_List); Pop_Scope; end; end if; end Build_Static_Dispatch_Tables; ------------------------------ -- Convert_Tag_To_Interface -- ------------------------------ function Convert_Tag_To_Interface (Typ : Entity_Id; Expr : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); Anon_Type : Entity_Id; Result : Node_Id; begin pragma Assert (Is_Class_Wide_Type (Typ) and then Is_Interface (Typ) and then ((Nkind (Expr) = N_Selected_Component and then Is_Tag (Entity (Selector_Name (Expr)))) or else (Nkind (Expr) = N_Function_Call and then Is_RTE (Entity (Name (Expr)), RE_Displace)))); Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr); Set_Directly_Designated_Type (Anon_Type, Typ); Set_Etype (Anon_Type, Anon_Type); Set_Can_Never_Be_Null (Anon_Type); -- Decorate the size and alignment attributes of the anonymous access -- type, as required by the back end. Layout_Type (Anon_Type); if Nkind (Expr) = N_Selected_Component and then Is_Tag (Entity (Selector_Name (Expr))) then Result := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Anon_Type, Make_Attribute_Reference (Loc, Prefix => Expr, Attribute_Name => Name_Address))); else Result := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Anon_Type, Expr)); end if; return Result; end Convert_Tag_To_Interface; ------------------- -- CPP_Num_Prims -- ------------------- function CPP_Num_Prims (Typ : Entity_Id) return Nat is CPP_Typ : Entity_Id; Tag_Comp : Entity_Id; begin if not Is_Tagged_Type (Typ) or else not Is_CPP_Class (Root_Type (Typ)) then return 0; else CPP_Typ := Enclosing_CPP_Parent (Typ); Tag_Comp := First_Tag_Component (CPP_Typ); -- If number of primitives already set in the tag component, use it if Present (Tag_Comp) and then Present (DT_Entry_Count (Tag_Comp)) then return UI_To_Int (DT_Entry_Count (Tag_Comp)); -- Otherwise, count the primitives of the enclosing CPP type else return List_Length (Primitive_Operations (CPP_Typ)); end if; end if; end CPP_Num_Prims; ------------------------------ -- Default_Prim_Op_Position -- ------------------------------ function Default_Prim_Op_Position (E : Entity_Id) return Uint is TSS_Name : TSS_Name_Type; begin Get_Name_String (Chars (E)); TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) = Name_uSize then return Uint_1; elsif TSS_Name = TSS_Stream_Read then return Uint_2; elsif TSS_Name = TSS_Stream_Write then return Uint_3; elsif TSS_Name = TSS_Stream_Input then return Uint_4; elsif TSS_Name = TSS_Stream_Output then return Uint_5; elsif Chars (E) = Name_Op_Eq then return Uint_6; elsif Chars (E) = Name_uAssign then return Uint_7; elsif TSS_Name = TSS_Deep_Adjust then return Uint_8; elsif TSS_Name = TSS_Deep_Finalize then return Uint_9; elsif TSS_Name = TSS_Put_Image then return Uint_10; -- In VM targets unconditionally allow obtaining the position associated -- with predefined interface primitives since in these platforms any -- tagged type has these primitives. elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then if Chars (E) = Name_uDisp_Asynchronous_Select then return Uint_11; elsif Chars (E) = Name_uDisp_Conditional_Select then return Uint_12; elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then return Uint_13; elsif Chars (E) = Name_uDisp_Get_Task_Id then return Uint_14; elsif Chars (E) = Name_uDisp_Requeue then return Uint_15; elsif Chars (E) = Name_uDisp_Timed_Select then return Uint_16; end if; end if; raise Program_Error; end Default_Prim_Op_Position; ---------------------- -- Elab_Flag_Needed -- ---------------------- function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is begin return Ada_Version >= Ada_2005 and then not Is_Interface (Typ) and then Has_Interfaces (Typ) and then not Building_Static_DT (Typ); end Elab_Flag_Needed; ----------------------------- -- Expand_Dispatching_Call -- ----------------------------- procedure Expand_Dispatching_Call (Call_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (Call_Node); Call_Typ : constant Entity_Id := Etype (Call_Node); Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); Param_List : constant List_Id := Parameter_Associations (Call_Node); Subp : Entity_Id; CW_Typ : Entity_Id; New_Call : Node_Id; New_Call_Name : Node_Id; New_Params : List_Id := No_List; Param : Node_Id; Subp_Ptr_Typ : Entity_Id; Subp_Typ : Entity_Id; Typ : Entity_Id; Eq_Prim_Op : Entity_Id := Empty; Controlling_Tag : Node_Id; function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an -- access parameter. --------------- -- New_Value -- --------------- function New_Value (From : Node_Id) return Node_Id is Res : constant Node_Id := Duplicate_Subexpr (From); begin if Is_Access_Type (Etype (From)) then return Make_Explicit_Dereference (Sloc (From), Prefix => Res); else return Res; end if; end New_Value; -- Local variables New_Node : Node_Id; SCIL_Node : Node_Id := Empty; SCIL_Related_Node : Node_Id := Call_Node; -- Start of processing for Expand_Dispatching_Call begin if No_Run_Time_Mode then Error_Msg_CRT ("tagged types", Call_Node); return; end if; -- Expand_Dispatching_Call is called directly from the semantics, so we -- only proceed if the expander is active. if not Expander_Active -- And there is no need to expand the call if we are compiling under -- restriction No_Dispatching_Calls; the semantic analyzer has -- previously notified the violation of this restriction. or else Restriction_Active (No_Dispatching_Calls) -- No action needed if the dispatching call has been already expanded or else Is_Expanded_Dispatching_Call (Name (Call_Node)) then return; end if; -- Set subprogram. If this is an inherited operation that was -- overridden, the body that is being called is its alias. Subp := Entity (Name (Call_Node)); if Present (Alias (Subp)) and then Is_Inherited_Operation (Subp) and then No (DTC_Entity (Subp)) then Subp := Alias (Subp); end if; -- Definition of the class-wide type and the tagged type -- If the controlling argument is itself a tag rather than a tagged -- object, then use the class-wide type associated with the subprogram's -- controlling type. This case can occur when a call to an inherited -- primitive has an actual that originated from a default parameter -- given by a tag-indeterminate call and when there is no other -- controlling argument providing the tag (AI-239 requires dispatching). -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). if Is_RTE (Ctrl_Typ, RE_Tag) or else Is_RTE (Ctrl_Typ, RE_Interface_Tag) then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); -- Class_Wide_Type is applied to the expressions used to initialize -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since -- there are cases where the controlling type is resolved to a specific -- type (such as for designated types of arguments such as CW'Access). elsif Is_Access_Type (Ctrl_Typ) then CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); else CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; Typ := Find_Specific_Type (CW_Typ); -- The tagged type of a dispatching call must be frozen at this stage pragma Assert (Is_Frozen (Typ)); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; -- Dispatching call to C++ primitive. Create a new parameter list -- with no tag checks. New_Params := New_List; if Is_CPP_Class (Typ) then Param := First_Actual (Call_Node); while Present (Param) loop Append_To (New_Params, Relocate_Node (Param)); Next_Actual (Param); end loop; -- Dispatching call to Ada primitive elsif Present (Param_List) then Apply_Tag_Checks (Call_Node); Param := First_Actual (Call_Node); while Present (Param) loop -- Cases in which we may have generated run-time checks. Note that -- we strip any qualification from Param before comparing with the -- already-stripped controlling argument. if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then Append_To (New_Params, Duplicate_Subexpr_Move_Checks (Param)); elsif Nkind (Parent (Param)) /= N_Parameter_Association or else not Is_Accessibility_Actual (Parent (Param)) then Append_To (New_Params, Relocate_Node (Param)); end if; Next_Actual (Param); end loop; end if; -- Generate the appropriate subprogram designated type Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); Copy_Strub_Mode (Subp_Typ, Subp); Set_Convention (Subp_Typ, Convention (Subp)); -- If this is a function and it has a controlling tagged result, then -- the call is dispatching on result and returns the class-wide type. if Ekind (Subp) = E_Function and then Has_Controlling_Result (Subp) and then Is_Tagged_Type (Etype (Subp)) then Set_Etype (Subp_Typ, Class_Wide_Type (Etype (Subp))); Set_Returns_By_Ref (Subp_Typ, True); else Set_Etype (Subp_Typ, Etype (Subp)); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); end if; -- Notify gigi that the designated type is a dispatching primitive Set_Is_Dispatch_Table_Entity (Subp_Typ); -- Create a new list of parameters which is a copy of the old formal -- list including the creation of a new set of matching entities. declare Old_Formal : Entity_Id := First_Formal (Subp); New_Formal : Entity_Id; Last_Formal : Entity_Id := Empty; begin if Present (Old_Formal) then New_Formal := New_Copy (Old_Formal); Set_First_Entity (Subp_Typ, New_Formal); Param := First_Actual (Call_Node); loop Set_Scope (New_Formal, Subp_Typ); -- Change all the controlling argument types to be class-wide -- to avoid a recursion in dispatching. if Is_Controlling_Formal (New_Formal) then Set_Etype (New_Formal, Etype (Param)); end if; -- If the type of the formal is an itype, there was code here -- introduced in 1998 in revision 1.46, to create a new itype -- by copy. This seems useless, and in fact leads to semantic -- errors when the itype is the completion of a type derived -- from a private type. Last_Formal := New_Formal; Next_Formal (Old_Formal); exit when No (Old_Formal); Link_Entities (New_Formal, New_Copy (Old_Formal)); Next_Entity (New_Formal); Next_Actual (Param); end loop; Unlink_Next_Entity (New_Formal); Set_Last_Entity (Subp_Typ, Last_Formal); end if; -- Now that the explicit formals have been duplicated, any extra -- formals needed by the subprogram must be duplicated; we know -- that extra formals are available because they were added when -- the tagged type was frozen (see Expand_Freeze_Record_Type). pragma Assert (Is_Frozen (Typ)); -- Warning: The addition of the extra formals cannot be performed -- here invoking Create_Extra_Formals since we must ensure that all -- the extra formals of the pointer type and the target subprogram -- match (and for functions that return a tagged type the profile of -- the built subprogram type always returns a class-wide type, which -- may affect the addition of some extra formals). if Present (Last_Formal) and then Present (Extra_Formal (Last_Formal)) then Old_Formal := Extra_Formal (Last_Formal); New_Formal := New_Copy (Old_Formal); Set_Scope (New_Formal, Subp_Typ); Set_Extra_Formal (Last_Formal, New_Formal); Set_Extra_Formals (Subp_Typ, New_Formal); if Ekind (Subp) = E_Function and then Present (Extra_Accessibility_Of_Result (Subp)) and then Extra_Accessibility_Of_Result (Subp) = Old_Formal then Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); end if; Old_Formal := Extra_Formal (Old_Formal); while Present (Old_Formal) loop Set_Extra_Formal (New_Formal, New_Copy (Old_Formal)); New_Formal := Extra_Formal (New_Formal); Set_Scope (New_Formal, Subp_Typ); if Ekind (Subp) = E_Function and then Present (Extra_Accessibility_Of_Result (Subp)) and then Extra_Accessibility_Of_Result (Subp) = Old_Formal then Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); end if; Old_Formal := Extra_Formal (Old_Formal); end loop; end if; end; -- Generate the appropriate subprogram pointer type and decorate it Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); Layout_Type (Subp_Ptr_Typ); -- If the controlling argument is a value of type Ada.Tag or an abstract -- interface class-wide type then use it directly. Otherwise, the tag -- must be extracted from the controlling object. if Is_RTE (Ctrl_Typ, RE_Tag) or else Is_RTE (Ctrl_Typ, RE_Interface_Tag) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); -- Extract the tag from an unchecked type conversion. Done to avoid -- the expansion of additional code just to obtain the value of such -- tag because the current management of interface type conversions -- generates in some cases this unchecked type conversion with the -- tag of the object (see Expand_Interface_Conversion). elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion and then (Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Tag) or else Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Interface_Tag)) then Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg)); -- Ada 2005 (AI-251): Abstract interface class-wide type elsif Is_Interface (Ctrl_Typ) and then Is_Class_Wide_Type (Ctrl_Typ) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); elsif Is_Access_Type (Ctrl_Typ) then Controlling_Tag := Make_Selected_Component (Loc, Prefix => Make_Explicit_Dereference (Loc, Duplicate_Subexpr_Move_Checks (Ctrl_Arg)), Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc)); else Controlling_Tag := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc)); end if; -- Handle dispatching calls to predefined primitives if Is_Predefined_Dispatching_Operation (Subp) or else Is_Predefined_Dispatching_Alias (Subp) then Build_Get_Predefined_Prim_Op_Address (Loc, Tag_Node => Controlling_Tag, Position => DT_Position (Subp), New_Node => New_Node); -- Handle dispatching calls to user-defined primitives else Build_Get_Prim_Op_Address (Loc, Typ => Underlying_Type (Find_Dispatching_Type (Subp)), Tag_Node => Controlling_Tag, Position => DT_Position (Subp), New_Node => New_Node); end if; New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); -- Generate the SCIL node for this dispatching call. Done now because -- attribute SCIL_Controlling_Tag must be set after the new call name -- is built to reference the nodes that will see the SCIL backend -- (because Build_Get_Prim_Op_Address generates an unchecked type -- conversion which relocates the controlling tag node). if Generate_SCIL then SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); Set_SCIL_Entity (SCIL_Node, Typ); Set_SCIL_Target_Prim (SCIL_Node, Subp); -- Common case: the controlling tag is the tag of an object -- (for example, obj.tag) if Nkind (Controlling_Tag) = N_Selected_Component then Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); -- Handle renaming of selected component elsif Nkind (Controlling_Tag) = N_Identifier and then Nkind (Parent (Entity (Controlling_Tag))) = N_Object_Renaming_Declaration and then Nkind (Name (Parent (Entity (Controlling_Tag)))) = N_Selected_Component then Set_SCIL_Controlling_Tag (SCIL_Node, Name (Parent (Entity (Controlling_Tag)))); -- If the controlling tag is an identifier, the SCIL node references -- the corresponding object or parameter declaration elsif Nkind (Controlling_Tag) = N_Identifier and then Nkind (Parent (Entity (Controlling_Tag))) in N_Object_Declaration | N_Parameter_Specification then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Controlling_Tag))); -- If the controlling tag is a dereference, the SCIL node references -- the corresponding object or parameter declaration elsif Nkind (Controlling_Tag) = N_Explicit_Dereference and then Nkind (Prefix (Controlling_Tag)) = N_Identifier and then Nkind (Parent (Entity (Prefix (Controlling_Tag)))) in N_Object_Declaration | N_Parameter_Specification then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Prefix (Controlling_Tag)))); -- For a direct reference of the tag of the type the SCIL node -- references the internal object declaration containing the tag -- of the type. elsif Nkind (Controlling_Tag) = N_Attribute_Reference and then Attribute_Name (Controlling_Tag) = Name_Tag then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Node (First_Elmt (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); -- Interfaces are not supported. For now we leave the SCIL node -- decorated with the Controlling_Tag. More work needed here??? elsif Is_Interface (Etype (Controlling_Tag)) then Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); else pragma Assert (False); null; end if; end if; if Nkind (Call_Node) = N_Function_Call then New_Call := Make_Function_Call (Loc, Name => New_Call_Name, Parameter_Associations => New_Params); -- If this is a dispatching "=", we must first compare the tags so -- we generate: x.tag = y.tag and then x = y if Subp = Eq_Prim_Op then Param := First_Actual (Call_Node); New_Call := Make_And_Then (Loc, Left_Opnd => Make_Op_Eq (Loc, Left_Opnd => Make_Selected_Component (Loc, Prefix => New_Value (Param), Selector_Name => New_Occurrence_Of (First_Tag_Component (Typ), Loc)), Right_Opnd => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, New_Value (Next_Actual (Param))), Selector_Name => New_Occurrence_Of (First_Tag_Component (Typ), Loc))), Right_Opnd => New_Call); SCIL_Related_Node := Right_Opnd (New_Call); end if; else New_Call := Make_Procedure_Call_Statement (Loc, Name => New_Call_Name, Parameter_Associations => New_Params); end if; -- Register the dispatching call in the call graph nodes table Register_CG_Node (Call_Node); Rewrite (Call_Node, New_Call); -- Associate the SCIL node of this dispatching call if Generate_SCIL then Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); end if; -- Suppress all checks during the analysis of the expanded code to avoid -- the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); end Expand_Dispatching_Call; --------------------------------- -- Expand_Interface_Conversion -- --------------------------------- procedure Expand_Interface_Conversion (N : Node_Id) is function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id; -- Return the underlying record type of Typ ---------------------------- -- Underlying_Record_Type -- ---------------------------- function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is E : Entity_Id := Typ; begin -- Handle access types if Is_Access_Type (E) then E := Directly_Designated_Type (E); end if; -- Handle class-wide types. This conversion can appear explicitly in -- the source code. Example: I'Class (Obj) if Is_Class_Wide_Type (E) then E := Root_Type (E); end if; -- If the target type is a tagged synchronized type, the dispatch -- table info is in the corresponding record type. if Is_Concurrent_Type (E) then E := Corresponding_Record_Type (E); end if; -- Handle private types E := Underlying_Type (E); -- Handle subtypes return Base_Type (E); end Underlying_Record_Type; -- Local variables Loc : constant Source_Ptr := Sloc (N); Etyp : constant Entity_Id := Etype (N); Operand : constant Node_Id := Expression (N); Operand_Typ : Entity_Id := Etype (Operand); Func : Node_Id; Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N)); Iface_Tag : Entity_Id; Is_Static : Boolean; -- Start of processing for Expand_Interface_Conversion begin -- Freeze the entity associated with the target interface to have -- available the attribute Access_Disp_Table. Freeze_Before (N, Iface_Typ); -- Ada 2005 (AI-345): Handle synchronized interface type derivations if Is_Concurrent_Type (Operand_Typ) then Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); end if; -- No displacement of the pointer to the object needed when the type of -- the operand is not an interface type and the interface is one of -- its parent types (since they share the primary dispatch table). declare Opnd : Entity_Id := Operand_Typ; begin if Is_Access_Type (Opnd) then Opnd := Designated_Type (Opnd); end if; Opnd := Underlying_Record_Type (Opnd); if not Is_Interface (Opnd) and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) then return; end if; -- When the type of the operand and the target interface type match, -- it is generally safe to skip generating code to displace the -- pointer to the object to reference the secondary dispatch table -- associated with the target interface type. The exception to this -- general rule is when the underlying object of the type conversion -- is an object built by means of a dispatching constructor (since in -- such case the expansion of the constructor call is a direct call -- to an object primitive, i.e. without thunks, and the expansion of -- the constructor call adds an explicit conversion to the target -- interface type to force the displacement of the pointer to the -- object to reference the corresponding secondary dispatch table -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)). -- At this stage we cannot identify whether the underlying object is -- a BIP object and hence we cannot skip generating the code to try -- displacing the pointer to the object. However, under configurable -- runtime it is safe to skip generating code to displace the pointer -- to the object, because generic dispatching constructors are not -- supported. if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then return; end if; end; -- Evaluate if we can statically displace the pointer to the object declare Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ); begin Is_Static := not Is_Interface (Opnd_Typ) and then Interface_Present_In_Ancestor (Typ => Opnd_Typ, Iface => Iface_Typ) and then (Etype (Opnd_Typ) = Opnd_Typ or else not Is_Variable_Size_Record (Etype (Opnd_Typ))); end; if not Tagged_Type_Expansion then return; -- A static conversion to an interface type that is not class-wide is -- curious but legal if the interface operation is a null procedure. -- If the operation is abstract it will be rejected later. elsif Is_Static and then Is_Interface (Etype (N)) and then not Is_Class_Wide_Type (Etype (N)) and then Comes_From_Source (N) then Rewrite (N, Unchecked_Convert_To (Etype (N), N)); Analyze (N); return; end if; if not Is_Static then -- Give error if configurable run-time and Displace not available if not RTE_Available (RE_Displace) then Error_Msg_CRT ("dynamic interface conversion", N); return; end if; -- Handle conversion of access-to-class-wide interface types. Target -- can be an access to an object or an access to another class-wide -- interface (see -1- and -2- in the following example): -- type Iface1_Ref is access all Iface1'Class; -- type Iface2_Ref is access all Iface1'Class; -- Acc1 : Iface1_Ref := new ... -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 if Is_Access_Type (Operand_Typ) then Rewrite (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Displace), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Relocate_Node (Expression (N))), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), Loc))))); Analyze (N); return; end if; Rewrite (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Displace), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Relocate_Node (Expression (N)), Attribute_Name => Name_Address), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), Loc)))); Analyze (N); -- If target is a class-wide interface, change the type of the data -- returned by IW_Convert to indicate this is a dispatching call. declare New_Itype : Entity_Id; begin New_Itype := Create_Itype (E_Anonymous_Access_Type, N); Set_Etype (New_Itype, New_Itype); Set_Directly_Designated_Type (New_Itype, Etyp); Rewrite (N, Make_Explicit_Dereference (Loc, Prefix => Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); Analyze (N); Freeze_Itype (New_Itype, N); return; end; end if; Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); pragma Assert (Present (Iface_Tag)); -- Keep separate access types to interfaces because one internal -- function is used to handle the null value (see following comments) if not Is_Access_Type (Etype (N)) then -- Statically displace the pointer to the object to reference the -- component containing the secondary dispatch table. Rewrite (N, Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ), Make_Selected_Component (Loc, Prefix => Relocate_Node (Expression (N)), Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)))); else -- Build internal function to handle the case in which the actual is -- null. If the actual is null returns null because no displacement -- is required; otherwise performs a type conversion that will be -- expanded in the code that returns the value of the displaced -- actual. That is: -- function Func (O : Address) return Iface_Typ is -- type Op_Typ is access all Operand_Typ; -- Aux : Op_Typ := To_Op_Typ (O); -- begin -- if O = Null_Address then -- return null; -- else -- return Iface_Typ!(Aux.Iface_Tag'Address); -- end if; -- end Func; declare Desig_Typ : Entity_Id; Fent : Entity_Id; New_Typ_Decl : Node_Id; Stats : List_Id; begin Desig_Typ := Etype (Expression (N)); if Is_Access_Type (Desig_Typ) then Desig_Typ := Available_View (Directly_Designated_Type (Desig_Typ)); end if; if Is_Concurrent_Type (Desig_Typ) then Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ)); end if; New_Typ_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => False, Constant_Present => False, Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))); Stats := New_List ( Make_Simple_Return_Statement (Loc, Unchecked_Convert_To (Etype (N), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl), Make_Identifier (Loc, Name_uO)), Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)), Attribute_Name => Name_Address)))); -- If the type is null-excluding, no need for the null branch. -- Otherwise we need to check for it and return null. if not Can_Never_Be_Null (Etype (N)) then Stats := New_List ( Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => Make_Identifier (Loc, Name_uO), Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Make_Null (Loc))), Else_Statements => Stats)); end if; Fent := Make_Temporary (Loc, 'F'); Func := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Fent, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc))), Result_Definition => New_Occurrence_Of (Etype (N), Loc)), Declarations => New_List (New_Typ_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stats)); -- Place function body before the expression containing the -- conversion. We suppress all checks because the body of the -- internally generated function already takes care of the case -- in which the actual is null; therefore there is no need to -- double check that the pointer is not null when the program -- executes the alternative that performs the type conversion). Insert_Action (N, Func, Suppress => All_Checks); if Is_Access_Type (Etype (Expression (N))) then -- Generate: Func (Address!(Expression)) Rewrite (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (Fent, Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Relocate_Node (Expression (N)))))); else -- Generate: Func (Operand_Typ!(Expression)'Address) Rewrite (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (Fent, Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Unchecked_Convert_To (Operand_Typ, Relocate_Node (Expression (N))), Attribute_Name => Name_Address)))); end if; end; end if; Analyze (N); end Expand_Interface_Conversion; ------------------------------ -- Expand_Interface_Actuals -- ------------------------------ procedure Expand_Interface_Actuals (Call_Node : Node_Id) is Actual : Node_Id; Actual_Dup : Node_Id; Actual_Typ : Entity_Id; Anon : Entity_Id; Conversion : Node_Id; Formal : Entity_Id; Formal_Typ : Entity_Id; Subp : Entity_Id; Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning begin -- This subprogram is called directly from the semantics, so we need a -- check to see whether expansion is active before proceeding. if not Expander_Active then return; end if; -- Call using access to subprogram with explicit dereference if Nkind (Name (Call_Node)) = N_Explicit_Dereference then Subp := Etype (Name (Call_Node)); -- Call using selected component elsif Nkind (Name (Call_Node)) = N_Selected_Component then Subp := Entity (Selector_Name (Name (Call_Node))); -- Call using direct name else Subp := Entity (Name (Call_Node)); end if; -- Ada 2005 (AI-251): Look for interface type formals to force "this" -- displacement Formal := First_Formal (Subp); Actual := First_Actual (Call_Node); while Present (Formal) loop Formal_Typ := Etype (Formal); if Has_Non_Limited_View (Formal_Typ) then Formal_Typ := Non_Limited_View (Formal_Typ); end if; if Ekind (Formal_Typ) = E_Record_Type_With_Private then Formal_Typ := Full_View (Formal_Typ); end if; if Is_Access_Type (Formal_Typ) then Formal_DDT := Directly_Designated_Type (Formal_Typ); if Has_Non_Limited_View (Formal_DDT) then Formal_DDT := Non_Limited_View (Formal_DDT); end if; end if; Actual_Typ := Etype (Actual); if Has_Non_Limited_View (Actual_Typ) then Actual_Typ := Non_Limited_View (Actual_Typ); end if; if Is_Access_Type (Actual_Typ) then Actual_DDT := Directly_Designated_Type (Actual_Typ); if Has_Non_Limited_View (Actual_DDT) then Actual_DDT := Non_Limited_View (Actual_DDT); end if; end if; if Is_Interface (Formal_Typ) and then Is_Class_Wide_Type (Formal_Typ) then -- No need to displace the pointer if the type of the actual -- coincides with the type of the formal. if Actual_Typ = Formal_Typ then null; -- No need to displace the pointer if the interface type is a -- parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. elsif Is_Ancestor (Formal_Typ, Actual_Typ, Use_Full_View => True) then null; -- Implicit conversion to the class-wide formal type to force the -- displacement of the pointer. else -- Normally, expansion of actuals for calls to build-in-place -- functions happens as part of Expand_Actuals, but in this -- case the call will be wrapped in a conversion and soon after -- expanded further to handle the displacement for a class-wide -- interface conversion, so if this is a BIP call then we need -- to handle it now. if Is_Build_In_Place_Function_Call (Actual) then Make_Build_In_Place_Call_In_Anonymous_Context (Actual); end if; Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_Typ); end if; -- Access to class-wide interface type elsif Is_Access_Type (Formal_Typ) and then Is_Interface (Formal_DDT) and then Is_Class_Wide_Type (Formal_DDT) and then Interface_Present_In_Ancestor (Typ => Actual_DDT, Iface => Etype (Formal_DDT)) then -- Handle attributes 'Access and 'Unchecked_Access if Nkind (Actual) = N_Attribute_Reference and then (Attribute_Name (Actual) = Name_Access or else Attribute_Name (Actual) = Name_Unchecked_Access) then -- This case must have been handled by the analysis and -- expansion of 'Access. The only exception is when types -- match and no further expansion is required. pragma Assert (Base_Type (Etype (Prefix (Actual))) = Base_Type (Formal_DDT)); null; -- No need to displace the pointer if the type of the actual -- coincides with the type of the formal. elsif Actual_DDT = Formal_DDT then null; -- No need to displace the pointer if the interface type is -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. elsif Is_Ancestor (Formal_DDT, Actual_DDT, Use_Full_View => True) then null; else Actual_Dup := Relocate_Node (Actual); if From_Limited_With (Actual_Typ) then -- If the type of the actual parameter comes from a limited -- with_clause and the nonlimited view is already available, -- we replace the anonymous access type by a duplicate -- declaration whose designated type is the nonlimited view. if Has_Non_Limited_View (Actual_DDT) then Anon := New_Copy (Actual_Typ); if Is_Itype (Anon) then Set_Scope (Anon, Current_Scope); end if; Set_Directly_Designated_Type (Anon, Non_Limited_View (Actual_DDT)); Set_Etype (Actual_Dup, Anon); end if; end if; Conversion := Convert_To (Formal_Typ, Actual_Dup); Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_Typ); end if; end if; Next_Actual (Actual); Next_Formal (Formal); end loop; end Expand_Interface_Actuals; ---------------------------- -- Expand_Interface_Thunk -- ---------------------------- procedure Expand_Interface_Thunk (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out List_Id; Iface : Entity_Id) is Actuals : constant List_Id := New_List; Decl : constant List_Id := New_List; Formals : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Prim); Target : constant Entity_Id := Ultimate_Alias (Prim); Is_Predef_Op : constant Boolean := Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Operation (Target); Decl_1 : Node_Id; Decl_2 : Node_Id; Expr : Node_Id; Formal : Entity_Id; Ftyp : Entity_Id; Iface_Formal : Entity_Id; New_Arg : Node_Id; Offset_To_Top : Node_Id; Target_Formal : Entity_Id; begin Thunk_Id := Empty; Thunk_Code := Empty_List; -- No thunk needed if the primitive has been eliminated if Is_Eliminated (Target) then return; -- No thunk needed if the primitive has no formals. In this case, this -- must be a function with a controlling result. elsif No (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); return; end if; -- Duplicate the formals of the target primitive. In the thunk, the type -- of the controlling formal is the covered interface type (instead of -- the target tagged type). Done to avoid problems with discriminated -- tagged types because, if the controlling type has discriminants with -- default values, then the type conversions done inside the body of -- the thunk (after the displacement of the pointer to the base of the -- actual object) generate code that modify its contents. -- Note: This special management is not done for predefined primitives -- because they don't have available the Interface_Alias attribute (see -- Sem_Ch3.Add_Internal_Interface_Entities). if Is_Predef_Op then Iface_Formal := Empty; else Iface_Formal := First_Formal (Interface_Alias (Prim)); end if; Formal := First_Formal (Target); while Present (Formal) loop -- Use the interface type as the type of the controlling formal (see -- comment above). if not Is_Controlling_Formal (Formal) then Ftyp := Etype (Formal); Expr := New_Copy_Tree (Expression (Parent (Formal))); -- For predefined primitives the controlling type of the thunk is -- the interface type passed by the caller (since they don't have -- available the Interface_Alias attribute; see comment above). elsif Is_Predef_Op then Ftyp := Iface; Expr := Empty; else Ftyp := Etype (Iface_Formal); Expr := Empty; -- Sanity check performed to ensure the proper controlling type -- when the thunk has exactly one controlling parameter and it -- comes first. In such a case, the GCC back end reuses the C++ -- thunks machinery which perform a computation equivalent to -- the code generated by the expander; for other cases the GCC -- back end translates the expanded code unmodified. However, as -- a generalization, the check is performed for all controlling -- types. if Is_Access_Type (Ftyp) then pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface); null; else Ftyp := Base_Type (Ftyp); pragma Assert (Ftyp = Iface); end if; end if; Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars => Chars (Formal)), Aliased_Present => Aliased_Present (Parent (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), Parameter_Type => New_Occurrence_Of (Ftyp, Loc), Expression => Expr)); if not Is_Predef_Op then Next_Formal (Iface_Formal); end if; Next_Formal (Formal); end loop; Target_Formal := First_Formal (Target); Formal := First (Formals); while Present (Formal) loop -- If the parent is a constrained discriminated type, then the -- primitive operation will have been defined on a first subtype. -- For proper matching with controlling type, use base type. if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type then Ftyp := Base_Type (Directly_Designated_Type (Etype (Target_Formal))); else Ftyp := Base_Type (Etype (Target_Formal)); end if; -- For concurrent types, the relevant information is found in the -- Corresponding_Record_Type, rather than the type entity itself. if Is_Concurrent_Type (Ftyp) then Ftyp := Corresponding_Record_Type (Ftyp); end if; if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type and then Is_Controlling_Formal (Target_Formal) then -- Generate: -- type T is access all <> -- S : Storage_Offset := Storage_Offset!(Formal) -- + Offset_To_Top (address!(Formal)) Decl_2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => False, Constant_Present => False, Subtype_Indication => New_Occurrence_Of (Ftyp, Loc))); New_Arg := Unchecked_Convert_To (RTE (RE_Address), New_Occurrence_Of (Defining_Identifier (Formal), Loc)); if not RTE_Available (RE_Offset_To_Top) then Offset_To_Top := Build_Offset_To_Top (Loc, New_Arg); else Offset_To_Top := Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List (New_Arg)); end if; Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), Expression => Make_Op_Add (Loc, Left_Opnd => Unchecked_Convert_To (RTE (RE_Storage_Offset), New_Occurrence_Of (Defining_Identifier (Formal), Loc)), Right_Opnd => Offset_To_Top)); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); -- Reference the new actual. Generate: -- T!(S) Append_To (Actuals, Unchecked_Convert_To (Defining_Identifier (Decl_2), New_Occurrence_Of (Defining_Identifier (Decl_1), Loc))); elsif Is_Controlling_Formal (Target_Formal) then -- Generate: -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) -- + Offset_To_Top (Formal'Address) -- S2 : Addr_Ptr := Addr_Ptr!(S1) New_Arg := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address); if not RTE_Available (RE_Offset_To_Top) then Offset_To_Top := Build_Offset_To_Top (Loc, New_Arg); else Offset_To_Top := Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List (New_Arg)); end if; Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), Expression => Make_Op_Add (Loc, Left_Opnd => Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address)), Right_Opnd => Offset_To_Top)); Decl_2 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc), Expression => Unchecked_Convert_To (RTE (RE_Addr_Ptr), New_Occurrence_Of (Defining_Identifier (Decl_1), Loc))); Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); -- Reference the new actual, generate: -- Target_Formal (S2.all) Append_To (Actuals, Unchecked_Convert_To (Ftyp, Make_Explicit_Dereference (Loc, New_Occurrence_Of (Defining_Identifier (Decl_2), Loc)))); -- Ensure proper matching of access types. Required to avoid -- reporting spurious errors. elsif Is_Access_Type (Etype (Target_Formal)) then Append_To (Actuals, Unchecked_Convert_To (Base_Type (Etype (Target_Formal)), New_Occurrence_Of (Defining_Identifier (Formal), Loc))); -- No special management required for this actual else Append_To (Actuals, New_Occurrence_Of (Defining_Identifier (Formal), Loc)); end if; Next_Formal (Target_Formal); Next (Formal); end loop; Thunk_Id := Make_Temporary (Loc, 'T'); -- Note: any change to this symbol name needs to be coordinated -- with GNATcoverage, as that tool relies on it to identify -- thunks and exclude them from source coverage analysis. Mutate_Ekind (Thunk_Id, Ekind (Prim)); Set_Is_Thunk (Thunk_Id); Set_Has_Controlling_Result (Thunk_Id, False); Set_Convention (Thunk_Id, Convention (Prim)); Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target)); Set_Thunk_Entity (Thunk_Id, Target); Thunk_Code := New_List; -- Procedure case if Ekind (Target) = E_Procedure then Append_To (Thunk_Code, Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals), Declarations => Decl, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals))))); -- Function case else pragma Assert (Ekind (Target) = E_Function); declare Call_Node : Node_Id; Result_Def : Node_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; begin Call_Node := Make_Function_Call (Loc, Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals); if not Is_Interface (Etype (Prim)) then Result_Def := New_Copy (Result_Definition (Parent (Target))); -- Thunk of function returning a class-wide interface object. No -- extra displacement needed since the displacement is generated -- in the return statement of Prim. Example: -- type Iface is interface ... -- function F (O : Iface) return Iface'Class; -- type T is new ... and Iface with ... -- function F (O : T) return Iface'Class; elsif Is_Class_Wide_Type (Etype (Prim)) then Result_Def := New_Occurrence_Of (Etype (Prim), Loc); -- Thunk of function returning an interface object. Displacement -- needed. Example: -- type Iface is interface ... -- function F (O : Iface) return Iface; -- type T is new ... and Iface with ... -- function F (O : T) return T; else Expand_Secondary_Stack_Thunk (Target, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then Set_Thunk_Entity (Thunk_Id, SS_Thunk_Id); Call_Node := Make_Function_Call (Loc, Name => New_Occurrence_Of (SS_Thunk_Id, Loc), Parameter_Associations => Actuals); Append_To (Thunk_Code, SS_Thunk_Code); end if; Result_Def := New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc); -- Adding implicit conversion to force the displacement of -- the pointer to the object to reference the corresponding -- secondary dispatch table. Call_Node := Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc), Expression => Relocate_Node (Call_Node)); end if; Append_To (Thunk_Code, Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals, Result_Definition => Result_Def), Declarations => Decl, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Call_Node))))); end; end if; end Expand_Interface_Thunk; ------------------------------------ -- Expand_Secondary_Stack_Thunk -- ------------------------------------ procedure Expand_Secondary_Stack_Thunk (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id) is Actuals : constant List_Id := New_List; Formals : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Prim); Typ : constant Entity_Id := Etype (Prim); Call_Node : Node_Id; Expr : Node_Id; Formal : Entity_Id; Prim_Formal : Entity_Id; Result_Def : Node_Id; begin Thunk_Id := Empty; Thunk_Code := Empty; -- No thunk needed if the primitive has been eliminated if Is_Eliminated (Prim) then return; -- No thunk needed for procedures or functions not dispatching on result elsif Ekind (Prim) = E_Procedure or else not Has_Controlling_Result (Prim) then return; -- No thunk needed if the result type is an access type elsif Is_Access_Type (Typ) then return; -- No thunk needed if the tagged type is returned in place elsif Is_Build_In_Place_Result_Type (Typ) then return; -- No thunk needed if the tagged type is returned on the secondary stack elsif Needs_Secondary_Stack (Typ) then return; end if; pragma Assert (Is_Tagged_Type (Typ)); -- Duplicate the formals of the target primitive and build the actuals Prim_Formal := First_Formal (Prim); while Present (Prim_Formal) loop Expr := New_Copy_Tree (Expression (Parent (Prim_Formal))); Formal := Make_Defining_Identifier (Sloc (Prim_Formal), Chars => Chars (Prim_Formal)); Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Formal, Aliased_Present => Aliased_Present (Parent (Prim_Formal)), In_Present => In_Present (Parent (Prim_Formal)), Out_Present => Out_Present (Parent (Prim_Formal)), Parameter_Type => New_Occurrence_Of (Etype (Prim_Formal), Loc), Expression => Expr)); -- Ensure proper matching of access types. Required to avoid -- reporting spurious errors. if Is_Access_Type (Etype (Prim_Formal)) then Append_To (Actuals, Unchecked_Convert_To (Base_Type (Etype (Prim_Formal)), New_Occurrence_Of (Formal, Loc))); -- No special management required for this actual else Append_To (Actuals, New_Occurrence_Of (Formal, Loc)); end if; Next_Formal (Prim_Formal); end loop; Thunk_Id := Make_Temporary (Loc, 'T'); -- Note: any change to this symbol name needs to be coordinated -- with GNATcoverage, as that tool relies on it to identify -- thunks and exclude them from source coverage analysis. Mutate_Ekind (Thunk_Id, E_Function); Set_Is_Thunk (Thunk_Id); Set_Has_Controlling_Result (Thunk_Id, True); Set_Convention (Thunk_Id, Convention (Prim)); Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Prim)); Set_Thunk_Entity (Thunk_Id, Prim); Result_Def := New_Copy (Result_Definition (Parent (Prim))); Call_Node := Make_Function_Call (Loc, Name => New_Occurrence_Of (Prim, Loc), Parameter_Associations => Actuals); Thunk_Code := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals, Result_Definition => Result_Def), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Call_Node)))); end Expand_Secondary_Stack_Thunk; -------------------------- -- Has_CPP_Constructors -- -------------------------- function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is E : Entity_Id; begin -- Look for the constructor entities E := Next_Entity (Typ); while Present (E) loop if Ekind (E) = E_Function and then Is_Constructor (E) then return True; end if; Next_Entity (E); end loop; return False; end Has_CPP_Constructors; ------------ -- Has_DT -- ------------ function Has_DT (Typ : Entity_Id) return Boolean is begin return not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; ---------------------------------- -- Is_Expanded_Dispatching_Call -- ---------------------------------- function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is begin return Nkind (N) in N_Subprogram_Call and then Nkind (Name (N)) = N_Explicit_Dereference and then Is_Dispatch_Table_Entity (Etype (Name (N))); end Is_Expanded_Dispatching_Call; ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean is begin return not Is_Predefined_Dispatching_Operation (Prim) and then Present (Alias (Prim)) and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); end Is_Predefined_Dispatching_Alias; ---------------------------------------- -- Make_Disp_Asynchronous_Select_Body -- ---------------------------------------- -- For interface types, generate: -- procedure _Disp_Asynchronous_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- B : out System.Storage_Elements.Dummy_Communication_Block; -- F : out Boolean) -- is -- begin -- F := False; -- C := Ada.Tags.POK_Function; -- end _Disp_Asynchronous_Select; -- For protected types, generate: -- procedure _Disp_Asynchronous_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- B : out System.Storage_Elements.Dummy_Communication_Block; -- F : out Boolean) -- is -- I : Integer := -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); -- Bnn : System.Tasking.Protected_Objects.Operations. -- Communication_Block; -- begin -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call -- (T._object'Access, -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), -- P, -- System.Tasking.Asynchronous_Call, -- Bnn); -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn); -- end _Disp_Asynchronous_Select; -- For task types, generate: -- procedure _Disp_Asynchronous_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- B : out System.Storage_Elements.Dummy_Communication_Block; -- F : out Boolean) -- is -- I : Integer := -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); -- begin -- System.Tasking.Rendezvous.Task_Entry_Call -- (T._task_id, -- System.Tasking.Task_Entry_Index (I), -- P, -- System.Tasking.Asynchronous_Call, -- F); -- end _Disp_Asynchronous_Select; function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id is Com_Block : Entity_Id; Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Typ); Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- Null body is generated for interface types if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, Specification => Make_Disp_Asynchronous_Select_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer := -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (VP), S); -- where I will be used to capture the entry index of the primitive -- wrapper at position S. if Tagged_Type_Expansion then Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List (Tag_Node, Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then -- Generate: -- Bnn : Communication_Block; Com_Block := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Com_Block, Object_Definition => New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); -- Build T._object'Access for calls below Obj_Ref := Make_Attribute_Reference (Loc, Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))); case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => -- Generate: -- Protected_Entry_Call -- (T._object'Access, -- Object -- Protected_Entry_Index! (I), -- E -- P, -- Uninterpreted_Data -- Asynchronous_Call, -- Mode -- Bnn); -- Communication_Block -- where T is the protected object, I is the entry index, P -- is the wrapped parameters and B is the name of the -- communication block. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Obj_Ref, Unchecked_Convert_To ( -- entry index RTE (RE_Protected_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Occurrence_Of -- Asynchronous_Call (RTE (RE_Asynchronous_Call), Loc), New_Occurrence_Of -- comm block (Com_Block, Loc)))); when others => raise Program_Error; end case; -- Generate: -- B := Dummy_Communication_Block (Bnn); Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uB), Expression => Unchecked_Convert_To (RTE (RE_Dummy_Communication_Block), New_Occurrence_Of (Com_Block, Loc)))); -- Generate: -- F := False; Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Task_Entry_Call -- (T._task_id, -- Acceptor -- Task_Entry_Index! (I), -- E -- P, -- Uninterpreted_Data -- Asynchronous_Call, -- Mode -- F); -- Rendezvous_Successful -- where T is the task object, I is the entry index, P is the -- wrapped parameters and F is the status flag. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Unchecked_Convert_To ( -- entry index RTE (RE_Task_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Occurrence_Of -- Asynchronous_Call (RTE (RE_Asynchronous_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; else -- Ensure that the statements list is non-empty Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))); end if; return Make_Subprogram_Body (Loc, Specification => Make_Disp_Asynchronous_Select_Spec (Typ), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Asynchronous_Select_Body; ---------------------------------------- -- Make_Disp_Asynchronous_Select_Spec -- ---------------------------------------- function Make_Disp_Asynchronous_Select_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); B_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); Def_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select); Params : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- T : in out Typ; -- Object parameter -- S : Integer; -- Primitive operation slot -- P : Address; -- Wrapped parameters -- B : out Dummy_Communication_Block; -- Communication block dummy -- F : out Boolean; -- Status flag -- The B parameter may be left uninitialized Set_Warnings_Off (B_Id); Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Occurrence_Of (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => B_Id, Parameter_Type => New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc), Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), Out_Present => True))); return Make_Procedure_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => Params); end Make_Disp_Asynchronous_Select_Spec; --------------------------------------- -- Make_Disp_Conditional_Select_Body -- --------------------------------------- -- For interface types, generate: -- procedure _Disp_Conditional_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- begin -- F := False; -- C := Ada.Tags.POK_Function; -- end _Disp_Conditional_Select; -- For protected types, generate: -- procedure _Disp_Conditional_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- I : Integer; -- Bnn : System.Tasking.Protected_Objects.Operations. -- Communication_Block; -- begin -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (VP, S)); -- if C = Ada.Tags.POK_Procedure -- or else C = Ada.Tags.POK_Protected_Procedure -- or else C = Ada.Tags.POK_Task_Procedure -- then -- F := True; -- return; -- end if; -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call -- (T.object'Access, -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), -- P, -- System.Tasking.Conditional_Call, -- Bnn); -- F := not Cancelled (Bnn); -- end _Disp_Conditional_Select; -- For task types, generate: -- procedure _Disp_Conditional_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- I : Integer; -- begin -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); -- System.Tasking.Rendezvous.Task_Entry_Call -- (T._task_id, -- System.Tasking.Task_Entry_Index (I), -- P, -- System.Tasking.Conditional_Call, -- F); -- end _Disp_Conditional_Select; function Make_Disp_Conditional_Select_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Blk_Nam : Entity_Id; Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- Null body is generated for interface types if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, Specification => Make_Disp_Conditional_Select_Spec (Typ), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer; -- where I will be used to capture the entry index of the primitive -- wrapper at position S. Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Generate: -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (VP), S); -- if C = POK_Procedure -- or else C = POK_Protected_Procedure -- or else C = POK_Task_Procedure; -- then -- F := True; -- return; -- end if; Build_Common_Dispatching_Select_Statements (Typ, Stmts); -- Generate: -- Bnn : Communication_Block; -- where Bnn is the name of the communication block used in the -- call to Protected_Entry_Call. Blk_Nam := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Blk_Nam, Object_Definition => New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); -- Generate: -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (VP), S); -- I is the entry index and S is the dispatch table slot if Tagged_Type_Expansion then Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then Obj_Ref := -- T._object'Access Make_Attribute_Reference (Loc, Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))); case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => -- Generate: -- Protected_Entry_Call -- (T._object'Access, -- Object -- Protected_Entry_Index! (I), -- E -- P, -- Uninterpreted_Data -- Conditional_Call, -- Mode -- Bnn); -- Block -- where T is the protected object, I is the entry index, P -- are the wrapped parameters and Bnn is the name of the -- communication block. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Obj_Ref, Unchecked_Convert_To ( -- entry index RTE (RE_Protected_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Occurrence_Of -- Conditional_Call (RTE (RE_Conditional_Call), Loc), New_Occurrence_Of -- Bnn (Blk_Nam, Loc)))); when System_Tasking_Protected_Objects_Single_Entry => -- If we are compiling for a restricted run-time, the call -- uses the simpler form. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Protected_Single_Entry_Call), Loc), Parameter_Associations => New_List ( Obj_Ref, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uP), Attribute_Name => Name_Address), New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)))); when others => raise Program_Error; end case; -- Generate: -- F := not Cancelled (Bnn); -- where F is the success flag. The status of Cancelled is negated -- in order to match the behavior of the version for task types. Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => Make_Op_Not (Loc, Right_Opnd => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Blk_Nam, Loc)))))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Task_Entry_Call -- (T._task_id, -- Acceptor -- Task_Entry_Index! (I), -- E -- P, -- Uninterpreted_Data -- Conditional_Call, -- Mode -- F); -- Rendezvous_Successful -- where T is the task object, I is the entry index, P are the -- wrapped parameters and F is the status flag. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Unchecked_Convert_To ( -- entry index RTE (RE_Task_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Occurrence_Of -- Conditional_Call (RTE (RE_Conditional_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; else -- Initialize out parameters Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))); Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uC), Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc))); end if; return Make_Subprogram_Body (Loc, Specification => Make_Disp_Conditional_Select_Spec (Typ), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Conditional_Select_Body; --------------------------------------- -- Make_Disp_Conditional_Select_Spec -- --------------------------------------- function Make_Disp_Conditional_Select_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Def_Id : constant Node_Id := Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select); Params : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- T : in out Typ; -- Object parameter -- S : Integer; -- Primitive operation slot -- P : Address; -- Wrapped parameters -- C : out Prim_Op_Kind; -- Call kind -- F : out Boolean; -- Status flag Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Occurrence_Of (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), Out_Present => True))); return Make_Procedure_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => Params); end Make_Disp_Conditional_Select_Spec; ------------------------------------- -- Make_Disp_Get_Prim_Op_Kind_Body -- ------------------------------------- function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, Specification => Make_Disp_Get_Prim_Op_Kind_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Null_Statement (Loc)))); end if; -- Generate: -- C := get_prim_op_kind (tag! (VP), S); -- where C is the out parameter capturing the call kind and S is the -- dispatch table slot number. if Tagged_Type_Expansion then Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; return Make_Subprogram_Body (Loc, Specification => Make_Disp_Get_Prim_Op_Kind_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uC), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Identifier (Loc, Name_uS))))))); end Make_Disp_Get_Prim_Op_Kind_Body; ------------------------------------- -- Make_Disp_Get_Prim_Op_Kind_Spec -- ------------------------------------- function Make_Disp_Get_Prim_Op_Kind_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Def_Id : constant Node_Id := Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind); Params : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- T : in out Typ; -- Object parameter -- S : Integer; -- Primitive operation slot -- C : out Prim_Op_Kind; -- Call kind Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Occurrence_Of (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), Out_Present => True))); return Make_Procedure_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => Params); end Make_Disp_Get_Prim_Op_Kind_Spec; -------------------------------- -- Make_Disp_Get_Task_Id_Body -- -------------------------------- function Make_Disp_Get_Task_Id_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Ret : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); if Is_Concurrent_Record_Type (Typ) and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type then -- Generate: -- return To_Address (_T._task_id); Ret := Make_Simple_Return_Statement (Loc, Expression => Unchecked_Convert_To (RTE (RE_Address), Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)))); -- A null body is constructed for non-task types else -- Generate: -- return Null_Address; Ret := Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc)); end if; return Make_Subprogram_Body (Loc, Specification => Make_Disp_Get_Task_Id_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret))); end Make_Disp_Get_Task_Id_Body; -------------------------------- -- Make_Disp_Get_Task_Id_Spec -- -------------------------------- function Make_Disp_Get_Task_Id_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); return Make_Function_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Occurrence_Of (Typ, Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)); end Make_Disp_Get_Task_Id_Spec; ---------------------------- -- Make_Disp_Requeue_Body -- ---------------------------- function Make_Disp_Requeue_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Conc_Typ : Entity_Id := Empty; Stmts : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- Null body is generated for interface types and nonconcurrent -- tagged types. if Is_Interface (Typ) or else not Is_Concurrent_Record_Type (Typ) then return Make_Subprogram_Body (Loc, Specification => Make_Disp_Requeue_Spec (Typ), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Null_Statement (Loc)))); end if; Conc_Typ := Corresponding_Concurrent_Type (Typ); if Ekind (Conc_Typ) = E_Protected_Type then -- Generate statements: -- if F then -- System.Tasking.Protected_Objects.Operations. -- Requeue_Protected_Entry -- (Protection_Entries_Access (P), -- O._object'Unchecked_Access, -- Protected_Entry_Index (I), -- A); -- else -- System.Tasking.Protected_Objects.Operations. -- Requeue_Task_To_Protected_Entry -- (O._object'Unchecked_Access, -- Protected_Entry_Index (I), -- A); -- end if; if Restriction_Active (No_Entry_Queue) then Append_To (Stmts, Make_Null_Statement (Loc)); else Append_To (Stmts, Make_If_Statement (Loc, Condition => Make_Identifier (Loc, Name_uF), Then_Statements => New_List ( -- Call to Requeue_Protected_Entry Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Requeue_Protected_Entry), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To ( -- PEA (P) RTE (RE_Protection_Entries_Access), Make_Identifier (Loc, Name_uP)), Make_Attribute_Reference (Loc, -- O._object'Acc Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uObject))), Unchecked_Convert_To ( -- entry index RTE (RE_Protected_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))), -- abort status Else_Statements => New_List ( -- Call to Requeue_Task_To_Protected_Entry Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Requeue_Task_To_Protected_Entry), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, -- O._object'Acc Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uObject))), Unchecked_Convert_To ( -- entry index RTE (RE_Protected_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))))); -- abort status end if; else pragma Assert (Is_Task_Type (Conc_Typ)); -- Generate: -- if F then -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry -- (Protection_Entries_Access (P), -- O._task_id, -- Task_Entry_Index (I), -- A); -- else -- System.Tasking.Rendezvous.Requeue_Task_Entry -- (O._task_id, -- Task_Entry_Index (I), -- A); -- end if; Append_To (Stmts, Make_If_Statement (Loc, Condition => Make_Identifier (Loc, Name_uF), Then_Statements => New_List ( -- Call to Requeue_Protected_To_Task_Entry Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Requeue_Protected_To_Task_Entry), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To ( -- PEA (P) RTE (RE_Protection_Entries_Access), Make_Identifier (Loc, Name_uP)), Make_Selected_Component (Loc, -- O._task_id Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Unchecked_Convert_To ( -- entry index RTE (RE_Task_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))), -- abort status Else_Statements => New_List ( -- Call to Requeue_Task_Entry Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- O._task_id Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Unchecked_Convert_To ( -- entry index RTE (RE_Task_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))))); -- abort status end if; -- Even though no declarations are needed in both cases, we allocate -- a list for entities added by Freeze. return Make_Subprogram_Body (Loc, Specification => Make_Disp_Requeue_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Requeue_Body; ---------------------------- -- Make_Disp_Requeue_Spec -- ---------------------------- function Make_Disp_Requeue_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- O : in out Typ; - Object parameter -- F : Boolean; - Protected (True) / task (False) flag -- P : Address; - Protection_Entries_Access value -- I : Entry_Index - Index of entry call -- A : Boolean - Abort flag -- Note that the Protection_Entries_Access value is represented as a -- System.Address in order to avoid dragging in the tasking runtime -- when compiling sources without tasking constructs. return Make_Procedure_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Name_uDisp_Requeue), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, -- O Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), Parameter_Type => New_Occurrence_Of (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, -- F Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc)), Make_Parameter_Specification (Loc, -- P Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, -- I Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, -- A Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc)))); end Make_Disp_Requeue_Spec; --------------------------------- -- Make_Disp_Timed_Select_Body -- --------------------------------- -- For interface types, generate: -- procedure _Disp_Timed_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- D : Duration; -- M : Integer; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- begin -- F := False; -- C := Ada.Tags.POK_Function; -- end _Disp_Timed_Select; -- For protected types, generate: -- procedure _Disp_Timed_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- D : Duration; -- M : Integer; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- I : Integer; -- begin -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (VP), S); -- if C = Ada.Tags.POK_Procedure -- or else C = Ada.Tags.POK_Protected_Procedure -- or else C = Ada.Tags.POK_Task_Procedure -- then -- F := True; -- return; -- end if; -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP), S); -- System.Tasking.Protected_Objects.Operations. -- Timed_Protected_Entry_Call -- (T._object'Access, -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), -- P, -- D, -- M, -- F); -- end _Disp_Timed_Select; -- For task types, generate: -- procedure _Disp_Timed_Select -- (T : in out ; -- S : Integer; -- P : System.Address; -- D : Duration; -- M : Integer; -- C : out Ada.Tags.Prim_Op_Kind; -- F : out Boolean) -- is -- I : Integer; -- begin -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP), S); -- System.Tasking.Rendezvous.Timed_Task_Entry_Call -- (T._task_id, -- System.Tasking.Task_Entry_Index (I), -- P, -- D, -- M, -- F); -- end _Disp_Time_Select; function Make_Disp_Timed_Select_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- Null body is generated for interface types if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, Specification => Make_Disp_Timed_Select_Spec (Typ), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer; -- where I will be used to capture the entry index of the primitive -- wrapper at position S. Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Generate: -- C := Get_Prim_Op_Kind (tag! (VP), S); -- if C = POK_Procedure -- or else C = POK_Protected_Procedure -- or else C = POK_Task_Procedure; -- then -- F := True; -- return; -- end if; Build_Common_Dispatching_Select_Statements (Typ, Stmts); -- Generate: -- I := Get_Entry_Index (tag! (VP), S); -- I is the entry index and S is the dispatch table slot if Tagged_Type_Expansion then Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Identifier (Loc, Name_uS))))); -- Protected case if Ekind (Conc_Typ) = E_Protected_Type then -- Build T._object'Access Obj_Ref := Make_Attribute_Reference (Loc, Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))); -- Normal case, No_Entry_Queue restriction not active. In this -- case we generate: -- Timed_Protected_Entry_Call -- (T._object'access, -- Protected_Entry_Index! (I), -- P, D, M, F); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters, D is the delay amount, M is the delay -- mode and F is the status flag. -- Historically, there was also an implementation for single -- entry protected types (in s-tposen). However, it was removed -- by also testing for no No_Select_Statements restriction in -- Exp_Utils.Corresponding_Runtime_Package. This simplified the -- implementation of s-tposen.adb and provided consistency between -- all versions of System.Tasking.Protected_Objects.Single_Entry -- (s-tposen*.adb). case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Timed_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Obj_Ref, Unchecked_Convert_To ( -- entry index RTE (RE_Protected_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block Make_Identifier (Loc, Name_uD), -- delay Make_Identifier (Loc, Name_uM), -- delay mode Make_Identifier (Loc, Name_uF)))); -- status flag when others => raise Program_Error; end case; -- Task case else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Timed_Task_Entry_Call ( -- T._task_id, -- Task_Entry_Index! (I), -- P, -- D, -- M, -- F); -- where T is the task object, I is the entry index, P are the -- wrapped parameters, D is the delay amount, M is the delay -- mode and F is the status flag. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Unchecked_Convert_To ( -- entry index RTE (RE_Task_Entry_Index), Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block Make_Identifier (Loc, Name_uD), -- delay Make_Identifier (Loc, Name_uM), -- delay mode Make_Identifier (Loc, Name_uF)))); -- status flag end if; else -- Initialize out parameters Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (Standard_False, Loc))); Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uC), Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc))); end if; return Make_Subprogram_Body (Loc, Specification => Make_Disp_Timed_Select_Spec (Typ), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Timed_Select_Body; --------------------------------- -- Make_Disp_Timed_Select_Spec -- --------------------------------- function Make_Disp_Timed_Select_Spec (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Def_Id : constant Node_Id := Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select); Params : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- T : in out Typ; -- Object parameter -- S : Integer; -- Primitive operation slot -- P : Address; -- Wrapped parameters -- D : Duration; -- Delay -- M : Integer; -- Delay Mode -- C : out Prim_Op_Kind; -- Call kind -- F : out Boolean; -- Status flag Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Occurrence_Of (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD), Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM), Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), Out_Present => True))); Append_To (Params, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), Out_Present => True)); return Make_Procedure_Specification (Loc, Defining_Unit_Name => Def_Id, Parameter_Specifications => Params); end Make_Disp_Timed_Select_Spec; ------------- -- Make_DT -- ------------- -- The frontend supports two models for expanding dispatch tables -- associated with library-level defined tagged types: statically and -- non-statically allocated dispatch tables. In the former case the object -- containing the dispatch table is constant and it is initialized by means -- of a positional aggregate. In the latter case, the object containing -- the dispatch table is a variable which is initialized by means of -- assignments. -- In case of locally defined tagged types, the object containing the -- object containing the dispatch table is always a variable (instead of a -- constant). This is currently required to give support to late overriding -- of primitives. For example: -- procedure Example is -- package Pkg is -- type T1 is tagged null record; -- procedure Prim (O : T1); -- end Pkg; -- type T2 is new Pkg.T1 with null record; -- procedure Prim (X : T2) is -- late overriding -- begin -- ... -- ... -- end; -- WARNING: This routine manages Ghost regions. Return statements must be -- replaced by gotos which jump to the end of the routine and restore the -- Ghost mode. function Make_DT (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Max_Predef_Prims : constant Int := UI_To_Int (Intval (Expression (Parent (RTE (RE_Max_Predef_Prims))))); DT_Decl : constant Elist_Id := New_Elmt_List; DT_Aggr : constant Elist_Id := New_Elmt_List; -- Entities marked with attribute Is_Dispatch_Table_Entity Dummy_Object : Entity_Id := Empty; -- Extra nonexistent object of type Typ internally used to compute the -- offset to the components that reference secondary dispatch tables. -- Used to compute the offset of components located at fixed position. procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); -- Export the dispatch table DT of tagged type Typ. Required to generate -- forward references and statically allocate the table. For primary -- dispatch tables Index is 0; for secondary dispatch tables the value -- of index must match the Suffix_Index value assigned to the table by -- Make_Tags when generating its unique external name, and it is used to -- retrieve from the Dispatch_Table_Wrappers list associated with Typ -- the external name generated by Import_DT. procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; Iface_Comp : Node_Id; Suffix_Index : Int; Num_Iface_Prims : Nat; Iface_DT_Ptr : Entity_Id; Predef_Prims_Ptr : Entity_Id; Build_Thunks : Boolean; Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch -- Table of Typ associated with Iface. Each abstract interface of Typ -- has two secondary dispatch tables: one containing pointers to thunks -- and another containing pointers to the primitives covering the -- interface primitives. The former secondary table is generated when -- Build_Thunks is True, and provides common support for dispatching -- calls through interface types; the latter secondary table is -- generated when Build_Thunks is False, and provides support for -- Generic Dispatching Constructors that dispatch calls through -- interface types. When constructing this latter table the value of -- Suffix_Index is -1 to indicate that there is no need to export such -- table when building statically allocated dispatch tables; a positive -- value of Suffix_Index must match the Suffix_Index value assigned to -- this secondary dispatch table by Make_Tags when its unique external -- name was generated. function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat; -- Returns the number of predefined primitives of Typ --------------- -- Export_DT -- --------------- procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0) is Count : Nat; Elmt : Elmt_Id; begin Set_Is_Statically_Allocated (DT); Set_Is_True_Constant (DT); Set_Is_Exported (DT); Count := 0; Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ)); while Count /= Index loop Next_Elmt (Elmt); Count := Count + 1; end loop; -- Related_Type (Node (Elmt)) should be equal to Typ here, but we -- can't assert that, because it is sometimes false in illegal -- programs. We can't check Serious_Errors_Detected, because the -- errors have not yet been detected. Get_External_Name (Node (Elmt)); Set_Interface_Name (DT, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); -- Ensure proper Sprint output of this implicit importation Set_Is_Internal (DT); Set_Is_Public (DT); end Export_DT; ----------------------- -- Make_Secondary_DT -- ----------------------- procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; Iface_Comp : Node_Id; Suffix_Index : Int; Num_Iface_Prims : Nat; Iface_DT_Ptr : Entity_Id; Predef_Prims_Ptr : Entity_Id; Build_Thunks : Boolean; Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Exporting_Table : constant Boolean := Building_Static_DT (Typ) and then Suffix_Index > 0; Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; Nb_Prim : Nat; New_Node : Node_Id; OSD : Entity_Id; OSD_Aggr_List : List_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; begin -- Handle cases in which we do not generate statically allocated -- dispatch tables. if not Building_Static_DT (Typ) then Mutate_Ekind (Predef_Prims, E_Variable); Mutate_Ekind (Iface_DT, E_Variable); -- Statically allocated dispatch tables and related entities are -- constants. else Mutate_Ekind (Predef_Prims, E_Constant); Set_Is_Statically_Allocated (Predef_Prims); Set_Is_True_Constant (Predef_Prims); Mutate_Ekind (Iface_DT, E_Constant); Set_Is_Statically_Allocated (Iface_DT); Set_Is_True_Constant (Iface_DT); end if; -- Calculate the number of slots of the dispatch table. If the number -- of primitives of Typ is 0 we reserve a dummy single entry for its -- DT because at run time the pointer to this dummy entry will be -- used as the tag. if Num_Iface_Prims = 0 then Empty_DT := True; Nb_Prim := 1; else Nb_Prim := Num_Iface_Prims; end if; -- Generate: -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := -- (predef-prim-op-thunk-1'address, -- predef-prim-op-thunk-2'address, -- ... -- predef-prim-op-thunk-n'address); -- Create the thunks associated with the predefined primitives and -- save their entity to fill the aggregate. declare Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; Decl : Node_Id; E : Entity_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : List_Id; begin Prim_Ops_Aggr_List := New_List; Prim_Table := (others => Empty); if Building_Static_DT (Typ) then Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Is_Eliminated (Prim) and then not Generate_SCIL and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then if not Build_Thunks then E := Ultimate_Alias (Prim); Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (Result, SS_Thunk_Code); end if; Prim_Table (UI_To_Int (DT_Position (Prim))) := E; else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Append_List_To (Result, Thunk_Code); Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id; end if; end if; end if; Next_Elmt (Prim_Elmt); end loop; end if; for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; New_Node := Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); -- Remember aggregates initializing dispatch tables Append_Elmt (New_Node, DT_Aggr); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'S'), Subtype_Indication => New_Occurrence_Of (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Constant_Present => Building_Static_DT (Typ), Aliased_Present => True, Object_Definition => New_Occurrence_Of (Defining_Identifier (Decl), Loc), Expression => New_Node)); end; -- Generate -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := -- (OSD_Table => (1 => , -- ... -- N => )); -- for OSD'Alignment use Address'Alignment; -- Iface_DT : Dispatch_Table (Nb_Prims) := -- ([ Signature => ], -- Tag_Kind => , -- Predef_Prims => Predef_Prims'Address, -- Offset_To_Top => 0, -- OSD => OSD'Address, -- Prims_Ptr => (prim-op-1'address, -- prim-op-2'address, -- ... -- prim-op-n'address)); -- Stage 3: Initialize the discriminant and the record components DT_Constr_List := New_List; DT_Aggr_List := New_List; -- Nb_Prim Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim)); Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim)); -- Signature if RTE_Record_Component_Available (RE_Signature) then Append_To (DT_Aggr_List, New_Occurrence_Of (RTE (RE_Secondary_DT), Loc)); end if; -- Tag_Kind if RTE_Record_Component_Available (RE_Tag_Kind) then Append_To (DT_Aggr_List, Tagged_Kind (Typ)); end if; -- Predef_Prims Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Interface component located at variable offset; the value of -- Offset_To_Top will be set by the init subprogram. if No (Dummy_Object) or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) then Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- Interface component located at fixed offset else Append_To (DT_Aggr_List, Make_Op_Minus (Loc, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Dummy_Object, Loc), Selector_Name => New_Occurrence_Of (Iface_Comp, Loc)), Attribute_Name => Name_Position))); end if; -- Generate the Object Specific Data table required to dispatch calls -- through synchronized interfaces. if Empty_DT or else Is_Abstract_Type (Typ) or else Is_Controlled (Typ) or else Restriction_Active (No_Dispatching_Calls) or else not Is_Limited_Type (Typ) or else not Has_Interfaces (Typ) or else not Build_Thunks or else not RTE_Record_Component_Available (RE_OSD_Table) then -- No OSD table required Append_To (DT_Aggr_List, New_Occurrence_Of (RTE (RE_Null_Address), Loc)); else OSD_Aggr_List := New_List; declare Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; Prim : Entity_Id; Prim_Alias : Entity_Id; Prim_Elmt : Elmt_Id; E : Entity_Id; Count : Nat; Pos : Nat; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; begin Prim_Table := (others => Empty); Prim_Alias := Empty; Count := 0; Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Present (Interface_Alias (Prim)) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface then Prim_Alias := Interface_Alias (Prim); E := Ultimate_Alias (Prim); Pos := UI_To_Int (DT_Position (Prim_Alias)); if No (Prim_Table (Pos)) then Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (Result, SS_Thunk_Code); end if; Prim_Table (Pos) := E; Append_To (OSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( Make_Integer_Literal (Loc, DT_Position (Prim_Alias))), Expression => Make_Integer_Literal (Loc, DT_Position (Alias (Prim))))); Count := Count + 1; end if; end if; Next_Elmt (Prim_Elmt); end loop; pragma Assert (Count = Nb_Prim); end; OSD := Make_Temporary (Loc, 'I'); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => OSD, Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), Expression => Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), Expression => Make_Integer_Literal (Loc, Nb_Prim)), Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Table), Loc)), Expression => Make_Aggregate (Loc, Component_Associations => OSD_Aggr_List)))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Occurrence_Of (OSD, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); -- In secondary dispatch tables the Typeinfo component contains -- the address of the Object Specific Data (see a-tags.ads). Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (OSD, Loc), Attribute_Name => Name_Address)); end if; -- Initialize the table of primitive operations Prim_Ops_Aggr_List := New_List; if Empty_DT then Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif Is_Abstract_Type (Typ) or else not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else declare CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); E : Entity_Id; Prim_Pos : Nat; Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : List_Id; begin Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); E := Ultimate_Alias (Prim); Prim_Pos := UI_To_Int (DT_Position (E)); -- Do not reference predefined primitives because they are -- located in a separate dispatch table; skip abstract and -- eliminated primitives; skip primitives located in the C++ -- part of the dispatch table because their slot is set by -- the IC routine. if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) and then not Is_Eliminated (Alias (Prim)) and then (not Is_CPP_Class (Root_Type (Typ)) or else Prim_Pos > CPP_Nb_Prims) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface -- Generate the code of the thunk only if the abstract -- interface type is not an immediate ancestor of -- Tagged_Type. Otherwise the DT associated with the -- interface is the primary DT. and then not Is_Ancestor (Iface, Typ, Use_Full_View => True) then if not Build_Thunks then E := Alias (Prim); Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (Result, SS_Thunk_Code); end if; Prim_Pos := UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Prim_Pos) := E; else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Prim_Pos := UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Prim_Pos) := Thunk_Id; Append_List_To (Result, Thunk_Code); end if; end if; end if; Next_Elmt (Prim_Elmt); end loop; for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; end; end if; New_Node := Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); Append_To (DT_Aggr_List, New_Node); -- Remember aggregates initializing dispatch tables Append_Elmt (New_Node, DT_Aggr); -- Note: Secondary dispatch tables are declared constant only if -- we can compute their offset field by means of the extra dummy -- object; otherwise they cannot be declared constant and the -- Offset_To_Top component is initialized by the IP routine. Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT, Aliased_Present => True, Constant_Present => Building_Static_Secondary_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)), Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); if Exporting_Table then Export_DT (Typ, Iface_DT, Suffix_Index); -- Generate code to create the pointer to the dispatch table -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address); -- Note: This declaration is not added here if the table is exported -- because in such case Make_Tags has already added this declaration. else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Interface_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Iface_DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end if; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Iface_DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); -- Remember entities containing dispatch tables Append_Elmt (Predef_Prims, DT_Decl); Append_Elmt (Iface_DT, DT_Decl); end Make_Secondary_DT; -------------------------------- -- Number_Of_Predefined_Prims -- -------------------------------- function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat is Nb_Predef_Prims : Nat := 0; begin if not Generate_SCIL then declare Prim : Entity_Id; Prim_Elmt : Elmt_Id; Pos : Nat; begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) then Pos := UI_To_Int (DT_Position (Prim)); if Pos > Nb_Predef_Prims then Nb_Predef_Prims := Pos; end if; end if; Next_Elmt (Prim_Elmt); end loop; end; end if; pragma Assert (Nb_Predef_Prims <= Max_Predef_Prims); return Nb_Predef_Prims; end Number_Of_Predefined_Prims; -- Local variables Elab_Code : constant List_Id := New_List; Result : constant List_Id := New_List; Tname : constant Name_Id := Chars (Typ); -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply -- we initialize the Expanded_Name and the External_Tag of this tagged -- type with an empty string. This is useful to avoid exposing entity -- names at binary level. It can be done when both pragmas apply because -- (1) Discard_Names allows initializing Expanded_Name with an -- implementation defined value (Ada RM Section C.5 (7/2)). -- (2) External_Tag (combined with Internal_Tag) is used for object -- streaming and No_Tagged_Streams inhibits the generation of -- streams. Discard_Names : constant Boolean := Present (No_Tagged_Streams_Pragma (Typ)) and then (Global_Discard_Names or else Einfo.Entities.Discard_Names (Typ)); -- The following name entries are used by Make_DT to generate a number -- of entities related to a tagged type. These entities may be generated -- in a scope other than that of the tagged type declaration, and if -- the entities for two tagged types with the same name happen to be -- generated in the same scope, we have to take care to use different -- names. This is achieved by means of a unique serial number appended -- to each generated entity name. Name_DT : constant Name_Id := New_External_Name (Tname, 'T', Suffix_Index => -1); Name_Exname : constant Name_Id := New_External_Name (Tname, 'E', Suffix_Index => -1); Name_HT_Link : constant Name_Id := New_External_Name (Tname, 'H', Suffix_Index => -1); Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R', Suffix_Index => -1); Name_SSD : constant Name_Id := New_External_Name (Tname, 'S', Suffix_Index => -1); Name_TSD : constant Name_Id := New_External_Name (Tname, 'B', Suffix_Index => -1); Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; Saved_IGR : constant Node_Id := Ignored_Ghost_Region; -- Save the Ghost-related attributes to restore on exit AI : Elmt_Id; AI_Tag_Elmt : Elmt_Id; AI_Tag_Comp : Elmt_Id; DT : Entity_Id; DT_Aggr_List : List_Id; DT_Constr_List : List_Id; DT_Ptr : Entity_Id; Exname : Entity_Id; HT_Link : Entity_Id; ITable : Node_Id; I_Depth : Nat; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; Nb_Prim : Nat := 0; New_Node : Node_Id; Num_Ifaces : Nat := 0; Parent_Typ : Entity_Id; Predef_Prims : Entity_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; SSD : Entity_Id; Suffix_Index : Int; Typ_Comps : Elist_Id; Typ_Ifaces : Elist_Id; TSD : Entity_Id; TSD_Aggr_List : List_Id; TSD_Tags_List : List_Id; -- Start of processing for Make_DT begin pragma Assert (Is_Frozen (Typ)); -- The tagged type being processed may be subject to pragma Ghost. Set -- the mode now to ensure that any nodes generated during dispatch table -- creation are properly marked as Ghost. Set_Ghost_Mode (Typ); -- Handle cases in which there is no need to build the dispatch table if Has_Dispatch_Table (Typ) or else No (Access_Disp_Table (Typ)) or else Is_CPP_Class (Typ) then goto Leave; elsif No_Run_Time_Mode then Error_Msg_CRT ("tagged types", Typ); goto Leave; elsif not RTE_Available (RE_Tag) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Node (First_Elmt (Access_Disp_Table (Typ))), Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); Analyze_List (Result, Suppress => All_Checks); Error_Msg_CRT ("tagged types", Typ); goto Leave; end if; -- Ensure that the value of Max_Predef_Prims defined in a-tags is -- correct. Valid values are 10 under configurable runtime or 16 -- with full runtime. if RTE_Available (RE_Interface_Data) then if Max_Predef_Prims /= 16 then Error_Msg_N ("run-time library configuration error", Typ); goto Leave; end if; else if Max_Predef_Prims /= 10 then Error_Msg_N ("run-time library configuration error", Typ); Error_Msg_CRT ("tagged types", Typ); goto Leave; end if; end if; DT := Make_Defining_Identifier (Loc, Name_DT); Exname := Make_Defining_Identifier (Loc, Name_Exname); HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link); Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims); SSD := Make_Defining_Identifier (Loc, Name_SSD); TSD := Make_Defining_Identifier (Loc, Name_TSD); -- Initialize Parent_Typ handling private types Parent_Typ := Etype (Typ); if Present (Full_View (Parent_Typ)) then Parent_Typ := Full_View (Parent_Typ); end if; if not Is_Interface (Typ) and then Has_Interfaces (Typ) then declare Cannot_Have_Null_Disc : Boolean := False; Dummy_Object_Typ : constant Entity_Id := Typ; Name_Dummy_Object : constant Name_Id := New_External_Name (Tname, 'P', Suffix_Index => -1); begin Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object); -- Define the extra object imported and constant to avoid linker -- errors (since this object is never declared). Required because -- we implement RM 13.3(19) for exported and imported (variable) -- objects by making them volatile. Set_Is_Imported (Dummy_Object); Mutate_Ekind (Dummy_Object, E_Constant); Set_Is_True_Constant (Dummy_Object); Set_Related_Type (Dummy_Object, Typ); -- The scope must be set now to call Get_External_Name Set_Scope (Dummy_Object, Current_Scope); Get_External_Name (Dummy_Object); Set_Interface_Name (Dummy_Object, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); -- Ensure proper Sprint output of this implicit importation Set_Is_Internal (Dummy_Object); if not Has_Discriminants (Dummy_Object_Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Dummy_Object, Constant_Present => True, Object_Definition => New_Occurrence_Of (Dummy_Object_Typ, Loc))); else declare Constr_List : constant List_Id := New_List; Discrim : Node_Id; begin Discrim := First_Discriminant (Dummy_Object_Typ); while Present (Discrim) loop if Is_Discrete_Type (Etype (Discrim)) then Append_To (Constr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etype (Discrim), Loc), Attribute_Name => Name_First)); else pragma Assert (Is_Access_Type (Etype (Discrim))); Cannot_Have_Null_Disc := Cannot_Have_Null_Disc or else Can_Never_Be_Null (Etype (Discrim)); Append_To (Constr_List, Make_Null (Loc)); end if; Next_Discriminant (Discrim); end loop; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Dummy_Object, Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Dummy_Object_Typ, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constr_List)))); end; end if; -- Given that the dummy object will not be declared at run time, -- analyze its declaration with expansion disabled and warnings -- and error messages ignored. Expander_Mode_Save_And_Set (False); Ignore_Errors_Enable := Ignore_Errors_Enable + 1; Analyze (Last (Result), Suppress => All_Checks); Ignore_Errors_Enable := Ignore_Errors_Enable - 1; Expander_Mode_Restore; end; end if; -- Ada 2005 (AI-251): Build the secondary dispatch tables if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); -- Each secondary dispatch table is assigned an unique positive -- suffix index; such value also corresponds with the location of -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags). -- Note: This value must be kept sync with the Suffix_Index values -- generated by Make_Tags Suffix_Index := 1; AI_Tag_Elmt := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P')); -- Build the secondary table containing pointers to thunks Make_Secondary_DT (Typ => Typ, Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), Iface_Comp => Node (AI_Tag_Comp), Suffix_Index => Suffix_Index, Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => True, Result => Result); -- Skip secondary dispatch table referencing thunks to predefined -- primitives. Next_Elmt (AI_Tag_Elmt); pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y')); -- Secondary dispatch table referencing user-defined primitives -- covered by this interface. Next_Elmt (AI_Tag_Elmt); pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D')); -- Build the secondary table containing pointers to primitives -- (used to give support to Generic Dispatching Constructors). Make_Secondary_DT (Typ => Typ, Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), Iface_Comp => Node (AI_Tag_Comp), Suffix_Index => -1, Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => False, Result => Result); -- Skip secondary dispatch table referencing predefined primitives Next_Elmt (AI_Tag_Elmt); pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z')); Suffix_Index := Suffix_Index + 1; Next_Elmt (AI_Tag_Elmt); Next_Elmt (AI_Tag_Comp); end loop; end if; -- Get the _tag entity and number of primitives of its dispatch table DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); if Generate_SCIL then Nb_Prim := 0; end if; Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); Set_Is_Statically_Allocated (Predef_Prims, Is_Library_Level_Tagged_Type (Typ)); -- In case of locally defined tagged type we declare the object -- containing the dispatch table by means of a variable. Its -- initialization is done later by means of an assignment. This is -- required to generate its External_Tag. if not Building_Static_DT (Typ) then -- Generate: -- DT : No_Dispatch_Table_Wrapper; -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); if not Has_DT (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); Set_Is_Statically_Allocated (DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); -- Generate the SCIL node for the previous object declaration -- because it has a tag initialization. if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); Set_SCIL_Entity (New_Node, Typ); Set_SCIL_Node (Last (Result), New_Node); goto Leave_SCIL; -- Gnat2scil has its own implementation of dispatch tables, -- different than what is being implemented here. Generating -- further dispatch table initialization code would just -- cause gnat2scil to generate useless Scil which CodePeer -- would waste time and space analyzing, so we skip it. end if; -- Generate: -- DT : Dispatch_Table_Wrapper (Nb_Prim); -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); else -- If the tagged type has no primitives we add a dummy slot -- whose address will be the tag of this type. if Nb_Prim = 0 then DT_Constr_List := New_List (Make_Integer_Literal (Loc, 1)); else DT_Constr_List := New_List (Make_Integer_Literal (Loc, Nb_Prim)); end if; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => False, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); Set_Is_Statically_Allocated (DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); -- Generate the SCIL node for the previous object declaration -- because it has a tag initialization. if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); Set_SCIL_Entity (New_Node, Typ); Set_SCIL_Node (Last (Result), New_Node); goto Leave_SCIL; -- Gnat2scil has its own implementation of dispatch tables, -- different than what is being implemented here. Generating -- further dispatch table initialization code would just -- cause gnat2scil to generate useless Scil which CodePeer -- would waste time and space analyzing, so we skip it. end if; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); end if; end if; -- Generate: Expanded_Name : constant String := ""; if Discard_Names then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, ""))); -- Generate: Exname : constant String := full_qualified_name (typ); -- The type itself may be an anonymous parent type, so use the first -- subtype to have a user-recognizable name. else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Fully_Qualified_Name_String (First_Subtype (Typ))))); end if; Set_Is_Statically_Allocated (Exname); Set_Is_True_Constant (Exname); -- Declare the object used by Ada.Tags.Register_Tag, unless -- No_Tagged_Type_Registration is active. if not Restriction_Active (No_Tagged_Type_Registration) and then RTE_Available (RE_Register_Tag) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => HT_Link, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc))); end if; -- Generate code to create the storage for the type specific data object -- with enough space to store the tags of the ancestors plus the tags -- of all the implemented interfaces (as described in a-tags.adb). -- TSD : Type_Specific_Data (I_Depth) := -- (Idepth => I_Depth, -- Access_Level => Type_Access_Level (Typ), -- Alignment => Typ'Alignment, -- Expanded_Name => Cstring_Ptr!(Exname'Address)) -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, -- Transportable => <>, -- Is_Abstract => <>, -- Needs_Finalization => <>, -- [ Size_Func => Size_Prim'Access, ] -- [ Interfaces_Table => <>, ] -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, -- 1 => Parent'Tag -- ...); TSD_Aggr_List := New_List; -- Idepth: Count ancestors to compute the inheritance depth. For private -- extensions, always go to the full view in order to compute the real -- inheritance depth. declare Current_Typ : Entity_Id; Parent_Typ : Entity_Id; begin I_Depth := 0; Current_Typ := Typ; loop Parent_Typ := Etype (Current_Typ); if Is_Private_Type (Parent_Typ) then Parent_Typ := Full_View (Base_Type (Parent_Typ)); end if; exit when Parent_Typ = Current_Typ; I_Depth := I_Depth + 1; Current_Typ := Parent_Typ; end loop; end; Append_To (TSD_Aggr_List, Make_Integer_Literal (Loc, I_Depth)); -- Access_Level Append_To (TSD_Aggr_List, Make_Integer_Literal (Loc, Type_Access_Level (Typ))); -- Alignment -- For CPP types we cannot rely on the value of 'Alignment provided -- by the backend to initialize this TSD field. if Convention (Typ) = Convention_CPP or else Is_CPP_Class (Root_Type (Typ)) then Append_To (TSD_Aggr_List, Make_Integer_Literal (Loc, 0)); else Append_To (TSD_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Alignment)); end if; -- Expanded_Name Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address))); -- External_Tag of a local tagged type -- A : constant String := -- "Internal tag at 16#tag-addr#: "; -- The reason we generate this strange name is that we do not want to -- enter local tagged types in the global hash table used to compute -- the Internal_Tag attribute for two reasons: -- 1. It is hard to avoid a tasking race condition for entering the -- entry into the hash table. -- 2. It would cause a storage leak, unless we rig up considerable -- mechanism to remove the entry from the hash table on exit. -- So what we do is to generate the above external tag name, where the -- hex address is the address of the local dispatch table (i.e. exactly -- the value we want if Internal_Tag is computed from this string). -- Of course this value will only be valid if the tagged type is still -- in scope, but it clearly must be erroneous to compute the internal -- tag of a tagged type that is out of scope. -- We don't do this processing if an explicit external tag has been -- specified. That's an odd case for which we have already issued a -- warning, where we will not be able to compute the internal tag. if not Discard_Names and then not Is_Library_Level_Entity (Typ) and then not Has_External_Tag_Rep_Clause (Typ) then declare Exname : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Tname, 'A')); Full_Name : constant String_Id := Fully_Qualified_Name_String (First_Subtype (Typ)); Str1_Id : String_Id; Str2_Id : String_Id; begin -- Generate: -- Str1 = "Internal tag at 16#"; Start_String; Store_String_Chars ("Internal tag at 16#"); Str1_Id := End_String; -- Generate: -- Str2 = "#: "; Start_String; Store_String_Chars ("#: "); Store_String_Chars (Full_Name); Str2_Id := End_String; -- Generate: -- Exname : constant String := -- Str1 & Address_Image (Tag) & Str2; if RTE_Available (RE_Address_Image) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_Op_Concat (Loc, Left_Opnd => Make_String_Literal (Loc, Str1_Id), Right_Opnd => Make_Op_Concat (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Address_Image), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), New_Occurrence_Of (DT_Ptr, Loc)))), Right_Opnd => Make_String_Literal (Loc, Str2_Id))))); -- Generate: -- Exname : constant String := Str1 & Str2; else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_Op_Concat (Loc, Left_Opnd => Make_String_Literal (Loc, Str1_Id), Right_Opnd => Make_String_Literal (Loc, Str2_Id)))); end if; New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address)); end; -- External tag of a library-level tagged type: Check for a definition -- of External_Tag. The clause is considered only if it applies to this -- specific tagged type, as opposed to one of its ancestors. -- If the type is an unconstrained type extension, we are building the -- dispatch table of its anonymous base type, so the external tag, if -- any was specified, must be retrieved from the first subtype. Go to -- the full view in case the clause is in the private part. else declare Def : constant Node_Id := Get_Attribute_Definition_Clause (Underlying_Type (First_Subtype (Typ)), Attribute_External_Tag); Old_Val : String_Id; New_Val : String_Id; E : Entity_Id; begin if not Present (Def) or else Entity (Name (Def)) /= First_Subtype (Typ) then New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); -- For the rep clause "for 'external_tag use y" generate: -- A : constant string := y; -- -- A'Address is used to set the External_Tag component -- of the TSD -- Create a new nul terminated string if it is not already if String_Length (Old_Val) > 0 and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 then New_Val := Old_Val; else Start_String (Old_Val); Store_String_Char (Get_Char_Code (ASCII.NUL)); New_Val := End_String; end if; E := Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'A')); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => E, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, New_Val))); New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Address)); end if; end; end if; Append_To (TSD_Aggr_List, New_Node); -- HT_Link if not Restriction_Active (No_Tagged_Type_Registration) and then RTE_Available (RE_Register_Tag) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Tag_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (HT_Link, Loc), Attribute_Name => Name_Address))); elsif RTE_Record_Component_Available (RE_HT_Link) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Tag_Ptr), New_Occurrence_Of (RTE (RE_Null_Address), Loc))); end if; -- Transportable: Set for types that can be used in remote calls -- with respect to E.4(18) legality rules. declare Transportable : Entity_Id; begin Transportable := Boolean_Literals (Is_Pure (Typ) or else Is_Shared_Passive (Typ) or else ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ)) and then Original_View_In_Visible_Part (Typ)) or else not Comes_From_Source (Typ)); Append_To (TSD_Aggr_List, New_Occurrence_Of (Transportable, Loc)); end; -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not -- available in the HIE runtime. if RTE_Record_Component_Available (RE_Is_Abstract) then declare Is_Abstract : Entity_Id; begin Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ)); Append_To (TSD_Aggr_List, New_Occurrence_Of (Is_Abstract, Loc)); end; end if; -- Needs_Finalization: Set if the type is controlled or has controlled -- components. declare Needs_Fin : Entity_Id; begin Needs_Fin := Boolean_Literals (Needs_Finalization (Typ)); Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc)); end; -- Size_Func if RTE_Record_Component_Available (RE_Size_Func) then -- Initialize this field to Null_Address if we are not building -- static dispatch tables static or if the size function is not -- available. In the former case we cannot initialize this field -- until the function is frozen and registered in the dispatch -- table (see Register_Primitive). if not Building_Static_DT (Typ) or else not Has_DT (Typ) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Size_Ptr), New_Occurrence_Of (RTE (RE_Null_Address), Loc))); else declare Prim_Elmt : Elmt_Id; Prim : Entity_Id; Size_Comp : Node_Id := Empty; begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Chars (Prim) = Name_uSize then Prim := Ultimate_Alias (Prim); if Is_Abstract_Subprogram (Prim) then Size_Comp := Unchecked_Convert_To (RTE (RE_Size_Ptr), New_Occurrence_Of (RTE (RE_Null_Address), Loc)); else Size_Comp := Unchecked_Convert_To (RTE (RE_Size_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)); end if; exit; end if; Next_Elmt (Prim_Elmt); end loop; pragma Assert (Present (Size_Comp)); Append_To (TSD_Aggr_List, Size_Comp); end; end if; end if; -- Interfaces_Table (required for AI-405) if RTE_Record_Component_Available (RE_Interfaces_Table) then -- Count the number of interface types implemented by Typ Collect_Interfaces (Typ, Typ_Ifaces); AI := First_Elmt (Typ_Ifaces); while Present (AI) loop Num_Ifaces := Num_Ifaces + 1; Next_Elmt (AI); end loop; if Num_Ifaces = 0 then Iface_Table_Node := Make_Null (Loc); -- Generate the Interface_Table object else declare TSD_Ifaces_List : constant List_Id := New_List; Elmt : Elmt_Id; Offset_To_Top : Node_Id; Sec_DT_Tag : Node_Id; Dummy_Object_Ifaces_List : Elist_Id := No_Elist; Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist; Dummy_Object_Ifaces_Tag_List : Elist_Id := No_Elist; -- Interfaces information of the dummy object begin -- Collect interfaces information if we need to compute the -- offset to the top using the dummy object. if Present (Dummy_Object) then Collect_Interfaces_Info (Typ, Ifaces_List => Dummy_Object_Ifaces_List, Components_List => Dummy_Object_Ifaces_Comp_List, Tags_List => Dummy_Object_Ifaces_Tag_List); end if; AI := First_Elmt (Typ_Ifaces); while Present (AI) loop if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then Sec_DT_Tag := New_Occurrence_Of (DT_Ptr, Loc); else Elmt := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); pragma Assert (Has_Thunks (Node (Elmt))); while Is_Tag (Node (Elmt)) and then not Is_Ancestor (Node (AI), Related_Type (Node (Elmt)), Use_Full_View => True) loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); pragma Assert (not Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); pragma Assert (not Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); end loop; pragma Assert (Ekind (Node (Elmt)) = E_Constant and then not Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); Sec_DT_Tag := New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Elmt))), Loc); end if; -- Use the dummy object to compute Offset_To_Top of -- components located at fixed position. if Present (Dummy_Object) then declare Iface : constant Node_Id := Node (AI); Iface_Comp : Node_Id := Empty; Iface_Comp_Elmt : Elmt_Id; Iface_Elmt : Elmt_Id; begin Iface_Elmt := First_Elmt (Dummy_Object_Ifaces_List); Iface_Comp_Elmt := First_Elmt (Dummy_Object_Ifaces_Comp_List); while Present (Iface_Elmt) loop if Node (Iface_Elmt) = Iface then Iface_Comp := Node (Iface_Comp_Elmt); exit; end if; Next_Elmt (Iface_Elmt); Next_Elmt (Iface_Comp_Elmt); end loop; pragma Assert (Present (Iface_Comp)); if not Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) then Offset_To_Top := Make_Op_Minus (Loc, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Dummy_Object, Loc), Selector_Name => New_Occurrence_Of (Iface_Comp, Loc)), Attribute_Name => Name_Position)); else Offset_To_Top := Make_Integer_Literal (Loc, 0); end if; end; else Offset_To_Top := Make_Integer_Literal (Loc, 0); end if; Append_To (TSD_Ifaces_List, Make_Aggregate (Loc, Expressions => New_List ( -- Iface_Tag Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Node (AI)))), Loc)), -- Static_Offset_To_Top New_Occurrence_Of (Standard_True, Loc), -- Offset_To_Top_Value Offset_To_Top, -- Offset_To_Top_Func Make_Null (Loc), -- Secondary_DT Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)))); Next_Elmt (AI); end loop; Name_ITable := New_External_Name (Tname, 'I'); ITable := Make_Defining_Identifier (Loc, Name_ITable); Set_Is_Statically_Allocated (ITable, Is_Library_Level_Tagged_Type (Typ)); -- The table of interfaces is constant if we are building a -- static dispatch table; otherwise is not constant because -- its slots are filled at run time by the IP routine. Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => ITable, Aliased_Present => True, Constant_Present => Building_Static_Secondary_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Interface_Data), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Num_Ifaces)))), Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Integer_Literal (Loc, Num_Ifaces), Make_Aggregate (Loc, TSD_Ifaces_List))))); Iface_Table_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (ITable, Loc), Attribute_Name => Name_Unchecked_Access); end; end if; Append_To (TSD_Aggr_List, Iface_Table_Node); end if; -- Generate the Select Specific Data table for synchronized types that -- implement synchronized interfaces. The size of the table is -- constrained by the number of non-predefined primitive operations. if RTE_Record_Component_Available (RE_SSD) then if Ada_Version >= Ada_2005 and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) and then Has_Interfaces (Typ) and then Nb_Prim > 0 and then not Is_Abstract_Type (Typ) and then not Is_Controlled (Typ) and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Select_Statements) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => SSD, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of ( RTE (RE_Select_Specific_Data), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Occurrence_Of (SSD, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); -- This table is initialized by Make_Select_Specific_Data_Table, -- which calls Set_Entry_Index and Set_Prim_Op_Kind. Append_To (TSD_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (SSD, Loc), Attribute_Name => Name_Unchecked_Access)); else Append_To (TSD_Aggr_List, Make_Null (Loc)); end if; end if; -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. TSD_Tags_List := New_List; -- If we are not statically allocating the dispatch table then we must -- fill position 0 with null because we still have not generated the -- tag of Typ. if not Building_Static_DT (Typ) or else Is_Interface (Typ) then Append_To (TSD_Tags_List, Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc))); -- Otherwise we can safely reference the tag else Append_To (TSD_Tags_List, New_Occurrence_Of (DT_Ptr, Loc)); end if; -- Fill the rest of the table with the tags of the ancestors declare Current_Typ : Entity_Id; Parent_Typ : Entity_Id; Pos : Nat; begin Pos := 1; Current_Typ := Typ; loop Parent_Typ := Etype (Current_Typ); if Is_Private_Type (Parent_Typ) then Parent_Typ := Full_View (Base_Type (Parent_Typ)); end if; exit when Parent_Typ = Current_Typ; if Is_CPP_Class (Parent_Typ) then -- The tags defined in the C++ side will be inherited when -- the object is constructed (Exp_Ch3.Build_Init_Procedure) Append_To (TSD_Tags_List, Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc))); else Append_To (TSD_Tags_List, New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), Loc)); end if; Pos := Pos + 1; Current_Typ := Parent_Typ; end loop; pragma Assert (Pos = I_Depth + 1); end; Append_To (TSD_Aggr_List, Make_Aggregate (Loc, Expressions => TSD_Tags_List)); -- Build the TSD object Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => TSD, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of ( RTE (RE_Type_Specific_Data), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, I_Depth)))), Expression => Make_Aggregate (Loc, Expressions => TSD_Aggr_List))); Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); -- The debugging information for type Ada.Tags.Type_Specific_Data is -- needed by the debugger in order to display values of tagged types. Set_Needs_Debug_Info (TSD, Needs_Debug_Info (Typ)); -- Initialize or declare the dispatch table object if not Has_DT (Typ) then DT_Constr_List := New_List; DT_Aggr_List := New_List; -- Typeinfo New_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Address); Append_To (DT_Constr_List, New_Node); Append_To (DT_Aggr_List, New_Copy (New_Node)); Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- In case of locally defined tagged types we have already declared -- and uninitialized object for the dispatch table, which is now -- initialized by means of the following assignment: -- DT := (TSD'Address, 0); if not Building_Static_DT (Typ) then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (DT, Loc), Expression => Make_Aggregate (Loc, DT_Aggr_List))); -- In case of library level tagged types we declare and export now -- the constant object containing the dummy dispatch table. There -- is no need to declare the tag here because it has been previously -- declared by Make_Tags -- DT : aliased constant No_Dispatch_Table := -- (NDT_TSD => TSD'Address; -- NDT_Prims_Ptr => 0); else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc), Expression => Make_Aggregate (Loc, DT_Aggr_List))); Export_DT (Typ, DT); end if; -- Common case: Typ has a dispatch table -- Generate: -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := -- (predef-prim-op-1'address, -- predef-prim-op-2'address, -- ... -- predef-prim-op-n'address); -- DT : Dispatch_Table (Nb_Prims) := -- (Signature => , -- Tag_Kind => , -- Predef_Prims => Predef_Prims'First'Address, -- Offset_To_Top => 0, -- TSD => TSD'Address; -- Prims_Ptr => (prim-op-1'address, -- prim-op-2'address, -- ... -- prim-op-n'address)); -- for DT'Alignment use Address'Alignment else declare Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; Decl : Node_Id; E : Entity_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; begin Prim_Ops_Aggr_List := New_List; Prim_Table := (others => Empty); if Building_Static_DT (Typ) then Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Is_Eliminated (Prim) and then not Generate_SCIL and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then E := Ultimate_Alias (Prim); pragma Assert (not Is_Abstract_Subprogram (E)); Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (Result, SS_Thunk_Code); end if; Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); end loop; end if; for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; New_Node := Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'S'), Subtype_Indication => New_Occurrence_Of (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), Object_Definition => New_Occurrence_Of (Defining_Identifier (Decl), Loc), Expression => New_Node)); -- Remember aggregates initializing dispatch tables Append_Elmt (New_Node, DT_Aggr); end; -- Stage 1: Initialize the discriminant and the record components DT_Constr_List := New_List; DT_Aggr_List := New_List; -- Num_Prims. If the tagged type has no primitives we add a dummy -- slot whose address will be the tag of this type. if Nb_Prim = 0 then New_Node := Make_Integer_Literal (Loc, 1); else New_Node := Make_Integer_Literal (Loc, Nb_Prim); end if; Append_To (DT_Constr_List, New_Node); Append_To (DT_Aggr_List, New_Copy (New_Node)); -- Signature if RTE_Record_Component_Available (RE_Signature) then Append_To (DT_Aggr_List, New_Occurrence_Of (RTE (RE_Primary_DT), Loc)); end if; -- Tag_Kind if RTE_Record_Component_Available (RE_Tag_Kind) then Append_To (DT_Aggr_List, Tagged_Kind (Typ)); end if; -- Predef_Prims Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Offset_To_Top Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- Typeinfo Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Address)); -- Stage 2: Initialize the table of user-defined primitive operations Prim_Ops_Aggr_List := New_List; if Nb_Prim = 0 then Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else declare CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); E : Entity_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Pos : Nat; Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; begin Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Retrieve the ultimate alias of the primitive for proper -- handling of renamings and eliminated primitives. E := Ultimate_Alias (Prim); -- If the alias is not a primitive operation then Prim does -- not rename another primitive, but rather an operation -- declared elsewhere (e.g. in another scope) and therefore -- Prim is a new primitive. if No (Find_Dispatching_Type (E)) then E := Prim; end if; Prim_Pos := UI_To_Int (DT_Position (E)); -- Skip predefined primitives because they are located in a -- separate dispatch table. if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Operation (E) -- Skip entities with attribute Interface_Alias because -- those are only required to build secondary dispatch -- tables. and then not Present (Interface_Alias (Prim)) -- Skip abstract and eliminated primitives and then not Is_Abstract_Subprogram (E) and then not Is_Eliminated (E) -- For derivations of CPP types skip primitives located in -- the C++ part of the dispatch table because their slots -- are initialized by the IC routine. and then (not Is_CPP_Class (Root_Type (Typ)) or else Prim_Pos > CPP_Nb_Prims) -- Skip ignored Ghost subprograms as those will be removed -- from the executable. and then not Is_Ignored_Ghost_Entity (E) then pragma Assert (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (Result, SS_Thunk_Code); end if; Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); end loop; for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; end; end if; New_Node := Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); Append_To (DT_Aggr_List, New_Node); -- Remember aggregates initializing dispatch tables Append_Elmt (New_Node, DT_Aggr); -- In case of locally defined tagged types we have already declared -- and uninitialized object for the dispatch table, which is now -- initialized by means of an assignment. if not Building_Static_DT (Typ) then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (DT, Loc), Expression => Make_Aggregate (Loc, DT_Aggr_List))); -- In case of library level tagged types we declare now and export -- the constant object containing the dispatch table. else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)), Expression => Make_Aggregate (Loc, DT_Aggr_List))); Export_DT (Typ, DT); end if; end if; -- Initialize the table of ancestor tags if not building static -- dispatch table if not Building_Static_DT (Typ) and then not Is_Interface (Typ) and then not Is_CPP_Class (Typ) then Append_To (Result, Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (TSD, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Tags_Table), Loc)), Expressions => New_List (Make_Integer_Literal (Loc, 0))), Expression => New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; -- Inherit the dispatch tables of the parent. There is no need to -- inherit anything from the parent when building static dispatch tables -- because the whole dispatch table (including inherited primitives) has -- been already built. if Building_Static_DT (Typ) then null; -- If the ancestor is a CPP_Class type we inherit the dispatch tables -- in the init proc, and we don't need to fill them in here. elsif Is_CPP_Class (Parent_Typ) then null; -- Otherwise we fill in the dispatch tables here else if Typ /= Parent_Typ and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table if not Is_Interface (Typ) and then not Is_Interface (Parent_Typ) and then not Is_CPP_Class (Parent_Typ) then declare Nb_Prims : constant Int := UI_To_Int (DT_Entry_Count (First_Tag_Component (Parent_Typ))); begin Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => New_Occurrence_Of (Node (Next_Elmt (First_Elmt (Access_Disp_Table (Parent_Typ)))), Loc), New_Tag_Node => New_Occurrence_Of (Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), Loc), Num_Predef_Prims => Number_Of_Predefined_Prims (Parent_Typ))); if Nb_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, Typ => Typ, Old_Tag_Node => New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), Loc), New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), Num_Prims => Nb_Prims)); end if; end; end if; -- Inherit the secondary dispatch tables of the ancestor if not Is_CPP_Class (Parent_Typ) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Parent_Typ)))); Sec_DT_Typ : Elmt_Id := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); procedure Copy_Secondary_DTs (Typ : Entity_Id); -- Local procedure required to climb through the ancestors -- and copy the contents of all their secondary dispatch -- tables. ------------------------ -- Copy_Secondary_DTs -- ------------------------ procedure Copy_Secondary_DTs (Typ : Entity_Id) is E : Entity_Id; Iface : Elmt_Id; begin -- Climb to the ancestor (if any) handling private types if Present (Full_View (Etype (Typ))) then if Full_View (Etype (Typ)) /= Typ then Copy_Secondary_DTs (Full_View (Etype (Typ))); end if; elsif Etype (Typ) /= Typ then Copy_Secondary_DTs (Etype (Typ)); end if; if Present (Interfaces (Typ)) and then not Is_Empty_Elmt_List (Interfaces (Typ)) then Iface := First_Elmt (Interfaces (Typ)); E := First_Entity (Typ); while Present (E) and then Present (Node (Sec_DT_Ancestor)) and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant loop if Is_Tag (E) and then Chars (E) /= Name_uTag then declare Num_Prims : constant Int := UI_To_Int (DT_Entry_Count (E)); begin if not Is_Interface (Etype (Typ)) then -- Inherit first secondary dispatch table Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Ancestor)), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Typ)), Loc)), Num_Predef_Prims => Number_Of_Predefined_Prims (Parent_Typ))); if Num_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, Typ => Node (Iface), Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Sec_DT_Typ), Loc)), Num_Prims => Num_Prims)); end if; end if; Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); -- Skip the secondary dispatch table of -- predefined primitives Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); if not Is_Interface (Etype (Typ)) then -- Inherit second secondary dispatch table Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Ancestor)), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Typ)), Loc)), Num_Predef_Prims => Number_Of_Predefined_Prims (Parent_Typ))); if Num_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, Typ => Node (Iface), Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Sec_DT_Typ), Loc)), Num_Prims => Num_Prims)); end if; end if; end; Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); -- Skip the secondary dispatch table of -- predefined primitives Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); Next_Elmt (Iface); end if; Next_Entity (E); end loop; end if; end Copy_Secondary_DTs; begin if Present (Node (Sec_DT_Ancestor)) and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant then -- Handle private types if Present (Full_View (Typ)) then Copy_Secondary_DTs (Full_View (Typ)); else Copy_Secondary_DTs (Typ); end if; end if; end; end if; end if; end if; -- Generate code to check if the external tag of this type is the same -- as the external tag of some other declaration. -- Check_TSD (TSD'Unrestricted_Access); -- This check is a consequence of AI05-0113-1/06, so it officially -- applies to Ada 2005 (and Ada 2012). It might be argued that it is -- a desirable check to add in Ada 95 mode, but we hesitate to make -- this change, as it would be incompatible, and could conceivably -- cause a problem in existing Ada 95 code. -- We check for No_Run_Time_Mode here, because we do not want to pick -- up the RE_Check_TSD entity and call it in No_Run_Time mode. -- We cannot perform this check if the generation of its expanded name -- was discarded or if No_Tagged_Type_Registration is active. if not No_Run_Time_Mode and then not Discard_Names and then Ada_Version >= Ada_2005 and then not Duplicated_Tag_Checks_Suppressed (Typ) and then not Restriction_Active (No_Tagged_Type_Registration) and then RTE_Available (RE_Check_TSD) then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Unchecked_Access)))); end if; -- Generate code to register the Tag in the External_Tag hash table for -- the pure Ada type only. -- Register_Tag (Dt_Ptr); -- Skip this action in the following cases: -- 1) if Register_Tag is not available. -- 2) in No_Run_Time mode. -- 3) if Typ is not defined at the library level (this is required -- to avoid adding concurrency control to the hash table used -- by the run-time to register the tags). -- 4) No_Tagged_Type_Registration is active. if not No_Run_Time_Mode and then Is_Library_Level_Entity (Typ) and then not Restriction_Active (No_Tagged_Type_Registration) and then RTE_Available (RE_Register_Tag) then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Tag), Loc), Parameter_Associations => New_List (New_Occurrence_Of (DT_Ptr, Loc)))); end if; Append_List_To (Result, Elab_Code); -- Populate the two auxiliary tables used for dispatching asynchronous, -- conditional and timed selects for synchronized types that implement -- a limited interface. Skip this step in Ravenscar profile or when -- general dispatching is forbidden. if Ada_Version >= Ada_2005 and then Is_Concurrent_Record_Type (Typ) and then Has_Interfaces (Typ) and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Select_Statements) then Append_List_To (Result, Make_Select_Specific_Data_Table (Typ)); end if; -- Remember entities containing dispatch tables Append_Elmt (Predef_Prims, DT_Decl); Append_Elmt (DT, DT_Decl); Analyze_List (Result, Suppress => All_Checks); -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. if Has_DT (Typ) then declare Elmt : Elmt_Id; begin -- Object declarations Elmt := First_Elmt (DT_Decl); while Present (Elmt) loop Set_Is_Dispatch_Table_Entity (Node (Elmt)); pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); Next_Elmt (Elmt); end loop; -- Aggregates initializing dispatch tables Elmt := First_Elmt (DT_Aggr); while Present (Elmt) loop Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); Next_Elmt (Elmt); end loop; end; end if; <> Set_Has_Dispatch_Table (Typ); -- Register the tagged type in the call graph nodes table Register_CG_Node (Typ); <> Restore_Ghost_Region (Saved_GM, Saved_IGR); return Result; end Make_DT; ------------------------------------- -- Make_Select_Specific_Data_Table -- ------------------------------------- function Make_Select_Specific_Data_Table (Typ : Entity_Id) return List_Id is Assignments : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Typ); Conc_Typ : Entity_Id; Decls : List_Id := No_List; Prim : Entity_Id; Prim_Als : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Pos : Uint; Nb_Prim : Nat := 0; type Examined_Array is array (Int range <>) of Boolean; function Find_Entry_Index (E : Entity_Id) return Uint; -- Given an entry, find its index in the visible declarations of the -- corresponding concurrent type of Typ. ---------------------- -- Find_Entry_Index -- ---------------------- function Find_Entry_Index (E : Entity_Id) return Uint is Index : Uint := Uint_0; Subp_Decl : Node_Id; begin Subp_Decl := First (Decls); while Present (Subp_Decl) loop if Nkind (Subp_Decl) = N_Entry_Declaration then Index := Index + 1; if Defining_Identifier (Subp_Decl) = E then exit; end if; end if; Next (Subp_Decl); end loop; return Index; end Find_Entry_Index; -- Local variables Tag_Node : Node_Id; -- Start of processing for Make_Select_Specific_Data_Table begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); if Present (Corresponding_Concurrent_Type (Typ)) then Conc_Typ := Corresponding_Concurrent_Type (Typ); if Present (Full_View (Conc_Typ)) then Conc_Typ := Full_View (Conc_Typ); end if; if Ekind (Conc_Typ) = E_Protected_Type then Decls := Visible_Declarations (Protected_Definition ( Parent (Conc_Typ))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); Decls := Visible_Declarations (Task_Definition ( Parent (Conc_Typ))); end if; end if; -- Count the non-predefined primitive operations Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if not (Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim)) then Nb_Prim := Nb_Prim + 1; end if; Next_Elmt (Prim_Elmt); end loop; declare Examined : Examined_Array (1 .. Nb_Prim) := (others => False); begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Look for primitive overriding an abstract interface subprogram if Present (Interface_Alias (Prim)) and then not Is_Ancestor (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, Use_Full_View => True) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); Examined (UI_To_Int (Prim_Pos)) := True; -- Set the primitive operation kind regardless of subprogram -- type. Generate: -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, , ); if Tagged_Type_Expansion then Tag_Node := New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Integer_Literal (Loc, Prim_Pos), Prim_Op_Kind (Alias (Prim), Typ)))); -- Retrieve the root of the alias chain Prim_Als := Ultimate_Alias (Prim); -- In the case of an entry wrapper, set the entry index if Ekind (Prim) = E_Procedure and then Is_Primitive_Wrapper (Prim_Als) and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then -- Generate: -- Ada.Tags.Set_Entry_Index -- (DT_Ptr, , ); if Tagged_Type_Expansion then Tag_Node := New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Integer_Literal (Loc, Prim_Pos), Make_Integer_Literal (Loc, Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); end if; end if; Next_Elmt (Prim_Elmt); end loop; end; return Assignments; end Make_Select_Specific_Data_Table; --------------- -- Make_Tags -- --------------- function Make_Tags (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Result : constant List_Id := New_List; procedure Import_DT (Tag_Typ : Entity_Id; DT : Entity_Id; Is_Secondary_DT : Boolean); -- Import the dispatch table DT of tagged type Tag_Typ. Required to -- generate forward references and statically allocate the table. For -- primary dispatch tables that require no dispatch table generate: -- DT : static aliased constant Non_Dispatch_Table_Wrapper; -- pragma Import (Ada, DT); -- Otherwise generate: -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); -- pragma Import (Ada, DT); --------------- -- Import_DT -- --------------- procedure Import_DT (Tag_Typ : Entity_Id; DT : Entity_Id; Is_Secondary_DT : Boolean) is DT_Constr_List : List_Id; Nb_Prim : Nat; begin Set_Is_Imported (DT); Mutate_Ekind (DT, E_Constant); Set_Related_Type (DT, Typ); -- The scope must be set now to call Get_External_Name Set_Scope (DT, Current_Scope); Get_External_Name (DT); Set_Interface_Name (DT, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); -- Ensure proper Sprint output of this implicit importation Set_Is_Internal (DT); -- Save this entity to allow Make_DT to generate its exportation Append_Elmt (DT, Dispatch_Table_Wrappers (Typ)); -- No dispatch table required if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); else -- Calculate the number of primitives of the dispatch table and -- the size of the Type_Specific_Data record. Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ))); -- If the tagged type has no primitives we add a dummy slot whose -- address will be the tag of this type. if Nb_Prim = 0 then DT_Constr_List := New_List (Make_Integer_Literal (Loc, 1)); else DT_Constr_List := New_List (Make_Integer_Literal (Loc, Nb_Prim)); end if; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); end if; end Import_DT; -- Local variables Tname : constant Name_Id := Chars (Typ); AI_Tag_Comp : Elmt_Id; DT : Node_Id := Empty; DT_Ptr : Node_Id; Predef_Prims_Ptr : Node_Id; Iface_DT : Node_Id := Empty; Iface_DT_Ptr : Node_Id; New_Node : Node_Id; Suffix_Index : Int; Typ_Name : Name_Id; Typ_Comps : Elist_Id; -- Start of processing for Make_Tags begin pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); -- If the elaboration of this tagged type needs a boolean flag then -- define now its entity. It is initialized to True to indicate that -- elaboration is still pending; set to False by the IP routine. -- TypFxx : boolean := True; if Elab_Flag_Needed (Typ) then Set_Access_Disp_Table_Elab_Flag (Typ, Make_Defining_Identifier (Loc, Chars => New_External_Name (Tname, 'F'))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ), Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); end if; -- 1) Generate the primary tag entities -- Primary dispatch table containing user-defined primitives DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); Set_Etype (DT_Ptr, RTE (RE_Tag)); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); -- Minimum decoration Mutate_Ekind (DT_Ptr, E_Variable); Set_Related_Type (DT_Ptr, Typ); -- Notify back end that the types are associated with a dispatch table Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); -- For CPP types there is no need to build the dispatch tables since -- they are imported from the C++ side. If the CPP type has an IP then -- we declare now the variable that will store the copy of the C++ tag. -- If the CPP type is an interface, we need the variable as well because -- it becomes the pointer to the corresponding secondary table. if Is_CPP_Class (Typ) then if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); Set_Is_Statically_Allocated (DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); end if; -- Ada types else -- Primary dispatch table containing predefined primitives Predef_Prims_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Tname, 'Y')); Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); -- Import the forward declaration of the Dispatch Table wrapper -- record (Make_DT will take care of exporting it). if Building_Static_DT (Typ) then Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); DT := Make_Defining_Identifier (Loc, Chars => New_External_Name (Tname, 'T')); Import_DT (Typ, DT, Is_Secondary_DT => False); if Has_DT (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); -- Generate the SCIL node for the previous object declaration -- because it has a tag initialization. if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); Set_SCIL_Entity (New_Node, Typ); Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); -- No dispatch table required else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end if; Set_Is_True_Constant (DT_Ptr); Set_Is_Statically_Allocated (DT_Ptr); end if; end if; -- 2) Generate the secondary tag entities -- Collect the components associated with secondary dispatch tables if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); -- For each interface type we build a unique external name associated -- with its secondary dispatch table. This name is used to declare an -- object that references this secondary dispatch table, whose value -- will be used for the elaboration of Typ objects, and also for the -- elaboration of objects of types derived from Typ that do not -- override the primitives of this interface type. Suffix_Index := 1; -- Note: The value of Suffix_Index must be in sync with the values of -- Suffix_Index in secondary dispatch tables generated by Make_DT. if Is_CPP_Class (Typ) then AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop Get_Secondary_DT_External_Name (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); Typ_Name := Name_Find; -- Declare variables to store copy of the C++ secondary tags Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'P')); Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Mutate_Ekind (Iface_DT_Ptr, E_Variable); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT_Ptr, Object_Definition => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Interface_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); Set_Is_Statically_Allocated (Iface_DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); Next_Elmt (AI_Tag_Comp); end loop; -- This is not a CPP_Class type else AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop Get_Secondary_DT_External_Name (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); Typ_Name := Name_Find; if Building_Static_DT (Typ) then Iface_DT := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'T')); Import_DT (Tag_Typ => Related_Type (Node (AI_Tag_Comp)), DT => Iface_DT, Is_Secondary_DT => True); end if; -- Secondary dispatch table referencing thunks to user-defined -- primitives covered by this interface. Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'P')); Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Mutate_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); Set_Is_Statically_Allocated (Iface_DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); if Building_Static_DT (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT_Ptr, Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Interface_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Iface_DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end if; -- Secondary dispatch table referencing thunks to predefined -- primitives. Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'Y')); Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); Mutate_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); Set_Is_Statically_Allocated (Iface_DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); -- Secondary dispatch table referencing user-defined primitives -- covered by this interface. Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'D')); Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Mutate_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Is_Statically_Allocated (Iface_DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); -- Secondary dispatch table referencing predefined primitives Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'Z')); Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); Mutate_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Is_Statically_Allocated (Iface_DT_Ptr, Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); Next_Elmt (AI_Tag_Comp); end loop; end if; end if; -- 3) At the end of Access_Disp_Table, if the type has user-defined -- primitives, we add the entity of an access type declaration that -- is used by Build_Get_Prim_Op_Address to expand dispatching calls -- through the primary dispatch table. if DT_Entry_Count (First_Tag_Component (Typ)) = 0 then Analyze_List (Result); -- Generate: -- subtype Typ_DT is Address_Array (1 .. Nb_Prims); -- type Typ_DT_Acc is access Typ_DT; else declare Name_DT_Prims : constant Name_Id := New_External_Name (Tname, 'G'); Name_DT_Prims_Acc : constant Name_Id := New_External_Name (Tname, 'H'); DT_Prims : constant Entity_Id := Make_Defining_Identifier (Loc, Name_DT_Prims); DT_Prims_Acc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_DT_Prims_Acc); begin Append_To (Result, Make_Subtype_Declaration (Loc, Defining_Identifier => DT_Prims, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Address_Array), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => Make_Integer_Literal (Loc, DT_Entry_Count (First_Tag_Component (Typ))))))))); Append_To (Result, Make_Full_Type_Declaration (Loc, Defining_Identifier => DT_Prims_Acc, Type_Definition => Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Occurrence_Of (DT_Prims, Loc)))); Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); -- Analyze the resulting list and suppress the generation of the -- Init_Proc associated with the above array declaration because -- this type is never used in object declarations. It is only used -- to simplify the expansion associated with dispatching calls. Analyze_List (Result); Set_Suppress_Initialization (Base_Type (DT_Prims)); -- Disable backend optimizations based on assumptions about the -- aliasing status of objects designated by the access to the -- dispatch table. Required to handle dispatch tables imported -- from C++. Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc)); -- Add the freezing nodes of these declarations; required to avoid -- generating these freezing nodes in wrong scopes (for example in -- the IC routine of a derivation of Typ). -- What is an "IC routine"? Is "init_proc" meant here??? Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ)); -- Mark entity of dispatch table. Required by the back end to -- handle them properly. Set_Is_Dispatch_Table_Entity (DT_Prims); end; end if; -- Mark entities of dispatch table. Required by the back end to handle -- them properly. if Present (DT) then Set_Is_Dispatch_Table_Entity (DT); Set_Is_Dispatch_Table_Entity (Etype (DT)); end if; if Present (Iface_DT) then Set_Is_Dispatch_Table_Entity (Iface_DT); Set_Is_Dispatch_Table_Entity (Etype (Iface_DT)); end if; if Is_CPP_Class (Root_Type (Typ)) then Mutate_Ekind (DT_Ptr, E_Variable); else Mutate_Ekind (DT_Ptr, E_Constant); end if; Set_Is_Tag (DT_Ptr); Set_Related_Type (DT_Ptr, Typ); return Result; end Make_Tags; --------------- -- New_Value -- --------------- function New_Value (From : Node_Id) return Node_Id is Res : constant Node_Id := Duplicate_Subexpr (From); begin if Is_Access_Type (Etype (From)) then return Make_Explicit_Dereference (Sloc (From), Prefix => Res); else return Res; end if; end New_Value; ------------------ -- Prim_Op_Kind -- ------------------ function Prim_Op_Kind (Prim : Entity_Id; Typ : Entity_Id) return Node_Id is Full_Typ : Entity_Id := Typ; Loc : constant Source_Ptr := Sloc (Prim); Prim_Op : Entity_Id; begin -- Retrieve the original primitive operation Prim_Op := Ultimate_Alias (Prim); if Ekind (Typ) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Typ)) then Full_Typ := Corresponding_Concurrent_Type (Typ); end if; -- When a private tagged type is completed by a concurrent type, -- retrieve the full view. if Is_Private_Type (Full_Typ) then Full_Typ := Full_View (Full_Typ); end if; if Ekind (Prim_Op) = E_Function then -- Protected function if Ekind (Full_Typ) = E_Protected_Type then return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc); -- Task function elsif Ekind (Full_Typ) = E_Task_Type then return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc); -- Regular function else return New_Occurrence_Of (RTE (RE_POK_Function), Loc); end if; else pragma Assert (Ekind (Prim_Op) = E_Procedure); if Ekind (Full_Typ) = E_Protected_Type then -- Protected entry if Is_Primitive_Wrapper (Prim_Op) and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry then return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc); -- Protected procedure else return New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc); end if; elsif Ekind (Full_Typ) = E_Task_Type then -- Task entry if Is_Primitive_Wrapper (Prim_Op) and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry then return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc); -- Task "procedure". These are the internally Expander-generated -- procedures (task body for instance). else return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc); end if; -- Regular procedure else return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc); end if; end if; end Prim_Op_Kind; ----------------------------------- -- Register_Predefined_Primitive -- ----------------------------------- function Register_Predefined_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id is L : constant List_Id := New_List; Tagged_Typ : constant Entity_Id := Find_Dispatching_Type (Prim); E : Entity_Id; Iface_DT_Ptr : Elmt_Id; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : List_Id; begin if No (Access_Disp_Table (Tagged_Typ)) or else not Has_Interfaces (Tagged_Typ) or else not RTE_Available (RE_Interface_Tag) or else Restriction_Active (No_Dispatching_Calls) then return L; end if; -- Skip the first two access-to-dispatch-table pointers since they -- leads to the primary dispatch table (predefined DT and user -- defined DT). We are only concerned with the secondary dispatch -- table pointers. Note that the access-to- dispatch-table pointer -- corresponds to the first implemented interface retrieved below. Iface_DT_Ptr := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Related_Type (Node (Iface_DT_Ptr))); if Present (Thunk_Id) then Append_List_To (L, Thunk_Code); E := Prim; Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (L, SS_Thunk_Code); end if; Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc), Position => DT_Position (Prim), Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), Loc), Position => DT_Position (Prim), Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; -- Skip the tag of the predefined primitives dispatch table Next_Elmt (Iface_DT_Ptr); pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); -- Skip tag of the no-thunks dispatch table Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); -- Skip tag of predefined primitives no-thunks dispatch table Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); Next_Elmt (Iface_DT_Ptr); end loop; return L; end Register_Predefined_Primitive; ------------------------ -- Register_Primitive -- ------------------------ function Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id is L : constant List_Id := New_List; DT_Ptr : Entity_Id; E : Entity_Id; Iface_Prim : Entity_Id; Iface_Typ : Entity_Id; Iface_DT_Ptr : Entity_Id; Iface_DT_Elmt : Elmt_Id; Pos : Uint; SS_Thunk_Id : Entity_Id; SS_Thunk_Code : Node_Id; Tag : Entity_Id; Tag_Typ : Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : List_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); -- Do not register eliminated primitives in the dispatch table if not RTE_Available (RE_Tag) or else Is_Eliminated (Ultimate_Alias (Prim)) or else Generate_SCIL then return L; end if; -- Primitive associated with a tagged type if not Present (Interface_Alias (Prim)) then Tag_Typ := Scope (DTC_Entity (Prim)); Pos := DT_Position (Prim); Tag := First_Tag_Component (Tag_Typ); E := Prim; Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (L, SS_Thunk_Code); end if; if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); -- Register copy of the pointer to the 'size primitive in the TSD if Chars (Prim) = Name_uSize and then RTE_Record_Component_Available (RE_Size_Func) then DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); Append_To (L, Build_Set_Size_Function (Loc, Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), Size_Func => Prim)); end if; else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); -- Skip registration of primitives located in the C++ part of the -- dispatch table. Their slot is set by the IC routine. if not Is_CPP_Class (Root_Type (Tag_Typ)) or else Pos > CPP_Num_Prims (Tag_Typ) then DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); Append_To (L, Build_Set_Prim_Op_Address (Loc, Typ => Tag_Typ, Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; end if; -- Ada 2005 (AI-251): Primitive associated with an interface type -- Generate the code of the thunk only if the interface type is not an -- immediate ancestor of Typ; otherwise the dispatch table associated -- with the interface is the primary dispatch table and we have nothing -- else to do here. else Tag_Typ := Find_Dispatching_Type (Alias (Prim)); Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); -- No action needed for interfaces that are ancestors of Typ because -- their primitives are located in the primary dispatch table. if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then return L; -- No action needed for primitives located in the C++ part of the -- dispatch table. Their slot is set by the IC routine. elsif Is_CPP_Class (Root_Type (Tag_Typ)) and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ) and then not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Alias (Prim) then return L; end if; Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ); if Present (Thunk_Id) and then not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then -- Generate the code necessary to fill the appropriate entry of -- the secondary dispatch table of Prim's controlling type with -- Thunk_Id's address. Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); Iface_Prim := Interface_Alias (Prim); Pos := DT_Position (Iface_Prim); Tag := First_Tag_Component (Iface_Typ); Append_List_To (L, Thunk_Code); E := Ultimate_Alias (Prim); Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code); if Present (SS_Thunk_Id) then E := SS_Thunk_Id; Append_To (L, SS_Thunk_Code); end if; if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); Append_To (L, Build_Set_Prim_Op_Address (Loc, Typ => Iface_Typ, Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); Append_To (L, Build_Set_Prim_Op_Address (Loc, Typ => Iface_Typ, Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; end if; end if; return L; end Register_Primitive; ------------------------- -- Set_All_DT_Position -- ------------------------- procedure Set_All_DT_Position (Typ : Entity_Id) is function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean; -- Returns True if Prim is located in the dispatch table of -- predefined primitives procedure Validate_Position (Prim : Entity_Id); -- Check that position assigned to Prim is completely safe (it has not -- been assigned to a previously defined primitive operation of Typ). ------------------------ -- In_Predef_Prims_DT -- ------------------------ function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is begin -- Predefined primitives if Is_Predefined_Dispatching_Operation (Prim) then return True; -- Renamings of predefined primitives elsif Present (Alias (Prim)) and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)) then if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then return True; -- An overriding operation that is a user-defined renaming of -- predefined equality inherits its slot from the overridden -- operation. Otherwise it is treated as a predefined op and -- occupies the same predefined slot as equality. A call to it is -- transformed into a call to its alias, which is the predefined -- equality op. A dispatching call thus uses the proper slot if -- operation is further inherited and called with class-wide -- arguments. else return not Comes_From_Source (Prim) or else No (Overridden_Operation (Prim)); end if; -- User-defined primitives else return False; end if; end In_Predef_Prims_DT; ----------------------- -- Validate_Position -- ----------------------- procedure Validate_Position (Prim : Entity_Id) is Op_Elmt : Elmt_Id; Op : Entity_Id; begin -- Aliased primitives are safe if Present (Alias (Prim)) then return; end if; Op_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Op_Elmt) loop Op := Node (Op_Elmt); -- No need to check against itself if Op = Prim then null; -- Primitive operations covering abstract interfaces are -- allocated later elsif Present (Interface_Alias (Op)) then null; -- Predefined dispatching operations are completely safe. They -- are allocated at fixed positions in a separate table. elsif Is_Predefined_Dispatching_Operation (Op) or else Is_Predefined_Dispatching_Alias (Op) then null; -- Aliased subprograms are safe elsif Present (Alias (Op)) then null; elsif DT_Position (Op) = DT_Position (Prim) and then not Is_Predefined_Dispatching_Operation (Op) and then not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Alias (Op) and then not Is_Predefined_Dispatching_Alias (Prim) then -- Handle aliased subprograms declare Op_1 : Entity_Id; Op_2 : Entity_Id; begin Op_1 := Op; loop if Present (Overridden_Operation (Op_1)) then Op_1 := Overridden_Operation (Op_1); elsif Present (Alias (Op_1)) then Op_1 := Alias (Op_1); else exit; end if; end loop; Op_2 := Prim; loop if Present (Overridden_Operation (Op_2)) then Op_2 := Overridden_Operation (Op_2); elsif Present (Alias (Op_2)) then Op_2 := Alias (Op_2); else exit; end if; end loop; if Op_1 /= Op_2 then raise Program_Error; end if; end; end if; Next_Elmt (Op_Elmt); end loop; end Validate_Position; -- Local variables Parent_Typ : constant Entity_Id := Etype (Typ); First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); The_Tag : constant Entity_Id := First_Tag_Component (Typ); Adjusted : Boolean := False; Finalized : Boolean := False; Count_Prim : Nat; DT_Length : Nat; Nb_Prim : Nat; Prim : Entity_Id; Prim_Elmt : Elmt_Id; -- Start of processing for Set_All_DT_Position begin pragma Assert (Present (First_Tag_Component (Typ))); -- Set the DT_Position for each primitive operation. Perform some sanity -- checks to avoid building inconsistent dispatch tables. -- First stage: Set DTC entity of all the primitive operations. This is -- required to properly read the DT_Position attribute in latter stages. Prim_Elmt := First_Prim; Count_Prim := 0; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Predefined primitives have a separate dispatch table if not In_Predef_Prims_DT (Prim) then Count_Prim := Count_Prim + 1; end if; Set_DTC_Entity_Value (Typ, Prim); -- Clear any previous value of the DT_Position attribute. In this -- way we ensure that the final position of all the primitives is -- established by the following stages of this algorithm. Set_DT_Position_Value (Prim, No_Uint); Next_Elmt (Prim_Elmt); end loop; declare Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := (others => False); E : Entity_Id; procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); -- Called if Typ is declared in a nested package or a public child -- package to handle inherited primitives that were inherited by Typ -- in the visible part, but whose declaration was deferred because -- the parent operation was private and not visible at that point. procedure Set_Fixed_Prim (Pos : Nat); -- Sets to true an element of the Fixed_Prim table to indicate -- that this entry of the dispatch table of Typ is occupied. ------------------------------------------ -- Handle_Inherited_Private_Subprograms -- ------------------------------------------ procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is Op_List : Elist_Id; Op_Elmt : Elmt_Id; Op_Elmt_2 : Elmt_Id; Prim_Op : Entity_Id; Parent_Subp : Entity_Id; begin Op_List := Primitive_Operations (Typ); Op_Elmt := First_Elmt (Op_List); while Present (Op_Elmt) loop Prim_Op := Node (Op_Elmt); -- Search primitives that are implicit operations with an -- internal name whose parent operation has a normal name. if Present (Alias (Prim_Op)) and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ and then not Comes_From_Source (Prim_Op) and then Is_Internal_Name (Chars (Prim_Op)) and then not Is_Internal_Name (Chars (Alias (Prim_Op))) then Parent_Subp := Alias (Prim_Op); -- Check if the type has an explicit overriding for this -- primitive. Op_Elmt_2 := Next_Elmt (Op_Elmt); while Present (Op_Elmt_2) loop if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) then Set_DT_Position_Value (Prim_Op, DT_Position (Parent_Subp)); Set_DT_Position_Value (Node (Op_Elmt_2), DT_Position (Parent_Subp)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); goto Next_Primitive; end if; Next_Elmt (Op_Elmt_2); end loop; end if; <> Next_Elmt (Op_Elmt); end loop; end Handle_Inherited_Private_Subprograms; -------------------- -- Set_Fixed_Prim -- -------------------- procedure Set_Fixed_Prim (Pos : Nat) is begin pragma Assert (Pos <= Count_Prim); Fixed_Prim (Pos) := True; exception when Constraint_Error => raise Program_Error; end Set_Fixed_Prim; begin -- In case of nested packages and public child package it may be -- necessary a special management on inherited subprograms so that -- the dispatch table is properly filled. if Ekind (Scope (Scope (Typ))) = E_Package and then Scope (Scope (Typ)) /= Standard_Standard and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) or else (Nkind (Parent (Typ)) = N_Private_Extension_Declaration and then Is_Generic_Type (Typ))) and then In_Open_Scopes (Scope (Etype (Typ))) and then Is_Base_Type (Typ) then Handle_Inherited_Private_Subprograms (Typ); end if; -- Second stage: Register fixed entries Nb_Prim := 0; Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Predefined primitives have a separate table and all its -- entries are at predefined fixed positions. if In_Predef_Prims_DT (Prim) then if Is_Predefined_Dispatching_Operation (Prim) then Set_DT_Position_Value (Prim, Default_Prim_Op_Position (Prim)); else pragma Assert (Present (Alias (Prim))); Set_DT_Position_Value (Prim, Default_Prim_Op_Position (Ultimate_Alias (Prim))); end if; -- Overriding primitives of ancestor abstract interfaces elsif Present (Interface_Alias (Prim)) and then Is_Ancestor (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, Use_Full_View => True) then pragma Assert (No (DT_Position (Prim))); pragma Assert (Present (DTC_Entity (Interface_Alias (Prim)))); E := Interface_Alias (Prim); Set_DT_Position_Value (Prim, DT_Position (E)); pragma Assert (No (DT_Position (Alias (Prim))) or else DT_Position (Alias (Prim)) = DT_Position (E)); Set_DT_Position_Value (Alias (Prim), DT_Position (E)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the overridden -- primitive. Note that the Alias of the operation is set when the -- operation is declared by a renaming, in which case it is not -- overriding. If it renames another primitive it will use the -- same dispatch table slot, but if it renames an operation in a -- nested package it's a new primitive and will have its own slot. elsif not Present (Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) and then Nkind (Unit_Declaration_Node (Prim)) /= N_Subprogram_Renaming_Declaration then declare Par_Type : constant Entity_Id := Find_Dispatching_Type (Alias (Prim)); begin if Present (Par_Type) and then Par_Type /= Typ and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True) and then Present (DTC_Entity (Alias (Prim))) then E := Alias (Prim); Set_DT_Position_Value (Prim, DT_Position (E)); if not Is_Predefined_Dispatching_Alias (E) then Set_Fixed_Prim (UI_To_Int (DT_Position (E))); end if; end if; end; end if; Next_Elmt (Prim_Elmt); end loop; -- Third stage: Fix the position of all the new primitives. Entries -- associated with primitives covering interfaces are handled in a -- latter round. Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- Skip primitives previously set entries if Present (DT_Position (Prim)) then null; -- Primitives covering interface primitives are handled later elsif Present (Interface_Alias (Prim)) then null; else -- Take the next available position in the DT loop Nb_Prim := Nb_Prim + 1; pragma Assert (Nb_Prim <= Count_Prim); exit when not Fixed_Prim (Nb_Prim); end loop; Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim)); Set_Fixed_Prim (Nb_Prim); end if; Next_Elmt (Prim_Elmt); end loop; end; -- Fourth stage: Complete the decoration of primitives covering -- interfaces (that is, propagate the DT_Position attribute from -- the aliased primitive) Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if No (DT_Position (Prim)) and then Present (Interface_Alias (Prim)) then pragma Assert (Present (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) = Typ); -- Check if this entry will be placed in the primary DT if Is_Ancestor (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, Use_Full_View => True) then pragma Assert (Present (DT_Position (Alias (Prim)))); Set_DT_Position_Value (Prim, DT_Position (Alias (Prim))); -- Otherwise it will be placed in the secondary DT else pragma Assert (Present (DT_Position (Interface_Alias (Prim)))); Set_DT_Position_Value (Prim, DT_Position (Interface_Alias (Prim))); end if; end if; Next_Elmt (Prim_Elmt); end loop; -- Generate listing showing the contents of the dispatch tables. This -- action is done before some further static checks because in case of -- critical errors caused by a wrong dispatch table we need to see the -- contents of such table. if Debug_Flag_ZZ then Write_DT (Typ); end if; -- Final stage: Ensure that the table is correct plus some further -- verifications concerning the primitives. Prim_Elmt := First_Prim; DT_Length := 0; while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); -- At this point all the primitives MUST have a position in the -- dispatch table. if No (DT_Position (Prim)) then raise Program_Error; end if; -- Calculate real size of the dispatch table if not In_Predef_Prims_DT (Prim) and then UI_To_Int (DT_Position (Prim)) > DT_Length then DT_Length := UI_To_Int (DT_Position (Prim)); end if; -- Ensure that the assigned position to non-predefined dispatching -- operations in the dispatch table is correct. if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Alias (Prim) then Validate_Position (Prim); end if; if Chars (Prim) = Name_Finalize then Finalized := True; end if; if Chars (Prim) = Name_Adjust then Adjusted := True; end if; -- An abstract operation cannot be declared in the private part for a -- visible abstract type, because it can't be overridden outside this -- package hierarchy. For explicit declarations this is checked at -- the point of declaration, but for inherited operations it must be -- done when building the dispatch table. -- Ada 2005 (AI-251): Primitives associated with interfaces are -- excluded from this check because interfaces must be visible in -- the public and private part (RM 7.3 (7.3/2)) -- We disable this check in Relaxed_RM_Semantics mode, to accommodate -- legacy Ada code. if not Relaxed_RM_Semantics and then Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) and then not Is_Interface (Find_Dispatching_Type (Ultimate_Alias (Prim))) and then not Present (Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then List_Containing (Parent (Prim)) = Private_Declarations (Package_Specification (Current_Scope)) and then Original_View_In_Visible_Part (Typ) then -- We exclude Input and Output stream operations because -- Limited_Controlled inherits useless Input and Output stream -- operations from Root_Controlled, which can never be overridden. -- Move this check to sem??? if not Is_TSS (Prim, TSS_Stream_Input) and then not Is_TSS (Prim, TSS_Stream_Output) then Error_Msg_NE ("abstract inherited private operation&" & " must be overridden (RM 3.9.3(10))", Parent (Typ), Prim); end if; end if; Next_Elmt (Prim_Elmt); end loop; -- Additional check if Is_Controlled (Typ) then if not Finalized then Error_Msg_N ("controlled type has no explicit Finalize method??", Typ); elsif not Adjusted then Error_Msg_N ("controlled type has no explicit Adjust method??", Typ); end if; end if; -- Set the final size of the Dispatch Table Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); -- The derived type must have at least as many components as its parent -- (for root types Etype points to itself and the test cannot fail). if DT_Entry_Count (The_Tag) < DT_Entry_Count (First_Tag_Component (Parent_Typ)) then raise Program_Error; end if; end Set_All_DT_Position; -------------------------- -- Set_CPP_Constructors -- -------------------------- procedure Set_CPP_Constructors (Typ : Entity_Id) is function Gen_Parameters_Profile (E : Entity_Id) return List_Id; -- Duplicate the parameters profile of the imported C++ constructor -- adding the "this" pointer to the object as the additional first -- parameter under the usual form _Init : in out Typ. ---------------------------- -- Gen_Parameters_Profile -- ---------------------------- function Gen_Parameters_Profile (E : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (E); Parms : List_Id; P : Node_Id; begin Parms := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), In_Present => True, Out_Present => True, Parameter_Type => New_Occurrence_Of (Typ, Loc))); P := First (Parameter_Specifications (Parent (E))); while Present (P) loop Append_To (Parms, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars => Chars (Defining_Identifier (P))), Parameter_Type => New_Copy_Tree (Parameter_Type (P)), Expression => New_Copy_Tree (Expression (P)))); Next (P); end loop; return Parms; end Gen_Parameters_Profile; -- Local variables Loc : Source_Ptr; E : Entity_Id; Found : Boolean := False; IP : Entity_Id; IP_Body : Node_Id; P : Node_Id; Parms : List_Id; Covers_Default_Constructor : Entity_Id := Empty; -- Start of processing for Set_CPP_Constructor begin pragma Assert (Is_CPP_Class (Typ)); -- Look for the constructor entities E := Next_Entity (Typ); while Present (E) loop if Ekind (E) = E_Function and then Is_Constructor (E) then Found := True; Loc := Sloc (E); Parms := Gen_Parameters_Profile (E); IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); -- Case 1: Constructor of untagged type -- If the C++ class has no virtual methods then the matching Ada -- type is an untagged record type. In such case there is no need -- to generate a wrapper of the C++ constructor because the _tag -- component is not available. if not Is_Tagged_Type (Typ) then Discard_Node (Make_Subprogram_Declaration (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => IP, Parameter_Specifications => Parms))); Set_Init_Proc (Typ, IP); Set_Is_Imported (IP); Set_Is_Constructor (IP); Set_Interface_Name (IP, Interface_Name (E)); Set_Convention (IP, Convention_CPP); Set_Is_Public (IP); Set_Has_Completion (IP); -- Case 2: Constructor of a tagged type -- In this case we generate the IP routine as a wrapper of the -- C++ constructor because IP must also save a copy of the _tag -- generated in the C++ side. The copy of the _tag is used by -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. -- Generate: -- procedure IP (_init : in out Typ; ...) is -- procedure ConstructorP (_init : in out Typ; ...); -- pragma Import (ConstructorP); -- begin -- ConstructorP (_init, ...); -- if Typ._tag = null then -- Typ._tag := _init._tag; -- end if; -- end IP; else declare Body_Stmts : constant List_Id := New_List; Constructor_Id : Entity_Id; Constructor_Decl_Node : Node_Id; Init_Tags_List : List_Id; begin Constructor_Id := Make_Temporary (Loc, 'P'); Constructor_Decl_Node := Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, Defining_Unit_Name => Constructor_Id, Parameter_Specifications => Parms)); Set_Is_Imported (Constructor_Id); Set_Is_Constructor (Constructor_Id); Set_Interface_Name (Constructor_Id, Interface_Name (E)); Set_Convention (Constructor_Id, Convention_CPP); Set_Is_Public (Constructor_Id); Set_Has_Completion (Constructor_Id); -- Build the init procedure as a wrapper of this constructor Parms := Gen_Parameters_Profile (E); -- Invoke the C++ constructor declare Actuals : constant List_Id := New_List; begin P := First (Parms); while Present (P) loop Append_To (Actuals, New_Occurrence_Of (Defining_Identifier (P), Loc)); Next (P); end loop; Append_To (Body_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Constructor_Id, Loc), Parameter_Associations => Actuals)); end; -- Initialize copies of C++ primary and secondary tags Init_Tags_List := New_List; declare Tag_Elmt : Elmt_Id; Tag_Comp : Node_Id; begin Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); Tag_Comp := First_Tag_Component (Typ); while Present (Tag_Elmt) and then Is_Tag (Node (Tag_Elmt)) loop -- Skip the following assertion with primary tags -- because Related_Type is not set on primary tag -- components. pragma Assert (Tag_Comp = First_Tag_Component (Typ) or else Related_Type (Node (Tag_Elmt)) = Related_Type (Tag_Comp)); Append_To (Init_Tags_List, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Node (Tag_Elmt), Loc), Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)))); Tag_Comp := Next_Tag_Component (Tag_Comp); Next_Elmt (Tag_Elmt); end loop; end; Append_To (Body_Stmts, Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc), Right_Opnd => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (RTE (RE_Null_Address), Loc))), Then_Statements => Init_Tags_List)); IP_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => IP, Parameter_Specifications => Parms), Declarations => New_List (Constructor_Decl_Node), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Body_Stmts, Exception_Handlers => No_List)); Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); end; end if; -- If this constructor has parameters and all its parameters have -- defaults then it covers the default constructor. The semantic -- analyzer ensures that only one constructor with defaults covers -- the default constructor. if Present (Parameter_Specifications (Parent (E))) and then Needs_No_Actuals (E) then Covers_Default_Constructor := IP; end if; end if; Next_Entity (E); end loop; -- If there are no constructors, mark the type as abstract since we -- won't be able to declare objects of that type. if not Found then Set_Is_Abstract_Type (Typ); end if; -- Handle constructor that has all its parameters with defaults and -- hence it covers the default constructor. We generate a wrapper IP -- which calls the covering constructor. if Present (Covers_Default_Constructor) then declare Body_Stmts : List_Id; begin Loc := Sloc (Covers_Default_Constructor); Body_Stmts := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Covers_Default_Constructor, Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, Name_uInit)))); IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); IP_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => IP, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), Parameter_Type => New_Occurrence_Of (Typ, Loc)))), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Body_Stmts, Exception_Handlers => No_List)); Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); end; end if; -- If the CPP type has constructors then it must import also the default -- C++ constructor. It is required for default initialization of objects -- of the type. It is also required to elaborate objects of Ada types -- that are defined as derivations of this CPP type. if Has_CPP_Constructors (Typ) and then No (Init_Proc (Typ)) then Error_Msg_N ("??default constructor must be imported from C++", Typ); end if; end Set_CPP_Constructors; --------------------------- -- Set_DT_Position_Value -- --------------------------- procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is begin Set_DT_Position (Prim, Value); -- Propagate the value to the wrapped subprogram (if one is present) if Ekind (Prim) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Prim) and then Present (Wrapped_Entity (Prim)) and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) then Set_DT_Position (Wrapped_Entity (Prim), Value); end if; end Set_DT_Position_Value; -------------------------- -- Set_DTC_Entity_Value -- -------------------------- procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id) is begin if Present (Interface_Alias (Prim)) and then Is_Interface (Find_Dispatching_Type (Interface_Alias (Prim))) then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Tagged_Type, Iface => Find_Dispatching_Type (Interface_Alias (Prim)))); else Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); end if; -- Propagate the value to the wrapped subprogram (if one is present) if Ekind (Prim) in E_Function | E_Procedure and then Is_Primitive_Wrapper (Prim) and then Present (Wrapped_Entity (Prim)) and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) then Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim)); end if; end Set_DTC_Entity_Value; ----------------- -- Tagged_Kind -- ----------------- function Tagged_Kind (T : Entity_Id) return Node_Id is Conc_Typ : Entity_Id; Loc : constant Source_Ptr := Sloc (T); begin pragma Assert (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); -- Abstract kinds if Is_Abstract_Type (T) then if Is_Limited_Record (T) then return New_Occurrence_Of (RTE (RE_TK_Abstract_Limited_Tagged), Loc); else return New_Occurrence_Of (RTE (RE_TK_Abstract_Tagged), Loc); end if; -- Concurrent kinds elsif Is_Concurrent_Record_Type (T) then Conc_Typ := Corresponding_Concurrent_Type (T); if Present (Full_View (Conc_Typ)) then Conc_Typ := Full_View (Conc_Typ); end if; if Ekind (Conc_Typ) = E_Protected_Type then return New_Occurrence_Of (RTE (RE_TK_Protected), Loc); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); return New_Occurrence_Of (RTE (RE_TK_Task), Loc); end if; -- Regular tagged kinds else if Is_Limited_Record (T) then return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc); else return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc); end if; end if; end Tagged_Kind; -------------- -- Write_DT -- -------------- procedure Write_DT (Typ : Entity_Id) is Elmt : Elmt_Id; Prim : Node_Id; begin -- Protect this procedure against wrong usage. Required because it will -- be used directly from GDB if not (Typ <= Last_Node_Id) or else not Is_Tagged_Type (Typ) then Write_Str ("wrong usage: Write_DT must be used with tagged types"); Write_Eol; return; end if; Write_Int (Int (Typ)); Write_Str (": "); Write_Name (Chars (Typ)); if Is_Interface (Typ) then Write_Str (" is interface"); end if; Write_Eol; Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop Prim := Node (Elmt); Write_Str (" - "); -- Indicate if this primitive will be allocated in the primary -- dispatch table or in a secondary dispatch table associated -- with an abstract interface type if Present (DTC_Entity (Prim)) then if Is_RTE (Etype (DTC_Entity (Prim)), RE_Tag) then Write_Str ("[P] "); else Write_Str ("[s] "); end if; end if; -- Output the node of this primitive operation and its name Write_Int (Int (Prim)); Write_Str (": "); if Is_Predefined_Dispatching_Operation (Prim) then Write_Str ("(predefined) "); end if; -- Prefix the name of the primitive with its corresponding tagged -- type to facilitate seeing inherited primitives. if Present (Alias (Prim)) then Write_Name (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); else Write_Name (Chars (Typ)); end if; Write_Str ("."); Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive if Present (Alias (Prim)) then Write_Str (" (alias = "); Write_Int (Int (Alias (Prim))); -- If the DTC_Entity attribute is already set we can also output -- the name of the interface covered by this primitive (if any). if Ekind (Alias (Prim)) in E_Function | E_Procedure and then Present (DTC_Entity (Alias (Prim))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) then Write_Str (" from interface "); Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); end if; if Present (Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then Write_Str ("null primitive "); end if; Write_Name (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); Write_Char (':'); Write_Int (Int (Interface_Alias (Prim))); end if; Write_Str (")"); end if; -- Display the final position of this primitive in its associated -- (primary or secondary) dispatch table. if Present (DTC_Entity (Prim)) and then Present (DT_Position (Prim)) then Write_Str (" at #"); Write_Int (UI_To_Int (DT_Position (Prim))); end if; if Is_Abstract_Subprogram (Prim) then Write_Str (" is abstract;"); -- Check if this is a null primitive elsif Comes_From_Source (Prim) and then Ekind (Prim) = E_Procedure and then Null_Present (Parent (Prim)) then Write_Str (" is null;"); end if; if Is_Eliminated (Ultimate_Alias (Prim)) then Write_Str (" (eliminated)"); end if; if Is_Imported (Prim) and then Convention (Prim) = Convention_CPP then Write_Str (" (C++)"); end if; Write_Eol; Next_Elmt (Elmt); end loop; end Write_DT; end Exp_Disp;