------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ D I S P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- 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 Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; with Exp_Ch7; use Exp_Ch7; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; with Lib; use Lib; 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_Ch6; use Sem_Ch6; 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 Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; 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. 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 (ie. through a renaming) function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; -- Check if the type has a private view or if the public view appears -- in the visible part of a package spec. 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. ------------------------------ -- 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 Chars (E) = Name_uAlignment then return Uint_2; elsif TSS_Name = TSS_Stream_Read then return Uint_3; elsif TSS_Name = TSS_Stream_Write then return Uint_4; elsif TSS_Name = TSS_Stream_Input then return Uint_5; elsif TSS_Name = TSS_Stream_Output then return Uint_6; elsif Chars (E) = Name_Op_Eq then return Uint_7; elsif Chars (E) = Name_uAssign then return Uint_8; elsif TSS_Name = TSS_Deep_Adjust then return Uint_9; elsif TSS_Name = TSS_Deep_Finalize then return Uint_10; elsif Ada_Version >= Ada_05 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_Timed_Select then return Uint_15; end if; end if; raise Program_Error; end Default_Prim_Op_Position; ----------------------------- -- 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); 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; Res_Typ : Entity_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; -- 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 need a check to see whether expansion is active before -- proceeding. In addition, 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. 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 Etype (Ctrl_Arg) = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) and then Etype (Ctrl_Arg) = RTE (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 (Etype (Ctrl_Arg)) then CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); else CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg)); end if; Typ := Root_Type (CW_Typ); if Ekind (Typ) = E_Incomplete_Type then Typ := Non_Limited_View (Typ); end if; 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. if Is_CPP_Class (Typ) then New_Params := New_List; 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 -- Generate the Tag checks when appropriate New_Params := New_List; Param := First_Actual (Call_Node); while Present (Param) loop -- No tag check with itself if Param = Ctrl_Arg then Append_To (New_Params, Duplicate_Subexpr_Move_Checks (Param)); -- No tag check for parameter whose type is neither tagged nor -- access to tagged (for access parameters) elsif No (Find_Controlling_Arg (Param)) then Append_To (New_Params, Relocate_Node (Param)); -- 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 Append_To (New_Params, Relocate_Node (Param)); -- "=" 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 Append_To (New_Params, Duplicate_Subexpr_Move_Checks (Param)); -- 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 Append_To (New_Params, Relocate_Node (Param)); -- 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 Append_To (New_Params, Relocate_Node (Param)); -- 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_Reference_To (First_Tag_Component (Typ), Loc)), Right_Opnd => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, New_Value (Param)), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc))), Then_Statements => New_List (New_Constraint_Error (Loc)))); Append_To (New_Params, Relocate_Node (Param)); end if; Next_Actual (Param); end loop; end if; -- Generate the appropriate subprogram pointer type if Etype (Subp) = Typ then Res_Typ := CW_Typ; else Res_Typ := Etype (Subp); end if; Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Typ, Res_Typ); Init_Size_Align (Subp_Ptr_Typ); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); -- 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; Extra : 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 Is_Itype (Etype (New_Formal)) then Extra := New_Copy (Etype (New_Formal)); if Ekind (Extra) = E_Record_Subtype or else Ekind (Extra) = E_Class_Wide_Subtype then Set_Cloned_Subtype (Extra, Etype (New_Formal)); end if; Set_Etype (New_Formal, Extra); Set_Scope (Etype (New_Formal), Subp_Typ); end if; Extra := New_Formal; Next_Formal (Old_Formal); exit when No (Old_Formal); Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); Next_Entity (New_Formal); Next_Actual (Param); end loop; Set_Next_Entity (New_Formal, Empty); Set_Last_Entity (Subp_Typ, Extra); end if; -- Now that the explicit formals have been duplicated, any extra -- formals needed by the subprogram must be created. if Present (Extra) then Set_Extra_Formal (Extra, Empty); end if; Create_Extra_Formals (Subp_Typ); end; Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_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 Etype (Ctrl_Arg) = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) and then Etype (Ctrl_Arg) = RTE (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 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) and then Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag))) then Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg)); -- Ada 2005 (AI-251): Abstract interface class-wide type elsif Is_Interface (Etype (Ctrl_Arg)) and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); else Controlling_Tag := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), Selector_Name => New_Reference_To (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 New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, Build_Get_Predefined_Prim_Op_Address (Loc, Tag_Node => Controlling_Tag, Position => DT_Position (Subp))); -- Handle dispatching calls to user-defined primitives else New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, Build_Get_Prim_Op_Address (Loc, Typ => Find_Dispatching_Type (Subp), Tag_Node => Controlling_Tag, Position => DT_Position (Subp))); 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_Reference_To (First_Tag_Component (Typ), Loc)), Right_Opnd => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, New_Value (Next_Actual (Param))), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc))), Right_Opnd => New_Call); end if; else New_Call := Make_Procedure_Call_Statement (Loc, Name => New_Call_Name, Parameter_Associations => New_Params); end if; Rewrite (Call_Node, New_Call); -- Suppress all checks during the analysis of the expanded code -- to avoid the generation of spureous 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_Static : Boolean := True) is Loc : constant Source_Ptr := Sloc (N); Etyp : constant Entity_Id := Etype (N); Operand : constant Node_Id := Expression (N); Operand_Typ : Entity_Id := Etype (Operand); Fent : Entity_Id; Func : Node_Id; Iface_Typ : Entity_Id := Etype (N); Iface_Tag : Entity_Id; New_Itype : Entity_Id; Stats : List_Id; begin -- 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; -- Handle access types to interfaces if Is_Access_Type (Iface_Typ) then Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); end if; -- Handle class-wide interface types. This conversion can appear -- explicitly in the source code. Example: I'Class (Obj) if Is_Class_Wide_Type (Iface_Typ) then Iface_Typ := Root_Type (Iface_Typ); end if; pragma Assert (not Is_Static or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); if VM_Target /= No_VM then -- For VM, just do a conversion ??? 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 ("abstract interface types", 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 pragma Assert (Is_Interface (Directly_Designated_Type (Operand_Typ))); Rewrite (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, Name => New_Reference_To (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_Reference_To (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 the target is a class-wide interface we change the type of the -- data returned by IW_Convert to indicate that this is a dispatching -- call. New_Itype := Create_Itype (E_Anonymous_Access_Type, N); Set_Etype (New_Itype, New_Itype); Init_Esize (New_Itype); Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Etyp); Rewrite (N, Make_Explicit_Dereference (Loc, Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); Analyze (N); Freeze_Itype (New_Itype, N); return; end if; Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); pragma Assert (Iface_Tag /= Empty); -- Keep separate access types to interfaces because one internal -- function is used to handle the null value (see following comment) if not Is_Access_Type (Etype (N)) then Rewrite (N, Unchecked_Convert_To (Etype (N), 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 -- begin -- if O = Null_Address then -- return null; -- else -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address); -- end if; -- end Func; Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F')); declare Desig_Typ : Entity_Id; begin Desig_Typ := Etype (Expression (N)); if Is_Access_Type (Desig_Typ) then Desig_Typ := Directly_Designated_Type (Desig_Typ); end if; New_Itype := Create_Itype (E_Anonymous_Access_Type, N); Set_Etype (New_Itype, New_Itype); Set_Scope (New_Itype, Fent); Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Desig_Typ); end; Stats := New_List ( Make_Return_Statement (Loc, Unchecked_Convert_To (Etype (N), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (New_Itype, 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_Reference_To (RTE (RE_Null_Address), Loc)), Then_Statements => New_List ( Make_Return_Statement (Loc, Make_Null (Loc))), Else_Statements => Stats)); end if; 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_Reference_To (RTE (RE_Address), Loc))), Result_Definition => New_Reference_To (Etype (N), Loc)), Declarations => Empty_List, 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: Operand_Typ!(Expression.all)'Address Rewrite (N, Make_Function_Call (Loc, Name => New_Reference_To (Fent, Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Unchecked_Convert_To (Operand_Typ, Make_Explicit_Dereference (Loc, Relocate_Node (Expression (N)))), Attribute_Name => Name_Address)))); else -- Generate: Operand_Typ!(Expression)'Address Rewrite (N, Make_Function_Call (Loc, Name => New_Reference_To (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 if; Analyze (N); end Expand_Interface_Conversion; ------------------------------ -- Expand_Interface_Actuals -- ------------------------------ procedure Expand_Interface_Actuals (Call_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (Call_Node); 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; Nam : Name_Id; Formal_DDT : Entity_Id; Actual_DDT : Entity_Id; 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)); -- Normal case 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 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); end if; Actual_Typ := Etype (Actual); if Is_Access_Type (Actual_Typ) then Actual_DDT := Directly_Designated_Type (Actual_Typ); 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 -- coindices 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_Parent (Formal_Typ, Actual_Typ) then null; -- Implicit conversion to the class-wide formal type to force -- the displacement of the pointer. else 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 Nam := Attribute_Name (Actual); Conversion := Convert_To (Formal_DDT, Prefix (Actual)); Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_DDT); Rewrite (Actual, Unchecked_Convert_To (Formal_Typ, Make_Attribute_Reference (Loc, Prefix => Relocate_Node (Actual), Attribute_Name => Nam))); Analyze_And_Resolve (Actual, Formal_Typ); -- 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_Parent (Formal_DDT, Actual_DDT) then null; else Actual_Dup := Relocate_Node (Actual); if From_With_Type (Actual_Typ) then -- If the type of the actual parameter comes from a limited -- with-clause and the non-limited view is already available -- we replace the anonymous access type by a duplicate decla -- ration whose designated type is the non-limited view if Ekind (Actual_DDT) = E_Incomplete_Type and then Present (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); elsif Is_Class_Wide_Type (Actual_DDT) and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type and then Present (Non_Limited_View (Etype (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, New_Copy (Actual_DDT)); Set_Class_Wide_Type (Directly_Designated_Type (Anon), New_Copy (Class_Wide_Type (Actual_DDT))); Set_Etype (Directly_Designated_Type (Anon), Non_Limited_View (Etype (Actual_DDT))); Set_Etype ( Class_Wide_Type (Directly_Designated_Type (Anon)), Non_Limited_View (Etype (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 (N : Node_Id; Thunk_Alias : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id) is Loc : constant Source_Ptr := Sloc (N); Actuals : constant List_Id := New_List; Decl : constant List_Id := New_List; Formals : constant List_Id := New_List; Controlling_Typ : Entity_Id; Decl_1 : Node_Id; Decl_2 : Node_Id; Formal : Node_Id; Target : Entity_Id; Target_Formal : Entity_Id; begin Thunk_Id := Empty; Thunk_Code := Empty; -- Give message if configurable run-time and Offset_To_Top unavailable if not RTE_Available (RE_Offset_To_Top) then Error_Msg_CRT ("abstract interface types", N); return; end if; -- Traverse the list of alias to find the final target Target := Thunk_Alias; while Present (Alias (Target)) loop Target := Alias (Target); end loop; -- In case of primitives that are functions without formals and -- a controlling result there is no need to build the thunk. if not Present (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); return; end if; -- Duplicate the formals Formal := First_Formal (Target); while Present (Formal) loop Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Sloc (Formal), Chars => Chars (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), Parameter_Type => New_Reference_To (Etype (Formal), Loc), Expression => New_Copy_Tree (Expression (Parent (Formal))))); Next_Formal (Formal); end loop; if Ekind (First_Formal (Target)) = E_In_Parameter and then Ekind (Etype (First_Formal (Target))) = E_Anonymous_Access_Type then Controlling_Typ := Directly_Designated_Type (Etype (First_Formal (Target))); else Controlling_Typ := Etype (First_Formal (Target)); end if; Target_Formal := First_Formal (Target); Formal := First (Formals); while Present (Formal) loop if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type and then Directly_Designated_Type (Etype (Target_Formal)) = Controlling_Typ then -- Generate: -- type T is access all <> -- S1 := Storage_Offset!(formal) -- - Offset_To_Top (Formal.Tag) -- ... and the first actual of the call is generated as T!(S1) Decl_2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('T')), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => False, Constant_Present => False, Subtype_Indication => New_Reference_To (Directly_Designated_Type (Etype (Target_Formal)), Loc))); Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), Expression => Make_Op_Subtract (Loc, Left_Opnd => Unchecked_Convert_To (RTE (RE_Storage_Offset), New_Reference_To (Defining_Identifier (Formal), Loc)), Right_Opnd => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), New_Reference_To (Defining_Identifier (Formal), Loc)))))); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); -- Reference the new first actual Append_To (Actuals, Unchecked_Convert_To (Defining_Identifier (Decl_2), New_Reference_To (Defining_Identifier (Decl_1), Loc))); elsif Etype (Target_Formal) = Controlling_Typ then -- Generate: -- S1 := Storage_Offset!(Formal'Address) -- - Offset_To_Top (Formal.Tag) -- S2 := Tag_Ptr!(S3) Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), Expression => Make_Op_Subtract (Loc, Left_Opnd => Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address)), Right_Opnd => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address))))); Decl_2 := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('S')), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), Expression => Unchecked_Convert_To (RTE (RE_Addr_Ptr), New_Reference_To (Defining_Identifier (Decl_1), Loc))); Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); -- Reference the new first actual Append_To (Actuals, Unchecked_Convert_To (Etype (First_Entity (Target)), Make_Explicit_Dereference (Loc, New_Reference_To (Defining_Identifier (Decl_2), Loc)))); -- No special management required for this actual else Append_To (Actuals, New_Reference_To (Defining_Identifier (Formal), Loc)); end if; Next_Formal (Target_Formal); Next (Formal); end loop; Thunk_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('T')); if Ekind (Target) = E_Procedure then 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)))); else pragma Assert (Ekind (Target) = E_Function); Thunk_Code := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals, Result_Definition => New_Copy (Result_Definition (Parent (Target)))), Declarations => Decl, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Return_Statement (Loc, Make_Function_Call (Loc, Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals))))); end if; end Expand_Interface_Thunk; ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean is E : Entity_Id; begin if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Alias (Prim)) then E := Prim; while Present (Alias (E)) loop E := Alias (E); end loop; if Is_Predefined_Dispatching_Operation (E) then return True; end if; end if; return False; end Is_Predefined_Dispatching_Alias; ---------------------------------------- -- Make_Disp_Asynchronous_Select_Body -- ---------------------------------------- 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; DT_Ptr : Entity_Id; Loc : constant Source_Ptr := Sloc (Typ); Stmts : constant List_Id := New_List; 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_Null_Statement (Loc)))); end if; DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer := Get_Entry_Index (tag! (VP), S); -- 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_Reference_To (Standard_Integer, Loc), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then -- Generate: -- Com_Block : Communication_Block; Com_Block := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Com_Block, Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Generate: -- Protected_Entry_Call ( -- T._object'access, -- protected_entry_index! (I), -- P, -- Asynchronous_Call, -- Com_Block); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters and B is the name of the communication -- block. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, -- T._object'access Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Reference_To ( -- Asynchronous_Call RTE (RE_Asynchronous_Call), Loc), New_Reference_To (Com_Block, Loc)))); -- comm block -- Generate: -- B := Dummy_Communication_Bloc (Com_Block); Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uB), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To ( RTE (RE_Dummy_Communication_Block), Loc), Expression => New_Reference_To (Com_Block, Loc)))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Protected_Entry_Call ( -- T._task_id, -- task_entry_index! (I), -- P, -- Conditional_Call, -- F); -- 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_Reference_To (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)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Reference_To ( -- Asynchronous_Call RTE (RE_Asynchronous_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; 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); Def_Id : constant Node_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 Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), Parameter_Type => New_Reference_To (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Reference_To (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB), Parameter_Type => New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc), Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Reference_To (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 -- --------------------------------------- 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; DT_Ptr : Entity_Id; Stmts : constant List_Id := New_List; 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_Null_Statement (Loc)))); end if; DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); 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_Reference_To (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 (Loc, DT_Ptr, 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_Defining_Identifier (Loc, New_Internal_Name ('B')); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Blk_Nam, Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Generate: -- I := Get_Entry_Index (tag! (VP), S); -- I is the entry index and S is the dispatch table slot Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then -- Generate: -- Protected_Entry_Call ( -- T._object'access, -- protected_entry_index! (I), -- P, -- Conditional_Call, -- Bnn); -- 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_Reference_To (RTE (RE_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, -- T._object'access Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Reference_To ( -- Conditional_Call RTE (RE_Conditional_Call), Loc), New_Reference_To ( -- Bnn Blk_Nam, Loc)))); -- Generate: -- F := not Cancelled (Bnn); -- where F is the success flag. The status of Cancelled is negated -- in order to match the behaviour 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_Reference_To (RTE (RE_Cancelled), Loc), Parameter_Associations => New_List ( New_Reference_To (Blk_Nam, Loc)))))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Protected_Entry_Call ( -- T._task_id, -- task_entry_index! (I), -- P, -- Conditional_Call, -- F); -- 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_Reference_To (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)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Reference_To ( -- Conditional_Call RTE (RE_Conditional_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; 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_Reference_To (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Reference_To (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Reference_To (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); DT_Ptr : Entity_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; DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); -- 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. 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_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (DT_Ptr, Loc)), 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_Reference_To (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Reference_To (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Reference_To (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_Return_Statement (Loc, Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Address), Loc), Expression => 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_Return_Statement (Loc, Expression => New_Reference_To (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_Reference_To (Typ, Loc))), Result_Definition => New_Reference_To (RTE (RE_Address), Loc)); end Make_Disp_Get_Task_Id_Spec; --------------------------------- -- Make_Disp_Timed_Select_Body -- --------------------------------- 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; DT_Ptr : Entity_Id; Stmts : constant List_Id := New_List; 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_Null_Statement (Loc)))); end if; DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); 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_Reference_To (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 (Loc, DT_Ptr, Stmts); -- Generate: -- I := Get_Entry_Index (tag! (VP), S); -- I is the entry index and S is the dispatch table slot Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then -- 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. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, -- T._object'access Attribute_Name => Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uObject))), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), Expression => 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 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_Reference_To (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)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), Expression => 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; 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_Reference_To (Typ, Loc), In_Present => True, Out_Present => True), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => New_Reference_To (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD), Parameter_Type => New_Reference_To (Standard_Duration, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM), Parameter_Type => New_Reference_To (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), Parameter_Type => New_Reference_To (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_Reference_To (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; function Make_DT (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Is_Local_DT : constant Boolean := Ekind (Cunit_Entity (Get_Source_Unit (Typ))) /= E_Package; Max_Predef_Prims : constant Int := UI_To_Int (Intval (Expression (Parent (RTE (RE_Default_Prim_Op_Count))))); procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; AI_Tag : Entity_Id; Iface_DT_Ptr : Entity_Id; Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch -- Table of Typ associated with Iface (each abstract interface of Typ -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ -- and Suffix_Index are used to generate an unique external name which -- is added at the end of Acc_Disp_Tables; this external name will be -- used later by the subprogram Exp_Ch3.Build_Init_Procedure. ----------------------- -- Make_Secondary_DT -- ----------------------- procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; AI_Tag : Entity_Id; Iface_DT_Ptr : Entity_Id; Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); Name_DT : constant Name_Id := New_Internal_Name ('T'); Iface_DT : constant Entity_Id := Make_Defining_Identifier (Loc, Name_DT); Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); Predef_Prims : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Predef_Prims); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat; New_Node : Node_Id; OSD : Entity_Id; OSD_Aggr_List : List_Id; Pos : Nat; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; begin -- Handle the case where the backend does not support statically -- allocated dispatch tables. if not Static_Dispatch_Tables or else Is_Local_DT then Set_Ekind (Predef_Prims, E_Variable); Set_Is_Statically_Allocated (Predef_Prims); Set_Ekind (Iface_DT, E_Variable); Set_Is_Statically_Allocated (Iface_DT); -- Statically allocated dispatch tables and related entities are -- constants. else Set_Ekind (Predef_Prims, E_Constant); Set_Is_Statically_Allocated (Predef_Prims); Set_Is_True_Constant (Predef_Prims); Set_Ekind (Iface_DT, E_Constant); Set_Is_Statically_Allocated (Iface_DT); Set_Is_True_Constant (Iface_DT); end if; -- Generate code to create the storage for the Dispatch_Table object. -- 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. Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); if Nb_Prim = 0 then Empty_DT := True; Nb_Prim := 1; 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); -- for Predef_Prims'Alignment use Address'Alignment -- Stage 1: Calculate the number of predefined primitives if not Static_Dispatch_Tables then Nb_Predef_Prims := Max_Predef_Prims; else 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 if; -- Stage 2: Create the thunks associated with the predefined -- primitives and save their entity to fill the aggregate. declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; begin Prim_Ops_Aggr_List := New_List; Prim_Table := (others => Empty); 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 Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then while Present (Alias (Prim)) loop Prim := Alias (Prim); end loop; Expand_Interface_Thunk (N => Prim, Thunk_Alias => Prim, Thunk_Id => Thunk_Id, Thunk_Code => Thunk_Code); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id; 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 := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Address); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Constant_Present => Static_Dispatch_Tables, Aliased_Present => True, Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), Expression => Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Predef_Prims, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); end; -- Generate -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := -- (OSD_Table => (1 => , -- ... -- N => )); -- 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. 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_Reference_To (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_Reference_To (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Note: The correct value of Offset_To_Top will be set by the init -- subprogram Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- 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_Abstract_Interfaces (Typ) then -- No OSD table required Append_To (DT_Aggr_List, New_Reference_To (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 := 0; Pos : Nat; begin Prim_Table := (others => Empty); Prim_Alias := Empty; Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Present (Abstract_Interface_Alias (Prim)) and then Find_Dispatching_Type (Abstract_Interface_Alias (Prim)) = Iface then Prim_Alias := Abstract_Interface_Alias (Prim); E := Prim; while Present (Alias (E)) loop E := Alias (E); end loop; Pos := UI_To_Int (DT_Position (Prim_Alias)); if Present (Prim_Table (Pos)) then pragma Assert (Prim_Table (Pos) = E); null; else 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_Defining_Identifier (Loc, New_Internal_Name ('I')); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => OSD, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (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)))))); -- 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_Reference_To (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, New_Reference_To (RTE (RE_Null_Address), Loc)); elsif Is_Abstract_Type (Typ) or else not Static_Dispatch_Tables then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); end loop; else declare Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; Pos : Nat; Thunk_Code : Node_Id; Thunk_Id : Entity_Id; begin Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Abstract_Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) and then not Is_Imported (Alias (Prim)) and then Find_Dispatching_Type (Abstract_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_Parent (Iface, Typ) then Expand_Interface_Thunk (N => Prim, Thunk_Alias => Alias (Prim), Thunk_Id => Thunk_Id, Thunk_Code => Thunk_Code); if Present (Thunk_Id) then Pos := UI_To_Int (DT_Position (Abstract_Interface_Alias (Prim))); Prim_Table (Pos) := Thunk_Id; Append_To (Result, Thunk_Code); 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 := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Address); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; end; end if; Append_To (DT_Aggr_List, Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List)); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (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))); -- Generate code to create the pointer to the dispatch table -- Iface_DT_Ptr : Tag := Tag!(DT'Address); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT_Ptr, Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Interface_Tag), Loc), Expression => Unchecked_Convert_To (Generalized_Tag, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (Iface_DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end Make_Secondary_DT; -- Local variables -- Seems a huge list, shouldn't some of these be commented??? -- Seems like we are counting too much on guessing from names here??? Elab_Code : constant List_Id := New_List; Generalized_Tag : constant Entity_Id := RTE (RE_Tag); Result : constant List_Id := New_List; Tname : constant Name_Id := Chars (Typ); Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R'); Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); DT : constant Entity_Id := Make_Defining_Identifier (Loc, Name_DT); Exname : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Exname); Predef_Prims : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Predef_Prims); SSD : constant Entity_Id := Make_Defining_Identifier (Loc, Name_SSD); TSD : constant Entity_Id := Make_Defining_Identifier (Loc, Name_TSD); AI : Elmt_Id; AI_Tag_Comp : Elmt_Id; AI_Ptr_Elmt : Elmt_Id; DT_Constr_List : List_Id; DT_Aggr_List : List_Id; DT_Ptr : Entity_Id; Has_Dispatch_Table : Boolean := True; ITable : Node_Id; I_Depth : Nat := 0; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; Name_No_Reg : Name_Id; Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat := 0; New_Node : Node_Id; No_Reg : Node_Id; Null_Parent_Tag : Boolean := False; Num_Ifaces : Nat := 0; Old_Tag1 : Node_Id; Old_Tag2 : Node_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; Transportable : Entity_Id; RC_Offset_Node : Node_Id; Suffix_Index : Int; Typ_Comps : Elist_Id; Typ_Ifaces : Elist_Id; TSD_Aggr_List : List_Id; TSD_Tags_List : List_Id; TSD_Ifaces_List : List_Id; -- Start of processing for Make_DT begin -- Fill the contents of Access_Disp_Table -- 1) Generate the primary and secondary tag entities declare DT_Ptr : Node_Id; Name_DT_Ptr : Name_Id; Typ_Name : Name_Id; Iface_DT_Ptr : Node_Id; Suffix_Index : Int; AI_Tag_Comp : Elmt_Id; begin -- Collect the components associated with secondary dispatch tables if Has_Abstract_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); end if; -- Generate the primary tag entity Name_DT_Ptr := New_External_Name (Tname, 'P'); DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); Set_Ekind (DT_Ptr, E_Constant); Set_Is_Statically_Allocated (DT_Ptr); Set_Is_True_Constant (DT_Ptr); pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); -- Generate the secondary tag entities if Has_Abstract_Interfaces (Typ) then Suffix_Index := 0; -- For each interface type we build an unique external name -- associated with its corresponding secondary dispatch table. -- This external name will be used to declare an object that -- references this secondary dispatch table, value that will be -- used for the elaboration of Typ's objects and also for the -- elaboration of objects of derivations of Typ that do not -- override the primitive operation of this interface type. AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop Get_Secondary_DT_External_Name (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index); Typ_Name := Name_Find; Name_DT_Ptr := New_External_Name (Typ_Name, "P"); Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Statically_Allocated (Iface_DT_Ptr); Set_Is_True_Constant (Iface_DT_Ptr); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); Next_Elmt (AI_Tag_Comp); end loop; end if; end; -- 2) At the end of Access_Disp_Table we add the entity of an access -- type declaration. It is used by Build_Get_Prim_Op_Address to -- expand dispatching calls through the primary dispatch table. -- Generate: -- type Typ_DT is array (1 .. Nb_Prims) of Address; -- type Typ_DT_Acc is access Typ_DT; 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_Full_Type_Declaration (Loc, Defining_Identifier => DT_Prims, Type_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => 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))))), Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => New_Reference_To (RTE (RE_Address), Loc))))); 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)); end; if Is_CPP_Class (Typ) then return Result; end if; if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (Generalized_Tag, New_Reference_To (RTE (RE_Null_Address), Loc)))); Analyze_List (Result, Suppress => All_Checks); Error_Msg_CRT ("tagged types", Typ); return Result; end if; if not Static_Dispatch_Tables or else Is_Local_DT then Set_Ekind (DT, E_Variable); Set_Is_Statically_Allocated (DT); else Set_Ekind (DT, E_Constant); Set_Is_Statically_Allocated (DT); Set_Is_True_Constant (DT); end if; pragma Assert (Present (Access_Disp_Table (Typ))); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); -- Ada 2005 (AI-251): Build the secondary dispatch tables if Has_Abstract_Interfaces (Typ) then Suffix_Index := 0; AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop Make_Secondary_DT (Typ => Typ, Iface => Base_Type (Related_Interface (Node (AI_Tag_Comp))), AI_Tag => Node (AI_Tag_Comp), Iface_DT_Ptr => Node (AI_Ptr_Elmt), Result => Result); Suffix_Index := Suffix_Index + 1; Next_Elmt (AI_Ptr_Elmt); Next_Elmt (AI_Tag_Comp); end loop; end if; -- Evaluate if we generate the dispatch table Has_Dispatch_Table := not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls); -- Calculate the number of primitives of the dispatch table and the -- size of the Type_Specific_Data record. if Has_Dispatch_Table then Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); end if; if not Static_Dispatch_Tables then Set_Ekind (Predef_Prims, E_Variable); Set_Is_Statically_Allocated (Predef_Prims); else Set_Ekind (Predef_Prims, E_Constant); Set_Is_Statically_Allocated (Predef_Prims); Set_Is_True_Constant (Predef_Prims); end if; Set_Ekind (SSD, E_Constant); Set_Is_Statically_Allocated (SSD); Set_Is_True_Constant (SSD); Set_Ekind (TSD, E_Constant); Set_Is_Statically_Allocated (TSD); Set_Is_True_Constant (TSD); Set_Ekind (Exname, E_Constant); Set_Is_Statically_Allocated (Exname); Set_Is_True_Constant (Exname); -- Generate code to define the boolean that controls registration, in -- order to avoid multiple registrations for tagged types defined in -- multiple-called scopes. if not Is_Interface (Typ) then Name_No_Reg := New_External_Name (Tname, 'F'); No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); Set_Ekind (No_Reg, E_Variable); Set_Is_Statically_Allocated (No_Reg); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => No_Reg, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_True, Loc))); end if; -- In case of locally defined tagged type we declare the object -- contanining 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 Is_Local_DT then -- Generate: -- DT : No_Dispatch_Table_Wrapper; -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); if not Has_Dispatch_Table then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => False, Object_Definition => New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (Generalized_Tag, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); -- Generate: -- DT : Dispatch_Table_Wrapper (Nb_Prim); -- for DT'Alignment use Address'Alignment; -- 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_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (Generalized_Tag, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end if; end if; -- 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. Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Reference_To (Standard_String, Loc), Expression => Make_String_Literal (Loc, Full_Qualified_Name (First_Subtype (Typ))))); -- 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), -- Expanded_Name => Cstring_Ptr!(Exname'Address)) -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => null, -- Transportable => <>, -- RC_Offset => <>, -- [ Interfaces_Table => <> ] -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, -- 1 => Parent'Tag -- ...); -- for TSD'Alignment use Address'Alignment 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_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), Expression => Make_Integer_Literal (Loc, I_Depth))); -- Access_Level Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)), Expression => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))); -- Expanded_Name Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)), Expression => Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)))); -- External_Tag of a local tagged type -- Exname : 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! if Is_Local_DT then declare Name_Exname : constant Name_Id := New_External_Name (Tname, 'L'); Name_Str1 : constant Name_Id := New_Internal_Name ('I'); Name_Str2 : constant Name_Id := New_Internal_Name ('I'); Name_Str3 : constant Name_Id := New_Internal_Name ('I'); Exname : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Exname); Str1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Str1); Str2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Str2); Str3 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Str3); Full_Name : constant String_Id := Full_Qualified_Name (First_Subtype (Typ)); Str1_Id : String_Id; Str2_Id : String_Id; Str3_Id : String_Id; begin -- Generate: -- Str1 : constant String := "Internal tag at 16#"; Set_Ekind (Str1, E_Constant); Set_Is_Statically_Allocated (Str1); Set_Is_True_Constant (Str1); Start_String; Store_String_Chars ("Internal tag at 16#"); Str1_Id := End_String; -- Generate: -- Str2 : constant String := "#: "; Set_Ekind (Str2, E_Constant); Set_Is_Statically_Allocated (Str2); Set_Is_True_Constant (Str2); Start_String; Store_String_Chars ("#: "); Str2_Id := End_String; -- Generate: -- Str3 : constant String := ; Set_Ekind (Str3, E_Constant); Set_Is_Statically_Allocated (Str3); Set_Is_True_Constant (Str3); Start_String; Store_String_Chars (Full_Name); Str3_Id := End_String; -- Generate: -- Exname : constant String := -- Str1 & Address_Image (Tag) & Str2 & Str3; if RTE_Available (RE_Address_Image) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Reference_To (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_Reference_To (RTE (RE_Address_Image), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), New_Reference_To (DT_Ptr, Loc)))), Right_Opnd => Make_Op_Concat (Loc, Left_Opnd => Make_String_Literal (Loc, Str2_Id), Right_Opnd => Make_String_Literal (Loc, Str3_Id)))))); else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Reference_To (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_String_Literal (Loc, Str2_Id), Right_Opnd => Make_String_Literal (Loc, Str3_Id))))); end if; New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (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. else declare Def : constant Node_Id := Get_Attribute_Definition_Clause (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)) /= Typ then New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); -- For the rep clause "for x'external_tag use y" generate: -- xV : constant string := y; -- Set_External_Tag (x'tag, xV'Address); -- Register_Tag (x'tag); -- 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_Reference_To (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_Reference_To (E, Loc), Attribute_Name => Name_Address)); end if; end; end if; Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_External_Tag), Loc)), Expression => New_Node)); -- HT_Link Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_HT_Link), Loc)), Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (RTE (RE_Null_Address), Loc)))); -- Transportable: Set for types that can be used in remote calls -- with respect to E.4(18) legality rules. 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, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Transportable), Loc)), Expression => New_Occurrence_Of (Transportable, Loc))); -- RC_Offset: These are the valid values and their meaning: -- >0: For simple types with controlled components is -- type._record_controller'position -- 0: For types with no controlled components -- -1: For complex types with controlled components where the position -- of the record controller is not statically computable but there -- are controlled components at this level. The _Controller field -- is available right after the _parent. -- -2: There are no controlled components at this level. We need to -- get the position from the parent. if not Has_Controlled_Component (Typ) then RC_Offset_Node := Make_Integer_Literal (Loc, 0); elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then if Has_New_Controlled_Component (Typ) then RC_Offset_Node := Make_Integer_Literal (Loc, -1); else RC_Offset_Node := Make_Integer_Literal (Loc, -2); end if; else RC_Offset_Node := Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (Typ, Loc), Selector_Name => New_Reference_To (Controller_Component (Typ), Loc)), Attribute_Name => Name_Position); -- This is not proper Ada code to use the attribute 'Position -- on something else than an object but this is supported by -- the back end (see comment on the Bit_Component attribute in -- sem_attr). So we avoid semantic checking here. -- Is this documented in sinfo.ads??? it should be! Set_Analyzed (RC_Offset_Node); Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), RTE (RE_Record_Controller)); Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); end if; Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)), Expression => RC_Offset_Node)); -- 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_Abstract_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 TSD_Ifaces_List := New_List; declare Pos : Nat := 1; Aggr_List : List_Id; begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop Aggr_List := New_List ( Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Iface_Tag), Loc)), Expression => Unchecked_Convert_To (Generalized_Tag, New_Reference_To (Node (First_Elmt (Access_Disp_Table (Node (AI)))), Loc))), Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Static_Offset_To_Top), Loc)), Expression => New_Reference_To (Standard_True, Loc)), Make_Component_Association (Loc, Choices => New_List (Make_Others_Choice (Loc)), Expression => Empty, Box_Present => True)); Append_To (TSD_Ifaces_List, Make_Component_Association (Loc, Choices => New_List ( Make_Integer_Literal (Loc, Pos)), Expression => Make_Aggregate (Loc, Component_Associations => Aggr_List))); Pos := Pos + 1; Next_Elmt (AI); end loop; end; Name_ITable := New_External_Name (Tname, 'I'); ITable := Make_Defining_Identifier (Loc, Name_ITable); Set_Ekind (ITable, E_Constant); Set_Is_Statically_Allocated (ITable); Set_Is_True_Constant (ITable); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => ITable, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (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, Component_Associations => New_List ( Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Nb_Ifaces), Loc)), Expression => Make_Integer_Literal (Loc, Num_Ifaces)), Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Ifaces_Table), Loc)), Expression => Make_Aggregate (Loc, Component_Associations => TSD_Ifaces_List)))))); Iface_Table_Node := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (ITable, Loc), Attribute_Name => Name_Unchecked_Access); end if; Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Interfaces_Table), Loc)), Expression => 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_05 and then Has_Dispatch_Table and then Is_Concurrent_Record_Type (Typ) and then Has_Abstract_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) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => SSD, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To ( RTE (RE_Select_Specific_Data), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))))); -- 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_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_SSD), Loc)), Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (SSD, Loc), Attribute_Name => Name_Unchecked_Access))); else Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_SSD), Loc)), Expression => Make_Null (Loc))); end if; end if; -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. if Is_Interface (Typ) then Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List (Make_Others_Choice (Loc)), Expression => Empty, Box_Present => True)); else declare Current_Typ : Entity_Id; Parent_Typ : Entity_Id; Pos : Nat; begin TSD_Tags_List := New_List; -- Fill position 0 with null because we still have not generated -- the tag of Typ. Append_To (TSD_Tags_List, Make_Component_Association (Loc, Choices => New_List ( Make_Integer_Literal (Loc, 0)), Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (RTE (RE_Null_Address), Loc)))); -- Fill the rest of the table with the tags of the ancestors 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. -- (see Exp_Ch3.Build_Init_Procedure) Append_To (TSD_Tags_List, Make_Component_Association (Loc, Choices => New_List ( Make_Integer_Literal (Loc, Pos)), Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (RTE (RE_Null_Address), Loc)))); else Append_To (TSD_Tags_List, Make_Component_Association (Loc, Choices => New_List ( Make_Integer_Literal (Loc, Pos)), Expression => New_Reference_To (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_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_Tags_Table), Loc)), Expression => Make_Aggregate (Loc, Component_Associations => TSD_Tags_List))); end if; -- Build the TSD object Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => TSD, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To ( 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, Component_Associations => TSD_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (TSD, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); -- Generate the dummy Dispatch_Table object associated with tagged -- types that have no dispatch table. -- DT : No_Dispatch_Table := -- (NDT_TSD => TSD'Address; -- NDT_Prims_Ptr => 0); if not Has_Dispatch_Table then DT_Constr_List := New_List; DT_Aggr_List := New_List; -- Typeinfo New_Node := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (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 an assignment. if Is_Local_DT then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Reference_To (DT, Loc), Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); -- In case of library level tagged types we declare now the constant -- object containing the dispatch table. else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => Static_Dispatch_Tables, Object_Definition => New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (Generalized_Tag, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); 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); -- for Predef_Prims'Alignment use Address'Alignment -- 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)); else declare Pos : Nat; begin if not Static_Dispatch_Tables then Nb_Predef_Prims := Max_Predef_Prims; else 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 if; declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; E : Entity_Id; begin Prim_Ops_Aggr_List := New_List; Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Static_Dispatch_Tables and then Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then E := Prim; while Present (Alias (E)) loop E := Alias (E); end loop; pragma Assert (not Is_Abstract_Subprogram (E)); 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 := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Address); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Static_Dispatch_Tables, Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), Expression => Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Predef_Prims, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); end; 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_Reference_To (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_Reference_To (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Offset_To_Top if RTE_Record_Component_Available (RE_Offset_To_Top) then Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); end if; -- Typeinfo Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (TSD, Loc), Attribute_Name => Name_Address)); -- Stage 2: Initialize the table of primitive operations Prim_Ops_Aggr_List := New_List; if Nb_Prim = 0 then Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); elsif not Static_Dispatch_Tables then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); end loop; else declare Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; E : Entity_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; begin Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Is_Imported (Prim) or else Present (Abstract_Interface_Alias (Prim)) or else Is_Predefined_Dispatching_Operation (Prim) then null; else -- Traverse the list of aliased entities to handle -- renamings of predefined primitives. E := Prim; while Present (Alias (E)) loop E := Alias (E); end loop; if not Is_Predefined_Dispatching_Operation (E) and then not Is_Abstract_Subprogram (E) and then not Present (Abstract_Interface_Alias (E)) then pragma Assert (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); Prim_Table (UI_To_Int (DT_Position (Prim))) := E; -- There is no need to set Has_Delayed_Freeze here -- because the analysis of 'Address and 'Code_Address -- takes care of it. 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 := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Address); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; end; end if; Append_To (DT_Aggr_List, Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List)); -- 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 Is_Local_DT then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Reference_To (DT, Loc), Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); -- In case of library level tagged types we declare now the constant -- object containing the dispatch table. else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, Constant_Present => Static_Dispatch_Tables, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (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))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => Unchecked_Convert_To (Generalized_Tag, Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (DT, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); end if; end if; -- Initialize the table of ancestor tags if 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_Reference_To (TSD, Loc), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Tags_Table), Loc)), Expressions => New_List (Make_Integer_Literal (Loc, 0))), Expression => New_Reference_To (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; if Static_Dispatch_Tables 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 (Etype (Typ)) then null; -- Otherwise we fill in the dispatch tables here else if Typ = Etype (Typ) or else Is_CPP_Class (Etype (Typ)) or else Is_Interface (Typ) then Null_Parent_Tag := True; Old_Tag1 := Unchecked_Convert_To (Generalized_Tag, Make_Integer_Literal (Loc, 0)); Old_Tag2 := Unchecked_Convert_To (Generalized_Tag, Make_Integer_Literal (Loc, 0)); else Old_Tag1 := New_Reference_To (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); Old_Tag2 := New_Reference_To (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); end if; if Typ /= Etype (Typ) and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table if not Is_Interface (Etype (Typ)) then if not Null_Parent_Tag then declare Nb_Prims : constant Int := UI_To_Int (DT_Entry_Count (First_Tag_Component (Etype (Typ)))); begin Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Old_Tag1, New_Tag_Node => New_Reference_To (DT_Ptr, Loc))); if Nb_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, Old_Tag_Node => Old_Tag2, New_Tag_Node => New_Reference_To (DT_Ptr, Loc), Num_Prims => Nb_Prims)); end if; end; end if; end if; -- Inherit the secondary dispatch tables of the ancestor if not Is_CPP_Class (Etype (Typ)) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ)))); Sec_DT_Typ : Elmt_Id := 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 (Abstract_Interfaces (Typ)) and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) then Iface := First_Elmt (Abstract_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 if not Is_Interface (Etype (Typ)) then -- Inherit the dispatch table declare Num_Prims : constant Int := UI_To_Int (DT_Entry_Count (E)); begin Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (Sec_DT_Typ), Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (Sec_DT_Ancestor), Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (Sec_DT_Typ), Loc)), Num_Prims => Num_Prims)); end if; end; end if; 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 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 an abstract interface type (the secondary tags will -- be registered later in types implementing this interface type). -- 4) 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). -- Generate: -- if No_Reg then -- [ Elab_Code ] -- [ Register_Tag (Dt_Ptr); ] -- No_Reg := False; -- end if; if not Is_Interface (Typ) then if not No_Run_Time_Mode and then not Is_Local_DT and then RTE_Available (RE_Register_Tag) then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Register_Tag), Loc), Parameter_Associations => New_List (New_Reference_To (DT_Ptr, Loc)))); end if; Append_To (Elab_Code, Make_Assignment_Statement (Loc, Name => New_Reference_To (No_Reg, Loc), Expression => New_Reference_To (Standard_False, Loc))); Append_To (Result, Make_Implicit_If_Statement (Typ, Condition => New_Reference_To (No_Reg, Loc), Then_Statements => Elab_Code)); end if; Analyze_List (Result, Suppress => All_Checks); 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; DT_Ptr : Entity_Id; 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_1; Subp_Decl : Entity_Id; begin if Present (Decls) and then not Is_Empty_List (Decls) then Subp_Decl := First (Decls); while Present (Subp_Decl) loop if Nkind (Subp_Decl) = N_Entry_Declaration then if Defining_Identifier (Subp_Decl) = E then return Index; end if; Index := Index + 1; end if; Next (Subp_Decl); end loop; end if; return Uint_0; end Find_Entry_Index; -- Start of processing for Make_Select_Specific_Data_Table begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Present (Corresponding_Concurrent_Type (Typ)) then Conc_Typ := Corresponding_Concurrent_Type (Typ); 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 (Abstract_Interface_Alias (Prim)) 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, , ); Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( New_Reference_To (DT_Ptr, Loc), Make_Integer_Literal (Loc, Prim_Pos), Prim_Op_Kind (Alias (Prim), Typ)))); -- Retrieve the root of the alias chain Prim_Als := Prim; while Present (Alias (Prim_Als)) loop Prim_Als := Alias (Prim_Als); end loop; -- 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, , ); Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Entry_Index), Loc), Parameter_Associations => New_List ( New_Reference_To (DT_Ptr, Loc), 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; ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is Scop : constant Entity_Id := Scope (Typ); begin -- The scope must be a package if Ekind (Scop) /= E_Package and then Ekind (Scop) /= E_Generic_Package then return False; end if; -- A type with a private declaration has a private view declared in -- the visible part. if Has_Private_Declaration (Typ) then return True; end if; return List_Containing (Parent (Typ)) = Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); end Original_View_In_Visible_Part; ------------------ -- 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 := Prim; while Present (Alias (Prim_Op)) loop Prim_Op := Alias (Prim_Op); end loop; if Ekind (Typ) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Typ)) then Full_Typ := Corresponding_Concurrent_Type (Typ); end if; if Ekind (Prim_Op) = E_Function then -- Protected function if Ekind (Full_Typ) = E_Protected_Type then return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); -- Task function elsif Ekind (Full_Typ) = E_Task_Type then return New_Reference_To (RTE (RE_POK_Task_Function), Loc); -- Regular function else return New_Reference_To (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_Reference_To (RTE (RE_POK_Protected_Entry), Loc); -- Protected procedure else return New_Reference_To (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_Reference_To (RTE (RE_POK_Task_Entry), Loc); -- Task "procedure". These are the internally Expander-generated -- procedures (task body for instance). else return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); end if; -- Regular procedure else return New_Reference_To (RTE (RE_POK_Procedure), Loc); end if; end if; end Prim_Op_Kind; ------------------------ -- Register_Primitive -- ------------------------ procedure Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id; Ins_Nod : Node_Id) is DT_Ptr : Entity_Id; Iface_Prim : Entity_Id; Iface_Typ : Entity_Id; Iface_DT_Ptr : Entity_Id; Pos : Uint; Tag : Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; Typ : Entity_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); if not RTE_Available (RE_Tag) then return; end if; if not Present (Abstract_Interface_Alias (Prim)) then Typ := Scope (DTC_Entity (Prim)); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Pos := DT_Position (Prim); Tag := First_Tag_Component (Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Insert_After (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, Address_Node => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Address))); else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); Insert_After (Ins_Nod, Build_Set_Prim_Op_Address (Loc, Typ => Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, Address_Node => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Address))); 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 Typ := Find_Dispatching_Type (Alias (Prim)); Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); Expand_Interface_Thunk (N => Prim, Thunk_Alias => Alias (Prim), Thunk_Id => Thunk_Id, Thunk_Code => Thunk_Code); if not Is_Parent (Iface_Typ, Typ) and then Present (Thunk_Code) then Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); -- 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_Ptr := Find_Interface_ADT (Typ, Iface_Typ); Iface_Prim := Abstract_Interface_Alias (Prim); Pos := DT_Position (Iface_Prim); Tag := First_Tag_Component (Iface_Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Insert_Action (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Address))); else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); Insert_Action (Ins_Nod, Build_Set_Prim_Op_Address (Loc, Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Address))); end if; end if; end if; end Register_Primitive; ------------------------- -- Set_All_DT_Position -- ------------------------- procedure Set_All_DT_Position (Typ : Entity_Id) is procedure Validate_Position (Prim : Entity_Id); -- Check that the position assignated to Prim is completely safe -- (it has not been assigned to a previously defined primitive -- operation of Typ) ----------------------- -- 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 (Abstract_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 -- Set the DT_Position for each primitive operation. Perform some -- sanity checks to avoid to build completely inconsistant dispatch -- tables. -- First stage: Set the DTC entity of all the primitive operations -- This is required to properly read the DT_Position attribute in -- the 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 (Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (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 -- stablished by the following stages of this algorithm. Set_DT_Position (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 (Prim_Op, DT_Position (Parent_Subp)); Set_DT_Position (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 >= 0 and then 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 Typ = 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 Is_Predefined_Dispatching_Operation (Prim) then Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); elsif Is_Predefined_Dispatching_Alias (Prim) then E := Alias (Prim); while Present (Alias (E)) loop E := Alias (E); end loop; Set_DT_Position (Prim, Default_Prim_Op_Position (E)); -- Overriding primitives of ancestor abstract interfaces elsif Present (Abstract_Interface_Alias (Prim)) and then Is_Parent (Find_Dispatching_Type (Abstract_Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Prim) = No_Uint and then Present (DTC_Entity (Abstract_Interface_Alias (Prim)))); E := Abstract_Interface_Alias (Prim); Set_DT_Position (Prim, DT_Position (E)); pragma Assert (DT_Position (Alias (Prim)) = No_Uint or else DT_Position (Alias (Prim)) = DT_Position (E)); Set_DT_Position (Alias (Prim), DT_Position (E)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the -- overriden primitive. elsif not Present (Abstract_Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ and then Is_Parent (Find_Dispatching_Type (Alias (Prim)), Typ) and then Present (DTC_Entity (Alias (Prim))) then E := Alias (Prim); Set_DT_Position (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; 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 DT_Position (Prim) /= No_Uint then null; -- Primitives covering interface primitives are handled later elsif Present (Abstract_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 (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 DT_Position (Prim) = No_Uint and then Present (Abstract_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_Parent (Find_Dispatching_Type (Abstract_Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Alias (Prim))); -- Otherwise it will be placed in the secondary DT else pragma Assert (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Abstract_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 DT_Position (Prim) = No_Uint then raise Program_Error; end if; -- Calculate real size of the dispatch table if not (Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (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 asignated position to non-predefined -- dispatching operations in the dispatch table is correct. if not (Is_Predefined_Dispatching_Operation (Prim) or else 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 could never be over- -- ridden. 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): Hidden entities associated with abstract -- interface primitives are not taken into account because the -- check is done with the aliased primitive. if Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) and then not Present (Abstract_Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then List_Containing (Parent (Prim)) = Private_Declarations (Specification (Unit_Declaration_Node (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. 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 ('R'M 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, the Etype points back 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_Default_Constructor -- ----------------------------- procedure Set_Default_Constructor (Typ : Entity_Id) is Loc : Source_Ptr; Init : Entity_Id; Param : Entity_Id; E : Entity_Id; begin -- Look for the default constructor entity. For now only the -- default constructor has the flag Is_Constructor. E := Next_Entity (Typ); while Present (E) and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) loop Next_Entity (E); end loop; -- Create the init procedure if Present (E) then Loc := Sloc (E); Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); Param := Make_Defining_Identifier (Loc, Name_X); Discard_Node ( Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, Defining_Unit_Name => Init, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Param, Parameter_Type => New_Reference_To (Typ, Loc)))))); Set_Init_Proc (Typ, Init); Set_Is_Imported (Init); Set_Interface_Name (Init, Interface_Name (E)); Set_Convention (Init, Convention_C); Set_Is_Public (Init); Set_Has_Completion (Init); -- If there are no constructors, mark the type as abstract since we -- won't be able to declare objects of that type. else Set_Is_Abstract_Type (Typ); end if; end Set_Default_Constructor; -------------------------- -- Set_DTC_Entity_Value -- -------------------------- procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id) is begin if Present (Abstract_Interface_Alias (Prim)) and then Is_Interface (Find_Dispatching_Type (Abstract_Interface_Alias (Prim))) then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Tagged_Type, Iface => Find_Dispatching_Type (Abstract_Interface_Alias (Prim)))); else Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); 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_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); else return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); end if; -- Concurrent kinds elsif Is_Concurrent_Record_Type (T) then Conc_Typ := Corresponding_Concurrent_Type (T); if Ekind (Conc_Typ) = E_Protected_Type then return New_Reference_To (RTE (RE_TK_Protected), Loc); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); return New_Reference_To (RTE (RE_TK_Task), Loc); end if; -- Regular tagged kinds else if Is_Limited_Record (T) then return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); else return New_Reference_To (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 in First_Node_Id .. 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 Etype (DTC_Entity (Prim)) = RTE (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; 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 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 (Abstract_Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); Write_Name (Chars (Scope (DTC_Entity (Abstract_Interface_Alias (Prim))))); Write_Char (':'); Write_Int (Int (Abstract_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 DT_Position (Prim) /= No_Uint 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; Write_Eol; Next_Elmt (Elmt); end loop; end Write_DT; end Exp_Disp;