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 645 additions and 220 deletions
gcc/ada/exp_atag.adb
......@@ -369,7 +369,6 @@ package body Exp_Atag is
New_Tag_Node : Node_Id) return Node_Id
is
begin
if RTE_Available (RE_DT) then
return
Make_Assignment_Statement (Loc,
Name =>
......@@ -377,12 +376,9 @@ package body Exp_Atag is
Prefix =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Selected_Component (Loc,
Prefix =>
Build_DT (Loc, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
New_Tag_Node)))),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
......@@ -392,41 +388,13 @@ package body Exp_Atag is
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 =>
Make_Slice (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Build_Predef_Prims (Loc, Old_Tag_Node)),
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Old_Tag_Node)))),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound =>
Make_Integer_Literal (Loc, 1),
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
end if;
end Build_Inherit_Predefined_Prims;
------------------------
......@@ -472,8 +440,15 @@ package body Exp_Atag is
begin
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node, Position),
Name =>
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);
end Build_Set_Predefined_Prim_Op_Address;
......
gcc/ada/exp_atag.ads
......@@ -98,7 +98,8 @@ package Exp_Atag is
-- Generates: Predefined_DT (New_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
(Loc : Source_Ptr;
......
gcc/ada/exp_ch6.adb
......@@ -3388,7 +3388,7 @@ package body Exp_Ch6 is
-- not be posting warnings on the inlined body so it is unneeded.
elsif Nkind (N) = N_Pragma
and then Chars (N) = Name_Unreferenced
and then Pragma_Name (N) = Name_Unreferenced
then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return OK;
......@@ -4756,14 +4756,14 @@ package body Exp_Ch6 is
return;
end if;
-- Skip the first access-to-dispatch-table pointer since it leads
-- to the primary dispatch table. We are only concerned with the
-- secondary dispatch table pointers. Note that the access-to-
-- dispatch-table pointer corresponds to the first implemented
-- interface retrieved below.
-- Skip the first two access-to-dispatch-table pointers since they
-- leads to the primary dispatch table (predefined DT and user
-- defined DT). We are only concerned with the secondary dispatch
-- table pointers. Note that the access-to- dispatch-table pointer
-- corresponds to the first implemented interface retrieved below.
Iface_DT_Ptr :=
Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
while Present (Iface_DT_Ptr)
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
......@@ -4776,23 +4776,41 @@ package body Exp_Ch6 is
Thunk_Code,
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),
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)),
Attribute_Name => Name_Unrestricted_Access))),
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To
(Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Tag_Node =>
New_Reference_To
(Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
Loc),
Position => DT_Position (Prim),
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address))));
Attribute_Name => Name_Unrestricted_Access)))));
end if;
-- Skip the tag of the predefined primitives dispatch table
Next_Elmt (Iface_DT_Ptr);
pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
-- Skip 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);
pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
......
gcc/ada/exp_disp.adb
......@@ -46,6 +46,7 @@ with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
......@@ -175,14 +176,14 @@ package body Exp_Disp is
/= E_Record_Subtype
then
declare
E1, E2 : Entity_Id;
E1 : constant Entity_Id := Defining_Entity (D);
E2 : constant Entity_Id := Full_View (Defining_Entity (D));
begin
E1 := Defining_Entity (D);
E2 := Full_View (Defining_Entity (D));
Exchange_Entities (E1, E2);
Exchange_Declarations (E1);
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (E1));
Exchange_Entities (E1, E2);
Exchange_Declarations (E2);
end;
end if;
......@@ -612,6 +613,7 @@ package body Exp_Disp is
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
-- 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
......@@ -1531,6 +1533,7 @@ package body Exp_Disp is
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
begin
......@@ -1593,6 +1596,19 @@ package body Exp_Disp is
Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Build T._object'Access for calls below
Obj_Ref :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
-- Generate:
-- Protected_Entry_Call
-- (T._object'Access, -- Object
......@@ -1601,9 +1617,9 @@ package body Exp_Disp is
-- Asynchronous_Call, -- Mode
-- Bnn); -- Communication_Block
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters and B is the name of the communication
-- block.
-- 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,
......@@ -1611,22 +1627,13 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'Access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
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)),
New_Reference_To
(RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Asynchronous_Call
......@@ -1634,6 +1641,34 @@ package body Exp_Disp is
New_Reference_To (Com_Block, Loc)))); -- comm block
when System_Tasking_Protected_Objects_Single_Entry =>
-- Generate:
-- procedure Protected_Single_Entry_Call
-- (Object : Protection_Entry_Access;
-- Uninterpreted_Data : System.Address;
-- Mode : Call_Modes);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Reference_To
(RTE (RE_Asynchronous_Call), Loc))));
when others =>
raise Program_Error;
end case;
-- Generate:
-- B := Dummy_Communication_Block (Bnn);
......@@ -1660,7 +1695,7 @@ package body Exp_Disp is
-- Asynchronous_Call, -- Mode
-- 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.
Append_To (Stmts,
......@@ -1669,7 +1704,6 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Selected_Component (Loc, -- T._task_id
Prefix =>
Make_Identifier (Loc, Name_uT),
......@@ -1843,6 +1877,7 @@ package body Exp_Disp is
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
begin
......@@ -1929,7 +1964,18 @@ package body Exp_Disp is
if Ekind (Conc_Typ) = E_Protected_Type then
Obj_Ref := -- T._object'Access
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
-- Generate:
-- Protected_Entry_Call
-- (T._object'Access, -- Object
-- Protected_Entry_Index! (I), -- E
......@@ -1937,9 +1983,9 @@ package body Exp_Disp is
-- Conditional_Call, -- Mode
-- Bnn); -- Block
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters and Bnn is the name of the communication
-- block.
-- where T is the protected object, I is the entry index, P
-- are the wrapped parameters and Bnn is the name of the
-- communication block.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
......@@ -1947,29 +1993,45 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'Access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
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)),
New_Reference_To
(RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Conditional_Call
RTE (RE_Conditional_Call), Loc),
New_Reference_To ( -- Bnn
Blk_Nam, Loc))));
when System_Tasking_Protected_Objects_Single_Entry =>
-- If we are compiling for a restricted run-time, the call
-- uses the simpler form.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Reference_To
(RTE (RE_Conditional_Call), Loc))));
when others =>
raise Program_Error;
end case;
-- Generate:
-- F := not Cancelled (Bnn);
......@@ -2339,6 +2401,9 @@ package body Exp_Disp is
-- A);
-- end if;
if Restriction_Active (No_Entry_Queue) then
Append_To (Stmts, Make_Null_Statement (Loc));
else
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
......@@ -2412,6 +2477,7 @@ package body Exp_Disp is
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
else
pragma Assert (Is_Task_Type (Conc_Typ));
......@@ -2658,6 +2724,7 @@ package body Exp_Disp is
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
begin
......@@ -2727,41 +2794,47 @@ package body Exp_Disp is
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
-- Protected case
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
-- Timed_Protected_Entry_Call (
-- T._object'access,
-- Build T._object'Access
Obj_Ref :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
-- Normal case, No_Entry_Queue restriction not active. In this
-- case we generate:
-- Timed_Protected_Entry_Call
-- (T._object'access,
-- Protected_Entry_Index! (I),
-- P,
-- D,
-- M,
-- F);
-- P, D, M, F);
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag.
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
New_Reference_To
(RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Obj_Ref,
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
New_Reference_To
(RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
......@@ -2770,6 +2843,35 @@ package body Exp_Disp is
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when System_Tasking_Protected_Objects_Single_Entry =>
-- Generate:
-- Timed_Protected_Single_Entry_Call
-- (T._object'access, P, D, M, F);
-- where T is the protected object, P is the wrapped
-- parameters, D is the delay amount, M is the delay mode, F
-- is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when others =>
raise Program_Error;
end case;
-- Task case
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
......@@ -2961,6 +3063,7 @@ package body Exp_Disp is
Iface : Entity_Id;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
Build_Thunks : Boolean;
Result : List_Id);
-- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
......@@ -3028,6 +3131,7 @@ package body Exp_Disp is
Iface : Entity_Id;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
Build_Thunks : Boolean;
Result : List_Id)
is
......@@ -3168,9 +3272,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Address);
Attribute_Name => Name_Unrestricted_Access));
else
New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc);
......@@ -3451,9 +3556,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Address);
Attribute_Name => Name_Unrestricted_Access));
else
New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc);
......@@ -3513,6 +3619,30 @@ package body Exp_Disp is
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
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;
-- Local variables
......@@ -3535,10 +3665,7 @@ package body Exp_Disp is
Nb_Prim : Nat := 0;
New_Node : Node_Id;
No_Reg : Node_Id;
Null_Parent_Tag : Boolean := False;
Num_Ifaces : Nat := 0;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
......@@ -3686,7 +3813,8 @@ package body Exp_Disp is
Collect_Interface_Components (Typ, Typ_Comps);
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);
while Present (AI_Tag_Comp) loop
......@@ -3699,10 +3827,15 @@ package body Exp_Disp is
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True,
Result => Result);
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
-- (used to give support to Generic Dispatching Constructors).
......@@ -3712,10 +3845,15 @@ package body Exp_Disp is
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => False,
Result => Result);
Next_Elmt (AI_Tag_Elmt);
-- Skip the secondary dispatch table of predefined primitives
Next_Elmt (AI_Tag_Elmt);
Suffix_Index := Suffix_Index + 1;
Next_Elmt (AI_Tag_Comp);
end loop;
......@@ -3850,6 +3988,23 @@ package body Exp_Disp is
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
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;
......@@ -4245,7 +4400,9 @@ package body Exp_Disp is
Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc);
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)));
while Ekind (Node (Elmt)) = E_Constant
......@@ -4254,14 +4411,20 @@ package body Exp_Disp is
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
pragma Assert (not Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
pragma Assert (not Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
end loop;
pragma Assert (Ekind (Node (Elmt)) = E_Constant
and then not Has_Thunks (Node (Next_Elmt (Elmt))));
and then not
Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
Sec_DT_Tag :=
New_Reference_To (Node (Next_Elmt (Elmt)), Loc);
New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
Loc);
end if;
Append_To (TSD_Ifaces_List,
......@@ -4645,9 +4808,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Address);
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
end if;
......@@ -4787,9 +4951,10 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Address);
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
end if;
......@@ -4871,6 +5036,12 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if;
-- Inherit the dispatch tables of the parent
-- There is no need to inherit anything from the parent when building
-- static dispatch tables because the whole dispatch table (including
-- inherited primitives) has been already built.
if Building_Static_DT (Typ) then
null;
......@@ -4883,36 +5054,16 @@ package body Exp_Disp is
-- Otherwise we fill in the dispatch tables here
else
if Typ = Etype (Typ)
or else Is_CPP_Class (Etype (Typ))
or else Is_Interface (Typ)
then
Null_Parent_Tag := True;
Old_Tag1 :=
Unchecked_Convert_To (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)
and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then
-- Inherit the dispatch table
if not Is_Interface (Etype (Typ)) then
if not Null_Parent_Tag then
if not Is_Interface (Typ)
and then not Is_Interface (Etype (Typ))
and then not Is_CPP_Class (Etype (Typ))
then
declare
Nb_Prims : constant Int :=
UI_To_Int (DT_Entry_Count
......@@ -4920,21 +5071,33 @@ package body Exp_Disp is
begin
Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc,
Old_Tag_Node => Old_Tag1,
Old_Tag_Node =>
New_Reference_To
(Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))))), Loc),
New_Tag_Node =>
New_Reference_To (DT_Ptr, Loc)));
New_Reference_To
(Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Typ)))), Loc)));
if Nb_Prims /= 0 then
Append_To (Elab_Code,
Build_Inherit_Prims (Loc,
Typ => Typ,
Old_Tag_Node => Old_Tag2,
Old_Tag_Node =>
New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Etype (Typ)))), Loc),
New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Num_Prims => Nb_Prims));
end if;
end;
end if;
end if;
-- Inherit the secondary dispatch tables of the ancestor
......@@ -4942,12 +5105,14 @@ package body Exp_Disp is
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))));
(Access_Disp_Table (Etype (Typ)))));
Sec_DT_Typ : Elmt_Id :=
Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Typ)));
(Access_Disp_Table (Typ))));
procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- Local procedure required to climb through the ancestors
......@@ -4999,11 +5164,14 @@ package body Exp_Disp is
Old_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor), Loc)),
(Node
(Next_Elmt (Sec_DT_Ancestor)),
Loc)),
New_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc))));
(Node (Next_Elmt (Sec_DT_Typ)),
Loc))));
if Num_Prims /= 0 then
Append_To (Elab_Code,
......@@ -5027,6 +5195,12 @@ package body Exp_Disp is
Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ);
-- Skip the secondary dispatch table of
-- predefined primitives
Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ);
if not Is_Interface (Etype (Typ)) then
-- Inherit second secondary dispatch table
......@@ -5036,11 +5210,14 @@ package body Exp_Disp is
Old_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor), Loc)),
(Node
(Next_Elmt (Sec_DT_Ancestor)),
Loc)),
New_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc))));
(Node (Next_Elmt (Sec_DT_Typ)),
Loc))));
if Num_Prims /= 0 then
Append_To (Elab_Code,
......@@ -5064,6 +5241,13 @@ package body Exp_Disp is
Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ);
-- Skip the secondary dispatch table of
-- predefined primitives
Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ);
Next_Elmt (Iface);
end if;
......@@ -5143,6 +5327,15 @@ package body Exp_Disp is
Make_Select_Specific_Data_Table (Typ));
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);
Set_Has_Dispatch_Table (Typ);
......@@ -5319,6 +5512,7 @@ package body Exp_Disp is
DT : Node_Id;
DT_Constr_List : List_Id;
DT_Ptr : Node_Id;
Predef_Prims_Ptr : Node_Id;
Iface_DT_Ptr : Node_Id;
Nb_Prim : Nat;
Suffix_Index : Int;
......@@ -5334,18 +5528,28 @@ package body Exp_Disp is
Collect_Interface_Components (Typ, Typ_Comps);
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,
New_External_Name (Tname, 'P'));
Set_Etype (DT_Ptr, RTE (RE_Tag));
-- Primary dispatch table containing predefined primitives
Predef_Prims_Ptr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Tname, 'Y'));
Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-- Import the forward declaration of the Dispatch Table wrapper record
-- (Make_DT will take care of its exportation)
if Building_Static_DT (Typ) then
DT := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'T'));
DT :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Tname, 'T'));
-- Generate:
-- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
......@@ -5371,6 +5575,7 @@ package body Exp_Disp is
Set_Dispatch_Table_Wrapper (Typ, DT);
if Has_DT (Typ) then
-- Calculate the number of primitives of the dispatch table and
-- the size of the Type_Specific_Data record.
......@@ -5415,6 +5620,22 @@ package body Exp_Disp is
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
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
else
......@@ -5450,6 +5671,7 @@ package body Exp_Disp is
pragma Assert (No (Access_Disp_Table (Typ)));
Set_Access_Disp_Table (Typ, New_Elmt_List);
Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
-- 2) Generate the secondary tag entities
......@@ -5471,6 +5693,9 @@ package body Exp_Disp is
Typ_Name := Name_Find;
-- Secondary dispatch table referencing thunks to user-defined
-- primitives covered by this interface.
Iface_DT_Ptr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'P'));
......@@ -5484,6 +5709,25 @@ package body Exp_Disp is
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
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 :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'D'));
......@@ -5496,6 +5740,20 @@ package body Exp_Disp is
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
-- Secondary dispatch table referencing predefined primitives
Iface_DT_Ptr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'Z'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
Set_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Tag (Iface_DT_Ptr);
Set_Is_Statically_Allocated (Iface_DT_Ptr);
Set_Is_True_Constant (Iface_DT_Ptr);
Set_Related_Type
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
Next_Elmt (AI_Tag_Comp);
end loop;
end if;
......@@ -5704,32 +5962,37 @@ package body Exp_Disp is
if not Present (Abstract_Interface_Alias (Prim)) then
Typ := Scope (DTC_Entity (Prim));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Pos := DT_Position (Prim);
Tag := First_Tag_Component (Typ);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
then
DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
Insert_After (Ins_Nod,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
Address_Node => Make_Attribute_Reference (Loc,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
Attribute_Name => Name_Unrestricted_Access))));
else
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,
Build_Set_Prim_Op_Address (Loc,
Typ => Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
Address_Node => Make_Attribute_Reference (Loc,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
Attribute_Name => Name_Unrestricted_Access))));
end if;
-- Ada 2005 (AI-251): Primitive associated with an interface type
......@@ -5773,25 +6036,30 @@ package body Exp_Disp is
then
Append_To (L,
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,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
Attribute_Name => Name_Unrestricted_Access))));
Next_Elmt (Iface_DT_Elmt);
Next_Elmt (Iface_DT_Elmt);
Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (not Has_Thunks (Iface_DT_Ptr));
Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Tag_Node =>
New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Address)));
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L);
......@@ -5804,12 +6072,14 @@ package body Exp_Disp is
Typ => Iface_Typ,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos,
Address_Node => Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
Next_Elmt (Iface_DT_Elmt);
Next_Elmt (Iface_DT_Elmt);
Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (not Has_Thunks (Iface_DT_Ptr));
......@@ -5818,10 +6088,11 @@ package body Exp_Disp is
Typ => Iface_Typ,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos,
Address_Node => Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Address)));
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L);
end if;
......@@ -5980,8 +6251,9 @@ package body Exp_Disp is
end loop;
declare
Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
:= (others => False);
Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
(others => False);
E : Entity_Id;
procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
......@@ -6231,7 +6503,7 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt);
-- 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
raise Program_Error;
......@@ -6322,8 +6594,7 @@ package body Exp_Disp is
Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
-- The derived type must have at least as many components as its parent
-- (for root types, the Etype points back to itself and the test cannot
-- fail)
-- (for root types Etype points to itself and the test cannot fail).
if DT_Entry_Count (The_Tag) <
DT_Entry_Count (First_Tag_Component (Parent_Typ))
......
gcc/ada/exp_util.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -948,6 +948,43 @@ package body Exp_Util is
end if;
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 --
-------------------------------
......@@ -1384,6 +1421,10 @@ package body Exp_Util is
return;
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 (AI_Elmt);
......@@ -1420,7 +1461,7 @@ package body Exp_Util is
(not Is_Class_Wide_Type (Typ)
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)));
Find_Secondary_Table (Typ);
pragma Assert (Found);
......
gcc/ada/exp_util.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -212,43 +212,51 @@ package Exp_Util is
-- function itself must do its own cleanups.
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
-- This function is in charge of detecting record components that may cause
-- trouble in the back end if an attempt is made to assign the component.
-- The back end can handle such assignments with no problem if the
-- components involved are small (64-bits or less) records or scalar items
-- (including bit-packed arrays represented with modular types) or are both
-- aligned on a byte boundary (starting on a byte boundary, and occupying
-- an integral number of bytes).
-- This function is in charge of detecting record components that may
-- cause trouble in the back end if an attempt is made to assign the
-- component. The back end can handle such assignments with no problem if
-- the components involved are small (64-bits or less) records or scalar
-- items (including bit-packed arrays represented with modular types) or
-- are both aligned on a byte boundary (starting on a byte boundary, and
-- occupying an integral number of bytes).
--
-- However, problems arise for records larger than 64 bits, or for arrays
-- (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
-- number of bytes (i.e. there are some bits possibly shared with fields at
-- the start or beginning of the component). The back end cannot handle
-- number of bytes (i.e. there are some bits possibly shared with fields
-- at the start or beginning of the component). The back end cannot handle
-- loading and storing such components in a single operation.
--
-- This function is used to detect the troublesome situation. it is
-- conservative in the sense that it produces True unless it knows for sure
-- that the component is safe (as outlined in the first paragraph above).
-- The code generation for record and array assignment checks for trouble
-- using this function, and if so the assignment is generated
-- conservative in the sense that it produces True unless it knows for
-- sure that the component is safe (as outlined in the first paragraph
-- above). The code generation for record and array assignment checks for
-- trouble using this function, and if so the assignment is generated
-- 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
-- the hard work in checking for this case is wasted in GNAT 3, but it's
-- harmless, so it is easier to do it in all cases, rather than
-- Note that in GNAT 3, the back end will reject such components anyway,
-- so the hard work in checking for this case is wasted in GNAT 3, but
-- it is harmless, so it is easier to do it in all cases, rather than
-- conditionalize it in GNAT 5 or beyond.
procedure Convert_To_Actual_Subtype (Exp : Node_Id);
-- The Etype of an expression is the nominal type of the expression, not
-- the actual subtype. Often these are the same, but not always. For
-- example, a reference to a formal of unconstrained type has the
-- The Etype of an expression is the nominal type of the expression,
-- not the actual subtype. Often these are the same, but not always.
-- For example, a reference to a formal of unconstrained type has the
-- unconstrained type as its Etype, but the actual subtype is obtained by
-- applying the actual bounds. This routine is given an expression, Exp,
-- and (if necessary), replaces it using Rewrite, with a conversion to the
-- actual subtype, building the actual subtype if necessary. If the
-- and (if necessary), replaces it using Rewrite, with a conversion to
-- the actual subtype, building the actual subtype if necessary. If the
-- 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;
-- 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
......
gcc/ada/sem_util.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -1386,12 +1386,15 @@ package body Sem_Util is
ADT : Elmt_Id;
begin
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
while Present (ADT)
and then Ekind (Node (ADT)) = E_Constant
and then Related_Type (Node (ADT)) /= Iface
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);
end loop;
......@@ -3769,6 +3772,15 @@ package body Sem_Util is
return Entity_Id (Get_Name_Table_Info (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 --
---------------------------
......@@ -3906,31 +3918,42 @@ package body Sem_Util is
-----------------------------
function Has_Abstract_Interfaces
(Tagged_Type : Entity_Id;
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
Typ : Entity_Id;
begin
pragma Assert (Is_Record_Type (Tagged_Type)
and then Is_Tagged_Type (Tagged_Type));
-- Handle concurrent types
-- 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)
and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type))
if not Present (Typ)
or else not Is_Tagged_Type (Typ)
then
return True;
return False;
end if;
Typ := Tagged_Type;
pragma Assert (Is_Record_Type (Typ));
-- Handle private types
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
Typ := Full_View (Tagged_Type);
return True;
end if;
loop
......@@ -3953,7 +3976,7 @@ package body Sem_Util is
-- Protect the frontend against wrong source with cyclic
-- derivations
or else Etype (Typ) = Tagged_Type;
or else Etype (Typ) = T;
-- Climb to the ancestor type handling private types
......@@ -8910,8 +8933,9 @@ package body Sem_Util is
procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
begin
Basic_Set_Convention (E, Val);
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)
then
Set_Can_Use_Internal_Rep (E, False);
......@@ -8932,6 +8956,93 @@ package body Sem_Util is
Set_Name_Entity_Id (Chars (E), E);
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 --
---------------------------------
......
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