-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
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_Disp; use Sem_Disp;
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_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,
- Get_Tagged_Kind => RE_Get_Tagged_Kind,
- 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_Interface_Table => RE_Set_Interface_Table,
- 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,
- Set_Tagged_Kind => RE_Set_Tagged_Kind,
- TSD_Entry_Size => RE_TSD_Entry_Size,
- TSD_Prologue_Size => RE_TSD_Prologue_Size);
+ (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_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address,
+ 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,
+ Get_Tagged_Kind => RE_Get_Tagged_Kind,
+ 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_Interface_Table => RE_Set_Interface_Table,
+ Set_Offset_Index => RE_Set_Offset_Index,
+ Set_OSD => RE_Set_OSD,
+ Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address,
+ 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_Signature => RE_Set_Signature,
+ Set_SSD => RE_Set_SSD,
+ Set_TSD => RE_Set_TSD,
+ Set_Tagged_Kind => RE_Set_Tagged_Kind,
+ 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_Prim_Op_Address => False,
- Get_Prim_Op_Kind => False,
- Get_RC_Offset => False,
- Get_Remotely_Callable => False,
- Get_Tagged_Kind => 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_Interface_Table => 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,
- Set_Tagged_Kind => True,
- TSD_Entry_Size => False,
- TSD_Prologue_Size => False);
+ (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_Predefined_Prim_Op_Address => False,
+ Get_Prim_Op_Address => False,
+ Get_Prim_Op_Kind => False,
+ Get_RC_Offset => False,
+ Get_Remotely_Callable => False,
+ Get_Tagged_Kind => 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_Interface_Table => True,
+ Set_Offset_Index => True,
+ Set_OSD => True,
+ Set_Predefined_Prim_Op_Address => True,
+ Set_Prim_Op_Address => True,
+ Set_Prim_Op_Kind => True,
+ Set_RC_Offset => True,
+ Set_Remotely_Callable => True,
+ Set_Signature => True,
+ Set_SSD => True,
+ Set_TSD => True,
+ Set_Tagged_Kind => 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_Prim_Op_Address => 2,
- Get_Prim_Op_Kind => 2,
- Get_RC_Offset => 1,
- Get_Remotely_Callable => 1,
- Get_Tagged_Kind => 1,
- Inherit_DT => 3,
- Inherit_TSD => 2,
- Register_Interface_Tag => 3,
- Register_Tag => 1,
- Set_Access_Level => 2,
- Set_Entry_Index => 3,
- Set_Expanded_Name => 2,
- Set_External_Tag => 2,
- Set_Interface_Table => 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,
- Set_Tagged_Kind => 2,
- TSD_Entry_Size => 0,
- TSD_Prologue_Size => 0);
+ (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_Predefined_Prim_Op_Address => 2,
+ Get_Prim_Op_Address => 2,
+ Get_Prim_Op_Kind => 2,
+ Get_RC_Offset => 1,
+ Get_Remotely_Callable => 1,
+ Get_Tagged_Kind => 1,
+ Inherit_DT => 3,
+ Inherit_TSD => 2,
+ Register_Interface_Tag => 3,
+ Register_Tag => 1,
+ Set_Access_Level => 2,
+ Set_Entry_Index => 3,
+ Set_Expanded_Name => 2,
+ Set_External_Tag => 2,
+ Set_Interface_Table => 2,
+ Set_Offset_Index => 3,
+ Set_OSD => 2,
+ Set_Predefined_Prim_Op_Address => 3,
+ Set_Prim_Op_Address => 3,
+ Set_Prim_Op_Kind => 3,
+ Set_RC_Offset => 2,
+ Set_Remotely_Callable => 2,
+ Set_Signature => 2,
+ Set_SSD => 2,
+ Set_TSD => 2,
+ Set_Tagged_Kind => 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;
+ 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.
Next_Elmt (Elmt);
end loop;
- if not Present (Elmt) then
+ if No (Elmt) then
Append_Elmt (Iface, Abstract_Interfaces (T));
end if;
end Add_Interface;
-- Default_Prim_Op_Position --
------------------------------
- function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
+ function Default_Prim_Op_Position (E : Entity_Id) return Uint is
TSS_Name : TSS_Name_Type;
- E : Entity_Id := Subp;
begin
- -- Handle overriden subprograms
-
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
-
Get_Name_String (Chars (E));
TSS_Name :=
TSS_Name_Type
-- Start of processing for Expand_Dispatching_Call
begin
+ Check_Restriction (No_Dispatching_Calls, Call_Node);
+
-- If this is an inherited operation that was overridden, the body
-- that is being called is its alias.
-- 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)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
then
CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
-- Generate the Tag checks when appropriate
New_Params := New_List;
-
Param := First_Actual (Call_Node);
while Present (Param) loop
-- 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);
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
- -- If the controlling argument is a value of type Ada.Tag then
- -- use it directly. Otherwise, the tag must be extracted from
- -- the controlling object.
+ -- If the controlling argument is a value of type Ada.Tag or an abstract
+ -- interface class-wide type then use it directly. Otherwise, the tag
+ -- must be extracted from the controlling object.
if Etype (Ctrl_Arg) = RTE (RE_Tag)
- or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
+ then
+ Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
+
+ -- Ada 2005 (AI-251): Abstract interface class-wide type
+
+ elsif Is_Interface (Etype (Ctrl_Arg))
+ and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
-- Generate:
-- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
- 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) then
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ,
+ Make_DT_Access_Action (Typ,
+ Action => Get_Predefined_Prim_Op_Address,
+ Args => New_List (
+
+ -- Vptr
- -- Vptr
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Controlling_Tag),
- Controlling_Tag,
+ -- Position
- -- Position
+ Make_Integer_Literal (Loc, DT_Position (Subp)))));
+
+ else
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ,
+ Make_DT_Access_Action (Typ,
+ Action => Get_Prim_Op_Address,
+ Args => New_List (
- Make_Integer_Literal (Loc, DT_Position (Subp)))));
+ -- Vptr
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Controlling_Tag),
+
+ -- Position
+
+ Make_Integer_Literal (Loc, DT_Position (Subp)))));
+ end if;
if Nkind (Call_Node) = N_Function_Call then
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 ("abstract interface types", N);
+ return;
+ end if;
+
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displace), Loc),
Set_Directly_Designated_Type (New_Itype,
Class_Wide_Type (Iface_Typ));
- Rewrite (N, Unchecked_Convert_To (New_Itype,
- Relocate_Node (N)));
+ Rewrite (N, Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (New_Itype,
+ Relocate_Node (N))));
+ Analyze (N);
end;
return;
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Expression (N)),
+ Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))))))));
Next_Formal (E);
end loop;
+ -- Give message if configurable run-time and Offset_To_Top unavailable
+
+ if not RTE_Available (RE_Offset_To_Top) then
+ Error_Msg_CRT ("abstract interface types", N);
+ return Empty;
+ end if;
+
if Ekind (First_Formal (Target)) = E_In_Parameter
and then Ekind (Etype (First_Formal (Target)))
= E_Anonymous_Access_Type
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To
- (Defining_Identifier (First (Formals)),
- Loc),
- Selector_Name => Make_Identifier (Loc,
- Name_uTag))))));
+ Unchecked_Convert_To
+ (RTE (RE_Address),
+ New_Reference_To
+ (Defining_Identifier (First (Formals)), Loc))))));
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
- Make_Selected_Component (Loc,
+ Make_Attribute_Reference (Loc,
Prefix => New_Reference_To
(Defining_Identifier (First (Formals)),
Loc),
- Selector_Name => Make_Identifier (Loc,
- Name_uTag))))));
+ Attribute_Name => Name_Address)))));
Decl_2 :=
Make_Object_Declaration (Loc,
Tag : constant Entity_Id := First_Tag_Component (Typ);
begin
- if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
- raise Program_Error;
- end if;
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
- 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
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return
+ Make_DT_Access_Action (Typ,
+ Action => Set_Predefined_Prim_Op_Address,
+ Args => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)), -- DTptr
+
+ Make_Integer_Literal (Loc, Pos), -- Position
+
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Address)));
+ else
+ pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
+
+ 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
- Make_Integer_Literal (Loc, Pos), -- Position
+ Make_Integer_Literal (Loc, Pos), -- Position
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Address)));
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Address)));
+ end if;
end Fill_DT_Entry;
-----------------------------
First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
begin
- if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
- raise Program_Error;
- end if;
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return
+ Make_DT_Access_Action (Typ,
+ Action => Set_Predefined_Prim_Op_Address,
+ Args => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
- 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_Integer_Literal (Loc, Pos), -- Position
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Address)));
+ else
+ pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Thunk_Id, Loc),
- Attribute_Name => Name_Address)));
+ 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 if;
end Fill_Secondary_DT_Entry;
---------------------------
-- No need to inherit primitives if we have an abstract interface
-- type or a concurrent type.
- if Is_Interface (Typ) or else Is_Concurrent_Record_Type (Typ) then
+ if Is_Interface (Typ)
+ or else Is_Concurrent_Record_Type (Typ)
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
return Result;
end if;
-- associated with predefined primitives.
-- Generate:
- -- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count);
+ -- Inherit_DT (T'Tag, Iface'Tag, 0);
Append_To (Result,
Make_DT_Access_Action (Typ,
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))));
+ Node3 => Make_Integer_Literal (Loc, Uint_0))));
Next_Elmt (AI);
end loop;
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
Params : constant List_Id := New_List;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
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
Params : constant List_Id := New_List;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
DT_Ptr : Entity_Id;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Params : constant List_Id := New_List;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "C" - Call kind
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
Name_uDisp_Get_Task_Id);
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
Set_Is_Internal (Def_Id);
return
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
Params : constant List_Id := New_List;
begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
TSD_Num_Entries : Int;
Ancestor_Copy : Entity_Id;
+ Empty_DT : Boolean := False;
Typ_Copy : Entity_Id;
begin
-- Calculate the size of the DT and the TSD
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 will be used as the tag of this abstract
-- interface type.
+ Empty_DT := True;
Nb_Prim := 1;
TSD_Num_Entries := 0;
Num_Ifaces := 0;
TSD_Num_Entries := I_Depth + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
- -- 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.
+ -- If the number of primitives of Typ is 0 (or we are compiling with
+ -- the No_Dispatching_Calls restriction) we reserve a dummy single
+ -- entry for its DT because at run-time the pointer to this dummy DT
+ -- will be used as the tag of this tagged type.
- if Nb_Prim < Default_Prim_Op_Count then
- Nb_Prim := Default_Prim_Op_Count;
+ if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then
+ Empty_DT := True;
+ Nb_Prim := 1;
end if;
end if;
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- -- Initialize the signature of the interface tag. It is a sequence
- -- two bytes located in the header of the dispatch table.
-
- 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))));
-
- if not Is_Interface (Typ) then
-
- -- The signature of a Primary Dispatch table is:
- -- (Valid_Signature, Primary_DT)
-
- 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))));
-
- else
- -- The signature of an abstract interface is:
- -- (Valid_Signature, Abstract_Interface)
-
- 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))));
- end if;
-
-- Generate code to create the pointer to the dispatch table
-- DT_Ptr : Tag := Tag!(DT'Address);
-- Set Access_Disp_Table field to be the dispatch table pointer
- if not Present (Access_Disp_Table (Typ)) then
+ if No (Access_Disp_Table (Typ)) then
Set_Access_Disp_Table (Typ, New_Elmt_List);
end if;
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
+ -- Generate:
+ -- Set_Signature (DT_Ptr, Value);
+
+ if Is_Interface (Typ) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Signature,
+ Args => New_List (
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
+
+ elsif RTE_Available (RE_Set_Signature) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Signature,
+ Args => New_List (
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ New_Reference_To (RTE (RE_Primary_DT), Loc))));
+ end if;
+
-- Generate code to put the Address of the TSD in the dispatch table
-- Set_TSD (DT_Ptr, TSD);
null;
elsif Num_Ifaces = 0 then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Interface_Table,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
- New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null
+ if RTE_Available (RE_Set_Interface_Table) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Interface_Table,
+ Args => New_List (
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null
+ end if;
-- Generate the Interface_Table object and set the access
-- component if the TSD to it.
- else
+ elsif RTE_Available (RE_Set_Interface_Table) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
- 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;
-
- if Ada_Version >= Ada_05
- and then not Is_Interface (Typ)
- and then not Is_Abstract (Typ)
- and then not Is_Controlled (Typ)
- then
- -- Generate:
- -- Set_Type_Kind (T'Tag, Type_Kind (Typ));
-
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Tagged_Kind,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
- Tagged_Kind (Typ)))); -- Value
-
- -- Generate the Select Specific Data table for synchronized
- -- types that implement a synchronized interface. The size
- -- of the table is constrained by the number of non-predefined
- -- primitive operations.
+ if RTE_Available (RE_Set_Num_Prim_Ops) then
+ if not Is_Interface (Typ) then
+ if Empty_DT 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, Uint_0))));
+ else
+ 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;
+ end if;
- if Is_Concurrent_Record_Type (Typ)
- and then Implements_Interface (
- Typ => Typ,
- Kind => Any_Limited_Interface,
- Check_Parent => True)
- and then (Nb_Prim - Default_Prim_Op_Count) > 0
+ 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 not Restriction_Active (No_Dispatching_Calls)
then
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => SSD,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (
- RTE (RE_Select_Specific_Data), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc,
- Nb_Prim - Default_Prim_Op_Count))))));
-
- -- Set the pointer to the Select Specific Data table in the TSD
+ -- Generate:
+ -- Set_Type_Kind (T'Tag, Type_Kind (Typ));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
- Action => Set_SSD,
+ Action => Set_Tagged_Kind,
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))));
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ Tagged_Kind (Typ)))); -- Value
+
+ -- Generate the Select Specific Data table for synchronized
+ -- types that implement a synchronized interface. The size
+ -- of the table is constrained by the number of non-predefined
+ -- primitive operations.
+
+ if not Empty_DT
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Implements_Interface (
+ Typ => Typ,
+ Kind => Any_Limited_Interface,
+ Check_Parent => True)
+ 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))))));
+
+ -- Set the pointer to the Select Specific Data table in the TSD
+
+ 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;
end if;
end if;
if Typ /= Etype (Typ)
and then not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
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)))))));
+ if Restriction_Active (No_Dispatching_Calls) 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, Uint_0))));
+ else
+ 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;
end if;
-- Inherit the secondary dispatch tables of the ancestor
- if not Is_CPP_Class (Etype (Typ)) then
+ if not Restriction_Active (No_Dispatching_Calls)
+ and then not Is_CPP_Class (Etype (Typ))
+ then
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
------------------------
procedure Copy_Secondary_DTs (Typ : Entity_Id) is
- E : Entity_Id;
- Iface : Elmt_Id;
+ E : Entity_Id;
+ Iface : Elmt_Id;
begin
-- Climb to the ancestor (if any) handling private types
then
Iface := First_Elmt (Abstract_Interfaces (Typ));
E := First_Entity (Typ);
-
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
loop
Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
- -- For types with no controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, 0);
+ if not Is_Interface (Typ) then
- -- For simple types with controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
+ -- For types with no controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, 0);
- -- 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
+ -- For simple types with controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
- -- 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.
+ -- 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
+
+ -- 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 not Is_Interface (Typ) then
declare
Position : Node_Id;
New_Occurrence_Of (Status, Loc))));
end;
- -- Generate:
- -- Set_Offset_To_Top (0, DT_Ptr, 0);
+ if RTE_Available (RE_Set_Offset_To_Top) then
+ -- Generate:
+ -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
- 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 (RTE (RE_Null_Address), Loc),
- New_Reference_To (DT_Ptr, Loc),
- Make_Integer_Literal (Loc, Uint_0))));
+ 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 (RTE (RE_Null_Address), Loc),
+ New_Reference_To (DT_Ptr, Loc),
+ New_Occurrence_Of (Standard_True, Loc),
+ Make_Integer_Literal (Loc, Uint_0),
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
+ end if;
end if;
-- Generate: Set_External_Tag (DT_Ptr, exname'Address);
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
- -- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only.
+ -- Generate code to register the Tag in the External_Tag hash
+ -- table for the pure Ada type only.
- -- Register_Tag (Dt_Ptr);
+ -- Register_Tag (Dt_Ptr);
- -- 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)
+ -- 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 not No_Run_Time_Mode
and then RTE_Available (RE_Register_Tag)
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');
+ Empty_DT : Boolean := False;
Iface_DT : Node_Id;
Iface_DT_Ptr : Node_Id;
Name_DT_Ptr : Name_Id;
Set_Is_Statically_Allocated (Iface_DT_Ptr);
-- 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.
+ -- If the number of primitives of Typ is 0 we reserve a dummy single
+ -- entry for its DT because at run-time the pointer to this dummy entry
+ -- will be used as the tag.
Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
- if Nb_Prim < Default_Prim_Op_Count then
- Nb_Prim := Default_Prim_Op_Count;
+ if Nb_Prim = 0 then
+ Empty_DT := True;
+ Nb_Prim := 1;
end if;
-- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- -- 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).
-
- 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))));
-
- 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))));
-
-- Generate code to create the pointer to the dispatch table
-- Iface_DT_Ptr : Tag := Tag!(DT'Address);
OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ -- Nothing to do if configurable run time does not support the
+ -- Object_Specific_Data entity.
+
+ if not RTE_Available (RE_Object_Specific_Data) then
+ Error_Msg_CRT ("abstract interface types", Typ);
+ return;
+ end if;
+
-- Generate:
- -- OSD : Ada.Tags.Object_Specific_Data
- -- (Nb_Prims - Default_Prim_Op_Count);
+ -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
-- where the constraint is used to allocate space for the
-- non-predefined primitive operations only.
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
- Make_Integer_Literal (Loc,
- Nb_Prim - Default_Prim_Op_Count + 1))))));
+ Make_Integer_Literal (Loc, Nb_Prim))))));
+
+ Append_To (Result,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Signature,
+ Args => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Iface_DT_Ptr, Loc)),
+ New_Reference_To (RTE (RE_Secondary_DT), Loc))));
-- Generate:
-- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
-- 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))));
+ if RTE_Available (RE_Set_Num_Prim_Ops) then
+ if Empty_DT then
+ 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, Uint_0))));
+ else
+ 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 if;
+ end if;
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 RTE_Available (RE_Set_Tagged_Kind)
+ and then not Restriction_Active (No_Dispatching_Calls)
then
-- Generate:
-- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));
New_Reference_To (Iface_DT_Ptr, Loc)),
Tagged_Kind (Typ)))); -- Value
- if Is_Concurrent_Record_Type (Typ)
+ if not Empty_DT
+ and then Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
- and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
declare
Prim : Entity_Id;
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 : Int := 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
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));
Prim := Node (Prim_Elmt);
Prim_Pos := DT_Position (Prim);
- pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size);
-
- if Examined (UI_To_Int (Prim_Pos)) then
- goto Continue;
- else
- 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>);
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
- 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;
+ if Examined (UI_To_Int (Prim_Pos)) then
+ goto Continue;
else
- Prim_Als := Empty;
+ Examined (UI_To_Int (Prim_Pos)) := True;
end if;
- -- In the case of an entry wrapper, set the entry index
+ -- The current primitive overrides an interface-level
+ -- subprogram
- 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
+ if Present (Abstract_Interface_Alias (Prim)) then
- -- Generate:
- -- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>);
+ -- 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_Entry_Index,
+ Set_Prim_Op_Kind,
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))))));
+ 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;
+
+ -- 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>);
+
+ 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))))));
+ end if;
end if;
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;
if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) 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
null;
end loop;
declare
- Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
- Parent_EC + Count_Prim)
+ Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim)
of Boolean := (others => False);
E : Entity_Id;
begin
-- Second stage: Register fixed entries
- Nb_Prim := Default_Prim_Op_Count;
+ Nb_Prim := 0;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- -- Predefined primitives have a fixed position in all the
- -- dispatch tables
+ -- Predefined primitives have a separate table and all its
+ -- entries are at predefined fixed positions
if Is_Predefined_Dispatching_Operation (Prim) then
Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
-- Overriding interface primitives of an ancestor
-- Skip primitives previously set entries
- if DT_Position (Prim) /= No_Uint then
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ null;
+
+ elsif DT_Position (Prim) /= No_Uint then
null;
elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
-- Calculate real size of the dispatch table
- if UI_To_Int (DT_Position (Prim)) > DT_Length then
+ if not Is_Predefined_Dispatching_Operation (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 asignated position to non-predefined
+ -- dispatching operations in the dispatch table is correct.
- Validate_Position (Prim);
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Validate_Position (Prim);
+ end if;
if Chars (Prim) = Name_Finalize then
Finalized := True;
Loc : constant Source_Ptr := Sloc (T);
begin
- pragma Assert (Is_Tagged_Type (T));
+ pragma Assert
+ (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
-- Abstract kinds
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
OSDN Git Service
