Skip to content

R
riscv-gcc-1
Commit 1923d2d6 by Javier Miranda Committed by Arnaud Charlet
Options

exp_disp.adb (Make_DT, [...]): Set attribute Is_Static_Dispatch_Table 

2008-03-26  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute
	Is_Static_Dispatch_Table
	(Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls
	to Exchange_Declarations to exchange the private and full-view. Bug
	found working in this issue.
	(Expand_Dispatching_Call): Propagate the convention of the subprogram
	to the subprogram pointer type.
	(Make_Secondary_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_Disp_*_Bodies): When compiling for a restricted profile, use
	simple call form for single entry.
	(Make_DT): Handle new contents of Access_Disp_Table (access to dispatch
	tables of predefined primitives).
	(Make_Secondary_DT): Add support to handle access to dispatch tables of
	predefined primitives.
	(Make_Tags): Add entities to Access_Dispatch_Table associated with
	access to dispatch tables containing predefined primitives.

	* exp_ch6.adb (N_Pragma): Chars field removed, use Chars
	(Pragma_Identifier (..  instead, adjustments throughout to accomodate
	this change.
	(Register_Predefined_DT_Entry): Updated to handle the new contents
	of attribute Access_Disp_Table (pointers to dispatch tables containing
	predefined primitives).

	* exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New
	subprogram.
	(Find_Interface_ADT): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* sem_util.adb (Has_Abstract_Interfaces): Add missing support for
	concurrent types.
	(Set_Convention): Use new function Is_Access_Subprogram_Type
	(Collect_Interfaces_Info): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve
	expanded code avoiding calls to Build_Predef_Prims.
	(Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding
	call to Build_Get_Predefined_Prim_Op_Address.

From-SVN: r133564
parent 50cff367
Showing with 849 additions and 424 deletions
gcc/ada/exp_atag.adb
...@@ -369,64 +369,32 @@ package body Exp_Atag is ...@@ -369,64 +369,32 @@ package body Exp_Atag is
New_Tag_Node : Node_Id) return Node_Id New_Tag_Node : Node_Id) return Node_Id
is is
begin begin
if RTE_Available (RE_DT) then return
return Make_Assignment_Statement (Loc,
Make_Assignment_Statement (Loc, Name =>
Name => Make_Slice (Loc,
Make_Slice (Loc, Prefix =>
Prefix => Make_Explicit_Dereference (Loc,
Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc, Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Prefix => New_Tag_Node)))),
Build_DT (Loc, New_Tag_Node), Discrete_Range => Make_Range (Loc,
Selector_Name => Make_Integer_Literal (Loc, Uint_1),
New_Reference_To New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Selected_Component (Loc,
Prefix =>
Build_DT (Loc, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound =>
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
else
return
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Build_Predef_Prims (Loc, New_Tag_Node)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
Expression => Expression =>
Make_Slice (Loc, Make_Slice (Loc,
Prefix => Prefix =>
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Build_Predef_Prims (Loc, Old_Tag_Node)), Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Discrete_Range => Make_Explicit_Dereference (Loc,
Make_Range (Loc, Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Low_Bound => Make_Integer_Literal (Loc, 1), Old_Tag_Node)))),
High_Bound => Discrete_Range =>
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); Make_Range (Loc,
end if; Make_Integer_Literal (Loc, 1),
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
end Build_Inherit_Predefined_Prims; end Build_Inherit_Predefined_Prims;
------------------------ ------------------------
...@@ -472,8 +440,15 @@ package body Exp_Atag is ...@@ -472,8 +440,15 @@ package body Exp_Atag is
begin begin
return return
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Build_Get_Predefined_Prim_Op_Address (Loc, Name =>
Tag_Node, Position), Make_Indexed_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
Expressions =>
New_List (Make_Integer_Literal (Loc, Position))),
Expression => Address_Node); Expression => Address_Node);
end Build_Set_Predefined_Prim_Op_Address; end Build_Set_Predefined_Prim_Op_Address;
......
gcc/ada/exp_atag.ads
...@@ -90,15 +90,16 @@ package Exp_Atag is ...@@ -90,15 +90,16 @@ package Exp_Atag is
-- Generates: TSD (Tag).Transportable; -- Generates: TSD (Tag).Transportable;
function Build_Inherit_Predefined_Prims function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr; (Loc : Source_Ptr;
Old_Tag_Node : Node_Id; Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id) return Node_Id; New_Tag_Node : Node_Id) return Node_Id;
-- Build code that inherits the predefined primitives of the parent. -- Build code that inherits the predefined primitives of the parent.
-- --
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
-- Predefined_DT (Old_T).D (All_Predefined_Prims); -- Predefined_DT (Old_T).D (All_Predefined_Prims);
-- --
-- Required to build the dispatch tables with the 3.4 backend. -- Required to build non-library level dispatch tables. Also required
-- when compiling without static dispatch tables support.
function Build_Inherit_Prims function Build_Inherit_Prims
(Loc : Source_Ptr; (Loc : Source_Ptr;
......
gcc/ada/exp_ch6.adb
...@@ -3388,7 +3388,7 @@ package body Exp_Ch6 is ...@@ -3388,7 +3388,7 @@ package body Exp_Ch6 is
-- not be posting warnings on the inlined body so it is unneeded. -- not be posting warnings on the inlined body so it is unneeded.
elsif Nkind (N) = N_Pragma elsif Nkind (N) = N_Pragma
and then Chars (N) = Name_Unreferenced and then Pragma_Name (N) = Name_Unreferenced
then then
Rewrite (N, Make_Null_Statement (Sloc (N))); Rewrite (N, Make_Null_Statement (Sloc (N)));
return OK; return OK;
...@@ -4756,14 +4756,14 @@ package body Exp_Ch6 is ...@@ -4756,14 +4756,14 @@ package body Exp_Ch6 is
return; return;
end if; end if;
-- Skip the first access-to-dispatch-table pointer since it leads -- Skip the first two access-to-dispatch-table pointers since they
-- to the primary dispatch table. We are only concerned with the -- leads to the primary dispatch table (predefined DT and user
-- secondary dispatch table pointers. Note that the access-to- -- defined DT). We are only concerned with the secondary dispatch
-- dispatch-table pointer corresponds to the first implemented -- table pointers. Note that the access-to- dispatch-table pointer
-- interface retrieved below. -- corresponds to the first implemented interface retrieved below.
Iface_DT_Ptr := Iface_DT_Ptr :=
Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))); Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
while Present (Iface_DT_Ptr) while Present (Iface_DT_Ptr)
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
...@@ -4776,23 +4776,41 @@ package body Exp_Ch6 is ...@@ -4776,23 +4776,41 @@ package body Exp_Ch6 is
Thunk_Code, Thunk_Code,
Build_Set_Predefined_Prim_Op_Address (Loc, Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc), Tag_Node =>
New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Position => DT_Position (Prim), Position => DT_Position (Prim),
Address_Node => Address_Node =>
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Thunk_Id, Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address)), Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))),
Build_Set_Predefined_Prim_Op_Address (Loc, Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To Tag_Node =>
(Node (Next_Elmt (Iface_DT_Ptr)), Loc), New_Reference_To
(Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
Loc),
Position => DT_Position (Prim), Position => DT_Position (Prim),
Address_Node => Address_Node =>
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Prim, Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address)))); Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
end if; end if;
-- Skip the tag of the predefined primitives dispatch table
Next_Elmt (Iface_DT_Ptr);
pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
-- Skip the tag of the no-thunks dispatch table
Next_Elmt (Iface_DT_Ptr);
pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
-- Skip the tag of the predefined primitives no-thunks dispatch
-- table
Next_Elmt (Iface_DT_Ptr); Next_Elmt (Iface_DT_Ptr);
pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
......
gcc/ada/exp_disp.adb
...@@ -46,6 +46,7 @@ with Rident; use Rident; ...@@ -46,6 +46,7 @@ with Rident; use Rident;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6; with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp; with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval; with Sem_Eval; use Sem_Eval;
...@@ -175,14 +176,14 @@ package body Exp_Disp is ...@@ -175,14 +176,14 @@ package body Exp_Disp is
/= E_Record_Subtype /= E_Record_Subtype
then then
declare declare
E1, E2 : Entity_Id; E1 : constant Entity_Id := Defining_Entity (D);
E2 : constant Entity_Id := Full_View (Defining_Entity (D));
begin begin
E1 := Defining_Entity (D); Exchange_Declarations (E1);
E2 := Full_View (Defining_Entity (D));
Exchange_Entities (E1, E2);
Insert_List_After_And_Analyze (Last (Target_List), Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (E1)); Make_DT (E1));
Exchange_Entities (E1, E2); Exchange_Declarations (E2);
end; end;
end if; end if;
...@@ -612,6 +613,7 @@ package body Exp_Disp is ...@@ -612,6 +613,7 @@ package body Exp_Disp is
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
-- If the controlling argument is a value of type Ada.Tag or an abstract -- 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 -- interface class-wide type then use it directly. Otherwise, the tag
...@@ -1531,6 +1533,7 @@ package body Exp_Disp is ...@@ -1531,6 +1533,7 @@ package body Exp_Disp is
Decls : constant List_Id := New_List; Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
...@@ -1593,46 +1596,78 @@ package body Exp_Disp is ...@@ -1593,46 +1596,78 @@ package body Exp_Disp is
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc))); New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Generate: -- Build T._object'Access for calls below
-- 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 are Obj_Ref :=
-- the wrapped parameters and B is the name of the communication Make_Attribute_Reference (Loc,
-- block. Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
Append_To (Stmts, case Corresponding_Runtime_Package (Conc_Typ) is
Make_Procedure_Call_Statement (Loc, when System_Tasking_Protected_Objects_Entries =>
Name =>
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'Access -- Generate:
Attribute_Name => -- Protected_Entry_Call
Name_Unchecked_Access, -- (T._object'Access, -- Object
Prefix => -- Protected_Entry_Index! (I), -- E
Make_Selected_Component (Loc, -- P, -- Uninterpreted_Data
Prefix => -- Asynchronous_Call, -- Mode
Make_Identifier (Loc, Name_uT), -- Bnn); -- Communication_Block
Selector_Name =>
Make_Identifier (Loc, Name_uObject))), -- 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 Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark => Subtype_Mark =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), New_Reference_To
Expression => (RTE (RE_Protected_Entry_Index), Loc),
Make_Identifier (Loc, Name_uI)), Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Asynchronous_Call New_Reference_To ( -- Asynchronous_Call
RTE (RE_Asynchronous_Call), Loc), 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);
New_Reference_To (Com_Block, Loc)))); -- comm block 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: -- Generate:
-- B := Dummy_Communication_Block (Bnn); -- B := Dummy_Communication_Block (Bnn);
...@@ -1660,7 +1695,7 @@ package body Exp_Disp is ...@@ -1660,7 +1695,7 @@ package body Exp_Disp is
-- Asynchronous_Call, -- Mode -- Asynchronous_Call, -- Mode
-- F); -- Rendezvous_Successful -- F); -- Rendezvous_Successful
-- where T is the task object, I is the entry index, P are the -- where T is the task object, I is the entry index, P is the
-- wrapped parameters and F is the status flag. -- wrapped parameters and F is the status flag.
Append_To (Stmts, Append_To (Stmts,
...@@ -1669,7 +1704,6 @@ package body Exp_Disp is ...@@ -1669,7 +1704,6 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Task_Entry_Call), Loc), New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Parameter_Associations =>
New_List ( New_List (
Make_Selected_Component (Loc, -- T._task_id Make_Selected_Component (Loc, -- T._task_id
Prefix => Prefix =>
Make_Identifier (Loc, Name_uT), Make_Identifier (Loc, Name_uT),
...@@ -1843,6 +1877,7 @@ package body Exp_Disp is ...@@ -1843,6 +1877,7 @@ package body Exp_Disp is
Conc_Typ : Entity_Id := Empty; Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List; Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
...@@ -1929,46 +1964,73 @@ package body Exp_Disp is ...@@ -1929,46 +1964,73 @@ package body Exp_Disp is
if Ekind (Conc_Typ) = E_Protected_Type then if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate: Obj_Ref := -- T._object'Access
-- Protected_Entry_Call Make_Attribute_Reference (Loc,
-- (T._object'Access, -- Object Attribute_Name => Name_Unchecked_Access,
-- Protected_Entry_Index! (I), -- E Prefix =>
-- P, -- Uninterpreted_Data Make_Selected_Component (Loc,
-- Conditional_Call, -- Mode Prefix => Make_Identifier (Loc, Name_uT),
-- Bnn); -- Block Selector_Name => Make_Identifier (Loc, Name_uObject)));
-- where T is the protected object, I is the entry index, P are case Corresponding_Runtime_Package (Conc_Typ) is
-- the wrapped parameters and Bnn is the name of the communication when System_Tasking_Protected_Objects_Entries =>
-- block. -- Generate:
Append_To (Stmts, -- Protected_Entry_Call
Make_Procedure_Call_Statement (Loc, -- (T._object'Access, -- Object
Name => -- Protected_Entry_Index! (I), -- E
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), -- P, -- Uninterpreted_Data
Parameter_Associations => -- Conditional_Call, -- Mode
New_List ( -- Bnn); -- Block
Make_Attribute_Reference (Loc, -- T._object'Access -- where T is the protected object, I is the entry index, P
Attribute_Name => -- are the wrapped parameters and Bnn is the name of the
Name_Unchecked_Access, -- communication block.
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index Append_To (Stmts,
Subtype_Mark => Make_Procedure_Call_Statement (Loc,
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), Name =>
Expression => New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Make_Identifier (Loc, Name_uI)), Parameter_Associations =>
New_List (
Obj_Ref,
Make_Identifier (Loc, Name_uP), -- parameter block Make_Unchecked_Type_Conversion (Loc, -- entry index
New_Reference_To ( -- Conditional_Call Subtype_Mark =>
RTE (RE_Conditional_Call), Loc), New_Reference_To
New_Reference_To ( -- Bnn (RTE (RE_Protected_Entry_Index), Loc),
Blk_Nam, 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: -- Generate:
-- F := not Cancelled (Bnn); -- F := not Cancelled (Bnn);
...@@ -2339,79 +2401,83 @@ package body Exp_Disp is ...@@ -2339,79 +2401,83 @@ package body Exp_Disp is
-- A); -- A);
-- end if; -- end if;
Append_To (Stmts, if Restriction_Active (No_Entry_Queue) then
Make_If_Statement (Loc, Append_To (Stmts, Make_Null_Statement (Loc));
Condition => else
Make_Identifier (Loc, Name_uF), Append_To (Stmts,
Make_If_Statement (Loc,
Then_Statements => Condition =>
New_List ( Make_Identifier (Loc, Name_uF),
-- 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 Then_Statements =>
Subtype_Mark => New_List (
New_Reference_To (
RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status -- Call to Requeue_Protected_Entry
Else_Statements => Make_Procedure_Call_Statement (Loc,
New_List ( 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)),
-- Call to Requeue_Task_To_Protected_Entry Make_Identifier (Loc, Name_uA)))), -- abort status
Make_Procedure_Call_Statement (Loc, Else_Statements =>
Name => New_List (
New_Reference_To (
RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- O._object'Acc -- Call to Requeue_Task_To_Protected_Entry
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 Make_Procedure_Call_Statement (Loc,
Subtype_Mark => Name =>
New_Reference_To ( New_Reference_To (
RTE (RE_Protected_Entry_Index), Loc), RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
Expression => Parameter_Associations =>
Make_Identifier (Loc, Name_uI)), 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 Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
else else
pragma Assert (Is_Task_Type (Conc_Typ)); pragma Assert (Is_Task_Type (Conc_Typ));
...@@ -2658,6 +2724,7 @@ package body Exp_Disp is ...@@ -2658,6 +2724,7 @@ package body Exp_Disp is
Conc_Typ : Entity_Id := Empty; Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List; Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
...@@ -2727,48 +2794,83 @@ package body Exp_Disp is ...@@ -2727,48 +2794,83 @@ package body Exp_Disp is
New_Reference_To (DT_Ptr, Loc)), New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS))))); Make_Identifier (Loc, Name_uS)))));
-- Protected case
if Ekind (Conc_Typ) = E_Protected_Type then if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate: -- Build T._object'Access
-- Timed_Protected_Entry_Call (
-- 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), -- Protected_Entry_Index! (I),
-- P, -- P, D, M, F);
-- D,
-- M,
-- F);
-- where T is the protected object, I is the entry index, P are -- 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 -- the wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag. -- mode and F is the status flag.
Append_To (Stmts, case Corresponding_Runtime_Package (Conc_Typ) is
Make_Procedure_Call_Statement (Loc, when System_Tasking_Protected_Objects_Entries =>
Name => Append_To (Stmts,
New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), Make_Procedure_Call_Statement (Loc,
Parameter_Associations => Name =>
New_List ( 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_Attribute_Reference (Loc, -- T._object'access Make_Identifier (Loc, Name_uP), -- parameter block
Attribute_Name => Make_Identifier (Loc, Name_uD), -- delay
Name_Unchecked_Access, Make_Identifier (Loc, Name_uM), -- delay mode
Prefix => Make_Identifier (Loc, Name_uF)))); -- status flag
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index when System_Tasking_Protected_Objects_Single_Entry =>
Subtype_Mark => -- Generate:
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block -- Timed_Protected_Single_Entry_Call
Make_Identifier (Loc, Name_uD), -- delay -- (T._object'access, P, D, M, F);
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag -- 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 else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type); pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
...@@ -2957,12 +3059,13 @@ package body Exp_Disp is ...@@ -2957,12 +3059,13 @@ package body Exp_Disp is
-- generate forward references and statically allocate the table. -- generate forward references and statically allocate the table.
procedure Make_Secondary_DT procedure Make_Secondary_DT
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
Num_Iface_Prims : Nat; Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id; Iface_DT_Ptr : Entity_Id;
Build_Thunks : Boolean; Predef_Prims_Ptr : Entity_Id;
Result : List_Id); Build_Thunks : Boolean;
Result : List_Id);
-- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
-- Table of Typ associated with Iface. Each abstract interface of Typ -- Table of Typ associated with Iface. Each abstract interface of Typ
-- has two secondary dispatch tables: one containing pointers to thunks -- has two secondary dispatch tables: one containing pointers to thunks
...@@ -3024,12 +3127,13 @@ package body Exp_Disp is ...@@ -3024,12 +3127,13 @@ package body Exp_Disp is
----------------------- -----------------------
procedure Make_Secondary_DT procedure Make_Secondary_DT
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
Num_Iface_Prims : Nat; Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id; Iface_DT_Ptr : Entity_Id;
Build_Thunks : Boolean; Predef_Prims_Ptr : Entity_Id;
Result : List_Id) Build_Thunks : Boolean;
Result : List_Id)
is is
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Name_DT : constant Name_Id := New_Internal_Name ('T'); Name_DT : constant Name_Id := New_Internal_Name ('T');
...@@ -3168,9 +3272,10 @@ package body Exp_Disp is ...@@ -3168,9 +3272,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then if Present (Prim_Table (J)) then
New_Node := New_Node :=
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Prim_Table (J), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address); Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else else
New_Node := New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc); New_Reference_To (RTE (RE_Null_Address), Loc);
...@@ -3451,9 +3556,10 @@ package body Exp_Disp is ...@@ -3451,9 +3556,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then if Present (Prim_Table (J)) then
New_Node := New_Node :=
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Prim_Table (J), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address); Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else else
New_Node := New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc); New_Reference_To (RTE (RE_Null_Address), Loc);
...@@ -3513,6 +3619,30 @@ package body Exp_Disp is ...@@ -3513,6 +3619,30 @@ package body Exp_Disp is
(RTE_Record_Component (RE_Prims_Ptr), Loc)), (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address)))); Attribute_Name => Name_Address))));
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)));
-- Mark entities containing library level static dispatch tables.
-- This attribute is later propagated to all the access-to-subprogram
-- itypes generated to fill the dispatch table slots (see exp_attr).
if Building_Static_DT (Typ) then
Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
Set_Is_Static_Dispatch_Table_Entity (Iface_DT);
end if;
end Make_Secondary_DT; end Make_Secondary_DT;
-- Local variables -- Local variables
...@@ -3535,10 +3665,7 @@ package body Exp_Disp is ...@@ -3535,10 +3665,7 @@ package body Exp_Disp is
Nb_Prim : Nat := 0; Nb_Prim : Nat := 0;
New_Node : Node_Id; New_Node : Node_Id;
No_Reg : Node_Id; No_Reg : Node_Id;
Null_Parent_Tag : Boolean := False;
Num_Ifaces : Nat := 0; Num_Ifaces : Nat := 0;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Prim : Entity_Id; Prim : Entity_Id;
Prim_Elmt : Elmt_Id; Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id; Prim_Ops_Aggr_List : List_Id;
...@@ -3686,7 +3813,8 @@ package body Exp_Disp is ...@@ -3686,7 +3813,8 @@ package body Exp_Disp is
Collect_Interface_Components (Typ, Typ_Comps); Collect_Interface_Components (Typ, Typ_Comps);
Suffix_Index := 0; Suffix_Index := 0;
AI_Tag_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); AI_Tag_Elmt :=
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
AI_Tag_Comp := First_Elmt (Typ_Comps); AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop while Present (AI_Tag_Comp) loop
...@@ -3699,10 +3827,15 @@ package body Exp_Disp is ...@@ -3699,10 +3827,15 @@ package body Exp_Disp is
Num_Iface_Prims => UI_To_Int Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))), (DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt), Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True, Build_Thunks => True,
Result => Result); Result => Result);
Next_Elmt (AI_Tag_Elmt); Next_Elmt (AI_Tag_Elmt);
-- Skip the secondary dispatch table of predefined primitives
Next_Elmt (AI_Tag_Elmt);
-- Build the secondary table containing pointers to primitives -- Build the secondary table containing pointers to primitives
-- (used to give support to Generic Dispatching Constructors). -- (used to give support to Generic Dispatching Constructors).
...@@ -3712,10 +3845,15 @@ package body Exp_Disp is ...@@ -3712,10 +3845,15 @@ package body Exp_Disp is
Num_Iface_Prims => UI_To_Int Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))), (DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt), Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => False, Build_Thunks => False,
Result => Result); Result => Result);
Next_Elmt (AI_Tag_Elmt); Next_Elmt (AI_Tag_Elmt);
-- Skip the secondary dispatch table of predefined primitives
Next_Elmt (AI_Tag_Elmt);
Suffix_Index := Suffix_Index + 1; Suffix_Index := Suffix_Index + 1;
Next_Elmt (AI_Tag_Comp); Next_Elmt (AI_Tag_Comp);
end loop; end loop;
...@@ -3850,6 +3988,23 @@ package body Exp_Disp is ...@@ -3850,6 +3988,23 @@ package body Exp_Disp is
New_Occurrence_Of New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)), (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address)))); Attribute_Name => Name_Address))));
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;
end if; end if;
...@@ -4245,7 +4400,9 @@ package body Exp_Disp is ...@@ -4245,7 +4400,9 @@ package body Exp_Disp is
Sec_DT_Tag := Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc); New_Reference_To (DT_Ptr, Loc);
else else
Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); Elmt :=
Next_Elmt
(Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
pragma Assert (Has_Thunks (Node (Elmt))); pragma Assert (Has_Thunks (Node (Elmt)));
while Ekind (Node (Elmt)) = E_Constant while Ekind (Node (Elmt)) = E_Constant
...@@ -4254,14 +4411,20 @@ package body Exp_Disp is ...@@ -4254,14 +4411,20 @@ package body Exp_Disp is
loop loop
pragma Assert (Has_Thunks (Node (Elmt))); pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (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))); pragma Assert (not Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
pragma Assert (Ekind (Node (Elmt)) = E_Constant pragma Assert (Ekind (Node (Elmt)) = E_Constant
and then not Has_Thunks (Node (Next_Elmt (Elmt)))); and then not
Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
Sec_DT_Tag := Sec_DT_Tag :=
New_Reference_To (Node (Next_Elmt (Elmt)), Loc); New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
Loc);
end if; end if;
Append_To (TSD_Ifaces_List, Append_To (TSD_Ifaces_List,
...@@ -4645,9 +4808,10 @@ package body Exp_Disp is ...@@ -4645,9 +4808,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then if Present (Prim_Table (J)) then
New_Node := New_Node :=
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Prim_Table (J), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address); Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
end if; end if;
...@@ -4787,9 +4951,10 @@ package body Exp_Disp is ...@@ -4787,9 +4951,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then if Present (Prim_Table (J)) then
New_Node := New_Node :=
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Prim_Table (J), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address); Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
end if; end if;
...@@ -4871,6 +5036,12 @@ package body Exp_Disp is ...@@ -4871,6 +5036,12 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if; end if;
-- Inherit the dispatch tables of the parent
-- There is no need to inherit anything from the parent when building
-- static dispatch tables because the whole dispatch table (including
-- inherited primitives) has been already built.
if Building_Static_DT (Typ) then if Building_Static_DT (Typ) then
null; null;
...@@ -4880,60 +5051,52 @@ package body Exp_Disp is ...@@ -4880,60 +5051,52 @@ package body Exp_Disp is
elsif Is_CPP_Class (Etype (Typ)) then elsif Is_CPP_Class (Etype (Typ)) then
null; null;
-- Otherwise we fill in the dispatch tables here -- Otherwise we fill in the dispatch tables here
else else
if Typ = Etype (Typ)
or else Is_CPP_Class (Etype (Typ))
or else Is_Interface (Typ)
then
Null_Parent_Tag := True;
Old_Tag1 :=
Unchecked_Convert_To (RTE (RE_Tag),
Make_Integer_Literal (Loc, 0));
Old_Tag2 :=
Unchecked_Convert_To (RTE (RE_Tag),
Make_Integer_Literal (Loc, 0));
else
Old_Tag1 :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
Old_Tag2 :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if;
if Typ /= Etype (Typ) if Typ /= Etype (Typ)
and then not Is_Interface (Typ) and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Dispatching_Calls)
then then
-- Inherit the dispatch table -- Inherit the dispatch table
if not Is_Interface (Etype (Typ)) then if not Is_Interface (Typ)
if not Null_Parent_Tag then and then not Is_Interface (Etype (Typ))
declare and then not Is_CPP_Class (Etype (Typ))
Nb_Prims : constant Int := then
UI_To_Int (DT_Entry_Count declare
(First_Tag_Component (Etype (Typ)))); Nb_Prims : constant Int :=
begin UI_To_Int (DT_Entry_Count
(First_Tag_Component (Etype (Typ))));
begin
Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc,
Old_Tag_Node =>
New_Reference_To
(Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (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, Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc, Build_Inherit_Prims (Loc,
Old_Tag_Node => Old_Tag1, Typ => Typ,
New_Tag_Node => Old_Tag_Node =>
New_Reference_To (DT_Ptr, Loc))); New_Reference_To
(Node
if Nb_Prims /= 0 then (First_Elmt
Append_To (Elab_Code, (Access_Disp_Table (Etype (Typ)))), Loc),
Build_Inherit_Prims (Loc, New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Typ => Typ, Num_Prims => Nb_Prims));
Old_Tag_Node => Old_Tag2, end if;
New_Tag_Node => New_Reference_To (DT_Ptr, Loc), end;
Num_Prims => Nb_Prims));
end if;
end;
end if;
end if; end if;
-- Inherit the secondary dispatch tables of the ancestor -- Inherit the secondary dispatch tables of the ancestor
...@@ -4942,12 +5105,14 @@ package body Exp_Disp is ...@@ -4942,12 +5105,14 @@ package body Exp_Disp is
declare declare
Sec_DT_Ancestor : Elmt_Id := Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt Next_Elmt
(Next_Elmt
(First_Elmt (First_Elmt
(Access_Disp_Table (Etype (Typ)))); (Access_Disp_Table (Etype (Typ)))));
Sec_DT_Typ : Elmt_Id := Sec_DT_Typ : Elmt_Id :=
Next_Elmt Next_Elmt
(First_Elmt (Next_Elmt
(Access_Disp_Table (Typ))); (First_Elmt
(Access_Disp_Table (Typ))));
procedure Copy_Secondary_DTs (Typ : Entity_Id); procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- Local procedure required to climb through the ancestors -- Local procedure required to climb through the ancestors
...@@ -4998,12 +5163,15 @@ package body Exp_Disp is ...@@ -4998,12 +5163,15 @@ package body Exp_Disp is
Build_Inherit_Predefined_Prims (Loc, Build_Inherit_Predefined_Prims (Loc,
Old_Tag_Node => Old_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Sec_DT_Ancestor), Loc)), (Node
(Next_Elmt (Sec_DT_Ancestor)),
Loc)),
New_Tag_Node => New_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Sec_DT_Typ), Loc)))); (Node (Next_Elmt (Sec_DT_Typ)),
Loc))));
if Num_Prims /= 0 then if Num_Prims /= 0 then
Append_To (Elab_Code, Append_To (Elab_Code,
...@@ -5027,6 +5195,12 @@ package body Exp_Disp is ...@@ -5027,6 +5195,12 @@ package body Exp_Disp is
Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ); 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 if not Is_Interface (Etype (Typ)) then
-- Inherit second secondary dispatch table -- Inherit second secondary dispatch table
...@@ -5036,11 +5210,14 @@ package body Exp_Disp is ...@@ -5036,11 +5210,14 @@ package body Exp_Disp is
Old_Tag_Node => Old_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Sec_DT_Ancestor), Loc)), (Node
(Next_Elmt (Sec_DT_Ancestor)),
Loc)),
New_Tag_Node => New_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Sec_DT_Typ), Loc)))); (Node (Next_Elmt (Sec_DT_Typ)),
Loc))));
if Num_Prims /= 0 then if Num_Prims /= 0 then
Append_To (Elab_Code, Append_To (Elab_Code,
...@@ -5064,6 +5241,13 @@ package body Exp_Disp is ...@@ -5064,6 +5241,13 @@ package body Exp_Disp is
Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ); 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); Next_Elmt (Iface);
end if; end if;
...@@ -5143,6 +5327,15 @@ package body Exp_Disp is ...@@ -5143,6 +5327,15 @@ package body Exp_Disp is
Make_Select_Specific_Data_Table (Typ)); Make_Select_Specific_Data_Table (Typ));
end if; end if;
-- Mark entities containing library level static dispatch tables. This
-- attribute is later propagated to all the access-to-subprogram itypes
-- generated to fill the dispatch table slots (see exp_attr).
if Building_Static_DT (Typ) then
Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
Set_Is_Static_Dispatch_Table_Entity (DT);
end if;
Analyze_List (Result, Suppress => All_Checks); Analyze_List (Result, Suppress => All_Checks);
Set_Has_Dispatch_Table (Typ); Set_Has_Dispatch_Table (Typ);
...@@ -5312,18 +5505,19 @@ package body Exp_Disp is ...@@ -5312,18 +5505,19 @@ package body Exp_Disp is
--------------- ---------------
function Make_Tags (Typ : Entity_Id) return List_Id is function Make_Tags (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Tname : constant Name_Id := Chars (Typ); Tname : constant Name_Id := Chars (Typ);
Result : constant List_Id := New_List; Result : constant List_Id := New_List;
AI_Tag_Comp : Elmt_Id; AI_Tag_Comp : Elmt_Id;
DT : Node_Id; DT : Node_Id;
DT_Constr_List : List_Id; DT_Constr_List : List_Id;
DT_Ptr : Node_Id; DT_Ptr : Node_Id;
Iface_DT_Ptr : Node_Id; Predef_Prims_Ptr : Node_Id;
Nb_Prim : Nat; Iface_DT_Ptr : Node_Id;
Suffix_Index : Int; Nb_Prim : Nat;
Typ_Name : Name_Id; Suffix_Index : Int;
Typ_Comps : Elist_Id; Typ_Name : Name_Id;
Typ_Comps : Elist_Id;
begin begin
-- 1) Generate the primary and secondary tag entities -- 1) Generate the primary and secondary tag entities
...@@ -5334,18 +5528,28 @@ package body Exp_Disp is ...@@ -5334,18 +5528,28 @@ package body Exp_Disp is
Collect_Interface_Components (Typ, Typ_Comps); Collect_Interface_Components (Typ, Typ_Comps);
end if; end if;
-- 1) Generate the primary tag entity -- 1) Generate the primary tag entities
-- Primary dispatch table containing user-defined primitives
DT_Ptr := Make_Defining_Identifier (Loc, DT_Ptr := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'P')); New_External_Name (Tname, 'P'));
Set_Etype (DT_Ptr, RTE (RE_Tag)); 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 -- Import the forward declaration of the Dispatch Table wrapper record
-- (Make_DT will take care of its exportation) -- (Make_DT will take care of its exportation)
if Building_Static_DT (Typ) then if Building_Static_DT (Typ) then
DT := Make_Defining_Identifier (Loc, DT :=
New_External_Name (Tname, 'T')); Make_Defining_Identifier (Loc,
Chars => New_External_Name (Tname, 'T'));
-- Generate: -- Generate:
-- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
...@@ -5371,6 +5575,7 @@ package body Exp_Disp is ...@@ -5371,6 +5575,7 @@ package body Exp_Disp is
Set_Dispatch_Table_Wrapper (Typ, DT); Set_Dispatch_Table_Wrapper (Typ, DT);
if Has_DT (Typ) then if Has_DT (Typ) then
-- Calculate the number of primitives of the dispatch table and -- Calculate the number of primitives of the dispatch table and
-- the size of the Type_Specific_Data record. -- the size of the Type_Specific_Data record.
...@@ -5415,6 +5620,22 @@ package body Exp_Disp is ...@@ -5415,6 +5620,22 @@ package body Exp_Disp is
(RTE_Record_Component (RE_Prims_Ptr), Loc)), (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address)))); Attribute_Name => Name_Address))));
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 -- No dispatch table required
else else
...@@ -5450,6 +5671,7 @@ package body Exp_Disp is ...@@ -5450,6 +5671,7 @@ package body Exp_Disp is
pragma Assert (No (Access_Disp_Table (Typ))); pragma Assert (No (Access_Disp_Table (Typ)));
Set_Access_Disp_Table (Typ, New_Elmt_List); Set_Access_Disp_Table (Typ, New_Elmt_List);
Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
-- 2) Generate the secondary tag entities -- 2) Generate the secondary tag entities
...@@ -5471,6 +5693,9 @@ package body Exp_Disp is ...@@ -5471,6 +5693,9 @@ package body Exp_Disp is
Typ_Name := Name_Find; Typ_Name := Name_Find;
-- Secondary dispatch table referencing thunks to user-defined
-- primitives covered by this interface.
Iface_DT_Ptr := Iface_DT_Ptr :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'P')); Chars => New_External_Name (Typ_Name, 'P'));
...@@ -5484,6 +5709,25 @@ package body Exp_Disp is ...@@ -5484,6 +5709,25 @@ package body Exp_Disp is
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
-- 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);
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 := Iface_DT_Ptr :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'D')); Chars => New_External_Name (Typ_Name, 'D'));
...@@ -5496,6 +5740,20 @@ package body Exp_Disp is ...@@ -5496,6 +5740,20 @@ package body Exp_Disp is
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); 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);
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); Next_Elmt (AI_Tag_Comp);
end loop; end loop;
end if; end if;
...@@ -5703,33 +5961,38 @@ package body Exp_Disp is ...@@ -5703,33 +5961,38 @@ package body Exp_Disp is
end if; end if;
if not Present (Abstract_Interface_Alias (Prim)) then if not Present (Abstract_Interface_Alias (Prim)) then
Typ := Scope (DTC_Entity (Prim)); Typ := Scope (DTC_Entity (Prim));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Pos := DT_Position (Prim);
Pos := DT_Position (Prim); Tag := First_Tag_Component (Typ);
Tag := First_Tag_Component (Typ);
if Is_Predefined_Dispatching_Operation (Prim) if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim) or else Is_Predefined_Dispatching_Alias (Prim)
then then
DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
Insert_After (Ins_Nod, Insert_After (Ins_Nod,
Build_Set_Predefined_Prim_Op_Address (Loc, Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc), Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos, Position => Pos,
Address_Node => Make_Attribute_Reference (Loc, Address_Node =>
Prefix => New_Reference_To (Prim, Loc), Unchecked_Convert_To (RTE (RE_Address),
Attribute_Name => Name_Address))); Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
else else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Insert_After (Ins_Nod, Insert_After (Ins_Nod,
Build_Set_Prim_Op_Address (Loc, Build_Set_Prim_Op_Address (Loc,
Typ => Typ, Typ => Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc), Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos, Position => Pos,
Address_Node => Make_Attribute_Reference (Loc, Address_Node =>
Prefix => New_Reference_To (Prim, Loc), Unchecked_Convert_To (RTE (RE_Address),
Attribute_Name => Name_Address))); Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if; end if;
-- Ada 2005 (AI-251): Primitive associated with an interface type -- Ada 2005 (AI-251): Primitive associated with an interface type
...@@ -5763,35 +6026,40 @@ package body Exp_Disp is ...@@ -5763,35 +6026,40 @@ package body Exp_Disp is
Iface_DT_Ptr := Node (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (Has_Thunks (Iface_DT_Ptr)); pragma Assert (Has_Thunks (Iface_DT_Ptr));
Iface_Prim := Abstract_Interface_Alias (Prim); Iface_Prim := Abstract_Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim); Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ); Tag := First_Tag_Component (Iface_Typ);
L := New_List; L := New_List;
if Is_Predefined_Dispatching_Operation (Prim) if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim) or else Is_Predefined_Dispatching_Alias (Prim)
then then
Append_To (L, Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc, Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Tag_Node =>
New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
Position => Pos, Position => Pos,
Address_Node => Address_Node =>
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Thunk_Id, Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address))); Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
Next_Elmt (Iface_DT_Elmt); Next_Elmt (Iface_DT_Elmt);
Next_Elmt (Iface_DT_Elmt);
Iface_DT_Ptr := Node (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (not Has_Thunks (Iface_DT_Ptr)); pragma Assert (not Has_Thunks (Iface_DT_Ptr));
Append_To (L, Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc, Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Tag_Node =>
New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
Position => Pos, Position => Pos,
Address_Node => Address_Node =>
Make_Attribute_Reference (Loc, Unchecked_Convert_To (RTE (RE_Address),
Prefix => New_Reference_To (Alias (Prim), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address))); Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L); Insert_Actions_After (Ins_Nod, L);
...@@ -5804,12 +6072,14 @@ package body Exp_Disp is ...@@ -5804,12 +6072,14 @@ package body Exp_Disp is
Typ => Iface_Typ, Typ => Iface_Typ,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos, Position => Pos,
Address_Node => Make_Attribute_Reference (Loc, Address_Node =>
Prefix => Unchecked_Convert_To (RTE (RE_Address),
New_Reference_To (Thunk_Id, Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address))); Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
Next_Elmt (Iface_DT_Elmt); Next_Elmt (Iface_DT_Elmt);
Next_Elmt (Iface_DT_Elmt);
Iface_DT_Ptr := Node (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (not Has_Thunks (Iface_DT_Ptr)); pragma Assert (not Has_Thunks (Iface_DT_Ptr));
...@@ -5818,10 +6088,11 @@ package body Exp_Disp is ...@@ -5818,10 +6088,11 @@ package body Exp_Disp is
Typ => Iface_Typ, Typ => Iface_Typ,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos, Position => Pos,
Address_Node => Make_Attribute_Reference (Loc, Address_Node =>
Prefix => Unchecked_Convert_To (RTE (RE_Address),
New_Reference_To (Alias (Prim), Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address))); Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L); Insert_Actions_After (Ins_Nod, L);
end if; end if;
...@@ -5980,8 +6251,9 @@ package body Exp_Disp is ...@@ -5980,8 +6251,9 @@ package body Exp_Disp is
end loop; end loop;
declare declare
Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
:= (others => False); (others => False);
E : Entity_Id; E : Entity_Id;
procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
...@@ -6231,7 +6503,7 @@ package body Exp_Disp is ...@@ -6231,7 +6503,7 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
-- At this point all the primitives MUST have a position -- At this point all the primitives MUST have a position
-- in the dispatch table -- in the dispatch table.
if DT_Position (Prim) = No_Uint then if DT_Position (Prim) = No_Uint then
raise Program_Error; raise Program_Error;
...@@ -6322,8 +6594,7 @@ package body Exp_Disp is ...@@ -6322,8 +6594,7 @@ package body Exp_Disp is
Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
-- The derived type must have at least as many components as its parent -- The derived type must have at least as many components as its parent
-- (for root types, the Etype points back to itself and the test cannot -- (for root types Etype points to itself and the test cannot fail).
-- fail)
if DT_Entry_Count (The_Tag) < if DT_Entry_Count (The_Tag) <
DT_Entry_Count (First_Tag_Component (Parent_Typ)) DT_Entry_Count (First_Tag_Component (Parent_Typ))
......
gcc/ada/exp_util.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -948,6 +948,43 @@ package body Exp_Util is ...@@ -948,6 +948,43 @@ package body Exp_Util is
end if; end if;
end Component_May_Be_Bit_Aligned; end Component_May_Be_Bit_Aligned;
-----------------------------------
-- Corresponding_Runtime_Package --
-----------------------------------
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
Pkg_Id : RTU_Id := RTU_Null;
begin
pragma Assert (Is_Concurrent_Type (Typ));
if Ekind (Typ) in Protected_Kind then
if Has_Entries (Typ)
or else Has_Interrupt_Handler (Typ)
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Typ))))
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
then
Pkg_Id := System_Tasking_Protected_Objects_Entries;
else
Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
end if;
else
Pkg_Id := System_Tasking_Protected_Objects;
end if;
end if;
return Pkg_Id;
end Corresponding_Runtime_Package;
------------------------------- -------------------------------
-- Convert_To_Actual_Subtype -- -- Convert_To_Actual_Subtype --
------------------------------- -------------------------------
...@@ -1384,6 +1421,10 @@ package body Exp_Util is ...@@ -1384,6 +1421,10 @@ package body Exp_Util is
return; return;
end if; end if;
-- Document what is going on here, why four Next's???
Next_Elmt (ADT);
Next_Elmt (ADT);
Next_Elmt (ADT); Next_Elmt (ADT);
Next_Elmt (ADT); Next_Elmt (ADT);
Next_Elmt (AI_Elmt); Next_Elmt (AI_Elmt);
...@@ -1420,7 +1461,7 @@ package body Exp_Util is ...@@ -1420,7 +1461,7 @@ package body Exp_Util is
(not Is_Class_Wide_Type (Typ) (not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type); and then Ekind (Typ) /= E_Incomplete_Type);
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
pragma Assert (Present (Node (ADT))); pragma Assert (Present (Node (ADT)));
Find_Secondary_Table (Typ); Find_Secondary_Table (Typ);
pragma Assert (Found); pragma Assert (Found);
......
gcc/ada/exp_util.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -212,43 +212,51 @@ package Exp_Util is ...@@ -212,43 +212,51 @@ package Exp_Util is
-- function itself must do its own cleanups. -- function itself must do its own cleanups.
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
-- This function is in charge of detecting record components that may cause -- This function is in charge of detecting record components that may
-- trouble in the back end if an attempt is made to assign the component. -- cause trouble in the back end if an attempt is made to assign the
-- The back end can handle such assignments with no problem if the -- component. The back end can handle such assignments with no problem if
-- components involved are small (64-bits or less) records or scalar items -- the components involved are small (64-bits or less) records or scalar
-- (including bit-packed arrays represented with modular types) or are both -- items (including bit-packed arrays represented with modular types) or
-- aligned on a byte boundary (starting on a byte boundary, and occupying -- are both aligned on a byte boundary (starting on a byte boundary, and
-- an integral number of bytes). -- occupying an integral number of bytes).
-- --
-- However, problems arise for records larger than 64 bits, or for arrays -- However, problems arise for records larger than 64 bits, or for arrays
-- (other than bit-packed arrays represented with a modular type) if the -- (other than bit-packed arrays represented with a modular type) if the
-- component starts on a non-byte boundary, or does not occupy an integral -- component starts on a non-byte boundary, or does not occupy an integral
-- number of bytes (i.e. there are some bits possibly shared with fields at -- number of bytes (i.e. there are some bits possibly shared with fields
-- the start or beginning of the component). The back end cannot handle -- at the start or beginning of the component). The back end cannot handle
-- loading and storing such components in a single operation. -- loading and storing such components in a single operation.
-- --
-- This function is used to detect the troublesome situation. it is -- This function is used to detect the troublesome situation. it is
-- conservative in the sense that it produces True unless it knows for sure -- conservative in the sense that it produces True unless it knows for
-- that the component is safe (as outlined in the first paragraph above). -- sure that the component is safe (as outlined in the first paragraph
-- The code generation for record and array assignment checks for trouble -- above). The code generation for record and array assignment checks for
-- using this function, and if so the assignment is generated -- trouble using this function, and if so the assignment is generated
-- component-wise, which the back end is required to handle correctly. -- component-wise, which the back end is required to handle correctly.
-- --
-- Note that in GNAT 3, the back end will reject such components anyway, so -- Note that in GNAT 3, the back end will reject such components anyway,
-- the hard work in checking for this case is wasted in GNAT 3, but it's -- so the hard work in checking for this case is wasted in GNAT 3, but
-- harmless, so it is easier to do it in all cases, rather than -- it is harmless, so it is easier to do it in all cases, rather than
-- conditionalize it in GNAT 5 or beyond. -- conditionalize it in GNAT 5 or beyond.
procedure Convert_To_Actual_Subtype (Exp : Node_Id); procedure Convert_To_Actual_Subtype (Exp : Node_Id);
-- The Etype of an expression is the nominal type of the expression, not -- The Etype of an expression is the nominal type of the expression,
-- the actual subtype. Often these are the same, but not always. For -- not the actual subtype. Often these are the same, but not always.
-- example, a reference to a formal of unconstrained type has the -- For example, a reference to a formal of unconstrained type has the
-- unconstrained type as its Etype, but the actual subtype is obtained by -- unconstrained type as its Etype, but the actual subtype is obtained by
-- applying the actual bounds. This routine is given an expression, Exp, -- applying the actual bounds. This routine is given an expression, Exp,
-- and (if necessary), replaces it using Rewrite, with a conversion to the -- and (if necessary), replaces it using Rewrite, with a conversion to
-- actual subtype, building the actual subtype if necessary. If the -- the actual subtype, building the actual subtype if necessary. If the
-- expression is already of the requested type, then it is unchanged. -- expression is already of the requested type, then it is unchanged.
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id;
-- Return the id of the runtime package that will provide support for
-- concurrent type Typ. Currently only protected types are supported,
-- and the returned value is one of the following:
-- System_Tasking_Protected_Objects
-- System_Tasking_Protected_Objects_Entries
-- System_Tasking_Protected_Objects_Single_Entry
function Current_Sem_Unit_Declarations return List_Id; function Current_Sem_Unit_Declarations return List_Id;
-- Return the a place where it is fine to insert declarations for the -- Return the a place where it is fine to insert declarations for the
-- current semantic unit. If the unit is a package body, return the -- current semantic unit. If the unit is a package body, return the
......
gcc/ada/sem_util.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1386,12 +1386,15 @@ package body Sem_Util is ...@@ -1386,12 +1386,15 @@ package body Sem_Util is
ADT : Elmt_Id; ADT : Elmt_Id;
begin begin
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
while Present (ADT) while Present (ADT)
and then Ekind (Node (ADT)) = E_Constant and then Ekind (Node (ADT)) = E_Constant
and then Related_Type (Node (ADT)) /= Iface and then Related_Type (Node (ADT)) /= Iface
loop loop
-- Skip the two secondary dispatch tables of Iface -- Skip the secondary dispatch tables of Iface
Next_Elmt (ADT);
Next_Elmt (ADT);
Next_Elmt (ADT); Next_Elmt (ADT);
Next_Elmt (ADT); Next_Elmt (ADT);
end loop; end loop;
...@@ -3769,6 +3772,15 @@ package body Sem_Util is ...@@ -3769,6 +3772,15 @@ package body Sem_Util is
return Entity_Id (Get_Name_Table_Info (Id)); return Entity_Id (Get_Name_Table_Info (Id));
end Get_Name_Entity_Id; end Get_Name_Entity_Id;
-------------------
-- Get_Pragma_Id --
-------------------
function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
begin
return Get_Pragma_Id (Pragma_Name (N));
end Get_Pragma_Id;
--------------------------- ---------------------------
-- Get_Referenced_Object -- -- Get_Referenced_Object --
--------------------------- ---------------------------
...@@ -3906,31 +3918,42 @@ package body Sem_Util is ...@@ -3906,31 +3918,42 @@ package body Sem_Util is
----------------------------- -----------------------------
function Has_Abstract_Interfaces function Has_Abstract_Interfaces
(Tagged_Type : Entity_Id; (T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean Use_Full_View : Boolean := True) return Boolean
is is
Typ : Entity_Id; Typ : Entity_Id;
begin begin
pragma Assert (Is_Record_Type (Tagged_Type) -- Handle concurrent types
and then Is_Tagged_Type (Tagged_Type));
-- Handle concurrent record types if Is_Concurrent_Type (T) then
Typ := Corresponding_Record_Type (T);
else
Typ := T;
end if;
if Is_Concurrent_Record_Type (Tagged_Type) if not Present (Typ)
and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type)) or else not Is_Tagged_Type (Typ)
then then
return True; return False;
end if; end if;
Typ := Tagged_Type; pragma Assert (Is_Record_Type (Typ));
-- Handle private types -- Handle private types
if Use_Full_View if Use_Full_View
and then Present (Full_View (Tagged_Type)) and then Present (Full_View (Typ))
then
Typ := Full_View (Typ);
end if;
-- Handle concurrent record types
if Is_Concurrent_Record_Type (Typ)
and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
then then
Typ := Full_View (Tagged_Type); return True;
end if; end if;
loop loop
...@@ -3953,7 +3976,7 @@ package body Sem_Util is ...@@ -3953,7 +3976,7 @@ package body Sem_Util is
-- Protect the frontend against wrong source with cyclic -- Protect the frontend against wrong source with cyclic
-- derivations -- derivations
or else Etype (Typ) = Tagged_Type; or else Etype (Typ) = T;
-- Climb to the ancestor type handling private types -- Climb to the ancestor type handling private types
...@@ -8910,8 +8933,9 @@ package body Sem_Util is ...@@ -8910,8 +8933,9 @@ package body Sem_Util is
procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
begin begin
Basic_Set_Convention (E, Val); Basic_Set_Convention (E, Val);
if Is_Type (E) if Is_Type (E)
and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind and then Is_Access_Subprogram_Type (Base_Type (E))
and then Has_Foreign_Convention (E) and then Has_Foreign_Convention (E)
then then
Set_Can_Use_Internal_Rep (E, False); Set_Can_Use_Internal_Rep (E, False);
...@@ -8932,6 +8956,93 @@ package body Sem_Util is ...@@ -8932,6 +8956,93 @@ package body Sem_Util is
Set_Name_Entity_Id (Chars (E), E); Set_Name_Entity_Id (Chars (E), E);
end Set_Current_Entity; end Set_Current_Entity;
---------------------------
-- Set_Debug_Info_Needed --
---------------------------
procedure Set_Debug_Info_Needed (T : Entity_Id) is
procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
-- Used to set debug info in a related node if not set already
--------------------------------------
-- Set_Debug_Info_Needed_If_Not_Set --
--------------------------------------
procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
begin
if Present (E)
and then not Needs_Debug_Info (E)
then
Set_Debug_Info_Needed (E);
end if;
end Set_Debug_Info_Needed_If_Not_Set;
-- Start of processing for Set_Debug_Info_Needed
begin
-- Nothing to do if argument is Empty or has Debug_Info_Off set, which
-- indicates that Debug_Info_Needed is never required for the entity.
if No (T)
or else Debug_Info_Off (T)
then
return;
end if;
-- Set flag in entity itself. Note that we will go through the following
-- circuitry even if the flag is already set on T. That's intentional,
-- it makes sure that the flag will be set in subsidiary entities.
Set_Needs_Debug_Info (T);
-- Set flag on subsidiary entities if not set already
if Is_Object (T) then
Set_Debug_Info_Needed_If_Not_Set (Etype (T));
elsif Is_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Etype (T));
if Is_Record_Type (T) then
declare
Ent : Entity_Id := First_Entity (T);
begin
while Present (Ent) loop
Set_Debug_Info_Needed_If_Not_Set (Ent);
Next_Entity (Ent);
end loop;
end;
elsif Is_Array_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
declare
Indx : Node_Id := First_Index (T);
begin
while Present (Indx) loop
Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
Indx := Next_Index (Indx);
end loop;
end;
if Is_Packed (T) then
Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
end if;
elsif Is_Access_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
elsif Is_Private_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
elsif Is_Protected_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
end if;
end if;
end Set_Debug_Info_Needed;
--------------------------------- ---------------------------------
-- Set_Entity_With_Style_Check -- -- Set_Entity_With_Style_Check --
--------------------------------- ---------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment