-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with 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 Layout; use Layout;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Disp is
- --------------------------------
- -- Select_Expansion_Utilities --
- --------------------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- -- The following package contains helper routines used in the expansion of
- -- dispatching asynchronous, conditional and timed selects.
+ 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.
- package Select_Expansion_Utilities is
- procedure Build_B
- (Loc : Source_Ptr;
- Params : List_Id);
- -- Generate:
- -- B : out Communication_Block
+ function Has_DT (Typ : Entity_Id) return Boolean;
+ pragma Inline (Has_DT);
+ -- Returns true if we generate a dispatch table for tagged type Typ
- procedure Build_C
- (Loc : Source_Ptr;
- Params : List_Id);
- -- Generate:
- -- C : out Prim_Op_Kind
-
- procedure Build_Common_Dispatching_Select_Statements
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- DT_Ptr : Entity_Id;
- Stmts : List_Id);
- -- Ada 2005 (AI-345): Generate statements that are common between
- -- asynchronous, conditional and timed select expansion.
-
- procedure Build_F
- (Loc : Source_Ptr;
- Params : List_Id);
- -- Generate:
- -- F : out Boolean
+ function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
+ -- Returns true if Prim is not a predefined dispatching primitive but it is
+ -- an alias of a predefined dispatching primitive (i.e. through a renaming)
- procedure Build_P
- (Loc : Source_Ptr;
- Params : List_Id);
- -- Generate:
- -- P : Address
+ 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.
- procedure Build_S
- (Loc : Source_Ptr;
- Params : List_Id);
- -- Generate:
- -- S : Integer
+ 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.
- procedure Build_T
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Params : List_Id);
- -- Generate:
- -- T : in out Typ
- end Select_Expansion_Utilities;
+ 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.
- package body Select_Expansion_Utilities is
+ 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.
- -------------
- -- Build_B --
- -------------
+ ----------------------
+ -- Apply_Tag_Checks --
+ ----------------------
- procedure Build_B
- (Loc : Source_Ptr;
- Params : List_Id)
- is
- begin
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uB),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Communication_Block), Loc),
- Out_Present => True));
- end Build_B;
-
- -------------
- -- Build_C --
- -------------
-
- procedure Build_C
- (Loc : Source_Ptr;
- Params : List_Id)
- is
- begin
- Append_To (Params,
- 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));
- end Build_C;
-
- ------------------------------------------------
- -- Build_Common_Dispatching_Select_Statements --
- ------------------------------------------------
-
- procedure Build_Common_Dispatching_Select_Statements
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- DT_Ptr : Entity_Id;
- Stmts : List_Id)
- is
- begin
- -- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ procedure Apply_Tag_Checks (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
+ Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
+ Param_List : constant List_Id := Parameter_Associations (Call_Node);
- -- where C is the out parameter capturing the call kind and S is the
- -- dispatch table slot number.
+ Subp : Entity_Id;
+ CW_Typ : Entity_Id;
+ Param : Node_Id;
+ Typ : Entity_Id;
+ Eq_Prim_Op : Entity_Id := Empty;
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uC),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Prim_Op_Kind,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Call_Node);
+ return;
+ end if;
- -- Generate:
+ -- Apply_Tag_Checks is called directly from the semantics, so we need
+ -- a check to see whether expansion is active before proceeding. In
+ -- addition, there is no need to expand the call when compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
+ if not Expander_Active
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+ end if;
- -- where F is the out parameter capturing the status of a potential
- -- entry call.
+ -- Set subprogram. If this is an inherited operation that was
+ -- overridden, the body that is being called is its alias.
- Append_To (Stmts,
- Make_If_Statement (Loc,
+ Subp := Entity (Name (Call_Node));
- Condition =>
- Make_Or_Else (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Identifier (Loc, Name_uC),
- Right_Opnd =>
- New_Reference_To (RTE (RE_POK_Procedure), Loc)),
- Right_Opnd =>
- Make_Or_Else (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Identifier (Loc, Name_uC),
- Right_Opnd =>
- New_Reference_To (RTE (
- RE_POK_Protected_Procedure), Loc)),
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Identifier (Loc, Name_uC),
- Right_Opnd =>
- New_Reference_To (RTE (
- RE_POK_Task_Procedure), Loc)))),
+ if Present (Alias (Subp))
+ and then Is_Inherited_Operation (Subp)
+ and then No (DTC_Entity (Subp))
+ then
+ Subp := Alias (Subp);
+ end if;
- Then_Statements =>
- New_List (
- Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
- Expression => New_Reference_To (Standard_True, Loc)),
+ -- Definition of the class-wide type and the tagged type
- Make_Return_Statement (Loc))));
- end Build_Common_Dispatching_Select_Statements;
+ -- 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).
- -------------
- -- Build_F --
- -------------
+ if Ctrl_Typ = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ then
+ CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
- procedure Build_F
- (Loc : Source_Ptr;
- Params : List_Id)
- is
- begin
- 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));
- end Build_F;
-
- -------------
- -- Build_P --
- -------------
-
- procedure Build_P
- (Loc : Source_Ptr;
- Params : List_Id)
- is
- begin
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uP),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Address), Loc)));
- end Build_P;
-
- -------------
- -- Build_S --
- -------------
-
- procedure Build_S
- (Loc : Source_Ptr;
- Params : List_Id)
- is
- begin
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uS),
- Parameter_Type =>
- New_Reference_To (Standard_Integer, Loc)));
- end Build_S;
+ -- 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).
- -------------
- -- Build_T --
- -------------
+ elsif Is_Access_Type (Ctrl_Typ) then
+ CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
- procedure Build_T
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Params : List_Id)
- is
- begin
- Append_To (Params,
- 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));
- end Build_T;
- end Select_Expansion_Utilities;
-
- package SEU renames Select_Expansion_Utilities;
-
- Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
- (CW_Membership => RE_CW_Membership,
- IW_Membership => RE_IW_Membership,
- DT_Entry_Size => RE_DT_Entry_Size,
- DT_Prologue_Size => RE_DT_Prologue_Size,
- Get_Access_Level => RE_Get_Access_Level,
- Get_Entry_Index => RE_Get_Entry_Index,
- Get_External_Tag => RE_Get_External_Tag,
- Get_Offset_Index => RE_Get_Offset_Index,
- Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
- Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
- Get_RC_Offset => RE_Get_RC_Offset,
- Get_Remotely_Callable => RE_Get_Remotely_Callable,
- Inherit_DT => RE_Inherit_DT,
- Inherit_TSD => RE_Inherit_TSD,
- Register_Interface_Tag => RE_Register_Interface_Tag,
- Register_Tag => RE_Register_Tag,
- Set_Access_Level => RE_Set_Access_Level,
- Set_Entry_Index => RE_Set_Entry_Index,
- Set_Expanded_Name => RE_Set_Expanded_Name,
- Set_External_Tag => RE_Set_External_Tag,
- Set_Offset_Index => RE_Set_Offset_Index,
- Set_OSD => RE_Set_OSD,
- Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
- Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
- Set_RC_Offset => RE_Set_RC_Offset,
- Set_Remotely_Callable => RE_Set_Remotely_Callable,
- Set_SSD => RE_Set_SSD,
- Set_TSD => RE_Set_TSD,
- TSD_Entry_Size => RE_TSD_Entry_Size,
- TSD_Prologue_Size => RE_TSD_Prologue_Size);
-
- Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
- (CW_Membership => False,
- IW_Membership => False,
- DT_Entry_Size => False,
- DT_Prologue_Size => False,
- Get_Access_Level => False,
- Get_Entry_Index => False,
- Get_External_Tag => False,
- Get_Offset_Index => False,
- Get_Prim_Op_Address => False,
- Get_Prim_Op_Kind => False,
- Get_Remotely_Callable => False,
- Get_RC_Offset => False,
- Inherit_DT => True,
- Inherit_TSD => True,
- Register_Interface_Tag => True,
- Register_Tag => True,
- Set_Access_Level => True,
- Set_Entry_Index => True,
- Set_Expanded_Name => True,
- Set_External_Tag => True,
- Set_Offset_Index => True,
- Set_OSD => True,
- Set_Prim_Op_Address => True,
- Set_Prim_Op_Kind => True,
- Set_RC_Offset => True,
- Set_Remotely_Callable => True,
- Set_SSD => True,
- Set_TSD => True,
- TSD_Entry_Size => False,
- TSD_Prologue_Size => False);
-
- Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
- (CW_Membership => 2,
- IW_Membership => 2,
- DT_Entry_Size => 0,
- DT_Prologue_Size => 0,
- Get_Access_Level => 1,
- Get_Entry_Index => 2,
- Get_External_Tag => 1,
- Get_Offset_Index => 2,
- Get_Prim_Op_Address => 2,
- Get_Prim_Op_Kind => 2,
- Get_RC_Offset => 1,
- Get_Remotely_Callable => 1,
- Inherit_DT => 3,
- Inherit_TSD => 2,
- Register_Interface_Tag => 2,
- Register_Tag => 1,
- Set_Access_Level => 2,
- Set_Entry_Index => 3,
- Set_Expanded_Name => 2,
- Set_External_Tag => 2,
- Set_Offset_Index => 3,
- Set_OSD => 2,
- Set_Prim_Op_Address => 3,
- Set_Prim_Op_Kind => 3,
- Set_RC_Offset => 2,
- Set_Remotely_Callable => 2,
- Set_SSD => 2,
- Set_TSD => 2,
- TSD_Entry_Size => 0,
- TSD_Prologue_Size => 0);
-
- procedure Collect_All_Interfaces (T : Entity_Id);
- -- Ada 2005 (AI-251): Collect the whole list of interfaces that are
- -- directly or indirectly implemented by T. Used to compute the size
- -- of the table of interfaces.
-
- function Default_Prim_Op_Position (Subp : Entity_Id) return Uint;
- -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
- -- of the default primitive operations.
+ else
+ CW_Typ := Class_Wide_Type (Ctrl_Typ);
+ end if;
- 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.
+ Typ := Root_Type (CW_Typ);
- 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 RTE Prim_Op_Kind
- -- enumeration value.
+ if Ekind (Typ) = E_Incomplete_Type then
+ Typ := Non_Limited_View (Typ);
+ end if;
- ----------------------------
- -- Collect_All_Interfaces --
- ----------------------------
+ if not Is_Limited_Type (Typ) then
+ Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
+ end if;
- procedure Collect_All_Interfaces (T : Entity_Id) is
+ -- Dispatching call to C++ primitive
- procedure Add_Interface (Iface : Entity_Id);
- -- Add the interface it if is not already in the list
+ if Is_CPP_Class (Typ) then
+ null;
- procedure Collect (Typ : Entity_Id);
- -- Subsidiary subprogram used to traverse the whole list
- -- of directly and indirectly implemented interfaces
+ -- Dispatching call to Ada primitive
- -------------------
- -- Add_Interface --
- -------------------
+ elsif Present (Param_List) then
- procedure Add_Interface (Iface : Entity_Id) is
- Elmt : Elmt_Id;
+ -- Generate the Tag checks when appropriate
- begin
- Elmt := First_Elmt (Abstract_Interfaces (T));
- while Present (Elmt) and then Node (Elmt) /= Iface loop
- Next_Elmt (Elmt);
- end loop;
+ Param := First_Actual (Call_Node);
+ while Present (Param) loop
- if not Present (Elmt) then
- Append_Elmt (Iface, Abstract_Interfaces (T));
- end if;
- end Add_Interface;
+ -- No tag check with itself
- -------------
- -- Collect --
- -------------
+ if Param = Ctrl_Arg then
+ null;
- procedure Collect (Typ : Entity_Id) is
- Nod : constant Node_Id := Type_Definition (Parent (Typ));
- Id : Node_Id;
- Iface : Entity_Id;
- Ancestor : Entity_Id;
+ -- No tag check for parameter whose type is neither tagged nor
+ -- access to tagged (for access parameters)
- begin
- pragma Assert (False
- or else Nkind (Nod) = N_Derived_Type_Definition
- or else Nkind (Nod) = N_Record_Definition);
+ elsif No (Find_Controlling_Arg (Param)) then
+ null;
- if Nkind (Nod) = N_Record_Definition then
- return;
- end if;
+ -- No tag check for function dispatching on result if the
+ -- Tag given by the context is this one
- -- Include the ancestor if we are generating the whole list
- -- of interfaces. This is used to know the size of the table
- -- that stores the tag of all the ancestor interfaces.
+ elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
+ null;
- Ancestor := Etype (Typ);
+ -- "=" 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.
- if Is_Interface (Ancestor) then
- Add_Interface (Ancestor);
- end if;
+ elsif Subp = Eq_Prim_Op then
+ null;
- if Ancestor /= Typ
- and then Ekind (Ancestor) /= E_Record_Type_With_Private
- then
- Collect (Ancestor);
- end if;
+ -- No check in presence of suppress flags
- -- Traverse the graph of ancestor interfaces
+ elsif Tag_Checks_Suppressed (Etype (Param))
+ or else (Is_Access_Type (Etype (Param))
+ and then Tag_Checks_Suppressed
+ (Designated_Type (Etype (Param))))
+ then
+ null;
- if Is_Non_Empty_List (Interface_List (Nod)) then
- Id := First (Interface_List (Nod));
- while Present (Id) loop
- Iface := Etype (Id);
+ -- Optimization: no tag checks if the parameters are identical
- if Is_Interface (Iface) then
- Add_Interface (Iface);
- Collect (Iface);
- end if;
+ elsif Is_Entity_Name (Param)
+ and then Is_Entity_Name (Ctrl_Arg)
+ and then Entity (Param) = Entity (Ctrl_Arg)
+ then
+ null;
- Next (Id);
- end loop;
- end if;
- end Collect;
+ -- Now we need to generate the Tag check
- -- Start of processing for Collect_All_Interfaces
+ else
+ -- Generate code for tag equality check
+ -- Perhaps should have Checks.Apply_Tag_Equality_Check???
- begin
- Collect (T);
- end Collect_All_Interfaces;
+ 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)),
- ------------------------------
- -- Default_Prim_Op_Position --
- ------------------------------
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ, New_Value (Param)),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
- function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
- TSS_Name : TSS_Name_Type;
- E : Entity_Id := Subp;
+ Then_Statements =>
+ New_List (New_Constraint_Error (Loc))));
+ end if;
- begin
- -- Handle overriden subprograms
+ Next_Actual (Param);
+ end loop;
+ end if;
+ end Apply_Tag_Checks;
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
+ ------------------------
+ -- Building_Static_DT --
+ ------------------------
- Get_Name_String (Chars (E));
- TSS_Name :=
- TSS_Name_Type
- (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+ function Building_Static_DT (Typ : Entity_Id) return Boolean is
+ Root_Typ : Entity_Id := Root_Type (Typ);
- if Chars (E) = Name_uSize then
- return Uint_1;
+ begin
+ -- Handle private types
- elsif Chars (E) = Name_uAlignment then
- return Uint_2;
+ if Present (Full_View (Root_Typ)) then
+ Root_Typ := Full_View (Root_Typ);
+ end if;
- elsif TSS_Name = TSS_Stream_Read then
- return Uint_3;
+ return Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Typ)
- elsif TSS_Name = TSS_Stream_Write then
- return Uint_4;
+ -- If the type is derived from a CPP class we cannot statically
+ -- build the dispatch tables because we must inherit primitives
+ -- from the CPP side.
- elsif TSS_Name = TSS_Stream_Input then
- return Uint_5;
+ and then not Is_CPP_Class (Root_Typ);
+ end Building_Static_DT;
- elsif TSS_Name = TSS_Stream_Output then
- return Uint_6;
+ ----------------------------------
+ -- Build_Static_Dispatch_Tables --
+ ----------------------------------
- elsif Chars (E) = Name_Op_Eq then
- return Uint_7;
+ procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
+ Target_List : List_Id;
- elsif Chars (E) = Name_uAssign then
- return Uint_8;
+ procedure Build_Dispatch_Tables (List : List_Id);
+ -- Build the static dispatch table of tagged types found in the list of
+ -- declarations. The generated nodes are added at the end of Target_List
- elsif TSS_Name = TSS_Deep_Adjust then
- return Uint_9;
+ procedure Build_Package_Dispatch_Tables (N : Node_Id);
+ -- Build static dispatch tables associated with package declaration N
- elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
+ ---------------------------
+ -- Build_Dispatch_Tables --
+ ---------------------------
- elsif Ada_Version >= Ada_05 then
- if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ procedure Build_Dispatch_Tables (List : List_Id) is
+ D : Node_Id;
- elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ begin
+ D := First (List);
+ while Present (D) loop
- elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ -- Handle nested packages and package bodies recursively. The
+ -- generated code is placed on the Target_List established for
+ -- the enclosing compilation unit.
- elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ if Nkind (D) = N_Package_Declaration then
+ Build_Package_Dispatch_Tables (D);
- elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_15;
- end if;
- end if;
+ elsif Nkind (D) = N_Package_Body then
+ Build_Dispatch_Tables (Declarations (D));
- raise Program_Error;
- end Default_Prim_Op_Position;
+ elsif Nkind (D) = N_Package_Body_Stub
+ and then Present (Library_Unit (D))
+ then
+ Build_Dispatch_Tables
+ (Declarations (Proper_Body (Unit (Library_Unit (D)))));
- -----------------------------
- -- Expand_Dispatching_Call --
- -----------------------------
+ -- Handle full type declarations and derivations of library
+ -- level tagged types
- procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Call_Node);
- Call_Typ : constant Entity_Id := Etype (Call_Node);
+ elsif Nkind_In (D, N_Full_Type_Declaration,
+ N_Derived_Type_Definition)
+ and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
+ and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
+ and then not Is_Private_Type (Defining_Entity (D))
+ then
+ -- We do not generate dispatch tables for the internal types
+ -- created for a type extension with unknown discriminants
+ -- The needed information is shared with the source type,
+ -- See Expand_N_Record_Extension.
+
+ if Is_Underlying_Record_View (Defining_Entity (D))
+ or else
+ (not Comes_From_Source (Defining_Entity (D))
+ and then
+ Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
+ and then
+ not Comes_From_Source
+ (First_Subtype (Defining_Entity (D))))
+ then
+ null;
+ else
+ Insert_List_After_And_Analyze (Last (Target_List),
+ Make_DT (Defining_Entity (D)));
+ end if;
- Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
- Param_List : constant List_Id := Parameter_Associations (Call_Node);
- Subp : Entity_Id := Entity (Name (Call_Node));
+ -- Handle private types of library level tagged types. We must
+ -- exchange the private and full-view to ensure the correct
+ -- expansion. If the full view is a synchronized type ignore
+ -- the type because the table will be built for the corresponding
+ -- record type, that has its own declaration.
- CW_Typ : Entity_Id;
- New_Call : Node_Id;
+ elsif (Nkind (D) = N_Private_Type_Declaration
+ or else Nkind (D) = N_Private_Extension_Declaration)
+ and then Present (Full_View (Defining_Entity (D)))
+ then
+ declare
+ E1 : constant Entity_Id := Defining_Entity (D);
+ E2 : constant Entity_Id := Full_View (E1);
+
+ begin
+ if Is_Library_Level_Tagged_Type (E2)
+ and then Ekind (E2) /= E_Record_Subtype
+ and then not Is_Concurrent_Type (E2)
+ then
+ Exchange_Declarations (E1);
+ Insert_List_After_And_Analyze (Last (Target_List),
+ Make_DT (E1));
+ Exchange_Declarations (E2);
+ end if;
+ end;
+ end if;
+
+ Next (D);
+ end loop;
+ end Build_Dispatch_Tables;
+
+ -----------------------------------
+ -- Build_Package_Dispatch_Tables --
+ -----------------------------------
+
+ procedure Build_Package_Dispatch_Tables (N : Node_Id) is
+ Spec : constant Node_Id := Specification (N);
+ Id : constant Entity_Id := Defining_Entity (N);
+ Vis_Decls : constant List_Id := Visible_Declarations (Spec);
+ Priv_Decls : constant List_Id := Private_Declarations (Spec);
+
+ begin
+ Push_Scope (Id);
+
+ if Present (Priv_Decls) then
+ Build_Dispatch_Tables (Vis_Decls);
+ Build_Dispatch_Tables (Priv_Decls);
+
+ elsif Present (Vis_Decls) then
+ Build_Dispatch_Tables (Vis_Decls);
+ end if;
+
+ Pop_Scope;
+ end Build_Package_Dispatch_Tables;
+
+ -- Start of processing for Build_Static_Dispatch_Tables
+
+ begin
+ if not Expander_Active
+ or else not Tagged_Type_Expansion
+ then
+ return;
+ end if;
+
+ if Nkind (N) = N_Package_Declaration then
+ declare
+ Spec : constant Node_Id := Specification (N);
+ Vis_Decls : constant List_Id := Visible_Declarations (Spec);
+ Priv_Decls : constant List_Id := Private_Declarations (Spec);
+
+ begin
+ if Present (Priv_Decls)
+ and then Is_Non_Empty_List (Priv_Decls)
+ then
+ Target_List := Priv_Decls;
+
+ elsif not Present (Vis_Decls) then
+ Target_List := New_List;
+ Set_Private_Declarations (Spec, Target_List);
+ else
+ Target_List := Vis_Decls;
+ end if;
+
+ Build_Package_Dispatch_Tables (N);
+ end;
+
+ else pragma Assert (Nkind (N) = N_Package_Body);
+ Target_List := Declarations (N);
+ Build_Dispatch_Tables (Target_List);
+ end if;
+ end Build_Static_Dispatch_Tables;
+
+ ------------------------------
+ -- 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_Requeue then
+ return Uint_15;
+
+ elsif Chars (E) = Name_uDisp_Timed_Select then
+ return Uint_16;
+ end if;
+ end if;
+
+ raise Program_Error;
+ end Default_Prim_Op_Position;
+
+ -----------------------------
+ -- Expand_Dispatching_Call --
+ -----------------------------
+
+ procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Call_Typ : constant Entity_Id := Etype (Call_Node);
+
+ Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
+ Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
+ Param_List : constant List_Id := Parameter_Associations (Call_Node);
+
+ Subp : Entity_Id;
+ CW_Typ : Entity_Id;
+ New_Call : Node_Id;
New_Call_Name : Node_Id;
New_Params : List_Id := No_List;
Param : Node_Id;
-- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter.
- function Controlling_Type (Subp : Entity_Id) return Entity_Id;
- -- Returns the tagged type for which Subp is a primitive subprogram
-
---------------
-- New_Value --
---------------
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
- return Make_Explicit_Dereference (Sloc (From), Res);
+ return
+ Make_Explicit_Dereference (Sloc (From),
+ Prefix => Res);
else
return Res;
end if;
end New_Value;
- ----------------------
- -- Controlling_Type --
- ----------------------
-
- function Controlling_Type (Subp : Entity_Id) return Entity_Id is
- begin
- if Ekind (Subp) = E_Function
- and then Has_Controlling_Result (Subp)
- then
- return Base_Type (Etype (Subp));
+ -- Local variables
- else
- declare
- Formal : Entity_Id;
+ New_Node : Node_Id;
+ SCIL_Node : Node_Id;
- begin
- Formal := First_Formal (Subp);
- while Present (Formal) loop
- if Is_Controlling_Formal (Formal) then
- if Is_Access_Type (Etype (Formal)) then
- return Base_Type (Designated_Type (Etype (Formal)));
- else
- return Base_Type (Etype (Formal));
- end if;
- end if;
+ -- Start of processing for Expand_Dispatching_Call
- Next_Formal (Formal);
- end loop;
- end;
- end if;
+ begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Call_Node);
+ return;
+ end if;
- -- Controlling type not found (should never happen)
+ -- 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.
- return Empty;
- end Controlling_Type;
+ if not Expander_Active
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+ end if;
- -- Start of processing for Expand_Dispatching_Call
+ -- Set subprogram. If this is an inherited operation that was
+ -- overridden, the body that is being called is its alias.
- begin
- -- 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)
Subp := Alias (Subp);
end if;
- -- Expand_Dispatching_Call 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;
-
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
-- 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 Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
+ if Ctrl_Typ = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
then
- CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
+ 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 := Designated_Type (Etype (Ctrl_Arg));
+ elsif Is_Access_Type (Ctrl_Typ) then
+ CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
else
- CW_Typ := Etype (Ctrl_Arg);
+ CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
Typ := Root_Type (CW_Typ);
Typ := Non_Limited_View (Typ);
end if;
+ -- Generate the SCIL node for this dispatching call. The SCIL node for a
+ -- dispatching call is inserted in the tree before the call is rewriten
+ -- and expanded because the SCIL node must be found by the SCIL backend
+ -- BEFORE the expanded nodes associated with the call node are found.
+
+ if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
+ Set_SCIL_Related_Node (SCIL_Node, Call_Node);
+ Set_SCIL_Entity (SCIL_Node, Typ);
+ Set_SCIL_Target_Prim (SCIL_Node, Subp);
+ Insert_Action (Call_Node, SCIL_Node);
+ end if;
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
- if Is_CPP_Class (Root_Type (Typ)) then
+ -- Dispatching call to C++ primitive. Create a new parameter list
+ -- with no tag checks.
- -- Create a new parameter list with the displaced 'this'
+ New_Params := New_List;
- New_Params := New_List;
+ if Is_CPP_Class (Typ) then
Param := First_Actual (Call_Node);
while Present (Param) loop
Append_To (New_Params, Relocate_Node (Param));
Next_Actual (Param);
end loop;
- elsif Present (Param_List) then
-
- -- Generate the Tag checks when appropriate
+ -- Dispatching call to Ada primitive
- New_Params := New_List;
+ elsif Present (Param_List) then
+ Apply_Tag_Checks (Call_Node);
Param := First_Actual (Call_Node);
while Present (Param) loop
+ -- Cases in which we may have generated runtime checks
- -- 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
+ if Param = Ctrl_Arg
+ or else 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)
+ elsif Nkind (Parent (Param)) /= N_Parameter_Association
+ or else not Is_Accessibility_Actual (Parent (Param))
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);
-- Generate the appropriate subprogram pointer type
- if Etype (Subp) = Typ then
+ 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_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
declare
Old_Formal : Entity_Id := First_Formal (Subp);
New_Formal : Entity_Id;
- Extra : Entity_Id;
+ Extra : Entity_Id := Empty;
begin
if Present (Old_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;
+ -- If the type of the formal is an itype, there was code here
+ -- introduced in 1998 in revision 1.46, to create a new itype
+ -- by copy. This seems useless, and in fact leads to semantic
+ -- errors when the itype is the completion of a type derived
+ -- from a private type.
Extra := New_Formal;
Next_Formal (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;
- -- Copy extra formals
-
- New_Formal := First_Entity (Subp_Typ);
- while Present (New_Formal) loop
- if Present (Extra_Constrained (New_Formal)) then
- Set_Extra_Formal (Extra,
- New_Copy (Extra_Constrained (New_Formal)));
- Extra := Extra_Formal (Extra);
- Set_Extra_Constrained (New_Formal, Extra);
-
- elsif Present (Extra_Accessibility (New_Formal)) then
- Set_Extra_Formal (Extra,
- New_Copy (Extra_Accessibility (New_Formal)));
- Extra := Extra_Formal (Extra);
- Set_Extra_Accessibility (New_Formal, Extra);
- end if;
+ -- Now that the explicit formals have been duplicated, any extra
+ -- formals needed by the subprogram must be created.
- Next_Formal (New_Formal);
- end loop;
+ if Present (Extra) then
+ Set_Extra_Formal (Extra, Empty);
end if;
+
+ Create_Extra_Formals (Subp_Typ);
end;
+ -- Complete description of pointer type, including size information, as
+ -- must be done with itypes to prevent order-of-elaboration anomalies
+ -- in gigi.
+
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
+ Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
+ Layout_Type (Subp_Ptr_Typ);
+
+ -- If the controlling argument is a value of type Ada.Tag or an abstract
+ -- interface class-wide type then use it directly. Otherwise, the tag
+ -- must be extracted from the controlling object.
+
+ if Ctrl_Typ = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = 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));
- -- If the controlling argument is a value of type Ada.Tag then
- -- use it directly. Otherwise, the tag must be extracted from
- -- the controlling object.
+ -- Ada 2005 (AI-251): Abstract interface class-wide type
- if Etype (Ctrl_Arg) = RTE (RE_Tag)
- or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
+ elsif Is_Interface (Ctrl_Typ)
+ and then Is_Class_Wide_Type (Ctrl_Typ)
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
else
Controlling_Tag :=
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
+ Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
end if;
- -- Generate:
- -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
+ -- Handle dispatching calls to predefined primitives
- New_Call_Name :=
- Unchecked_Convert_To (Subp_Ptr_Typ,
- Make_DT_Access_Action (Typ,
- Action => Get_Prim_Op_Address,
- Args => New_List (
+ if Is_Predefined_Dispatching_Operation (Subp)
+ or else Is_Predefined_Dispatching_Alias (Subp)
+ then
+ Build_Get_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
+
+ -- Handle dispatching calls to user-defined primitives
+
+ else
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Find_Dispatching_Type (Subp),
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
+ end if;
- -- Vptr
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
- Controlling_Tag,
+ -- Complete decoration of SCIL dispatching node. It must be done after
+ -- the new call name is built to reference the nodes that will see the
+ -- SCIL backend (because Build_Get_Prim_Op_Address generates an
+ -- unchecked type conversion which relocates the controlling tag node).
- -- Position
+ if Generate_SCIL then
- Make_Integer_Literal (Loc, DT_Position (Subp)))));
+ -- Common case: the controlling tag is the tag of an object
+ -- (for example, obj.tag)
- if Nkind (Call_Node) = N_Function_Call then
+ if Nkind (Controlling_Tag) = N_Selected_Component then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
- -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface
- -- just requires the comparison of the tags.
+ -- Handle renaming of selected component
- if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
- and then Is_Interface (Etype (Ctrl_Arg))
- and then Subp = Eq_Prim_Op
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind (Parent (Entity (Controlling_Tag))) =
+ N_Object_Renaming_Declaration
+ and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
+ N_Selected_Component
then
- Param := First_Actual (Call_Node);
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Name (Parent (Entity (Controlling_Tag))));
- New_Call :=
- 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)));
+ -- If the controlling tag is an identifier, the SCIL node references
+ -- the corresponding object or parameter declaration
- else
- 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;
- end if;
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind_In (Parent (Entity (Controlling_Tag)),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Controlling_Tag)));
+
+ -- If the controlling tag is a dereference, the SCIL node references
+ -- the corresponding object or parameter declaration
+
+ elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
+ and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
+ and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Prefix (Controlling_Tag))));
+
+ -- For a direct reference of the tag of the type the SCIL node
+ -- references the the internal object declaration containing the tag
+ -- of the type.
+
+ elsif Nkind (Controlling_Tag) = N_Attribute_Reference
+ and then Attribute_Name (Controlling_Tag) = Name_Tag
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
+
+ -- Interfaces are not supported. For now we leave the SCIL node
+ -- decorated with the Controlling_Tag. More work needed here???
+
+ elsif Is_Interface (Etype (Controlling_Tag)) then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end if;
+
+ if Nkind (Call_Node) = N_Function_Call then
+ New_Call :=
+ Make_Function_Call (Loc,
+ Name => New_Call_Name,
+ Parameter_Associations => New_Params);
+
+ -- If this is a dispatching "=", we must first compare the tags so
+ -- we generate: x.tag = y.tag and then x = y
+
+ if Subp = Eq_Prim_Op then
+ Param := First_Actual (Call_Node);
+ New_Call :=
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Param),
+ Selector_Name =>
+ New_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,
+ Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
Rewrite (Call_Node, New_Call);
- Analyze_And_Resolve (Call_Node, Call_Typ);
+
+ -- Suppress all checks during the analysis of the expanded code
+ -- to avoid the generation of spurious warnings under ZFP run-time.
+
+ Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
end Expand_Dispatching_Call;
---------------------------------
-- Expand_Interface_Conversion --
---------------------------------
- procedure Expand_Interface_Conversion (N : Node_Id) is
+ 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);
+ Func : Node_Id;
Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
- Fent : Entity_Id;
- Func : Node_Id;
- P : Node_Id;
- Null_Op_Nod : Node_Id;
begin
- pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
+ -- Ada 2005 (AI-345): Handle synchronized interface type derivations
- -- Ada 2005 (AI-345): Handle task interfaces
-
- if Ekind (Operand_Typ) = E_Task_Type
- or else Ekind (Operand_Typ) = E_Protected_Type
- then
- Operand_Typ := Corresponding_Record_Type (Operand_Typ);
+ if Is_Concurrent_Type (Operand_Typ) then
+ Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
- -- Handle access types to interfaces
+ -- Handle access to class-wide interface types
if Is_Access_Type (Iface_Typ) then
Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
-- explicitly in the source code. Example: I'Class (Obj)
if Is_Class_Wide_Type (Iface_Typ) then
- Iface_Typ := Etype (Iface_Typ);
+ Iface_Typ := Root_Type (Iface_Typ);
+ end if;
+
+ -- If the target type is a tagged synchronized type, the dispatch table
+ -- info is in the corresponding record type.
+
+ if Is_Concurrent_Type (Iface_Typ) then
+ Iface_Typ := Corresponding_Record_Type (Iface_Typ);
+ end if;
+
+ -- Freeze the entity associated with the target interface to have
+ -- available the attribute Access_Disp_Table.
+
+ Freeze_Before (N, Iface_Typ);
+
+ pragma Assert (not Is_Static
+ or else (not Is_Class_Wide_Type (Iface_Typ)
+ and then Is_Interface (Iface_Typ)));
+
+ if not Tagged_Type_Expansion then
+
+ -- For VM, just do a conversion ???
+
+ Rewrite (N, Unchecked_Convert_To (Etype (N), N));
+ Analyze (N);
+ return;
end if;
- pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
- and then Is_Interface (Iface_Typ));
+ if not Is_Static then
+
+ -- Give error if configurable run time and Displace not available
+
+ if not RTE_Available (RE_Displace) then
+ Error_Msg_CRT ("dynamic interface conversion", N);
+ return;
+ end if;
+
+ -- Handle conversion of access-to-class-wide interface types. Target
+ -- can be an access to an object or an access to another class-wide
+ -- interface (see -1- and -2- in the following example):
+
+ -- type Iface1_Ref is access all Iface1'Class;
+ -- type Iface2_Ref is access all Iface1'Class;
+
+ -- Acc1 : Iface1_Ref := new ...
+ -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
+ -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
+
+ if Is_Access_Type (Operand_Typ) then
+ Rewrite (N,
+ Unchecked_Convert_To (Etype (N),
+ Make_Function_Call (Loc,
+ Name => New_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.
+
+ declare
+ New_Itype : Entity_Id;
+
+ begin
+ New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Set_Directly_Designated_Type (New_Itype, Etyp);
+
+ Rewrite (N,
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
+ Analyze (N);
+ Freeze_Itype (New_Itype, N);
+
+ return;
+ end;
+ end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
pragma Assert (Iface_Tag /= Empty);
-- conversion that will be expanded in the code that returns
-- the value of the displaced actual. That is:
- -- function Func (O : Operand_Typ) return Iface_Typ is
+ -- function Func (O : Address) return Iface_Typ is
+ -- type Op_Typ is access all Operand_Typ;
+ -- Aux : Op_Typ := To_Op_Typ (O);
-- begin
- -- if O = null then
+ -- if O = Null_Address then
-- return null;
-- else
- -- return Iface_Typ!(O);
+ -- return Iface_Typ!(Aux.Iface_Tag'Address);
-- end if;
-- end Func;
- Fent :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
+ declare
+ Desig_Typ : Entity_Id;
+ Fent : Entity_Id;
+ New_Typ_Decl : Node_Id;
+ Stats : List_Id;
- -- Decorate the "null" in the if-statement condition
+ begin
+ Desig_Typ := Etype (Expression (N));
- Null_Op_Nod := Make_Null (Loc);
- Set_Etype (Null_Op_Nod, Etype (Operand));
- Set_Analyzed (Null_Op_Nod);
+ if Is_Access_Type (Desig_Typ) then
+ Desig_Typ :=
+ Available_View (Directly_Designated_Type (Desig_Typ));
+ end if;
- Func :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Fent,
+ if Is_Concurrent_Type (Desig_Typ) then
+ Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
+ end if;
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uO),
- Parameter_Type =>
- New_Reference_To (Etype (Operand), Loc))),
- Result_Definition =>
- New_Reference_To (Etype (N), Loc)),
+ New_Typ_Decl :=
+ 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 (Desig_Typ, Loc)));
+
+ Stats := New_List (
+ Make_Simple_Return_Statement (Loc,
+ Unchecked_Convert_To (Etype (N),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (Defining_Identifier (New_Typ_Decl),
+ Make_Identifier (Loc, Name_uO)),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc)),
+ Attribute_Name => Name_Address))));
+
+ -- If the type is null-excluding, no need for the null branch.
+ -- Otherwise we need to check for it and return null.
+
+ if not Can_Never_Be_Null (Etype (N)) then
+ Stats := New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Make_Identifier (Loc, Name_uO),
+ Right_Opnd => New_Reference_To
+ (RTE (RE_Null_Address), Loc)),
+
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Make_Null (Loc))),
+ Else_Statements => Stats));
+ end if;
- Declarations => Empty_List,
+ Fent :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('F'));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Make_Identifier (Loc, Name_uO),
- Right_Opnd => Null_Op_Nod),
- Then_Statements => New_List (
- Make_Return_Statement (Loc,
- Make_Null (Loc))),
- Else_Statements => New_List (
- Make_Return_Statement (Loc,
- Unchecked_Convert_To (Etype (N),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Expression (N)),
- Selector_Name =>
- New_Occurrence_Of (Iface_Tag, Loc)),
- Attribute_Name => Name_Address))))))));
-
- -- Insert the new declaration in the nearest enclosing scope
- -- that has declarations.
-
- P := N;
- while not Has_Declarations (Parent (P)) loop
- P := Parent (P);
- end loop;
+ Func :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Fent,
- if Is_List_Member (P) then
- Insert_Before (P, Func);
+ 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))),
- elsif Nkind (Parent (P)) = N_Package_Specification then
- Append_To (Visible_Declarations (Parent (P)), Func);
+ Result_Definition =>
+ New_Reference_To (Etype (N), Loc)),
- else
- Append_To (Declarations (Parent (P)), Func);
- end if;
+ Declarations => New_List (New_Typ_Decl),
- Analyze (Func);
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stats));
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Fent, Loc),
- Parameter_Associations => New_List (
- Relocate_Node (Expression (N)))));
+ -- Place function body before the expression containing the
+ -- conversion. We suppress all checks because the body of the
+ -- internally generated function already takes care of the case
+ -- in which the actual is null; therefore there is no need to
+ -- double check that the pointer is not null when the program
+ -- executes the alternative that performs the type conversion).
+
+ Insert_Action (N, Func, Suppress => All_Checks);
+
+ if Is_Access_Type (Etype (Expression (N))) then
+
+ -- Generate: Func (Address!(Expression))
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Fent, Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Relocate_Node (Expression (N))))));
+
+ else
+ -- Generate: Func (Operand_Typ!(Expression)'Address)
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_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;
end if;
Analyze (N);
------------------------------
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;
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Subp : Entity_Id;
- Nam : Name_Id;
Formal_DDT : Entity_Id;
Actual_DDT : Entity_Id;
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (Call_Node));
- -- Normal case
+ -- Call using selected component
+
+ elsif Nkind (Name (Call_Node)) = N_Selected_Component then
+ Subp := Entity (Selector_Name (Name (Call_Node)));
+
+ -- Call using direct name
else
Subp := Entity (Name (Call_Node));
end if;
+ -- Ada 2005 (AI-251): Look for interface type formals to force "this"
+ -- displacement
+
Formal := First_Formal (Subp);
Actual := First_Actual (Call_Node);
while Present (Formal) loop
-
- -- Ada 2005 (AI-251): Conversion to interface to force "this"
- -- displacement.
-
- Formal_Typ := Etype (Etype (Formal));
+ Formal_Typ := Etype (Formal);
if Ekind (Formal_Typ) = E_Record_Type_With_Private then
Formal_Typ := Full_View (Formal_Typ);
Actual_DDT := Directly_Designated_Type (Actual_Typ);
end if;
- if Is_Interface (Formal_Typ) then
-
+ 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
- -- is class-wide of the formal-type interface; in this case the
- -- displacement of the pointer was already done at the point of
- -- the call to the enclosing subprogram. This case corresponds
- -- with the call to P (Obj) in the following example:
-
- -- type I is interface;
- -- procedure P (X : I) is abstract;
-
- -- procedure General_Op (Obj : I'Class) is
- -- begin
- -- P (Obj);
- -- end General_Op;
+ -- coindices with the type of the formal.
- if Is_Class_Wide_Type (Actual_Typ)
- and then Etype (Actual_Typ) = Formal_Typ
- then
+ if Actual_Typ = Formal_Typ then
null;
- -- No need to displace the pointer if the type of the actual is a
- -- derivation of the formal-type interface because in this case
- -- the interface primitives are located in the primary dispatch
- -- table.
+ -- No need to displace the pointer if the interface type is
+ -- a parent of the type of the actual because in this case the
+ -- interface primitives are located in the primary dispatch table.
elsif Is_Ancestor (Formal_Typ, Actual_Typ) 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);
+ Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
- -- Anonymous access type
+ -- Access to class-wide interface type
elsif Is_Access_Type (Formal_Typ)
- and then Is_Interface (Etype (Formal_DDT))
+ 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);
+ -- This case must have been handled by the analysis and
+ -- expansion of 'Access. The only exception is when types
+ -- match and no further expansion is required.
- Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
-
- Rewrite (Actual, Conversion);
- Analyze_And_Resolve (Actual, Etype (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);
+ pragma Assert (Base_Type (Etype (Prefix (Actual)))
+ = Base_Type (Formal_DDT));
+ null;
- -- No need to displace the pointer if the actual is a class-wide
- -- type of the formal-type interface because in this case the
- -- displacement of the pointer was already done at the point of
- -- the call to the enclosing subprogram (this case is similar
- -- to the example described above for the non access-type case)
+ -- No need to displace the pointer if the type of the actual
+ -- coincides with the type of the formal.
- elsif Is_Class_Wide_Type (Actual_DDT)
- and then Etype (Actual_DDT) = Formal_DDT
- then
+ elsif Actual_DDT = Formal_DDT then
null;
- -- No need to displace the pointer if the type of the actual is a
- -- derivation of the interface (because in this case the interface
- -- primitives are located in the primary dispatch table)
+ -- No need to displace the pointer if the interface type is
+ -- a parent of the type of the actual because in this case the
+ -- interface primitives are located in the primary dispatch table.
elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
null;
-- 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
+ -- we replace the anonymous access type by a duplicate
+ -- declaration whose designated type is the non-limited view
if Ekind (Actual_DDT) = E_Incomplete_Type
and then Present (Non_Limited_View (Actual_DDT))
-- Expand_Interface_Thunk --
----------------------------
- function Expand_Interface_Thunk
- (N : Node_Id;
- Thunk_Alias : Entity_Id;
- Thunk_Id : Entity_Id;
- Thunk_Tag : Entity_Id) return Node_Id
+ procedure Expand_Interface_Thunk
+ (Prim : Node_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;
- Target : Entity_Id;
- New_Code : Node_Id;
- Formal : Node_Id;
- New_Formal : Node_Id;
- Decl_1 : Node_Id;
- Decl_2 : Node_Id;
- E : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
+
+ Controlling_Typ : Entity_Id;
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ Expr : Node_Id;
+ Formal : Node_Id;
+ Ftyp : Entity_Id;
+ Iface_Formal : Node_Id;
+ New_Arg : Node_Id;
+ Offset_To_Top : Node_Id;
+ Target_Formal : Entity_Id;
begin
- -- Traverse the list of alias to find the final target
+ Thunk_Id := Empty;
+ Thunk_Code := Empty;
- 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
+ -- Duplicate the formals of the Target primitive. In the thunk, the type
+ -- of the controlling formal is the covered interface type (instead of
+ -- the target tagged type). Done to avoid problems with discriminated
+ -- tagged types because, if the controlling type has discriminants with
+ -- default values, then the type conversions done inside the body of
+ -- the thunk (after the displacement of the pointer to the base of the
+ -- actual object) generate code that modify its contents.
- Formal := First_Formal (Target);
- E := First_Formal (N);
- while Present (Formal) loop
- New_Formal := Copy_Separate_Tree (Parent (Formal));
+ -- Note: This special management is not done for predefined primitives
+ -- because???
- -- Propagate the parameter type to the copy. This is required to
- -- properly handle the case in which the subprogram covering the
- -- interface has been inherited:
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Iface_Formal := First_Formal (Interface_Alias (Prim));
+ end if;
- -- Example:
- -- type I is interface;
- -- procedure P (X : in I) is abstract;
+ Formal := First_Formal (Target);
+ while Present (Formal) loop
+ Ftyp := Etype (Formal);
- -- type T is tagged null record;
- -- procedure P (X : T);
+ -- Use the interface type as the type of the controlling formal (see
+ -- comment above).
- -- type DT is new T and I with ...
+ if not Is_Controlling_Formal (Formal)
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ then
+ Ftyp := Etype (Formal);
+ Expr := New_Copy_Tree (Expression (Parent (Formal)));
+ else
+ Ftyp := Etype (Iface_Formal);
+ Expr := Empty;
+ end if;
- Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
- Append_To (Formals, New_Formal);
+ 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 (Ftyp, Loc),
+ Expression => Expr));
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Next_Formal (Iface_Formal);
+ end if;
Next_Formal (Formal);
- Next_Formal (E);
end loop;
- if Ekind (First_Formal (Target)) = E_In_Parameter
- and then Ekind (Etype (First_Formal (Target)))
- = E_Anonymous_Access_Type
- then
- -- Generate:
+ Controlling_Typ := Find_Dispatching_Type (Target);
- -- type T is access all <<type of the first formal>>
- -- S1 := Storage_Offset!(First_formal)
- -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
+ Target_Formal := First_Formal (Target);
+ Formal := First (Formals);
+ while Present (Formal) loop
- -- ... and the first actual of the call is generated as T!(S1)
+ -- Handle concurrent types
- 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 (First_Formal (Target))), 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 (First (Formals)), Loc)),
- Right_Opnd =>
- Unchecked_Convert_To
- (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To
- (Defining_Identifier (First (Formals)), Loc),
- Selector_Name =>
- New_Occurrence_Of (Thunk_Tag, Loc)),
- Attribute_Name => Name_Position))));
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ then
+ Ftyp := Directly_Designated_Type (Etype (Target_Formal));
+ else
+ Ftyp := Etype (Target_Formal);
+ end if;
- Append_To (Decl, Decl_2);
- Append_To (Decl, Decl_1);
+ if Is_Concurrent_Type (Ftyp) then
+ Ftyp := Corresponding_Record_Type (Ftyp);
+ end if;
- -- Reference the new first actual
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ and then Ftyp = Controlling_Typ
+ then
+ -- Generate:
+ -- type T is access all <<type of the target formal>>
+ -- S : Storage_Offset := Storage_Offset!(Formal)
+ -- - Offset_To_Top (address!(Formal))
+
+ 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 (Ftyp, Loc)));
+
+ New_Arg :=
+ Unchecked_Convert_To (RTE (RE_Address),
+ New_Reference_To (Defining_Identifier (Formal), Loc));
+
+ if not RTE_Available (RE_Offset_To_Top) then
+ Offset_To_Top :=
+ Build_Offset_To_Top (Loc, New_Arg);
+ else
+ Offset_To_Top :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (New_Arg));
+ end if;
- Append_To (Actuals,
- Unchecked_Convert_To
- (Defining_Identifier (Decl_2),
- New_Reference_To (Defining_Identifier (Decl_1), 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 =>
+ Offset_To_Top));
- -- Side note: The reverse order of declarations is just to ensure
- -- that the call to RE_Print is correct.
+ Append_To (Decl, Decl_2);
+ Append_To (Decl, Decl_1);
- else
- -- Generate:
- --
- -- S1 := Storage_Offset!(First_formal'Address)
- -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
- -- S2 := Tag_Ptr!(S3)
+ -- Reference the new actual. Generate:
+ -- T!(S)
- 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 (First (Formals)), Loc),
- Attribute_Name => Name_Address)),
- Right_Opnd =>
- Unchecked_Convert_To
- (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To
- (Defining_Identifier (First (Formals)), Loc),
- Selector_Name =>
- New_Occurrence_Of (Thunk_Tag, Loc)),
- Attribute_Name => Name_Position))));
+ Append_To (Actuals,
+ Unchecked_Convert_To
+ (Defining_Identifier (Decl_2),
+ New_Reference_To (Defining_Identifier (Decl_1), Loc)));
- 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)));
+ elsif Ftyp = Controlling_Typ then
- Append_To (Decl, Decl_1);
- Append_To (Decl, Decl_2);
+ -- Generate:
+ -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
+ -- - Offset_To_Top (Formal'Address)
+ -- S2 : Addr_Ptr := Addr_Ptr!(S1)
- -- Reference the new first actual
+ New_Arg :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Defining_Identifier (Formal), Loc),
+ Attribute_Name =>
+ Name_Address);
+
+ if not RTE_Available (RE_Offset_To_Top) then
+ Offset_To_Top :=
+ Build_Offset_To_Top (Loc, New_Arg);
+ else
+ Offset_To_Top :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (New_Arg));
+ end if;
- Append_To (Actuals,
- Unchecked_Convert_To
- (Etype (First_Entity (Target)),
- Make_Explicit_Dereference (Loc,
- New_Reference_To (Defining_Identifier (Decl_2), Loc))));
- end if;
+ 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 =>
+ Offset_To_Top));
- Formal := Next (First (Formals));
- while Present (Formal) loop
- Append_To (Actuals,
- New_Reference_To (Defining_Identifier (Formal), Loc));
+ 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 actual. Generate:
+ -- Target_Formal (S2.all)
+
+ Append_To (Actuals,
+ Unchecked_Convert_To (Ftyp,
+ 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'));
+
+ Set_Is_Thunk (Thunk_Id);
+
+ -- Procedure case
+
if Ekind (Target) = E_Procedure then
- New_Code :=
+ Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Target, Loc),
- Parameter_Associations => Actuals))));
+ Name => New_Occurrence_Of (Target, Loc),
+ Parameter_Associations => Actuals))));
- else pragma Assert (Ekind (Target) = E_Function);
+ -- Function case
- New_Code :=
+ else pragma Assert (Ekind (Target) = E_Function);
+ Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals)))));
end if;
-
- Analyze (New_Code);
- return New_Code;
end Expand_Interface_Thunk;
- -------------------
- -- Fill_DT_Entry --
- -------------------
+ ------------
+ -- Has_DT --
+ ------------
- function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id) return Node_Id
+ function Has_DT (Typ : Entity_Id) return Boolean is
+ begin
+ return not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls);
+ end Has_DT;
+
+ -----------------------------------------
+ -- Is_Predefined_Dispatching_Operation --
+ -----------------------------------------
+
+ function Is_Predefined_Dispatching_Operation
+ (E : Entity_Id) return Boolean
is
- Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
- DT_Ptr : constant Entity_Id :=
- Node (First_Elmt (Access_Disp_Table (Typ)));
- Pos : constant Uint := DT_Position (Prim);
- Tag : constant Entity_Id := First_Tag_Component (Typ);
+ TSS_Name : TSS_Name_Type;
begin
- if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
- raise Program_Error;
+ if not Is_Dispatching_Operation (E) then
+ return False;
end if;
- return
- Make_DT_Access_Action (Typ,
- Action => Set_Prim_Op_Address,
- Args => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)), -- DTptr
+ Get_Name_String (Chars (E));
- Make_Integer_Literal (Loc, Pos), -- Position
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
+ .. Name_Len));
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Address)));
- end Fill_DT_Entry;
+ return False;
+ end Is_Predefined_Dispatching_Operation;
- -----------------------------
- -- Fill_Secondary_DT_Entry --
- -----------------------------
+ ---------------------------------------
+ -- Is_Predefined_Internal_Operation --
+ ---------------------------------------
- function Fill_Secondary_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id;
- Thunk_Id : Entity_Id;
- Iface_DT_Ptr : Entity_Id) return Node_Id
+ function Is_Predefined_Internal_Operation
+ (E : Entity_Id) return Boolean
is
- Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
- Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
- Pos : constant Uint := DT_Position (Iface_Prim);
- Tag : constant Entity_Id :=
- First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
+ TSS_Name : TSS_Name_Type;
begin
- if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
- raise Program_Error;
+ if not Is_Dispatching_Operation (E) then
+ return False;
end if;
- return
- Make_DT_Access_Action (Typ,
- Action => Set_Prim_Op_Address,
- Args => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
-
- Make_Integer_Literal (Loc, Pos), -- Position
-
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Thunk_Id, Loc),
- Attribute_Name => Name_Address)));
- end Fill_Secondary_DT_Entry;
+ Get_Name_String (Chars (E));
- ---------------------------
- -- Get_Remotely_Callable --
- ---------------------------
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
- function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Obj);
- begin
- return Make_DT_Access_Action
- (Typ => Etype (Obj),
- Action => Get_Remotely_Callable,
- Args => New_List (
- Make_Selected_Component (Loc,
- Prefix => Obj,
- Selector_Name => Make_Identifier (Loc, Name_uTag))));
- end Get_Remotely_Callable;
+ return False;
+ end Is_Predefined_Internal_Operation;
- ------------------------------------------
- -- Init_Predefined_Interface_Primitives --
- ------------------------------------------
+ -------------------------------------
+ -- Is_Predefined_Dispatching_Alias --
+ -------------------------------------
- function Init_Predefined_Interface_Primitives
- (Typ : Entity_Id) return List_Id
+ function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
is
- Loc : constant Source_Ptr := Sloc (Typ);
- DT_Ptr : constant Node_Id :=
- Node (First_Elmt (Access_Disp_Table (Typ)));
- Result : constant List_Id := New_List;
- AI : Elmt_Id;
+ E : Entity_Id;
begin
- -- No need to inherit primitives if we have an abstract interface
- -- type or a concurrent type.
+ 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_Interface (Typ) or else Is_Concurrent_Record_Type (Typ) then
- return Result;
+ if Is_Predefined_Dispatching_Operation (E) then
+ return True;
+ end if;
end if;
- AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
- while Present (AI) loop
+ return False;
+ end Is_Predefined_Dispatching_Alias;
- -- All the secondary tables inherit the dispatch table entries
- -- associated with predefined primitives.
-
- -- Generate:
- -- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count);
-
- Append_To (Result,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Node (AI), Loc)),
- Node3 => Make_Integer_Literal (Loc, Default_Prim_Op_Count))));
-
- Next_Elmt (AI);
- end loop;
+ ---------------------------------------
+ -- Is_Predefined_Interface_Primitive --
+ ---------------------------------------
- return Result;
- end Init_Predefined_Interface_Primitives;
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ return Ada_Version >= Ada_05
+ and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
+ Chars (E) = Name_uDisp_Conditional_Select or else
+ Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
+ Chars (E) = Name_uDisp_Get_Task_Id or else
+ Chars (E) = Name_uDisp_Requeue or else
+ Chars (E) = Name_uDisp_Timed_Select);
+ end Is_Predefined_Interface_Primitive;
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
+ -- For interface types, generate:
+
+ -- procedure _Disp_Asynchronous_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- B : out System.Storage_Elements.Dummy_Communication_Block;
+ -- F : out Boolean)
+ -- is
+ -- begin
+ -- null;
+ -- end _Disp_Asynchronous_Select;
+
+ -- For protected types, generate:
+
+ -- procedure _Disp_Asynchronous_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- B : out System.Storage_Elements.Dummy_Communication_Block;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer :=
+ -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
+ -- Bnn : System.Tasking.Protected_Objects.Operations.
+ -- Communication_Block;
+ -- begin
+ -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
+ -- (T._object'Access,
+ -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
+ -- P,
+ -- System.Tasking.Asynchronous_Call,
+ -- Bnn);
+ -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
+ -- end _Disp_Asynchronous_Select;
+
+ -- For task types, generate:
+
+ -- procedure _Disp_Asynchronous_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- B : out System.Storage_Elements.Dummy_Communication_Block;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer :=
+ -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
+ -- begin
+ -- System.Tasking.Rendezvous.Task_Entry_Call
+ -- (T._task_id,
+ -- System.Tasking.Task_Entry_Index (I),
+ -- P,
+ -- System.Tasking.Asynchronous_Call,
+ -- F);
+ -- end _Disp_Asynchronous_Select;
+
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id
is
- 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;
+ 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);
+ Obj_Ref : Node_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,
New_List (Make_Null_Statement (Loc))));
end if;
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
-
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- if Present (Conc_Typ) then
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
- -- I : Integer := get_entry_index (tag! (<type>VP), S);
+ -- I : Integer :=
+ -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
+ 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)),
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Asynchronous_Call,
- -- B);
+ -- Bnn : Communication_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.
+ Com_Block :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Com_Block,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
- 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))),
+ -- Build T._object'Access for calls below
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Obj_Ref :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)));
+
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+
+ -- Generate:
+ -- Protected_Entry_Call
+ -- (T._object'Access, -- Object
+ -- Protected_Entry_Index! (I), -- E
+ -- P, -- Uninterpreted_Data
+ -- Asynchronous_Call, -- Mode
+ -- Bnn); -- Communication_Block
+
+ -- where T is the protected object, I is the entry index, P
+ -- is the wrapped parameters and B is the name of the
+ -- communication block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
+
+ 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
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+
+ -- Generate:
+ -- procedure Protected_Single_Entry_Call
+ -- (Object : Protection_Entry_Access;
+ -- Uninterpreted_Data : System.Address;
+ -- Mode : Call_Modes);
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Protected_Single_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uP),
+ Attribute_Name => Name_Address),
+
+ New_Reference_To
+ (RTE (RE_Asynchronous_Call), Loc))));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Generate:
+ -- B := Dummy_Communication_Block (Bnn);
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uB),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (
+ RTE (RE_Dummy_Communication_Block), Loc),
+ Expression =>
+ New_Reference_To (Com_Block, Loc))));
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
- Make_Identifier (Loc, Name_uB)))); -- comm block
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
+ -- Task_Entry_Call
+ -- (T._task_id, -- Acceptor
+ -- Task_Entry_Index! (I), -- E
+ -- P, -- Uninterpreted_Data
+ -- Asynchronous_Call, -- Mode
+ -- F); -- Rendezvous_Successful
+
+ -- where T is the task object, I is the entry index, P is the
-- wrapped parameters and F is the status flag.
Append_To (Stmts,
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),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
- -- Implementation for limited tagged types
-
else
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
end if;
return
Params : constant List_Id := New_List;
begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "B" - Communication block
- -- "F" - Status flag
+ 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 (
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_B (Loc, Params);
- SEU.Build_F (Loc, Params);
+ 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),
- Set_Is_Internal (Def_Id);
+ 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);
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
end Make_Disp_Asynchronous_Select_Spec;
---------------------------------------
-- Make_Disp_Conditional_Select_Body --
---------------------------------------
+ -- For interface types, generate:
+
+ -- procedure _Disp_Conditional_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- begin
+ -- null;
+ -- end _Disp_Conditional_Select;
+
+ -- For protected types, generate:
+
+ -- procedure _Disp_Conditional_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer;
+ -- Bnn : System.Tasking.Protected_Objects.Operations.
+ -- Communication_Block;
+
+ -- begin
+ -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
+
+ -- if C = Ada.Tags.POK_Procedure
+ -- or else C = Ada.Tags.POK_Protected_Procedure
+ -- or else C = Ada.Tags.POK_Task_Procedure
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
+ -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
+ -- (T.object'Access,
+ -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
+ -- P,
+ -- System.Tasking.Conditional_Call,
+ -- Bnn);
+ -- F := not Cancelled (Bnn);
+ -- end _Disp_Conditional_Select;
+
+ -- For task types, generate:
+
+ -- procedure _Disp_Conditional_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer;
+
+ -- begin
+ -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
+ -- System.Tasking.Rendezvous.Task_Entry_Call
+ -- (T._task_id,
+ -- System.Tasking.Task_Entry_Index (I),
+ -- P,
+ -- System.Tasking.Conditional_Call,
+ -- F);
+ -- end _Disp_Conditional_Select;
+
function Make_Disp_Conditional_Select_Body
(Typ : Entity_Id) return Node_Id
is
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
+ Obj_Ref : Node_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,
New_List (Make_Null_Statement (Loc))));
end if;
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
-
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- if Present (Conc_Typ) then
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
-- I : Integer;
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
- end if;
-
- -- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
+ -- Generate:
+ -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
- if Present (Conc_Typ) then
+ 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.
+ -- 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'));
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
Name =>
Make_Identifier (Loc, Name_uI),
Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
+ 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)),
if Ekind (Conc_Typ) = E_Protected_Type then
- -- Generate:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- Bnn);
+ Obj_Ref := -- T._object'Access
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)));
- -- 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.
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ -- Generate:
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ -- Protected_Entry_Call
+ -- (T._object'Access, -- Object
+ -- Protected_Entry_Index! (I), -- E
+ -- P, -- Uninterpreted_Data
+ -- Conditional_Call, -- Mode
+ -- Bnn); -- Block
- 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))),
+ -- 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.
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Conditional_Call
- RTE (RE_Conditional_Call), Loc),
- New_Reference_To ( -- Bnn
- Blk_Nam, Loc))));
+ 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))));
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+
+ -- If we are compiling for a restricted run-time, the call
+ -- uses the simpler form.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Protected_Single_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uP),
+ Attribute_Name => Name_Address),
+
+ New_Reference_To
+ (RTE (RE_Conditional_Call), Loc))));
+ when others =>
+ raise Program_Error;
+ end case;
-- Generate:
-- F := not Cancelled (Bnn);
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
- -- Protected_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- F);
+ -- Task_Entry_Call
+ -- (T._task_id, -- Acceptor
+ -- Task_Entry_Index! (I), -- E
+ -- P, -- Uninterpreted_Data
+ -- Conditional_Call, -- Mode
+ -- F); -- Rendezvous_Successful
-- where T is the task object, I is the entry index, P are the
-- wrapped parameters and F is the status flag.
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
- -- Implementation for limited tagged types
-
else
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
end if;
return
Params : constant List_Id := New_List;
begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "C" - Call kind
- -- "F" - Status flag
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- 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),
- Set_Is_Internal (Def_Id);
+ 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,
DT_Ptr : Entity_Id;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Name =>
Make_Identifier (Loc, Name_uC),
Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Prim_Op_Kind,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))))));
+ 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;
-------------------------------------
Params : constant List_Id := New_List;
begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "C" - Call kind
+ 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 (
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_C (Loc, Params);
+ 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)),
- Set_Is_Internal (Def_Id);
+ 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,
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,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)));
+ 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,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- New_Reference_To (RTE (RO_ST_Null_Task), Loc));
+ New_Reference_To (RTE (RE_Null_Address), Loc));
end if;
return
function Make_Disp_Get_Task_Id_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_Task_Id);
+ Loc : constant Source_Ptr := Sloc (Typ);
begin
- Set_Is_Internal (Def_Id);
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
return
Make_Function_Specification (Loc,
- Defining_Unit_Name => Def_Id,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Parameter_Type =>
New_Reference_To (Typ, Loc))),
Result_Definition =>
- New_Reference_To (RTE (RO_ST_Task_Id), Loc));
+ New_Reference_To (RTE (RE_Address), Loc));
end Make_Disp_Get_Task_Id_Spec;
- ---------------------------------
- -- Make_Disp_Timed_Select_Body --
- ---------------------------------
+ ----------------------------
+ -- Make_Disp_Requeue_Body --
+ ----------------------------
+
+ function Make_Disp_Requeue_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Conc_Typ : Entity_Id := Empty;
+ Stmts : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- Null body is generated for interface types and non-concurrent
+ -- tagged types.
+
+ if Is_Interface (Typ)
+ or else not Is_Concurrent_Record_Type (Typ)
+ then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Requeue_Spec (Typ),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate statements:
+ -- if F then
+ -- System.Tasking.Protected_Objects.Operations.
+ -- Requeue_Protected_Entry
+ -- (Protection_Entries_Access (P),
+ -- O._object'Unchecked_Access,
+ -- Protected_Entry_Index (I),
+ -- A);
+ -- else
+ -- System.Tasking.Protected_Objects.Operations.
+ -- Requeue_Task_To_Protected_Entry
+ -- (O._object'Unchecked_Access,
+ -- Protected_Entry_Index (I),
+ -- A);
+ -- end if;
+
+ if Restriction_Active (No_Entry_Queue) then
+ Append_To (Stmts, Make_Null_Statement (Loc));
+ else
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Identifier (Loc, Name_uF),
+
+ Then_Statements =>
+ New_List (
+
+ -- Call to Requeue_Protected_Entry
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (
+ RTE (RE_Requeue_Protected_Entry), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
+ Subtype_Mark =>
+ New_Reference_To (
+ RTE (RE_Protection_Entries_Access), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uP)),
+
+ Make_Attribute_Reference (Loc, -- O._object'Acc
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uO),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ 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_uA)))), -- abort status
+
+ Else_Statements =>
+ New_List (
+
+ -- Call to Requeue_Task_To_Protected_Entry
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (
+ RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- O._object'Acc
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uO),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ 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_uA)))))); -- abort status
+ end if;
+ else
+ pragma Assert (Is_Task_Type (Conc_Typ));
+
+ -- Generate:
+ -- if F then
+ -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
+ -- (Protection_Entries_Access (P),
+ -- O._task_id,
+ -- Task_Entry_Index (I),
+ -- A);
+ -- else
+ -- System.Tasking.Rendezvous.Requeue_Task_Entry
+ -- (O._task_id,
+ -- Task_Entry_Index (I),
+ -- A);
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Identifier (Loc, Name_uF),
+
+ Then_Statements =>
+ New_List (
+
+ -- Call to Requeue_Protected_To_Task_Entry
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (
+ RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
+
+ Parameter_Associations =>
+ New_List (
+
+ Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
+ Subtype_Mark =>
+ New_Reference_To (
+ RTE (RE_Protection_Entries_Access), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uP)),
+
+ Make_Selected_Component (Loc, -- O._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uO),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ 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_uA)))), -- abort status
+
+ Else_Statements =>
+ New_List (
+
+ -- Call to Requeue_Task_Entry
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
+
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- O._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uO),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ 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_uA)))))); -- abort status
+ end if;
+
+ -- Even though no declarations are needed in both cases, we allocate
+ -- a list for entities added by Freeze.
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Requeue_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Requeue_Body;
+
+ ----------------------------
+ -- Make_Disp_Requeue_Spec --
+ ----------------------------
+
+ function Make_Disp_Requeue_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- O : in out Typ; - Object parameter
+ -- F : Boolean; - Protected (True) / task (False) flag
+ -- P : Address; - Protection_Entries_Access value
+ -- I : Entry_Index - Index of entry call
+ -- A : Boolean - Abort flag
+
+ -- Note that the Protection_Entries_Access value is represented as a
+ -- System.Address in order to avoid dragging in the tasking runtime
+ -- when compiling sources without tasking constructs.
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
+
+ Parameter_Specifications =>
+ New_List (
+
+ Make_Parameter_Specification (Loc, -- O
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc, -- F
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc)),
+
+ Make_Parameter_Specification (Loc, -- P
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)),
+
+ Make_Parameter_Specification (Loc, -- I
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc, -- A
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uA),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc))));
+ end Make_Disp_Requeue_Spec;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Body --
+ ---------------------------------
+
+ -- For interface types, generate:
+
+ -- procedure _Disp_Timed_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- D : Duration;
+ -- M : Integer;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- begin
+ -- null;
+ -- end _Disp_Timed_Select;
+
+ -- For protected types, generate:
+
+ -- procedure _Disp_Timed_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- D : Duration;
+ -- M : Integer;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer;
+
+ -- begin
+ -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
+
+ -- if C = Ada.Tags.POK_Procedure
+ -- or else C = Ada.Tags.POK_Protected_Procedure
+ -- or else C = Ada.Tags.POK_Task_Procedure
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
+ -- System.Tasking.Protected_Objects.Operations.
+ -- Timed_Protected_Entry_Call
+ -- (T._object'Access,
+ -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+ -- end _Disp_Timed_Select;
+
+ -- For task types, generate:
+
+ -- procedure _Disp_Timed_Select
+ -- (T : in out <Typ>;
+ -- S : Integer;
+ -- P : System.Address;
+ -- D : Duration;
+ -- M : Integer;
+ -- C : out Ada.Tags.Prim_Op_Kind;
+ -- F : out Boolean)
+ -- is
+ -- I : Integer;
+
+ -- begin
+ -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
+ -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
+ -- (T._task_id,
+ -- System.Tasking.Task_Entry_Index (I),
+ -- P,
+ -- D,
+ -- M,
+ -- D);
+ -- end _Disp_Time_Select;
+
+ function Make_Disp_Timed_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Obj_Ref : Node_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! (<type>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! (<type>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)))));
+
+ -- Protected case
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Build T._object'Access
+
+ Obj_Ref :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)));
+
+ -- Normal case, No_Entry_Queue restriction not active. In this
+ -- case we generate:
+
+ -- Timed_Protected_Entry_Call
+ -- (T._object'access,
+ -- Protected_Entry_Index! (I),
+ -- P, D, M, F);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
+
+ 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
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ -- Generate:
+
+ -- Timed_Protected_Single_Entry_Call
+ -- (T._object'access, P, D, M, F);
+
+ -- where T is the protected object, P is the wrapped
+ -- parameters, D is the delay amount, M is the delay mode, F
+ -- is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+ Obj_Ref,
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Task case
+
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Timed_Task_Entry_Call (
+ -- T._task_id,
+ -- Task_Entry_Index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_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;
+
+ else
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Timed_Select_Body;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Spec --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Timed_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- T : in out Typ; -- Object parameter
+ -- S : Integer; -- Primitive operation slot
+ -- P : Address; -- Wrapped parameters
+ -- D : Duration; -- Delay
+ -- M : Integer; -- Delay Mode
+ -- C : out Prim_Op_Kind; -- Call kind
+ -- F : out Boolean; -- Status flag
+
+ Append_List_To (Params, New_List (
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_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; N : Node_Id := Empty) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Max_Predef_Prims : constant Int :=
+ UI_To_Int
+ (Intval
+ (Expression
+ (Parent (RTE (RE_Max_Predef_Prims)))));
+
+ DT_Decl : constant Elist_Id := New_Elmt_List;
+ DT_Aggr : constant Elist_Id := New_Elmt_List;
+ -- Entities marked with attribute Is_Dispatch_Table_Entity
+
+ procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
+ -- Verify that all non-tagged types in the profile of a subprogram
+ -- are frozen at the point the subprogram is frozen. This enforces
+ -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
+ -- subprogram is frozen, enough must be known about it to build the
+ -- activation record for it, which requires at least that the size of
+ -- all parameters be known. Controlling arguments are by-reference,
+ -- and therefore the rule only applies to non-tagged types.
+ -- Typical violation of the rule involves an object declaration that
+ -- freezes a tagged type, when one of its primitive operations has a
+ -- type in its profile whose full view has not been analyzed yet.
+
+ procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
+ -- Export the dispatch table DT of tagged type Typ. Required to generate
+ -- forward references and statically allocate the table. For primary
+ -- dispatch tables Index is 0; for secondary dispatch tables the value
+ -- of index must match the Suffix_Index value assigned to the table by
+ -- Make_Tags when generating its unique external name, and it is used to
+ -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
+ -- the external name generated by Import_DT.
+
+ procedure Make_Secondary_DT
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Suffix_Index : Int;
+ Num_Iface_Prims : Nat;
+ Iface_DT_Ptr : Entity_Id;
+ Predef_Prims_Ptr : Entity_Id;
+ Build_Thunks : Boolean;
+ Result : List_Id);
+ -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
+ -- Table of Typ associated with Iface. Each abstract interface of Typ
+ -- has two secondary dispatch tables: one containing pointers to thunks
+ -- and another containing pointers to the primitives covering the
+ -- interface primitives. The former secondary table is generated when
+ -- Build_Thunks is True, and provides common support for dispatching
+ -- calls through interface types; the latter secondary table is
+ -- generated when Build_Thunks is False, and provides support for
+ -- Generic Dispatching Constructors that dispatch calls through
+ -- interface types. When constructing this latter table the value
+ -- of Suffix_Index is -1 to indicate that there is no need to export
+ -- such table when building statically allocated dispatch tables; a
+ -- positive value of Suffix_Index must match the Suffix_Index value
+ -- assigned to this secondary dispatch table by Make_Tags when its
+ -- unique external name was generated.
+
+ ------------------------------
+ -- Check_Premature_Freezing --
+ ------------------------------
+
+ procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
+ begin
+ if Present (N)
+ and then Is_Private_Type (Typ)
+ and then No (Full_View (Typ))
+ and then not Is_Generic_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ and then not Is_Frozen (Typ)
+ then
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_NE
+ ("declaration must appear after completion of type &", N, Typ);
+ Error_Msg_NE
+ ("\which is an untagged type in the profile of"
+ & " primitive operation & declared#",
+ N, Subp);
+ end if;
+ end Check_Premature_Freezing;
+
+ ---------------
+ -- Export_DT --
+ ---------------
+
+ procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
+ is
+ Count : Nat;
+ Elmt : Elmt_Id;
+
+ begin
+ Set_Is_Statically_Allocated (DT);
+ Set_Is_True_Constant (DT);
+ Set_Is_Exported (DT);
+
+ Count := 0;
+ Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
+ while Count /= Index loop
+ Next_Elmt (Elmt);
+ Count := Count + 1;
+ end loop;
+
+ pragma Assert (Related_Type (Node (Elmt)) = Typ);
+
+ Get_External_Name
+ (Entity => Node (Elmt),
+ Has_Suffix => True);
+
+ Set_Interface_Name (DT,
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ -- Ensure proper Sprint output of this implicit importation
+
+ Set_Is_Internal (DT);
+ Set_Is_Public (DT);
+ end Export_DT;
+
+ -----------------------
+ -- Make_Secondary_DT --
+ -----------------------
+
+ procedure Make_Secondary_DT
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Suffix_Index : Int;
+ Num_Iface_Prims : Nat;
+ Iface_DT_Ptr : Entity_Id;
+ Predef_Prims_Ptr : Entity_Id;
+ Build_Thunks : Boolean;
+ Result : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Exporting_Table : constant Boolean :=
+ Building_Static_DT (Typ)
+ and then Suffix_Index > 0;
+ Iface_DT : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+ Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
+ Predef_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => 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 cases in which we do not generate statically allocated
+ -- dispatch tables.
+
+ if not Building_Static_DT (Typ) then
+ Set_Ekind (Predef_Prims, E_Variable);
+ Set_Ekind (Iface_DT, E_Variable);
+
+ -- 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;
+
+ -- Calculate the number of slots of the dispatch table. If the number
+ -- of primitives of Typ is 0 we reserve a dummy single entry for its
+ -- DT because at run-time the pointer to this dummy entry will be
+ -- used as the tag.
+
+ if Num_Iface_Prims = 0 then
+ Empty_DT := True;
+ Nb_Prim := 1;
+ else
+ Nb_Prim := Num_Iface_Prims;
+ end if;
+
+ -- Generate:
+
+ -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
+ -- (predef-prim-op-thunk-1'address,
+ -- predef-prim-op-thunk-2'address,
+ -- ...
+ -- predef-prim-op-thunk-n'address);
+ -- for Predef_Prims'Alignment use Address'Alignment
+
+ -- Stage 1: Calculate the number of predefined primitives
+
+ if not Building_Static_DT (Typ) 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;
+ Decl : Node_Id;
+ Thunk_Id : Entity_Id;
+ Thunk_Code : Node_Id;
+
+ begin
+ Prim_Ops_Aggr_List := New_List;
+ Prim_Table := (others => Empty);
+
+ if Building_Static_DT (Typ) then
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ and then not Present (Prim_Table
+ (UI_To_Int (DT_Position (Prim))))
+ then
+ if not Build_Thunks then
+ Prim_Table (UI_To_Int (DT_Position (Prim))) :=
+ Alias (Prim);
+
+ else
+ while Present (Alias (Prim)) loop
+ Prim := Alias (Prim);
+ end loop;
+
+ Expand_Interface_Thunk (Prim, Thunk_Id, 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;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ New_Node := Make_Null (Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+
+ New_Node :=
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List);
+
+ -- Remember aggregates initializing dispatch tables
+
+ Append_Elmt (New_Node, DT_Aggr);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Address_Array), Loc));
+
+ Append_To (Result, Decl);
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims,
+ Constant_Present => Building_Static_DT (Typ),
+ Aliased_Present => True,
+ Object_Definition => New_Reference_To
+ (Defining_Identifier (Decl), Loc),
+ Expression => New_Node));
+
+ 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 => <value>,
+ -- ...
+ -- N => <value>));
+
+ -- Iface_DT : Dispatch_Table (Nb_Prims) :=
+ -- ([ Signature => <sig-value> ],
+ -- Tag_Kind => <tag_kind-value>,
+ -- 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));
+ -- for Iface_DT'Alignment use Address'Alignment;
+
+ -- 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_Interfaces (Typ)
+ or else not Build_Thunks
+ or else not RTE_Record_Component_Available (RE_OSD_Table)
+ then
+ -- No OSD table required
+
+ Append_To (DT_Aggr_List,
+ New_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 (Interface_Alias (Prim))
+ and then Find_Dispatching_Type
+ (Interface_Alias (Prim)) = Iface
+ then
+ Prim_Alias := 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))))));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (OSD, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+
+ -- In secondary dispatch tables the Typeinfo component contains
+ -- the address of the Object Specific Data (see a-tags.ads)
+
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_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, Make_Null (Loc));
+
+ elsif Is_Abstract_Type (Typ)
+ or else not Building_Static_DT (Typ)
+ then
+ for J in 1 .. Nb_Prim loop
+ Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
+ end loop;
+
+ else
+ declare
+ 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 (Interface_Alias (Prim))
+ and then not Is_Abstract_Subprogram (Alias (Prim))
+ and then not Is_Imported (Alias (Prim))
+ and then Find_Dispatching_Type
+ (Interface_Alias (Prim)) = Iface
+
+ -- Generate the code of the thunk only if the abstract
+ -- interface type is not an immediate ancestor of
+ -- Tagged_Type; otherwise the DT associated with the
+ -- interface is the primary DT.
+
+ and then not Is_Ancestor (Iface, Typ)
+ then
+ if not Build_Thunks then
+ Pos :=
+ UI_To_Int (DT_Position (Interface_Alias (Prim)));
+ Prim_Table (Pos) := Alias (Prim);
+ else
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+
+ if Present (Thunk_Id) then
+ Pos :=
+ UI_To_Int (DT_Position (Interface_Alias (Prim)));
+
+ Prim_Table (Pos) := Thunk_Id;
+ Append_To (Result, Thunk_Code);
+ end if;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ New_Node := Make_Null (Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+ end;
+ end if;
+
+ New_Node :=
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List);
+
+ Append_To (DT_Aggr_List, New_Node);
+
+ -- Remember aggregates initializing dispatch tables
+
+ Append_Elmt (New_Node, DT_Aggr);
+
+ -- Note: Secondary dispatch tables cannot be declared constant
+ -- because the component Offset_To_Top is currently initialized
+ -- by the IP routine.
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_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)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Iface_DT, Loc),
+ Chars => Name_Alignment,
+
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+
+ if Exporting_Table then
+ Export_DT (Typ, Iface_DT, Suffix_Index);
+
+ -- Generate code to create the pointer to the dispatch table
+
+ -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
+
+ -- Note: This declaration is not added here if the table is exported
+ -- because in such case Make_Tags has already added this declaration.
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Interface_Tag), Loc),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_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 if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims_Ptr,
+ Constant_Present => True,
+
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc),
+
+ Expression =>
+ 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_Predef_Prims), Loc)),
+ Attribute_Name => Name_Address)));
+
+ -- Remember entities containing dispatch tables
+
+ Append_Elmt (Predef_Prims, DT_Decl);
+ Append_Elmt (Iface_DT, DT_Decl);
+ end Make_Secondary_DT;
+
+ -- Local variables
+
+ Elab_Code : constant List_Id := New_List;
+ Result : constant List_Id := New_List;
+ Tname : constant Name_Id := Chars (Typ);
+ AI : Elmt_Id;
+ AI_Tag_Elmt : Elmt_Id;
+ AI_Tag_Comp : Elmt_Id;
+ DT_Aggr_List : List_Id;
+ DT_Constr_List : List_Id;
+ DT_Ptr : Entity_Id;
+ ITable : Node_Id;
+ I_Depth : Nat := 0;
+ Iface_Table_Node : Node_Id;
+ Name_ITable : Name_Id;
+ Nb_Predef_Prims : Nat := 0;
+ Nb_Prim : Nat := 0;
+ New_Node : Node_Id;
+ Num_Ifaces : Nat := 0;
+ Parent_Typ : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Ops_Aggr_List : List_Id;
+ Suffix_Index : Int;
+ Typ_Comps : Elist_Id;
+ Typ_Ifaces : Elist_Id;
+ TSD_Aggr_List : List_Id;
+ TSD_Tags_List : List_Id;
+
+ -- The following name entries are used by Make_DT to generate a number
+ -- of entities related to a tagged type. These entities may be generated
+ -- in a scope other than that of the tagged type declaration, and if
+ -- the entities for two tagged types with the same name happen to be
+ -- generated in the same scope, we have to take care to use different
+ -- names. This is achieved by means of a unique serial number appended
+ -- to each generated entity name.
+
+ Name_DT : constant Name_Id :=
+ New_External_Name (Tname, 'T', Suffix_Index => -1);
+ Name_Exname : constant Name_Id :=
+ New_External_Name (Tname, 'E', Suffix_Index => -1);
+ Name_HT_Link : constant Name_Id :=
+ New_External_Name (Tname, 'H', Suffix_Index => -1);
+ Name_Predef_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'R', Suffix_Index => -1);
+ Name_SSD : constant Name_Id :=
+ New_External_Name (Tname, 'S', Suffix_Index => -1);
+ Name_TSD : constant Name_Id :=
+ New_External_Name (Tname, 'B', Suffix_Index => -1);
+
+ -- Entities built with above names
+
+ DT : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_DT);
+ Exname : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Exname);
+ HT_Link : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_HT_Link);
+ 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);
+
+ -- Start of processing for Make_DT
+
+ begin
+ pragma Assert (Is_Frozen (Typ));
+
+ -- Handle cases in which there is no need to build the dispatch table
+
+ if Has_Dispatch_Table (Typ)
+ or else No (Access_Disp_Table (Typ))
+ or else Is_CPP_Class (Typ)
+ then
+ return Result;
+
+ elsif No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Typ);
+ return Result;
+
+ elsif not RTE_Available (RE_Tag) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Node (First_Elmt
+ (Access_Disp_Table (Typ))),
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_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;
+
+ -- Ensure that the value of Max_Predef_Prims defined in a-tags is
+ -- correct. Valid values are 10 under configurable runtime or 16
+ -- with full runtime.
+
+ if RTE_Available (RE_Interface_Data) then
+ if Max_Predef_Prims /= 16 then
+ Error_Msg_N ("run-time library configuration error", Typ);
+ return Result;
+ end if;
+ else
+ if Max_Predef_Prims /= 10 then
+ Error_Msg_N ("run-time library configuration error", Typ);
+ Error_Msg_CRT ("tagged types", Typ);
+ return Result;
+ end if;
+ end if;
+
+ -- Initialize Parent_Typ handling private types
+
+ Parent_Typ := Etype (Typ);
+
+ if Present (Full_View (Parent_Typ)) then
+ Parent_Typ := Full_View (Parent_Typ);
+ end if;
+
+ -- Ensure that all the primitives are frozen. This is only required when
+ -- building static dispatch tables --- the primitives must be frozen to
+ -- be referenced (otherwise we have problems with the backend). It is
+ -- not a requirement with nonstatic dispatch tables because in this case
+ -- we generate now an empty dispatch table; the extra code required to
+ -- register the primitives in the slots will be generated later --- when
+ -- each primitive is frozen (see Freeze_Subprogram).
+
+ if Building_Static_DT (Typ)
+ and then not Is_CPP_Class (Typ)
+ then
+ declare
+ Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Frnodes : List_Id;
+
+ begin
+ Freezing_Library_Level_Tagged_Type := True;
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Frnodes := Freeze_Entity (Prim, Loc);
+
+ declare
+ F : Entity_Id;
+
+ begin
+ F := First_Formal (Prim);
+ while Present (F) loop
+ Check_Premature_Freezing (Prim, Etype (F));
+ Next_Formal (F);
+ end loop;
+
+ Check_Premature_Freezing (Prim, Etype (Prim));
+ end;
+
+ if Present (Frnodes) then
+ Append_List_To (Result, Frnodes);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ Freezing_Library_Level_Tagged_Type := Save;
+ end;
+ end if;
+
+ -- Ada 2005 (AI-251): Build the secondary dispatch tables
+
+ if Has_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
+
+ -- Each secondary dispatch table is assigned an unique positive
+ -- suffix index; such value also corresponds with the location of
+ -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
+
+ -- Note: This value must be kept sync with the Suffix_Index values
+ -- generated by Make_Tags
+
+ Suffix_Index := 1;
+ AI_Tag_Elmt :=
+ Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
+
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+
+ -- Build the secondary table containing pointers to thunks
+
+ Make_Secondary_DT
+ (Typ => Typ,
+ Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => Suffix_Index,
+ Num_Iface_Prims => UI_To_Int
+ (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Iface_DT_Ptr => Node (AI_Tag_Elmt),
+ Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
+ Build_Thunks => True,
+ Result => Result);
+
+ -- Skip secondary dispatch table and secondary dispatch table of
+ -- predefined primitives
+
+ Next_Elmt (AI_Tag_Elmt);
+ Next_Elmt (AI_Tag_Elmt);
+
+ -- Build the secondary table containing pointers to primitives
+ -- (used to give support to Generic Dispatching Constructors).
+
+ Make_Secondary_DT
+ (Typ => Typ,
+ Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => -1,
+ Num_Iface_Prims => UI_To_Int
+ (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Iface_DT_Ptr => Node (AI_Tag_Elmt),
+ Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
+ Build_Thunks => False,
+ Result => Result);
+
+ -- Skip secondary dispatch table and secondary dispatch table of
+ -- predefined primitives
+
+ Next_Elmt (AI_Tag_Elmt);
+ Next_Elmt (AI_Tag_Elmt);
+
+ Suffix_Index := Suffix_Index + 1;
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
+
+ -- Get the _tag entity and the number of primitives of its dispatch
+ -- table.
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+
+ Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_Statically_Allocated (Predef_Prims,
+ Is_Library_Level_Tagged_Type (Typ));
+
+ -- In case of locally defined tagged type we declare the object
+ -- containing the dispatch table by means of a variable. Its
+ -- initialization is done later by means of an assignment. This is
+ -- required to generate its External_Tag.
+
+ if not Building_Static_DT (Typ) then
+
+ -- Generate:
+ -- DT : No_Dispatch_Table_Wrapper;
+ -- for DT'Alignment use Address'Alignment;
+ -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
+
+ if not Has_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => False,
+ Object_Definition =>
+ New_Reference_To
+ (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+
+ -- Generate a SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
+ 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 (RTE (RE_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 the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
+ -- 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))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
+ 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 (RTE (RE_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))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), 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)))));
+
+ Set_Is_Statically_Allocated (Exname);
+ Set_Is_True_Constant (Exname);
+
+ -- Declare the object used by Ada.Tags.Register_Tag
+
+ if RTE_Available (RE_Register_Tag) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => HT_Link,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
+ end if;
+
+ -- Generate code to create the storage for the type specific data object
+ -- with enough space to store the tags of the ancestors plus the tags
+ -- of all the implemented interfaces (as described in a-tags.adb).
+
+ -- TSD : Type_Specific_Data (I_Depth) :=
+ -- (Idepth => I_Depth,
+ -- Access_Level => Type_Access_Level (Typ),
+ -- Expanded_Name => Cstring_Ptr!(Exname'Address))
+ -- External_Tag => Cstring_Ptr!(Exname'Address))
+ -- HT_Link => HT_Link'Address,
+ -- Transportable => <<boolean-value>>,
+ -- RC_Offset => <<integer-value>>,
+ -- [ Size_Func => Size_Prim'Access ]
+ -- [ Interfaces_Table => <<access-value>> ]
+ -- [ 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_Integer_Literal (Loc, I_Depth));
+
+ -- Access_Level
+
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
- 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;
+ -- Expanded_Name
- begin
- 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;
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address)));
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
+ -- External_Tag of a local tagged type
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ -- <typ>A : constant String :=
+ -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
- if Present (Conc_Typ) then
+ -- 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:
- -- Generate:
- -- I : Integer;
+ -- 1. It is hard to avoid a tasking race condition for entering the
+ -- entry into the hash table.
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ -- 2. It would cause a storage leak, unless we rig up considerable
+ -- mechanism to remove the entry from the hash table on exit.
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
- end if;
+ -- 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).
- -- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ -- 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 C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
+ -- We don't do this processing if an explicit external tag has been
+ -- specified. That's an odd case for which we have already issued a
+ -- warning, where we will not be able to compute the internal tag.
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
+ if not Is_Library_Level_Entity (Typ)
+ and then not Has_External_Tag_Rep_Clause (Typ)
+ then
+ declare
+ Exname : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Tname, 'A'));
- if Present (Conc_Typ) then
+ Full_Name : constant String_Id :=
+ Full_Qualified_Name (First_Subtype (Typ));
+ Str1_Id : String_Id;
+ Str2_Id : String_Id;
- -- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ begin
+ -- Generate:
+ -- Str1 = "Internal tag at 16#";
- -- I is the entry index and S is the dispatch table slot
+ Start_String;
+ Store_String_Chars ("Internal tag at 16#");
+ Str1_Id := End_String;
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ -- Generate:
+ -- Str2 = "#: <type-full-name>";
- if Ekind (Conc_Typ) = E_Protected_Type then
+ Start_String;
+ Store_String_Chars ("#: ");
+ Store_String_Chars (Full_Name);
+ Str2_Id := End_String;
-- Generate:
- -- Timed_Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ -- Exname : constant String :=
+ -- Str1 & Address_Image (Tag) & Str2;
+
+ if RTE_Available (RE_Address_Image) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_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_String_Literal (Loc, Str2_Id)))));
- -- 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.
+ 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_String_Literal (Loc, Str2_Id))));
+ end if;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address));
+ end;
- 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))),
+ -- External tag of a library-level tagged type: Check for a definition
+ -- of External_Tag. The clause is considered only if it applies to this
+ -- specific tagged type, as opposed to one of its ancestors.
+ -- If the type is an unconstrained type extension, we are building the
+ -- dispatch table of its anonymous base type, so the external tag, if
+ -- any was specified, must be retrieved from the first subtype. Go to
+ -- the full view in case the clause is in the private part.
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ else
+ declare
+ Def : constant Node_Id := Get_Attribute_Definition_Clause
+ (Underlying_Type (First_Subtype (Typ)),
+ Attribute_External_Tag);
- 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
+ Old_Val : String_Id;
+ New_Val : String_Id;
+ E : Entity_Id;
- else
- pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ begin
+ if not Present (Def)
+ or else Entity (Name (Def)) /= First_Subtype (Typ)
+ then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address));
+ else
+ Old_Val := Strval (Expr_Value_S (Expression (Def)));
- -- Generate:
- -- Timed_Task_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ -- For the rep clause "for <typ>'external_tag use y" generate:
- -- 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.
+ -- <typ>A : constant string := y;
+ --
+ -- <typ>A'Address is used to set the External_Tag component
+ -- of the TSD
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ -- Create a new nul terminated string if it is not already
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ 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;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ E := Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Typ), 'A'));
- 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;
+ 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;
- -- Implementation for limited tagged types
+ Append_To (TSD_Aggr_List, New_Node);
+ -- HT_Link
+
+ if RTE_Available (RE_Register_Tag) then
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (HT_Link, Loc),
+ Attribute_Name => Name_Address)));
else
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ New_Reference_To (RTE (RE_Null_Address), Loc)));
end if;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Timed_Select_Body;
+ -- Transportable: Set for types that can be used in remote calls
+ -- with respect to E.4(18) legality rules.
- ---------------------------------
- -- Make_Disp_Timed_Select_Spec --
- ---------------------------------
+ declare
+ Transportable : Entity_Id;
- 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
+ Transportable :=
+ Boolean_Literals
+ (Is_Pure (Typ)
+ or else Is_Shared_Passive (Typ)
+ or else
+ ((Is_Remote_Types (Typ)
+ or else Is_Remote_Call_Interface (Typ))
+ and then Original_View_In_Visible_Part (Typ))
+ or else not Comes_From_Source (Typ));
+
+ Append_To (TSD_Aggr_List,
+ New_Occurrence_Of (Transportable, Loc));
+ end;
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "D" - Delay
- -- "M" - Delay Mode
- -- "C" - Call kind
- -- "F" - Status flag
-
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
+ -- RC_Offset: These are the valid values and their meaning:
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uD),
- Parameter_Type =>
- New_Reference_To (Standard_Duration, Loc)));
+ -- >0: For simple types with controlled components is
+ -- type._record_controller'position
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uM),
- Parameter_Type =>
- New_Reference_To (Standard_Integer, Loc)));
+ -- 0: For types with no controlled components
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- -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.
- Set_Is_Internal (Def_Id);
+ -- -2: There are no controlled components at this level. We need to
+ -- get the position from the parent.
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Def_Id,
- Parameter_Specifications => Params);
- end Make_Disp_Timed_Select_Spec;
+ declare
+ RC_Offset_Node : Node_Id;
- -------------
- -- Make_DT --
- -------------
+ begin
+ if not Has_Controlled_Component (Typ) then
+ RC_Offset_Node := Make_Integer_Literal (Loc, 0);
- function Make_DT (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Result : constant List_Id := New_List;
- Elab_Code : constant List_Id := New_List;
-
- Tname : constant Name_Id := Chars (Typ);
- Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
- Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
- Name_SSD : constant Name_Id := New_External_Name (Tname, 'S');
- Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
- Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
- Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
-
- DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
- DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
- SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD);
- TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
- Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
- No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
-
- Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
- I_Depth : Int;
- Size_Expr_Node : Node_Id;
- Old_Tag1 : Node_Id;
- Old_Tag2 : Node_Id;
- Num_Ifaces : Int;
- Nb_Prim : Int;
- TSD_Num_Entries : Int;
- Typ_Copy : constant Entity_Id := New_Copy (Typ);
- AI : Elmt_Id;
+ elsif Etype (Typ) /= Typ
+ and then Has_Discriminants (Parent_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;
- begin
- if not RTE_Available (RE_Tag) then
- Error_Msg_CRT ("tagged types", Typ);
- return New_List;
- end if;
+ Append_To (TSD_Aggr_List, RC_Offset_Node);
+ end;
- -- Collect full list of directly and indirectly implemented interfaces
+ -- Size_Func
- Set_Parent (Typ_Copy, Parent (Typ));
- Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
- Collect_All_Interfaces (Typ_Copy);
+ if RTE_Record_Component_Available (RE_Size_Func) then
+ if not Building_Static_DT (Typ)
+ or else Is_Interface (Typ)
+ then
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Size_Ptr),
+ New_Reference_To (RTE (RE_Null_Address), Loc)));
- -- Calculate the size of the DT and the TSD
+ else
+ declare
+ Prim_Elmt : Elmt_Id;
+ Prim : Entity_Id;
- if Is_Interface (Typ) then
- -- Abstract interfaces need neither the DT nor the ancestors table.
- -- We reserve a single entry for its DT because at run-time the
- -- pointer to this dummy DT is the tag of this abstract interface
- -- type.
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- Nb_Prim := 1;
- TSD_Num_Entries := 0;
+ if Chars (Prim) = Name_uSize then
+ while Present (Alias (Prim)) loop
+ Prim := Alias (Prim);
+ end loop;
- else
- -- Calculate the number of entries for the table of interfaces
+ if Is_Abstract_Subprogram (Prim) then
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Size_Ptr),
+ New_Reference_To (RTE (RE_Null_Address), Loc)));
+ else
+ Append_To (TSD_Aggr_List,
+ Unchecked_Convert_To (RTE (RE_Size_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
+
+ exit;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ -- Interfaces_Table (required for AI-405)
+
+ if RTE_Record_Component_Available (RE_Interfaces_Table) then
+
+ -- Count the number of interface types implemented by Typ
- Num_Ifaces := 0;
- AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
+ Collect_Interfaces (Typ, Typ_Ifaces);
+
+ AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
- -- Count ancestors to compute the inheritance depth. For private
- -- extensions, always go to the full view in order to compute the
- -- real inheritance depth.
+ if Num_Ifaces = 0 then
+ Iface_Table_Node := Make_Null (Loc);
- declare
- Parent_Type : Entity_Id := Typ;
- P : Entity_Id;
+ -- Generate the Interface_Table object
- begin
- I_Depth := 0;
- loop
- P := Etype (Parent_Type);
+ else
+ declare
+ TSD_Ifaces_List : constant List_Id := New_List;
+ Elmt : Elmt_Id;
+ Sec_DT_Tag : Node_Id;
- if Is_Private_Type (P) then
- P := Full_View (Base_Type (P));
- end if;
+ begin
+ AI := First_Elmt (Typ_Ifaces);
+ while Present (AI) loop
+ if Is_Ancestor (Node (AI), Typ) then
+ Sec_DT_Tag :=
+ New_Reference_To (DT_Ptr, Loc);
+ else
+ Elmt :=
+ Next_Elmt
+ (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
+ pragma Assert (Has_Thunks (Node (Elmt)));
+
+ while Ekind (Node (Elmt)) = E_Constant
+ and then not
+ Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
+ loop
+ pragma Assert (Has_Thunks (Node (Elmt)));
+ Next_Elmt (Elmt);
+ pragma Assert (Has_Thunks (Node (Elmt)));
+ Next_Elmt (Elmt);
+ pragma Assert (not Has_Thunks (Node (Elmt)));
+ Next_Elmt (Elmt);
+ pragma Assert (not Has_Thunks (Node (Elmt)));
+ Next_Elmt (Elmt);
+ end loop;
+
+ pragma Assert (Ekind (Node (Elmt)) = E_Constant
+ and then not
+ Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
+ Sec_DT_Tag :=
+ New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
+ Loc);
+ end if;
- exit when P = Parent_Type;
+ Append_To (TSD_Ifaces_List,
+ Make_Aggregate (Loc,
+ Expressions => New_List (
- I_Depth := I_Depth + 1;
- Parent_Type := P;
- end loop;
- end;
+ -- Iface_Tag
- TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
- Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
+ Loc)),
- -- If the number of primitives of Typ is less that the number of
- -- predefined primitives, we must reserve at least enough space
- -- for the predefined primitives.
+ -- Static_Offset_To_Top
- if Nb_Prim < Default_Prim_Op_Count then
- Nb_Prim := Default_Prim_Op_Count;
- end if;
- end if;
+ New_Reference_To (Standard_True, Loc),
- -- Dispatch table and related entities are allocated statically
+ -- Offset_To_Top_Value
- Set_Ekind (DT, E_Variable);
- Set_Is_Statically_Allocated (DT);
+ Make_Integer_Literal (Loc, 0),
- Set_Ekind (DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (DT_Ptr);
+ -- Offset_To_Top_Func
- Set_Ekind (SSD, E_Variable);
- Set_Is_Statically_Allocated (SSD);
+ Make_Null (Loc),
- Set_Ekind (TSD, E_Variable);
- Set_Is_Statically_Allocated (TSD);
+ -- Secondary_DT
- Set_Ekind (Exname, E_Variable);
- Set_Is_Statically_Allocated (Exname);
+ Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
- Set_Ekind (No_Reg, E_Variable);
- Set_Is_Statically_Allocated (No_Reg);
+ )));
- -- Generate code to create the storage for the Dispatch_Table object:
+ Next_Elmt (AI);
+ end loop;
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ Name_ITable := New_External_Name (Tname, 'I');
+ ITable := Make_Defining_Identifier (Loc, Name_ITable);
+ Set_Is_Statically_Allocated (ITable,
+ Is_Library_Level_Tagged_Type (Typ));
+
+ -- The table of interfaces is not constant; its slots are
+ -- filled at run-time by the IP routine using attribute
+ -- 'Position to know the location of the tag components
+ -- (and this attribute cannot be safely used before the
+ -- object is initialized).
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => ITable,
+ Aliased_Present => True,
+ Constant_Present => False,
+ 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,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces),
+ Make_Aggregate (Loc,
+ Expressions => TSD_Ifaces_List)))));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (ITable, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
- Size_Expr_Node :=
- Make_Op_Add (Loc,
- Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
- Right_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Nb_Prim)));
+ Iface_Table_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (ITable, Loc),
+ Attribute_Name => Name_Unchecked_Access);
+ end;
+ end if;
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To
- (RTE (RE_Storage_Array), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node))))));
+ Append_To (TSD_Aggr_List, Iface_Table_Node);
+ end if;
- 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)));
+ -- 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_DT (Typ)
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then Nb_Prim > 0
+ and then not Is_Abstract_Type (Typ)
+ and then not Is_Controlled (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => SSD,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Select_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Nb_Prim))))));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (SSD, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+
+ -- This table is initialized by Make_Select_Specific_Data_Table,
+ -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
- -- Initialize the signature of the interface tag. It is a sequence
- -- two bytes located in the header of the dispatch table.
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+ else
+ Append_To (TSD_Aggr_List, Make_Null (Loc));
+ end if;
+ end if;
- Append_To (Result,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, Uint_1))),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Storage_Element),
- New_Reference_To (RTE (RE_Valid_Signature), Loc))));
+ -- Initialize the table of ancestor tags. In case of interface types
+ -- this table is not needed.
- if not Is_Interface (Typ) then
+ TSD_Tags_List := New_List;
- -- The signature of a Primary Dispatch table is:
- -- (Valid_Signature, Primary_DT)
+ -- If we are not statically allocating the dispatch table then we must
+ -- fill position 0 with null because we still have not generated the
+ -- tag of Typ.
- Append_To (Result,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, Uint_2))),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Storage_Element),
- New_Reference_To (RTE (RE_Primary_DT), Loc))));
+ if not Building_Static_DT (Typ)
+ or else Is_Interface (Typ)
+ then
+ Append_To (TSD_Tags_List,
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc)));
- else
- -- The signature of an abstract interface is:
- -- (Valid_Signature, Abstract_Interface)
+ -- Otherwise we can safely reference the tag
- Append_To (Result,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, Uint_2))),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Storage_Element),
- New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
+ else
+ Append_To (TSD_Tags_List,
+ New_Reference_To (DT_Ptr, Loc));
end if;
- -- Generate code to create the pointer to the dispatch table
+ -- Fill the rest of the table with the tags of the ancestors
- -- DT_Ptr : Tag := Tag!(DT'Address);
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+ Pos : Nat;
- -- According to the C++ ABI, the base of the vtable is located after a
- -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
- -- down the pointer to the real base of the vtable
+ begin
+ Pos := 1;
+ Current_Typ := Typ;
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Generalized_Tag, Loc),
- Expression =>
- Unchecked_Convert_To (Generalized_Tag,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Attribute_Name => Name_Address)),
- Right_Opnd =>
- Make_DT_Access_Action (Typ,
- DT_Prologue_Size, No_List)))));
+ loop
+ Parent_Typ := Etype (Current_Typ);
- -- Generate code to define the boolean that controls registration, in
- -- order to avoid multiple registrations for tagged types defined in
- -- multiple-called scopes.
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
- 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)));
+ exit when Parent_Typ = Current_Typ;
- -- Set Access_Disp_Table field to be the dispatch table pointer
+ if Is_CPP_Class (Parent_Typ) then
- if not Present (Access_Disp_Table (Typ)) then
- Set_Access_Disp_Table (Typ, New_Elmt_List);
- end if;
+ -- The tags defined in the C++ side will be inherited when
+ -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
- Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+ Append_To (TSD_Tags_List,
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc)));
+ else
+ Append_To (TSD_Tags_List,
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
+ Loc));
+ end if;
- -- Generate code to create the storage for the type specific data object
- -- with enough space to store the tags of the ancestors plus the tags
- -- of all the implemented interfaces (as described in a-tags.adb).
+ Pos := Pos + 1;
+ Current_Typ := Parent_Typ;
+ end loop;
- -- TSD: Storage_Array
- -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
- -- for TSD'Alignment use Address'Alignment
+ pragma Assert (Pos = I_Depth + 1);
+ end;
+
+ Append_To (TSD_Aggr_List,
+ Make_Aggregate (Loc,
+ Expressions => TSD_Tags_List));
- Size_Expr_Node :=
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
- Right_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
- Right_Opnd =>
- Make_Integer_Literal (Loc, TSD_Num_Entries)));
+ -- Build the TSD object
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
+ Constant_Present => Building_Static_DT (Typ),
Object_Definition =>
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node))))));
+ 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,
+ Expressions => TSD_Aggr_List)));
+
+ Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- -- Generate code to put the Address of the TSD in the dispatch table
- -- Set_TSD (DT_Ptr, TSD);
+ -- Initialize or declare the dispatch table object
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_TSD,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (TSD, Loc),
- Attribute_Name => Name_Address))));
+ if not Has_DT (Typ) then
+ DT_Constr_List := New_List;
+ DT_Aggr_List := New_List;
- -- Generate:
- -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
+ -- Typeinfo
- if not Is_Interface (Typ) then
- Append_To (Elab_Code,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
- Make_Integer_Literal (Loc, Nb_Prim))));
- end if;
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Address);
- if Ada_Version >= Ada_05
- and then not Is_Interface (Typ)
- and then not Is_Abstract (Typ)
- and then not Is_Controlled (Typ)
- and then Implements_Interface (
- Typ => Typ,
- Kind => Any_Limited_Interface,
- Check_Parent => True)
- and then (Nb_Prim - Default_Prim_Op_Count) > 0
- then
- -- Generate the Select Specific Data table for tagged types that
- -- implement a synchronized interface. The size of the table is
- -- constrained by the number of non-predefined primitive operations.
+ 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));
- 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 - Default_Prim_Op_Count))))));
+ -- In case of locally defined tagged types we have already declared
+ -- and uninitialized object for the dispatch table, which is now
+ -- initialized by means of the following assignment:
- -- Set the pointer to the Select Specific Data table in the TSD
+ -- DT := (TSD'Address, 0);
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_SSD,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (SSD, Loc),
- Attribute_Name => Name_Address))));
- end if;
+ if not Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (DT, Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
- -- 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.
+ -- In case of library level tagged types we declare and export now
+ -- the constant object containing the dummy dispatch table. There
+ -- is no need to declare the tag here because it has been previously
+ -- declared by Make_Tags
- 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)))));
+ -- DT : aliased constant No_Dispatch_Table :=
+ -- (NDT_TSD => TSD'Address;
+ -- NDT_Prims_Ptr => 0);
+ -- for DT'Alignment use Address'Alignment;
- -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Expanded_Name,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
+ 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)));
- if not Is_Interface (Typ) then
- -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
+ Export_DT (Typ, DT);
+ end if;
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Access_Level,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
- end if;
+ -- Common case: Typ has a dispatch table
- if Typ = Etype (Typ)
- or else Is_CPP_Class (Etype (Typ))
- or else Is_Interface (Typ)
- then
- Old_Tag1 :=
- Unchecked_Convert_To (Generalized_Tag,
- Make_Integer_Literal (Loc, 0));
- Old_Tag2 :=
- Unchecked_Convert_To (Generalized_Tag,
- Make_Integer_Literal (Loc, 0));
+ -- Generate:
- 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;
+ -- 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 => <sig-value>,
+ -- Tag_Kind => <tag_kind-value>,
+ -- Predef_Prims => Predef_Prims'First'Address,
+ -- Offset_To_Top => 0,
+ -- TSD => TSD'Address;
+ -- Prims_Ptr => (prim-op-1'address,
+ -- prim-op-2'address,
+ -- ...
+ -- prim-op-n'address));
+ -- for DT'Alignment use Address'Alignment
- if Typ /= Etype (Typ)
- and then not Is_Interface (Typ)
- then
- -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
-
- if not Is_Interface (Etype (Typ)) then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Old_Tag1,
- Node2 => New_Reference_To (DT_Ptr, Loc),
- Node3 =>
- Make_Integer_Literal (Loc,
- DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
- end if;
+ else
+ declare
+ Pos : Nat;
- -- Inherit the secondary dispatch tables of the ancestor
+ begin
+ if not Building_Static_DT (Typ) then
+ Nb_Predef_Prims := Max_Predef_Prims;
- 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;
+ else
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- begin
- -- Climb to the ancestor (if any) handling private types
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Pos := UI_To_Int (DT_Position (Prim));
- if Present (Full_View (Etype (Typ))) then
- if Full_View (Etype (Typ)) /= Typ then
- Copy_Secondary_DTs (Full_View (Etype (Typ)));
+ if Pos > Nb_Predef_Prims then
+ Nb_Predef_Prims := Pos;
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);
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
- while Present (E)
- and then Present (Node (Sec_DT_Ancestor))
- loop
- if Is_Tag (E) and then Chars (E) /= Name_uTag then
- if not Is_Interface (Etype (Typ)) then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Ancestor),
- Loc)),
- Node2 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Typ), Loc)),
- Node3 => Make_Integer_Literal (Loc,
- DT_Entry_Count (E)))));
- end if;
+ declare
+ Prim_Table : array
+ (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ Decl : Node_Id;
+ E : Entity_Id;
- Next_Elmt (Sec_DT_Ancestor);
- Next_Elmt (Sec_DT_Typ);
- Next_Elmt (Iface);
- end if;
+ begin
+ Prim_Ops_Aggr_List := New_List;
- Next_Entity (E);
- end loop;
- end if;
- end Copy_Secondary_DTs;
+ Prim_Table := (others => Empty);
- begin
- if Present (Node (Sec_DT_Ancestor)) then
+ if Building_Static_DT (Typ) then
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ and then not 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;
- -- Handle private types
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
- if Present (Full_View (Typ)) then
- Copy_Secondary_DTs (Full_View (Typ));
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
else
- Copy_Secondary_DTs (Typ);
+ New_Node := Make_Null (Loc);
end if;
- end if;
- end;
- end if;
- end if;
- -- Generate:
- -- Inherit_TSD (parent'tag, DT_Ptr);
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_TSD,
- Args => New_List (
- Node1 => Old_Tag2,
- Node2 => New_Reference_To (DT_Ptr, Loc))));
+ New_Node :=
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Address_Array), Loc));
+
+ Append_To (Result, Decl);
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims,
+ Aliased_Present => True,
+ Constant_Present => Building_Static_DT (Typ),
+ Object_Definition => New_Reference_To
+ (Defining_Identifier (Decl), Loc),
+ Expression => New_Node));
+
+ -- Remember aggregates initializing dispatch tables
+
+ Append_Elmt (New_Node, DT_Aggr);
+
+ 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;
- -- For types with no controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, 0);
+ -- Stage 1: Initialize the discriminant and the record components
- -- For simple types with controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
+ DT_Constr_List := New_List;
+ DT_Aggr_List := New_List;
- -- For complex types with controlled components where the position
- -- of the record controller is not statically computable, if there are
- -- controlled components at this level, generate:
- -- Set_RC_Offset (DT_Ptr, -1);
- -- to indicate that the _controller field is right after the _parent
+ -- Num_Prims. If the tagged type has no primitives we add a dummy
+ -- slot whose address will be the tag of this type.
- -- Or if there are no controlled components at this level, generate:
- -- Set_RC_Offset (DT_Ptr, -2);
- -- to indicate that we need to get the position from the parent.
+ if Nb_Prim = 0 then
+ New_Node := Make_Integer_Literal (Loc, 1);
+ else
+ New_Node := Make_Integer_Literal (Loc, Nb_Prim);
+ end if;
- if not Is_Interface (Typ) then
- declare
- Position : Node_Id;
+ Append_To (DT_Constr_List, New_Node);
+ Append_To (DT_Aggr_List, New_Copy (New_Node));
- begin
- if not Has_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, 0);
+ -- Signature
- elsif Etype (Typ) /= Typ
- and then Has_Discriminants (Etype (Typ))
- then
- if Has_New_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, -1);
- else
- Position := Make_Integer_Literal (Loc, -2);
- end if;
- else
- Position :=
- 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 (Position);
- Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
- Set_Etype (Prefix (Prefix (Position)), Typ);
- Set_Etype (Selector_Name (Prefix (Position)),
- RTE (RE_Record_Controller));
- Set_Etype (Position, RTE (RE_Storage_Offset));
- end if;
+ if RTE_Record_Component_Available (RE_Signature) then
+ Append_To (DT_Aggr_List,
+ New_Reference_To (RTE (RE_Primary_DT), Loc));
+ end if;
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_RC_Offset,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => Position)));
- end;
+ -- Tag_Kind
- -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
- -- described in E.4 (18)
+ if RTE_Record_Component_Available (RE_Tag_Kind) then
+ Append_To (DT_Aggr_List, Tagged_Kind (Typ));
+ end if;
- declare
- Status : Entity_Id;
+ -- Predef_Prims
- begin
- Status :=
- 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 (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Remotely_Callable,
- Args => New_List (
- New_Occurrence_Of (DT_Ptr, Loc),
- New_Occurrence_Of (Status, Loc))));
- end;
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Predef_Prims, Loc),
+ Attribute_Name => Name_Address));
- -- Generate:
- -- Set_Offset_To_Top (DT_Ptr, 0);
+ -- Offset_To_Top
- Append_To (Elab_Code,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
- Make_Integer_Literal (Loc, Uint_0))));
- end if;
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
- -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
- -- Should be the external name not the qualified name???
+ -- Typeinfo
- if not Has_External_Tag_Rep_Clause (Typ) then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_External_Tag,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Address));
- -- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only.
+ -- Stage 2: Initialize the table of primitive operations
- -- Register_Tag (Dt_Ptr);
+ Prim_Ops_Aggr_List := New_List;
- -- Skip this if routine not available, or in No_Run_Time mode
- -- or Typ is an abstract interface type (because the table to
- -- register it is not available in the abstract type but in
- -- types implementing this interface)
+ if Nb_Prim = 0 then
+ Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
- if not No_Run_Time_Mode
- and then RTE_Available (RE_Register_Tag)
- and then Is_RTE (Generalized_Tag, RE_Tag)
- and then not Is_Interface (Typ)
- 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;
- end if;
+ elsif not Building_Static_DT (Typ) then
+ for J in 1 .. Nb_Prim loop
+ Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
+ end loop;
- -- Generate:
- -- if No_Reg then
- -- <elab_code>
- -- No_Reg := False;
- -- end if;
+ else
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ E : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
- Append_To (Elab_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (No_Reg, Loc),
- Expression => New_Reference_To (Standard_False, Loc)));
+ begin
+ Prim_Table := (others => Empty);
- Append_To (Result,
- Make_Implicit_If_Statement (Typ,
- Condition => New_Reference_To (No_Reg, Loc),
- Then_Statements => Elab_Code));
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- Ada 2005 (AI-251): Register the tag of the interfaces into
- -- the table of implemented interfaces and ...
+ -- Retrieve the ultimate alias of the primitive for proper
+ -- handling of renamings and eliminated primitives.
- if not Is_Interface (Typ)
- and then Present (Abstract_Interfaces (Typ_Copy))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
- then
- AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
- while Present (AI) loop
+ E := Ultimate_Alias (Prim);
- -- Generate:
- -- Register_Interface (DT_Ptr, Interface'Tag);
+ if Is_Imported (Prim)
+ or else Present (Interface_Alias (Prim))
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Eliminated (E)
+ then
+ null;
- Append_To (Result,
- Make_DT_Access_Action (Typ,
- Action => Register_Interface_Tag,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table (Node (AI)))),
- Loc))));
+ else
+ if not Is_Predefined_Dispatching_Operation (E)
+ and then not Is_Abstract_Subprogram (E)
+ and then not Present (Interface_Alias (E))
+ then
+ pragma Assert
+ (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
- Next_Elmt (AI);
- end loop;
- end if;
+ Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
+ end if;
+ end if;
- return Result;
- end Make_DT;
+ Next_Elmt (Prim_Elmt);
+ end loop;
- ---------------------------
- -- Make_DT_Access_Action --
- ---------------------------
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ New_Node := Make_Null (Loc);
+ end if;
- function Make_DT_Access_Action
- (Typ : Entity_Id;
- Action : DT_Access_Action;
- Args : List_Id) return Node_Id
- is
- Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
- Loc : Source_Ptr;
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+ end;
+ end if;
- begin
- if No (Args) then
+ New_Node :=
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List);
- -- This is a constant
+ Append_To (DT_Aggr_List, New_Node);
- return New_Reference_To (Action_Name, Sloc (Typ));
- end if;
+ -- Remember aggregates initializing dispatch tables
- pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
+ Append_Elmt (New_Node, DT_Aggr);
- Loc := Sloc (First (Args));
+ -- 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 Action_Is_Proc (Action) then
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
+ if not Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (DT, Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
- else
- return
- Make_Function_Call (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
- end if;
- end Make_DT_Access_Action;
+ -- In case of library level tagged types we declare now and export
+ -- the constant object containing the dispatch table.
- -----------------------
- -- Make_Secondary_DT --
- -----------------------
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_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 the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
- procedure Make_Secondary_DT
- (Typ : Entity_Id;
- Ancestor_Typ : Entity_Id;
- Suffix_Index : Int;
- Iface : Entity_Id;
- AI_Tag : Entity_Id;
- Acc_Disp_Tables : in out Elist_Id;
- Result : out List_Id)
- is
- Loc : constant Source_Ptr := Sloc (AI_Tag);
- Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
- Name_DT : constant Name_Id := New_Internal_Name ('T');
- Iface_DT : Node_Id;
- Iface_DT_Ptr : Node_Id;
- Name_DT_Ptr : Name_Id;
- Nb_Prim : Int;
- OSD : Entity_Id;
- Size_Expr_Node : Node_Id;
- Tname : Name_Id;
+ 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)));
- begin
- Result := New_List;
+ Export_DT (Typ, DT);
+ end if;
+ end if;
- -- Generate a unique external name associated with the secondary
- -- dispatch table. This external name will be used to declare an
- -- access to this secondary dispatch table, value that will be used
- -- for the elaboration of Typ's objects and also for the elaboration
- -- of objects of any derivation of Typ that do not override any
- -- primitive operation of Typ.
+ -- Initialize the table of ancestor tags if not building static
+ -- dispatch table
- Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);
+ if not Building_Static_DT (Typ)
+ and then not Is_Interface (Typ)
+ and then not Is_CPP_Class (Typ)
+ then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (TSD, Loc),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Tags_Table), Loc)),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 0))),
- Tname := Name_Find;
- Name_DT_Ptr := New_External_Name (Tname, "P");
- Iface_DT := Make_Defining_Identifier (Loc, Name_DT);
- Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
+ Expression =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
+ end if;
- -- Dispatch table and related entities are allocated statically
+ -- Inherit the dispatch tables of the parent. There is no need to
+ -- inherit anything from the parent when building static dispatch tables
+ -- because the whole dispatch table (including inherited primitives) has
+ -- been already built.
- Set_Ekind (Iface_DT, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT);
+ if Building_Static_DT (Typ) then
+ null;
- Set_Ekind (Iface_DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT_Ptr);
+ -- 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.
- -- Generate code to create the storage for the Dispatch_Table object.
- -- If the number of primitives of Typ is less that the number of
- -- predefined primitives, we must reserve at least enough space
- -- for the predefined primitives.
+ elsif Is_CPP_Class (Parent_Typ) then
+ null;
- Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
+ -- Otherwise we fill in the dispatch tables here
- if Nb_Prim < Default_Prim_Op_Count then
- Nb_Prim := Default_Prim_Op_Count;
- end if;
+ else
+ if Typ /= Parent_Typ
+ and then not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ then
+ -- Inherit the dispatch table
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
-
- Size_Expr_Node :=
- Make_Op_Add (Loc,
- Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
- DT_Prologue_Size,
- No_List),
- Right_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Etype (AI_Tag),
- DT_Entry_Size,
- No_List),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Nb_Prim)));
+ if not Is_Interface (Typ)
+ and then not Is_Interface (Parent_Typ)
+ and then not Is_CPP_Class (Parent_Typ)
+ then
+ declare
+ Nb_Prims : constant Int :=
+ UI_To_Int (DT_Entry_Count
+ (First_Tag_Component (Parent_Typ)));
- 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_Storage_Array), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node))))));
+ begin
+ Append_To (Elab_Code,
+ Build_Inherit_Predefined_Prims (Loc,
+ Old_Tag_Node =>
+ New_Reference_To
+ (Node
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Parent_Typ)))), Loc),
+ New_Tag_Node =>
+ New_Reference_To
+ (Node
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ)))), Loc)));
+
+ if Nb_Prims /= 0 then
+ Append_To (Elab_Code,
+ Build_Inherit_Prims (Loc,
+ Typ => Typ,
+ Old_Tag_Node =>
+ New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Parent_Typ))), Loc),
+ New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Num_Prims => Nb_Prims));
+ end if;
+ end;
+ end if;
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Reference_To (Iface_DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
+ -- Inherit the secondary dispatch tables of the ancestor
- -- Initialize the signature of the interface tag. It is a sequence of
- -- two bytes located in the header of the dispatch table. The signature
- -- of a Secondary Dispatch Table is (Valid_Signature, Secondary_DT).
+ if not Is_CPP_Class (Parent_Typ) then
+ declare
+ Sec_DT_Ancestor : Elmt_Id :=
+ Next_Elmt
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Parent_Typ))));
+ Sec_DT_Typ : Elmt_Id :=
+ Next_Elmt
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ))));
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id);
+ -- Local procedure required to climb through the ancestors
+ -- and copy the contents of all their secondary dispatch
+ -- tables.
+
+ ------------------------
+ -- Copy_Secondary_DTs --
+ ------------------------
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
+ Iface : Elmt_Id;
+
+ begin
+ -- Climb to the ancestor (if any) handling private types
+
+ if Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Copy_Secondary_DTs (Full_View (Etype (Typ)));
+ end if;
- Append_To (Result,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Iface_DT, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, Uint_1))),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Storage_Element),
- New_Reference_To (RTE (RE_Valid_Signature), Loc))));
+ elsif Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
- Append_To (Result,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Iface_DT, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, Uint_2))),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Storage_Element),
- New_Reference_To (RTE (RE_Secondary_DT), Loc))));
+ if Present (Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Interfaces (Typ))
+ then
+ Iface := First_Elmt (Interfaces (Typ));
+ E := First_Entity (Typ);
+ while Present (E)
+ and then Present (Node (Sec_DT_Ancestor))
+ and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
+ loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ declare
+ Num_Prims : constant Int :=
+ UI_To_Int (DT_Entry_Count (E));
+
+ begin
+ if not Is_Interface (Etype (Typ)) then
+
+ -- Inherit first secondary dispatch table
+
+ Append_To (Elab_Code,
+ Build_Inherit_Predefined_Prims (Loc,
+ Old_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (Next_Elmt (Sec_DT_Ancestor)),
+ Loc)),
+ New_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Next_Elmt (Sec_DT_Typ)),
+ Loc))));
+
+ if Num_Prims /= 0 then
+ Append_To (Elab_Code,
+ Build_Inherit_Prims (Loc,
+ Typ => Node (Iface),
+ Old_Tag_Node =>
+ Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_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 if;
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+
+ -- Skip the secondary dispatch table of
+ -- predefined primitives
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+
+ if not Is_Interface (Etype (Typ)) then
+
+ -- Inherit second secondary dispatch table
+
+ Append_To (Elab_Code,
+ Build_Inherit_Predefined_Prims (Loc,
+ Old_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (Next_Elmt (Sec_DT_Ancestor)),
+ Loc)),
+ New_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Next_Elmt (Sec_DT_Typ)),
+ Loc))));
+
+ if Num_Prims /= 0 then
+ Append_To (Elab_Code,
+ Build_Inherit_Prims (Loc,
+ Typ => Node (Iface),
+ Old_Tag_Node =>
+ Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_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 if;
+ end;
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+
+ -- Skip the secondary dispatch table of
+ -- predefined primitives
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+
+ Next_Elmt (Iface);
+ end if;
- -- Generate code to create the pointer to the dispatch table
+ 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
- -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+ 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;
- -- According to the C++ ABI, the base of the vtable is located
- -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
- -- Hence, move the pointer down to the real base of the vtable.
+ -- Generate code to register the Tag in the External_Tag hash table for
+ -- the pure Ada type only.
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Iface_DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Generalized_Tag, Loc),
- Expression =>
- Unchecked_Convert_To (Generalized_Tag,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Attribute_Name => Name_Address)),
- Right_Opnd =>
- Make_DT_Access_Action (Etype (AI_Tag),
- DT_Prologue_Size, No_List)))));
+ -- Register_Tag (Dt_Ptr);
- -- Note: Offset_To_Top will be initialized by the init subprogram
+ -- Skip this action in the following cases:
+ -- 1) if Register_Tag is not available.
+ -- 2) in No_Run_Time mode.
+ -- 3) if Typ is not defined at the library level (this is required
+ -- to avoid adding concurrency control to the hash table used
+ -- by the run-time to register the tags).
- -- Set Access_Disp_Table field to be the dispatch table pointer
+ if not No_Run_Time_Mode
+ and then Is_Library_Level_Entity (Typ)
+ 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;
- if not (Present (Acc_Disp_Tables)) then
- Acc_Disp_Tables := New_Elmt_List;
+ if not Is_Empty_List (Elab_Code) then
+ Append_List_To (Result, Elab_Code);
end if;
- Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
+ -- Populate the two auxiliary tables used for dispatching asynchronous,
+ -- conditional and timed selects for synchronized types that implement
+ -- a limited interface. Skip this step in Ravenscar profile or when
+ -- general dispatching is forbidden.
- -- Step 1: Generate an Object Specific Data (OSD) table
+ if Ada_Version >= Ada_05
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ Append_List_To (Result,
+ Make_Select_Specific_Data_Table (Typ));
+ end if;
- OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ -- Remember entities containing dispatch tables
- -- Generate:
- -- OSD : Ada.Tags.Object_Specific_Data
- -- (Nb_Prims - Default_Prim_Op_Count);
- -- where the constraint is used to allocate space for the
- -- non-predefined primitive operations only.
+ Append_Elmt (Predef_Prims, DT_Decl);
+ Append_Elmt (DT, DT_Decl);
- 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 - Default_Prim_Op_Count))))));
+ Analyze_List (Result, Suppress => All_Checks);
+ Set_Has_Dispatch_Table (Typ);
- -- Generate:
- -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
+ -- Mark entities containing dispatch tables. Required by the backend to
+ -- handle them properly.
- Append_To (Result,
- Make_DT_Access_Action (Typ,
- Action => Set_OSD,
- Args => New_List (
- New_Reference_To (Iface_DT_Ptr, Loc),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (OSD, Loc),
- Attribute_Name => Name_Address))));
-
- -- Offset table creation
-
- if not Is_Interface (Typ)
- and then not Is_Abstract (Typ)
- and then not Is_Controlled (Typ)
- and then Implements_Interface
- (Typ => Typ,
- Kind => Any_Limited_Interface,
- Check_Parent => True)
- and then (Nb_Prim - Default_Prim_Op_Count) > 0
- then
+ if not Is_Interface (Typ) then
declare
- Prim : Entity_Id;
- Prim_Alias : Entity_Id;
- Prim_Elmt : Elmt_Id;
+ Elmt : Elmt_Id;
begin
- -- Step 2: Populate the OSD table
+ -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
+ -- the decoration required by the backend
- Prim_Alias := Empty;
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
+ Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
- if Present (Abstract_Interface_Alias (Prim)) then
- Prim_Alias := Abstract_Interface_Alias (Prim);
- end if;
+ -- Object declarations
- if Present (Prim_Alias)
- and then Present (First_Entity (Prim_Alias))
- and then Etype (First_Entity (Prim_Alias)) = Iface
- then
- -- Generate:
- -- Ada.Tags.Set_Offset_Index (
- -- Iface_DT_Ptr, secondary_DT_Pos, primary_DT_pos);
-
- Append_To (Result,
- Make_DT_Access_Action (Iface,
- Action => Set_Offset_Index,
- Args => New_List (
- New_Reference_To (Iface_DT_Ptr, Loc),
- Make_Integer_Literal (Loc, DT_Position (Prim_Alias)),
- Make_Integer_Literal (Loc, DT_Position (Prim)))));
-
- Prim_Alias := Empty;
- end if;
+ Elmt := First_Elmt (DT_Decl);
+ while Present (Elmt) loop
+ Set_Is_Dispatch_Table_Entity (Node (Elmt));
+ pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
+ or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
+ Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
+ Next_Elmt (Elmt);
+ end loop;
- Next_Elmt (Prim_Elmt);
+ -- Aggregates initializing dispatch tables
+
+ Elmt := First_Elmt (DT_Aggr);
+ while Present (Elmt) loop
+ Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
+ Next_Elmt (Elmt);
end loop;
end;
end if;
- -- Generate:
- -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
-
- Append_To (Result,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Iface_DT_Ptr, Loc)),
- Make_Integer_Literal (Loc, Nb_Prim))));
-
- end Make_Secondary_DT;
+ return Result;
+ end Make_DT;
-------------------------------------
-- Make_Select_Specific_Data_Table --
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 : Int := 0;
+ 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;
-- 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 Present (Full_View (Conc_Typ)) then
+ Conc_Typ := Full_View (Conc_Typ);
+ end if;
+
if Ekind (Conc_Typ) = E_Protected_Type then
Decls := Visible_Declarations (Protected_Definition (
Parent (Conc_Typ)));
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
- if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
+ 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;
end loop;
declare
- Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count;
- Examined : Examined_Array (1 .. Examined_Size) := (others => False);
+ 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);
- Prim_Pos := DT_Position (Prim);
- pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size);
+ -- Look for primitive overriding an abstract interface subprogram
- if Examined (UI_To_Int (Prim_Pos)) then
- goto Continue;
- else
+ if Present (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;
- end if;
-
- -- The current primitive overrides an interface-level subprogram
-
- if Present (Abstract_Interface_Alias (Prim)) then
-- Set the primitive operation kind regardless of subprogram
-- type. Generate:
-- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
Append_To (Assignments,
- Make_DT_Access_Action (Typ,
- Action =>
- Set_Prim_Op_Kind,
- Args =>
- New_List (
- New_Reference_To (DT_Ptr, Loc),
- Make_Integer_Literal (Loc, Prim_Pos),
- Prim_Op_Kind (Prim, Typ))));
-
- -- Retrieve the root of the alias chain if one is present
-
- if Present (Alias (Prim)) then
- Prim_Als := Prim;
- while Present (Alias (Prim_Als)) loop
- Prim_Als := Alias (Prim_Als);
- end loop;
- else
- Prim_Als := Empty;
- end if;
+ 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 Present (Prim_Als)
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, <position>, <index>);
+ -- Ada.Tags.Set_Entry_Index
+ -- (DT_Ptr, <position>, <index>);
Append_To (Assignments,
- Make_DT_Access_Action (Typ,
- Action =>
- Set_Entry_Index,
- Args =>
- 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))))));
+ 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;
- <<Continue>>
-
Next_Elmt (Prim_Elmt);
end loop;
end;
return Assignments;
end Make_Select_Specific_Data_Table;
+ ---------------
+ -- Make_Tags --
+ ---------------
+
+ function Make_Tags (Typ : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Result : constant List_Id := New_List;
+
+ procedure Import_DT
+ (Tag_Typ : Entity_Id;
+ DT : Entity_Id;
+ Is_Secondary_DT : Boolean);
+ -- Import the dispatch table DT of tagged type Tag_Typ. Required to
+ -- generate forward references and statically allocate the table. For
+ -- primary dispatch tables that require no dispatch table generate:
+ -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
+ -- $pragma import (ada, DT);
+ -- Otherwise generate:
+ -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
+ -- $pragma import (ada, DT);
+
+ ---------------
+ -- Import_DT --
+ ---------------
+
+ procedure Import_DT
+ (Tag_Typ : Entity_Id;
+ DT : Entity_Id;
+ Is_Secondary_DT : Boolean)
+ is
+ DT_Constr_List : List_Id;
+ Nb_Prim : Nat;
+
+ begin
+ Set_Is_Imported (DT);
+ Set_Ekind (DT, E_Constant);
+ Set_Related_Type (DT, Typ);
+
+ -- The scope must be set now to call Get_External_Name
+
+ Set_Scope (DT, Current_Scope);
+
+ Get_External_Name (DT, True);
+ Set_Interface_Name (DT,
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ -- Ensure proper Sprint output of this implicit importation
+
+ Set_Is_Internal (DT);
+
+ -- Save this entity to allow Make_DT to generate its exportation
+
+ Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
+
+ -- No dispatch table required
+
+ if not Is_Secondary_DT
+ and then not Has_DT (Tag_Typ)
+ then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+
+ else
+ -- Calculate the number of primitives of the dispatch table and
+ -- the size of the Type_Specific_Data record.
+
+ Nb_Prim :=
+ UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
+
+ -- If the tagged type has no primitives we add a dummy slot
+ -- whose address will be the tag of this type.
+
+ if Nb_Prim = 0 then
+ DT_Constr_List :=
+ New_List (Make_Integer_Literal (Loc, 1));
+ else
+ DT_Constr_List :=
+ New_List (Make_Integer_Literal (Loc, Nb_Prim));
+ end if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => DT_Constr_List))));
+ end if;
+ end Import_DT;
+
+ -- Local variables
+
+ Tname : constant Name_Id := Chars (Typ);
+ AI_Tag_Comp : Elmt_Id;
+ DT : Node_Id := Empty;
+ DT_Ptr : Node_Id;
+ Predef_Prims_Ptr : Node_Id;
+ Iface_DT : Node_Id := Empty;
+ Iface_DT_Ptr : Node_Id;
+ New_Node : Node_Id;
+ Suffix_Index : Int;
+ Typ_Name : Name_Id;
+ Typ_Comps : Elist_Id;
+
+ -- Start of processing for Make_Tags
+
+ begin
+ -- 1) Generate the primary and secondary tag entities
+
+ -- Collect the components associated with secondary dispatch tables
+
+ if Has_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
+ end if;
+
+ -- 1) Generate the primary tag entities
+
+ -- Primary dispatch table containing user-defined primitives
+
+ DT_Ptr := Make_Defining_Identifier (Loc,
+ New_External_Name (Tname, 'P'));
+ Set_Etype (DT_Ptr, RTE (RE_Tag));
+
+ -- Primary dispatch table containing predefined primitives
+
+ Predef_Prims_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'Y'));
+ Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+
+ -- Import the forward declaration of the Dispatch Table wrapper record
+ -- (Make_DT will take care of its exportation)
+
+ if Building_Static_DT (Typ) then
+ Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+
+ DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'T'));
+
+ Import_DT (Typ, DT, Is_Secondary_DT => False);
+
+ if Has_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_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))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Attribute_Name => Name_Address)));
+
+ -- No dispatch table required
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_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 the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+ end if;
+
+ Set_Is_True_Constant (DT_Ptr);
+ Set_Is_Statically_Allocated (DT_Ptr);
+ end if;
+
+ pragma Assert (No (Access_Disp_Table (Typ)));
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
+ Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+ Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
+
+ -- 2) Generate the secondary tag entities
+
+ if Has_Interfaces (Typ) then
+
+ -- Note: The following value of Suffix_Index must be in sync with
+ -- the Suffix_Index values of secondary dispatch tables generated
+ -- by Make_DT.
+
+ Suffix_Index := 1;
+
+ -- 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_Type (Node (AI_Tag_Comp)), Suffix_Index);
+ Typ_Name := Name_Find;
+
+ if Building_Static_DT (Typ) then
+ Iface_DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name
+ (Typ_Name, 'T', Suffix_Index => -1));
+ Import_DT
+ (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+ DT => Iface_DT,
+ Is_Secondary_DT => True);
+ end if;
+
+ -- Secondary dispatch table referencing thunks to user-defined
+ -- primitives covered by this interface.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'P'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ if Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Interface_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_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 if;
+
+ -- Secondary dispatch table referencing thunks to predefined
+ -- primitives.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Y'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing user-defined primitives
+ -- covered by this interface.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'D'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing predefined primitives
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Z'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
+
+ -- 3) At the end of Access_Disp_Table, if the type has user-defined
+ -- primitives, we add the entity of an access type declaration that
+ -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
+ -- through the primary dispatch table.
+
+ if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
+ Analyze_List (Result);
+
+ -- Generate:
+ -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
+ -- type Typ_DT_Acc is access Typ_DT;
+
+ else
+ declare
+ Name_DT_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'G');
+ Name_DT_Prims_Acc : constant Name_Id :=
+ New_External_Name (Tname, 'H');
+ DT_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_DT_Prims);
+ DT_Prims_Acc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_DT_Prims_Acc);
+ begin
+ Append_To (Result,
+ Make_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_Prim_Ptr), 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));
+
+ -- Analyze the resulting list and suppress the generation of the
+ -- Init_Proc associated with the above array declaration because
+ -- this type is never used in object declarations. It is only used
+ -- to simplify the expansion associated with dispatching calls.
+
+ Analyze_List (Result);
+ Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+
+ -- Mark entity of dispatch table. Required by the back end to
+ -- handle them properly.
+
+ Set_Is_Dispatch_Table_Entity (DT_Prims);
+ end;
+ end if;
+
+ -- Mark entities of dispatch table. Required by the back end to
+ -- handle them properly.
+
+ if Present (DT) then
+ Set_Is_Dispatch_Table_Entity (DT);
+ Set_Is_Dispatch_Table_Entity (Etype (DT));
+ end if;
+
+ if Present (Iface_DT) then
+ Set_Is_Dispatch_Table_Entity (Iface_DT);
+ Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
+ end if;
+
+ Set_Ekind (DT_Ptr, E_Constant);
+ Set_Is_Tag (DT_Ptr);
+ Set_Related_Type (DT_Ptr, Typ);
+
+ return Result;
+ end Make_Tags;
+
+ ---------------
+ -- New_Value --
+ ---------------
+
+ function New_Value (From : Node_Id) return Node_Id is
+ Res : constant Node_Id := Duplicate_Subexpr (From);
+ begin
+ if Is_Access_Type (Etype (From)) then
+ return
+ Make_Explicit_Dereference (Sloc (From),
+ Prefix => Res);
+ else
+ return Res;
+ end if;
+ end New_Value;
+
-----------------------------------
-- Original_View_In_Visible_Part --
-----------------------------------
begin
-- The scope must be a package
- if Ekind (Scop) /= E_Package
- and then Ekind (Scop) /= E_Generic_Package
- then
+ if not Is_Package_Or_Generic_Package (Scop) then
return False;
end if;
is
Full_Typ : Entity_Id := Typ;
Loc : constant Source_Ptr := Sloc (Prim);
- Prim_Op : Entity_Id := 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;
Full_Typ := Corresponding_Concurrent_Type (Typ);
end if;
+ -- When a private tagged type is completed by a concurrent type,
+ -- retrieve the full view.
+
+ if Is_Private_Type (Full_Typ) then
+ Full_Typ := Full_View (Full_Typ);
+ end if;
+
if Ekind (Prim_Op) = E_Function then
-- Protected function
-- procedures (task body for instance).
else
- return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
- end if;
-
- -- Regular procedure
+ 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 --
+ ------------------------
+
+ function Register_Primitive
+ (Loc : Source_Ptr;
+ Prim : Entity_Id) return List_Id
+ is
+ DT_Ptr : Entity_Id;
+ Iface_Prim : Entity_Id;
+ Iface_Typ : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Iface_DT_Elmt : Elmt_Id;
+ L : constant List_Id := New_List;
+ Pos : Uint;
+ Tag : Entity_Id;
+ Tag_Typ : Entity_Id;
+ Thunk_Id : Entity_Id;
+ Thunk_Code : Node_Id;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ if not RTE_Available (RE_Tag) then
+ return L;
+ end if;
+
+ if not Present (Interface_Alias (Prim)) then
+ Tag_Typ := Scope (DTC_Entity (Prim));
+ Pos := DT_Position (Prim);
+ Tag := First_Tag_Component (Tag_Typ);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim)
+ then
+ DT_Ptr :=
+ Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
+
+ Append_To (L,
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ -- Register copy of the pointer to the 'size primitive in the TSD
+
+ if Chars (Prim) = Name_uSize
+ and then RTE_Record_Component_Available (RE_Size_Func)
+ then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+ Append_To (L,
+ Build_Set_Size_Function (Loc,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Size_Func => Prim));
+ end if;
+
+ else
+ pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+ Append_To (L,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Tag_Typ,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
+
+ -- Ada 2005 (AI-251): Primitive associated with an interface type
+ -- Generate the code of the thunk only if the interface type is not an
+ -- immediate ancestor of Typ; otherwise the dispatch table associated
+ -- with the interface is the primary dispatch table and we have nothing
+ -- else to do here.
+
+ else
+ Tag_Typ := Find_Dispatching_Type (Alias (Prim));
+ Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
+
+ pragma Assert (Is_Interface (Iface_Typ));
+
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+
+ if not Is_Ancestor (Iface_Typ, Tag_Typ)
+ and then Present (Thunk_Code)
+ then
+ -- Generate the code necessary to fill the appropriate entry of
+ -- the secondary dispatch table of Prim's controlling type with
+ -- Thunk_Id's address.
+
+ Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
+ Iface_DT_Ptr := Node (Iface_DT_Elmt);
+ pragma Assert (Has_Thunks (Iface_DT_Ptr));
+
+ Iface_Prim := Interface_Alias (Prim);
+ Pos := DT_Position (Iface_Prim);
+ Tag := First_Tag_Component (Iface_Typ);
+
+ Prepend_To (L, Thunk_Code);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim)
+ then
+ Append_To (L,
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node =>
+ New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ Next_Elmt (Iface_DT_Elmt);
+ Next_Elmt (Iface_DT_Elmt);
+ Iface_DT_Ptr := Node (Iface_DT_Elmt);
+ pragma Assert (not Has_Thunks (Iface_DT_Ptr));
+
+ Append_To (L,
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node =>
+ New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Alias (Prim), Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ else
+ pragma Assert (Pos /= Uint_0
+ and then Pos <= DT_Entry_Count (Tag));
+
+ Append_To (L,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Iface_Typ,
+ Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ Next_Elmt (Iface_DT_Elmt);
+ Next_Elmt (Iface_DT_Elmt);
+ Iface_DT_Ptr := Node (Iface_DT_Elmt);
+ pragma Assert (not Has_Thunks (Iface_DT_Ptr));
+
+ Append_To (L,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Iface_Typ,
+ Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Alias (Prim), Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
- else
- return New_Reference_To (RTE (RE_POK_Procedure), Loc);
+ end if;
end if;
end if;
- end Prim_Op_Kind;
+
+ return L;
+ end Register_Primitive;
-------------------------
-- Set_All_DT_Position --
-------------------------
procedure Set_All_DT_Position (Typ : Entity_Id) is
- Parent_Typ : constant Entity_Id := Etype (Typ);
- Root_Typ : constant Entity_Id := Root_Type (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 : Int;
- DT_Length : Int;
- Nb_Prim : Int;
- Parent_EC : Int;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
procedure Validate_Position (Prim : Entity_Id);
- -- Check that the position assignated to Prim is completely safe
+ -- Check that the position assigned to Prim is completely safe
-- (it has not been assigned to a previously defined primitive
-- operation of Typ)
-----------------------
procedure Validate_Position (Prim : Entity_Id) is
- Prim_Elmt : Elmt_Id;
+ Op_Elmt : Elmt_Id;
+ Op : Entity_Id;
begin
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt)
- and then Node (Prim_Elmt) /= Prim
- loop
+ -- 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
- if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
+ elsif Present (Interface_Alias (Op)) then
null;
- -- Predefined dispatching operations are completely safe.
- -- They are allocated at fixed positions.
+ -- Predefined dispatching operations are completely safe. They
+ -- are allocated at fixed positions in a separate table.
- elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
+ elsif Is_Predefined_Dispatching_Operation (Op)
+ or else Is_Predefined_Dispatching_Alias (Op)
+ then
null;
-- Aliased subprograms are safe
- elsif Present (Alias (Prim)) then
+ elsif Present (Alias (Op)) then
null;
- elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
+ 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
Op_2 : Entity_Id;
begin
- Op_1 := Node (Prim_Elmt);
+ Op_1 := Op;
loop
if Present (Overridden_Operation (Op_1)) then
Op_1 := Overridden_Operation (Op_1);
end;
end if;
- Next_Elmt (Prim_Elmt);
+ Next_Elmt (Op_Elmt);
end loop;
end Validate_Position;
- -- Start of processing for Set_All_DT_Position
+ -- Local variables
- begin
- -- Get Entry_Count of the parent
+ 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);
- if Parent_Typ /= Typ
- and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
- then
- Parent_EC := UI_To_Int (DT_Entry_Count
- (First_Tag_Component (Parent_Typ)));
- else
- Parent_EC := 0;
- end if;
+ Adjusted : Boolean := False;
+ Finalized : Boolean := False;
- -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
- -- give a coherent set of information
+ Count_Prim : Nat;
+ DT_Length : Nat;
+ Nb_Prim : Nat;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
- if Is_CPP_Class (Root_Typ) then
+ -- Start of processing for Set_All_DT_Position
- -- Compute the number of primitive operations in the main Vtable
- -- Set their position:
- -- - where it was set if overriden or inherited
- -- - after the end of the parent vtable otherwise
+ begin
+ pragma Assert (Present (First_Tag_Component (Typ)));
- Prim_Elmt := First_Prim;
- Nb_Prim := 0;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ -- Set the DT_Position for each primitive operation. Perform some sanity
+ -- checks to avoid building inconsistent dispatch tables.
- if not Is_CPP_Class (Typ) then
- Set_DTC_Entity (Prim, The_Tag);
+ -- 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.
- elsif Present (Alias (Prim)) then
- Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
- Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+ Prim_Elmt := First_Prim;
+ Count_Prim := 0;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
- Error_Msg_NE ("is a primitive operation of&," &
- " pragma Cpp_Virtual required", Prim, Typ);
- end if;
+ -- Predefined primitives have a separate dispatch table
- if DTC_Entity (Prim) = The_Tag then
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else
+ Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Count_Prim := Count_Prim + 1;
+ end if;
- -- Get the slot from the parent subprogram if any
+ Set_DTC_Entity_Value (Typ, Prim);
- declare
- H : Entity_Id;
+ -- Clear any previous value of the DT_Position attribute. In this
+ -- way we ensure that the final position of all the primitives is
+ -- established by the following stages of this algorithm.
- begin
- H := Homonym (Prim);
- while Present (H) loop
- if Present (DTC_Entity (H))
- and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
- then
- Set_DT_Position (Prim, DT_Position (H));
- exit;
- end if;
+ Set_DT_Position (Prim, No_Uint);
- H := Homonym (H);
- end loop;
- end;
+ Next_Elmt (Prim_Elmt);
+ end loop;
- -- Otherwise take the canonical slot after the end of the
- -- parent Vtable
+ declare
+ Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
+ (others => False);
- if DT_Position (Prim) = No_Uint then
- Nb_Prim := Nb_Prim + 1;
- Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
+ E : Entity_Id;
- elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
- Nb_Prim := Nb_Prim + 1;
- end if;
- end if;
+ 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.
- Next_Elmt (Prim_Elmt);
- end loop;
+ 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.
- -- Check that the declared size of the Vtable is bigger or equal
- -- than the number of primitive operations (if bigger it means that
- -- some of the c++ virtual functions were not imported, that is
- -- allowed).
+ ------------------------------------------
+ -- Handle_Inherited_Private_Subprograms --
+ ------------------------------------------
- if DT_Entry_Count (The_Tag) = No_Uint
- or else not Is_CPP_Class (Typ)
- then
- Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
+ 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;
- elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
- Error_Msg_N ("not enough room in the Vtable for all virtual"
- & " functions", The_Tag);
- end if;
+ begin
+ Op_List := Primitive_Operations (Typ);
- -- Check that Positions are not duplicate nor outside the range of
- -- the Vtable.
+ Op_Elmt := First_Elmt (Op_List);
+ while Present (Op_Elmt) loop
+ Prim_Op := Node (Op_Elmt);
- declare
- Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
- Pos : Int;
- Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
- (others => Empty);
+ -- Search primitives that are implicit operations with an
+ -- internal name whose parent operation has a normal name.
- begin
- Prim_Elmt := First_Prim;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ 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);
- if DTC_Entity (Prim) = The_Tag then
- Pos := UI_To_Int (DT_Position (Prim));
+ -- Check if the type has an explicit overriding for this
+ -- primitive.
- if Pos not in Prim_Pos_Table'Range then
- Error_Msg_N
- ("position not in range of virtual table", Prim);
+ 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)));
- elsif Present (Prim_Pos_Table (Pos)) then
- Error_Msg_NE ("cannot be at the same position in the"
- & " vtable than&", Prim, Prim_Pos_Table (Pos));
+ goto Next_Primitive;
+ end if;
- else
- Prim_Pos_Table (Pos) := Prim;
- end if;
+ Next_Elmt (Op_Elmt_2);
+ end loop;
end if;
- Next_Elmt (Prim_Elmt);
+ <<Next_Primitive>>
+ Next_Elmt (Op_Elmt);
end loop;
- end;
-
- -- Generate listing showing the contents of the dispatch tables
+ end Handle_Inherited_Private_Subprograms;
- if Debug_Flag_ZZ then
- Write_DT (Typ);
- end if;
+ --------------------
+ -- Set_Fixed_Prim --
+ --------------------
- -- For regular Ada tagged types, just set the DT_Position for
- -- each primitive operation. Perform some sanity checks to avoid
- -- to build completely inconsistant dispatch tables.
+ procedure Set_Fixed_Prim (Pos : Nat) is
+ begin
+ pragma Assert (Pos <= Count_Prim);
+ Fixed_Prim (Pos) := True;
+ exception
+ when Constraint_Error =>
+ raise Program_Error;
+ end Set_Fixed_Prim;
- -- Note that the _Size primitive is always set at position 1 in order
- -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
- -- in Ada.Tags).
+ 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;
- else
- -- 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.
+ -- Second stage: Register fixed entries
- Prim_Elmt := First_Prim;
- Count_Prim := 0;
+ Nb_Prim := 0;
+ Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
- Count_Prim := Count_Prim + 1;
- Prim := Node (Prim_Elmt);
-
- -- Ada 2005 (AI-251)
-
- if Present (Abstract_Interface_Alias (Prim))
- and then Is_Interface (Scope (DTC_Entity
- (Abstract_Interface_Alias (Prim))))
- then
- Set_DTC_Entity (Prim,
- Find_Interface_Tag
- (T => Typ,
- Iface => Scope (DTC_Entity
- (Abstract_Interface_Alias (Prim)))));
-
- else
- Set_DTC_Entity (Prim, The_Tag);
- end if;
-
- -- 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.
+ Prim := Node (Prim_Elmt);
- Set_DT_Position (Prim, No_Uint);
+ -- Predefined primitives have a separate table and all its
+ -- entries are at predefined fixed positions.
- Next_Elmt (Prim_Elmt);
- end loop;
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- declare
- Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
- Parent_EC + Count_Prim)
- of Boolean := (others => False);
+ elsif Is_Predefined_Dispatching_Alias (Prim) then
+ E := Alias (Prim);
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
- E : Entity_Id;
+ Set_DT_Position (Prim, Default_Prim_Op_Position (E));
- begin
- -- Second stage: Register fixed entries
+ -- Overriding primitives of ancestor abstract interfaces
- Nb_Prim := Default_Prim_Op_Count;
- Prim_Elmt := First_Prim;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ elsif Present (Interface_Alias (Prim))
+ and then Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ then
+ pragma Assert (DT_Position (Prim) = No_Uint
+ and then Present (DTC_Entity (Interface_Alias (Prim))));
- -- Predefined primitives have a fixed position in all the
- -- dispatch tables
-
- if Is_Predefined_Dispatching_Operation (Prim) then
- Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
-
- -- Overriding interface primitives of an ancestor
-
- elsif DT_Position (Prim) = No_Uint
- and then Present (Abstract_Interface_Alias (Prim))
- and then Present (DTC_Entity
- (Abstract_Interface_Alias (Prim)))
- and then DT_Position (Abstract_Interface_Alias (Prim))
- /= No_Uint
- and then Is_Inherited_Operation (Prim)
- and then Is_Ancestor (Scope
- (DTC_Entity
- (Abstract_Interface_Alias (Prim))),
- Typ)
- then
- Set_DT_Position (Prim,
- DT_Position (Abstract_Interface_Alias (Prim)));
- Set_DT_Position (Alias (Prim),
- DT_Position (Abstract_Interface_Alias (Prim)));
- Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
-
- -- Overriding primitives must use the same entry as the
- -- overriden primitive
-
- elsif DT_Position (Prim) = No_Uint
- and then Present (Alias (Prim))
- and then Present (DTC_Entity (Alias (Prim)))
- and then DT_Position (Alias (Prim)) /= No_Uint
- and then Is_Inherited_Operation (Prim)
- and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
- then
- E := Alias (Prim);
- while not (Present (DTC_Entity (E))
- or else DT_Position (E) = No_Uint)
- and then Present (Alias (E))
- loop
- E := Alias (E);
- end loop;
+ E := Interface_Alias (Prim);
+ Set_DT_Position (Prim, DT_Position (E));
- pragma Assert (Present (DTC_Entity (E))
- and then
- DT_Position (E) /= No_Uint);
+ 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)));
- Set_DT_Position (Prim, DT_Position (E));
- Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
+ -- Overriding primitives must use the same entry as the
+ -- overridden primitive.
- -- If this is not the last element in the chain continue
- -- traversing the chain. This is required to properly
- -- handling renamed primitives
+ elsif not Present (Interface_Alias (Prim))
+ and then Present (Alias (Prim))
+ and then Chars (Prim) = Chars (Alias (Prim))
+ and then Find_Dispatching_Type (Alias (Prim)) /= Typ
+ and then Is_Ancestor
+ (Find_Dispatching_Type (Alias (Prim)), Typ)
+ and then Present (DTC_Entity (Alias (Prim)))
+ then
+ E := Alias (Prim);
+ Set_DT_Position (Prim, DT_Position (E));
- while Present (Alias (E)) loop
- E := Alias (E);
- Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
- end loop;
+ 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.
+ Next_Elmt (Prim_Elmt);
+ end loop;
- Prim_Elmt := First_Prim;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ -- Third stage: Fix the position of all the new primitives
+ -- Entries associated with primitives covering interfaces
+ -- are handled in a latter round.
- -- Skip primitives previously set entries
+ Prim_Elmt := First_Prim;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- if DT_Position (Prim) /= No_Uint then
- null;
+ -- Skip primitives previously set entries
- elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
- null;
+ if DT_Position (Prim) /= No_Uint then
+ null;
- -- Primitives covering interface primitives are
- -- handled later
+ -- Primitives covering interface primitives are handled later
- elsif Present (Abstract_Interface_Alias (Prim)) then
- null;
+ elsif Present (Interface_Alias (Prim)) then
+ null;
- else
- -- Take the next available position in the DT
+ else
+ -- Take the next available position in the DT
- loop
- Nb_Prim := Nb_Prim + 1;
- exit when not Fixed_Prim (Nb_Prim);
- end loop;
+ 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));
- Fixed_Prim (Nb_Prim) := True;
- end if;
+ Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Set_Fixed_Prim (Nb_Prim);
+ end if;
- Next_Elmt (Prim_Elmt);
- end loop;
- end;
+ 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)
+ -- 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);
+ 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
- -- Check if this entry will be placed in the primary DT
+ if DT_Position (Prim) = No_Uint
+ and then Present (Interface_Alias (Prim))
+ then
+ pragma Assert (Present (Alias (Prim))
+ and then Find_Dispatching_Type (Alias (Prim)) = Typ);
- if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
- = RTE (RE_Tag)
- then
- pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
- Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+ -- Check if this entry will be placed in the primary DT
- -- Otherwise it will be placed in the secondary DT
+ if Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ then
+ pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
+ Set_DT_Position (Prim, DT_Position (Alias (Prim)));
- else
- pragma Assert
- (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
+ -- Otherwise it will be placed in the secondary DT
- Set_DT_Position (Prim,
- DT_Position (Abstract_Interface_Alias (Prim)));
- end if;
+ else
+ pragma Assert
+ (DT_Position (Interface_Alias (Prim)) /= No_Uint);
+ Set_DT_Position (Prim,
+ DT_Position (Interface_Alias (Prim)));
end if;
+ end if;
- Next_Elmt (Prim_Elmt);
- end loop;
+ 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.
+ -- 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;
+ 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.
+ -- 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);
+ 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
+ -- 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;
+ if DT_Position (Prim) = No_Uint then
+ raise Program_Error;
+ end if;
- -- Calculate real size of the dispatch table
+ -- Calculate real size of the dispatch table
- if UI_To_Int (DT_Position (Prim)) > DT_Length then
- DT_Length := UI_To_Int (DT_Position (Prim));
- end if;
+ 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 in the dispatch
- -- table is correct
+ -- Ensure that the assigned 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;
+ if Chars (Prim) = Name_Finalize then
+ Finalized := 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. Input is excluded
- -- because
+ if Chars (Prim) = Name_Adjust then
+ Adjusted := True;
+ end if;
- if Is_Abstract (Typ)
- and then Is_Abstract (Prim)
- and then Present (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)
+ -- 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): Primitives associated with interfaces are
+ -- excluded from this check because interfaces must be visible in
+ -- the public and private part (RM 7.3 (7.3/2))
+
+ if Is_Abstract_Type (Typ)
+ and then Is_Abstract_Subprogram (Prim)
+ and then Present (Alias (Prim))
+ and then not Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Prim)))
+ and then not Present (Interface_Alias (Prim))
+ and then Is_Derived_Type (Typ)
+ and then In_Private_Part (Current_Scope)
+ and then
+ List_Containing (Parent (Prim)) =
+ Private_Declarations
+ (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
- -- 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;
+ Error_Msg_NE
+ ("abstract inherited private operation&" &
+ " must be overridden (RM 3.9.3(10))",
+ Parent (Typ), Prim);
end if;
+ end if;
- Next_Elmt (Prim_Elmt);
- end loop;
+ Next_Elmt (Prim_Elmt);
+ end loop;
- -- Additional check
+ -- Additional check
- if Is_Controlled (Typ) then
- if not Finalized then
- Error_Msg_N
- ("controlled type has no explicit Finalize method?", Typ);
+ 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;
+ 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));
+ -- Set the final size of the Dispatch Table
- -- 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 should not fail)
+ Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
- -- This test fails compiling the partial view of a tagged type
- -- derived from an interface which defines the overriding subprogram
- -- in the private part. This needs further investigation???
+ -- The derived type must have at least as many components as its parent
+ -- (for root types Etype points to itself and the test cannot fail).
- if not Has_Private_Declaration (Typ) then
- pragma Assert (
- DT_Entry_Count (The_Tag) >=
- DT_Entry_Count (First_Tag_Component (Parent_Typ)));
- null;
- end if;
+ 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 --
- -----------------------------
+ --------------------------
+ -- Set_CPP_Constructors --
+ --------------------------
- procedure Set_Default_Constructor (Typ : Entity_Id) is
+ procedure Set_CPP_Constructors (Typ : Entity_Id) is
Loc : Source_Ptr;
Init : Entity_Id;
- Param : Entity_Id;
E : Entity_Id;
+ Found : Boolean := False;
+ P : Node_Id;
+ Parms : List_Id;
begin
- -- Look for the default constructor entity. For now only the
- -- default constructor has the flag Is_Constructor.
+ -- Look for the constructor entities
E := Next_Entity (Typ);
- while Present (E)
- and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
- loop
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ -- Create the init procedure
+
+ Found := True;
+ Loc := Sloc (E);
+ Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Discard_Node (
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Init,
+ Parameter_Specifications => Parms)));
+
+ 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);
+ end if;
+
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.
+ if not Found then
+ Set_Is_Abstract_Type (Typ);
+ end if;
+ end Set_CPP_Constructors;
+
+ --------------------------
+ -- Set_DTC_Entity_Value --
+ --------------------------
+
+ procedure Set_DTC_Entity_Value
+ (Tagged_Type : Entity_Id;
+ Prim : Entity_Id)
+ is
+ begin
+ if Present (Interface_Alias (Prim))
+ and then Is_Interface
+ (Find_Dispatching_Type (Interface_Alias (Prim)))
+ then
+ Set_DTC_Entity (Prim,
+ Find_Interface_Tag
+ (T => Tagged_Type,
+ Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
+ else
+ Set_DTC_Entity (Prim,
+ First_Tag_Component (Tagged_Type));
+ end if;
+ 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 Present (Full_View (Conc_Typ)) then
+ Conc_Typ := Full_View (Conc_Typ);
+ end if;
+
+ 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
- Set_Is_Abstract (Typ);
+ 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 Set_Default_Constructor;
+ end Tagged_Kind;
--------------
-- Write_DT --
-- 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)
+ if not (Typ <= Last_Node_Id)
or else not Is_Tagged_Type (Typ)
then
Write_Str ("wrong usage: Write_DT must be used with tagged types");
Write_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
Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
end if;
- if Present (Abstract_Interface_Alias (Prim)) then
+ if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
- Write_Name (Chars (Scope (DTC_Entity
- (Abstract_Interface_Alias (Prim)))));
+ Write_Name
+ (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');
- Write_Int (Int (Abstract_Interface_Alias (Prim)));
+ Write_Int (Int (Interface_Alias (Prim)));
end if;
Write_Str (")");
Write_Int (UI_To_Int (DT_Position (Prim)));
end if;
- if Is_Abstract (Prim) then
+ if Is_Abstract_Subprogram (Prim) then
Write_Str (" is abstract;");
+
+ -- Check if this is a null primitive
+
+ elsif Comes_From_Source (Prim)
+ and then Ekind (Prim) = E_Procedure
+ and then Null_Present (Parent (Prim))
+ then
+ Write_Str (" is null;");
+ end if;
+
+ if Is_Eliminated (Ultimate_Alias (Prim)) then
+ Write_Str (" (eliminated)");
end if;
Write_Eol;
OSDN Git Service
