Skip to content

R
riscv-gcc-1
Commit d44202ba by Hristian Kirtchev Committed by Arnaud Charlet
Options

einfo.adb: Flag245 is now used. 

2008-07-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb: Flag245 is now used.
	(Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion
	check to include functions.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.
	(Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to
	include functions.
	(Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive
	to the list of displayed flags.

	* einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and
	Wrapped_Entity. These two flags are now present in functions.
	New flag Is_Private_Primitive.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.

	* exp_ch9.adb:
	(Build_Wrapper_Bodies): New subprogram.
	(Build_Wrapper_Body): The spec and body have been moved to in
	Build_Wrapper_ Bodies. Code cleanup.
	(Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup.
	Wrappers are now generated for primitives declared between the private
	and full view of a concurrent type that implements an interface.
	(Build_Wrapper_Specs): New subprogram.
	(Expand_N_Protected_Body): Code reformatting. Replace the wrapper body
	creation mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Protected_Type_Declaration): Code reformatting. Replace the
	wrapper spec creation mechanism with a call to Build_Wrapper_Specs.
	(Expand_N_Task_Body): Replace the wrapper body creation
	mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Task_Type_Declaration): Replace the wrapper spec
	creation mechanism with a call to Build_Wrapper_Specs.
	(Is_Private_Primitive_Subprogram): New subprogram.
	(Overriding_Possible): Code cleanup.
	(Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup.

	* exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9.

	* sem_ch3.adb: Add with and use clause for Exp_Ch9.
	(Process_Full_View): Build wrapper specs for all primitives
	that belong to a private view completed by a concurrent type
	implementing an interface.
	
	* sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram
	is a primitive of a
	concurrent type with a private view that implements an interface, try to
	find the proper spec.
	(Analyze_Subprogram_Declaration): Mark a subprogram as a private
	primitive if the type of its first parameter is a non-generic tagged
	private type.
	(Analyze_Subprogram_Specification): Code reformatting.
	(Disambiguate_Spec): New routine.
	(Find_Corresponding_Spec): Add a flag to controll the output of errors.
	(Is_Private_Concurrent_Primitive): New routine.

	* sem_ch6.ads:
	(Find_Corresponding_Spec): Add a formal to control the output of errors.

From-SVN: r138324
parent dc829590
Showing with 752 additions and 496 deletions
gcc/ada/einfo.adb
......@@ -504,9 +504,8 @@ package body Einfo is
-- Optimize_Alignment_Time Flag242
-- Overlays_Constant Flag243
-- Is_RACW_Stub_Type Flag244
-- Is_Private_Primitive Flag245
-- (unused) Flag169
-- (unused) Flag245
-- (unused) Flag246
-- (unused) Flag247
......@@ -1929,7 +1928,8 @@ package body Einfo is
function Is_Primitive_Wrapper (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
return Flag195 (Id);
end Is_Primitive_Wrapper;
......@@ -1944,6 +1944,13 @@ package body Einfo is
return Flag53 (Id);
end Is_Private_Descendant;
function Is_Private_Primitive (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
return Flag245 (Id);
end Is_Private_Primitive;
function Is_Protected_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
......@@ -2702,7 +2709,8 @@ package body Einfo is
function Wrapped_Entity (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Procedure
pragma Assert ((Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure)
and then Is_Primitive_Wrapper (Id));
return Node27 (Id);
end Wrapped_Entity;
......@@ -4372,7 +4380,8 @@ package body Einfo is
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
Set_Flag195 (Id, V);
end Set_Is_Primitive_Wrapper;
......@@ -4387,6 +4396,13 @@ package body Einfo is
Set_Flag53 (Id, V);
end Set_Is_Private_Descendant;
procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
......@@ -5168,7 +5184,8 @@ package body Einfo is
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Procedure
pragma Assert ((Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure)
and then Is_Primitive_Wrapper (Id));
Set_Node27 (Id, V);
end Set_Wrapped_Entity;
......@@ -7597,9 +7614,11 @@ package body Einfo is
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
W ("Is_Protected_Interface", Flag198 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
......@@ -7666,7 +7685,6 @@ package body Einfo is
W ("Suppress_Init_Proc", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
W ("Is_Primitive", Flag218 (Id));
W ("Treat_As_Volatile", Flag41 (Id));
W ("Universal_Aliasing", Flag216 (Id));
W ("Used_As_Generic_Actual", Flag222 (Id));
......
gcc/ada/einfo.ads
......@@ -2513,9 +2513,9 @@ package Einfo is
-- indicators in bodies.
-- Is_Primitive_Wrapper (Flag195)
-- Present in all entities. Set for procedure entries that are used as
-- primitive wrappers. which are generated by the expander to wrap
-- entries of protected or task types implementing a limited interface.
-- Present in functions and procedures created by the expander to serve
-- as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures.
-- Is_Prival (synthesized)
-- Applies to all entities, true for renamings of private protected
......@@ -2533,6 +2533,10 @@ package Einfo is
-- functions, procedures). Set if the library unit is itself a private
-- child unit, or if it is the descendent of a private child unit.
-- Is_Private_Primitive (Flag245)
-- Present in subprograms. Set if the first parameter of the subprogram
-- is of concurrent tagged type with a private view.
-- Is_Private_Type (synthesized)
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes
......@@ -3723,8 +3727,8 @@ package Einfo is
-- attribute when the limited-view is installed (Ada 2005: AI-217).
-- Wrapped_Entity (Node27)
-- Present in an E_Procedure classified as an Is_Primitive_Wrapper. Set
-- to the entity that is being wrapped.
-- Present in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
------------------
-- Access Kinds --
......@@ -5013,6 +5017,7 @@ package Einfo is
-- Protection_Object (Node23) (for concurrent kind)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
......@@ -5039,7 +5044,9 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Thunk (Flag225)
-- Is_Visible_Child_Unit (Flag116)
......@@ -5305,6 +5312,7 @@ package Einfo is
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Thunk (Flag225)
-- Is_Valued_Procedure (Flag127)
......@@ -5974,6 +5982,7 @@ package Einfo is
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
......@@ -6538,6 +6547,7 @@ package Einfo is
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
procedure Set_Is_Protected_Interface (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
......@@ -7216,6 +7226,7 @@ package Einfo is
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Protected_Interface);
pragma Inline (Is_Protected_Type);
......@@ -7609,6 +7620,7 @@ package Einfo is
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
pragma Inline (Set_Is_Protected_Interface);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
......
gcc/ada/exp_ch9.adb
......@@ -152,29 +152,25 @@ package body Exp_Ch9 is
-- <formalN> : AnnN;
-- end record;
function Build_Wrapper_Body
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Proc_Nam : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id;
-- Ada 2005 (AI-345): Build the body that wraps a primitive operation
-- associated with a protected or task type. This is required to implement
-- dispatching calls through interfaces. Proc_Nam is the entry name to be
-- wrapped, Obj_Typ is the type of the newly added formal parameter to
-- handle object notation, Formals are the original entry formals that will
-- be explicitly replicated.
function Build_Wrapper_Spec
Typ : Entity_Id;
N : Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all bodies
-- will be placed. This routine builds the bodies of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new body is analyzed.
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Proc_Nam : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id;
-- Ada 2005 (AI-345): Build the specification of a primitive operation
-- associated with a protected or task type. This is required implement
-- dispatching calls through interfaces. Proc_Nam is the entry name to be
-- wrapped, Obj_Typ is the type of the newly added formal parameter to
-- handle object notation, Formals are the original entry formals that will
-- be explicitly replicated.
Typ : Entity_Id;
N : in out Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all specs
-- will be placed. This routine builds the specs of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new spec is analyzed.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
......@@ -359,6 +355,10 @@ package body Exp_Ch9 is
Lo : Node_Id;
Hi : Node_Id) return Boolean;
function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
-- Determine whether Id is a function or a procedure and is marked as a
-- private primitive.
function Null_Statements (Stats : List_Id) return Boolean;
-- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
-- Allows labels, and pragma Warnings/Unreferenced in the sequence as
......@@ -1541,33 +1541,60 @@ package body Exp_Ch9 is
return Rec_Nam;
end Build_Parameter_Block;
--------------------------
-- Build_Wrapper_Bodies --
--------------------------
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Typ : Entity_Id;
N : Node_Id)
is
Rec_Typ : Entity_Id;
function Build_Wrapper_Body
(Loc : Source_Ptr;
Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id;
-- Ada 2005 (AI-345): Build the body that wraps a primitive operation
-- associated with a protected or task type. Subp_Id is the subprogram
-- name which will be wrapped. Obj_Typ is the type of the new formal
-- parameter which handles dispatching and object notation. Formals are
-- the original formals of Subp_Id which will be explicitly replicated.
------------------------
-- Build_Wrapper_Body --
------------------------
function Build_Wrapper_Body
(Loc : Source_Ptr;
Proc_Nam : Entity_Id;
Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
Actuals : List_Id := No_List;
Body_Spec : Node_Id;
Conv_Id : Node_Id;
First_Formal : Node_Id;
Formal : Node_Id;
begin
Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals);
Body_Spec := Build_Wrapper_Spec (Loc, Subp_Id, Obj_Typ, Formals);
-- If we did not generate the specification do have nothing else to do
-- The subprogram is not overriding or is not a primitive declared
-- between two views.
if Body_Spec = Empty then
if No (Body_Spec) then
return Empty;
end if;
-- Map formals to actuals. Use the list built for the wrapper spec,
-- skipping the object notation parameter.
declare
Actuals : List_Id := No_List;
Conv_Id : Node_Id;
First_Formal : Node_Id;
Formal : Node_Id;
Nam : Node_Id;
begin
-- Map formals to actuals. Use the list built for the wrapper
-- spec, skipping the object notation parameter.
First_Formal := First (Parameter_Specifications (Body_Spec));
......@@ -1586,43 +1613,64 @@ package body Exp_Ch9 is
end loop;
end if;
-- An access-to-variable first parameter will require an explicit
-- dereference in the unchecked conversion. This case occurs when
-- a protected entry wrapper must override an interface-level
-- procedure with interface access as first parameter.
-- Special processing for primitives declared between a private
-- type and its completion.
if Is_Private_Primitive_Subprogram (Subp_Id) then
if No (Actuals) then
Actuals := New_List;
end if;
Prepend_To (Actuals,
Unchecked_Convert_To (
Corresponding_Concurrent_Type (Obj_Typ),
Make_Identifier (Loc, Name_uO)));
-- SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N)
Nam := New_Reference_To (Subp_Id, Loc);
if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then
else
-- An access-to-variable object parameter requires an explicit
-- dereference in the unchecked conversion. This case occurs
-- when a protected entry wrapper must override an interface
-- level procedure with interface access as first parameter.
-- O.all.Subp_Id (Formal_1 .. Formal_N)
if Nkind (Parameter_Type (First_Formal)) =
N_Access_Definition
then
Conv_Id :=
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Identifier (Loc, Chars => Name_uO));
Prefix => Make_Identifier (Loc, Name_uO));
else
Conv_Id :=
Make_Identifier (Loc, Chars => Name_uO);
Conv_Id := Make_Identifier (Loc, Name_uO);
end if;
if Ekind (Proc_Nam) = E_Function then
Nam :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
Corresponding_Concurrent_Type (Obj_Typ),
Conv_Id),
Selector_Name =>
New_Reference_To (Subp_Id, Loc));
end if;
-- Create the subprogram body
if Ekind (Subp_Id) = E_Function then
return
Make_Subprogram_Body (Loc,
Specification => Body_Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Make_Function_Call (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
Corresponding_Concurrent_Type (Obj_Typ),
Conv_Id),
Selector_Name =>
New_Reference_To (Proc_Nam, Loc)),
Name => Nam,
Parameter_Associations => Actuals)))));
else
return
Make_Subprogram_Body (Loc,
......@@ -1630,55 +1678,104 @@ package body Exp_Ch9 is
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
Corresponding_Concurrent_Type (Obj_Typ),
Conv_Id),
Selector_Name =>
New_Reference_To (Proc_Nam, Loc)),
Name => Nam,
Parameter_Associations => Actuals))));
end if;
end;
end Build_Wrapper_Body;
-- Start of processing for Build_Wrapper_Bodies
begin
if Is_Concurrent_Type (Typ) then
Rec_Typ := Corresponding_Record_Type (Typ);
else
Rec_Typ := Typ;
end if;
-- Generate wrapper bodies for a concurrent type which implements an
-- interface.
if Present (Interfaces (Rec_Typ)) then
declare
Insert_Nod : Node_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Decl : Node_Id;
Subp : Entity_Id;
Wrap_Body : Node_Id;
Wrap_Id : Entity_Id;
begin
Insert_Nod := N;
-- Examine all primitive operations of the corresponding record
-- type, looking for wrapper specs. Generate bodies in order to
-- complete them.
Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if (Ekind (Prim) = E_Function
or else Ekind (Prim) = E_Procedure)
and then Is_Primitive_Wrapper (Prim)
then
Subp := Wrapped_Entity (Prim);
Prim_Decl := Parent (Parent (Prim));
Wrap_Body :=
Build_Wrapper_Body (Loc,
Subp_Id => Subp,
Obj_Typ => Rec_Typ,
Formals => Parameter_Specifications (Parent (Subp)));
Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
Set_Corresponding_Spec (Wrap_Body, Prim);
Set_Corresponding_Body (Prim_Decl, Wrap_Id);
Insert_After (Insert_Nod, Wrap_Body);
Insert_Nod := Wrap_Body;
Analyze (Wrap_Body);
end if;
Next_Elmt (Prim_Elmt);
end loop;
end;
end if;
end Build_Wrapper_Bodies;
------------------------
-- Build_Wrapper_Spec --
------------------------
function Build_Wrapper_Spec
(Loc : Source_Ptr;
Proc_Nam : Entity_Id;
Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
New_Name_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Proc_Nam));
First_Param : Node_Id := Empty;
First_Param : Node_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id := No_Elmt;
New_Formals : List_Id;
Obj_Param : Node_Id;
Obj_Param_Typ : Node_Id;
Iface_Prim_Op : Entity_Id;
Iface_Prim_Op_Elmt : Elmt_Id;
Iface_Elmt : Elmt_Id;
Iface_Op : Entity_Id;
Iface_Op_Elmt : Elmt_Id;
function Overriding_Possible
(Iface_Prim_Op : Entity_Id;
Proc_Nam : Entity_Id) return Boolean;
-- Determine whether a primitive operation can be overridden by the
-- wrapper. Iface_Prim_Op is the candidate primitive operation of an
-- abstract interface type, Proc_Nam is the generated entry wrapper.
(Iface_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean;
-- Determine whether a primitive operation can be overridden by Wrapper.
-- Iface_Op is the candidate primitive operation of an interface type,
-- Wrapper is the generated entry wrapper.
function Replicate_Entry_Formals
function Replicate_Formals
(Loc : Source_Ptr;
Formals : List_Id) return List_Id;
-- An explicit parameter replication is required due to the
-- Is_Entry_Formal flag being set for all the formals. The explicit
-- An explicit parameter replication is required due to the Is_Entry_
-- Formal flag being set for all the formals of an entry. The explicit
-- replication removes the flag that would otherwise cause a different
-- path of analysis.
......@@ -1687,18 +1784,15 @@ package body Exp_Ch9 is
-------------------------
function Overriding_Possible
(Iface_Prim_Op : Entity_Id;
Proc_Nam : Entity_Id) return Boolean
(Iface_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean
is
Prim_Op_Spec : constant Node_Id := Parent (Iface_Prim_Op);
Proc_Spec : constant Node_Id := Parent (Proc_Nam);
Is_Access_To_Variable : Boolean;
Is_Out_Present : Boolean;
Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
Wrapper_Spec : constant Node_Id := Parent (Wrapper);
function Type_Conformant_Parameters
(Prim_Op_Param_Specs : List_Id;
Proc_Param_Specs : List_Id) return Boolean;
(Iface_Op_Params : List_Id;
Wrapper_Params : List_Id) return Boolean;
-- Determine whether the parameters of the generated entry wrapper
-- and those of a primitive operation are type conformant. During
-- this check, the first parameter of the primitive operation is
......@@ -1709,40 +1803,40 @@ package body Exp_Ch9 is
--------------------------------
function Type_Conformant_Parameters
(Prim_Op_Param_Specs : List_Id;
Proc_Param_Specs : List_Id) return Boolean
(Iface_Op_Params : List_Id;
Wrapper_Params : List_Id) return Boolean
is
Prim_Op_Param : Node_Id;
Prim_Op_Typ : Entity_Id;
Proc_Param : Node_Id;
Proc_Typ : Entity_Id;
Iface_Op_Param : Node_Id;
Iface_Op_Typ : Entity_Id;
Wrapper_Param : Node_Id;
Wrapper_Typ : Entity_Id;
begin
-- Skip the first parameter of the primitive operation
Prim_Op_Param := Next (First (Prim_Op_Param_Specs));
Proc_Param := First (Proc_Param_Specs);
while Present (Prim_Op_Param)
and then Present (Proc_Param)
Iface_Op_Param := Next (First (Iface_Op_Params));
Wrapper_Param := First (Wrapper_Params);
while Present (Iface_Op_Param)
and then Present (Wrapper_Param)
loop
Prim_Op_Typ := Find_Parameter_Type (Prim_Op_Param);
Proc_Typ := Find_Parameter_Type (Proc_Param);
Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
-- The two parameters must be mode conformant
if not Conforming_Types
(Prim_Op_Typ, Proc_Typ, Mode_Conformant)
(Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
then
return False;
end if;
Next (Prim_Op_Param);
Next (Proc_Param);
Next (Iface_Op_Param);
Next (Wrapper_Param);
end loop;
-- One of the lists is longer than the other
if Present (Prim_Op_Param) or else Present (Proc_Param) then
if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
return False;
end if;
......@@ -1752,47 +1846,42 @@ package body Exp_Ch9 is
-- Start of processing for Overriding_Possible
begin
if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then
if Chars (Iface_Op) /= Chars (Wrapper) then
return False;
end if;
-- Special check for protected procedures: If an inherited subprogram
-- is implemented by a protected procedure or an entry, then the
-- first parameter of the inherited subprogram shall be of mode OUT
-- or IN OUT, or an access-to-variable parameter.
if Ekind (Iface_Prim_Op) = E_Procedure then
-- If an inherited subprogram is implemented by a protected procedure
-- or an entry, then the first parameter of the inherited subprogram
-- shall be of mode OUT or IN OUT, or access-to-variable parameter.
Is_Out_Present :=
Present (Parameter_Specifications (Prim_Op_Spec))
and then
Out_Present (First (Parameter_Specifications (Prim_Op_Spec)));
Is_Access_To_Variable :=
Present (Parameter_Specifications (Prim_Op_Spec))
and then
Nkind (Parameter_Type
(First
(Parameter_Specifications (Prim_Op_Spec)))) =
N_Access_Definition;
if Ekind (Iface_Op) = E_Procedure
and then Present (Parameter_Specifications (Iface_Op_Spec))
then
declare
Obj_Param : constant Node_Id :=
First (Parameter_Specifications (Iface_Op_Spec));
if not Is_Out_Present
and then not Is_Access_To_Variable
begin
if not Out_Present (Obj_Param)
and then Nkind (Parameter_Type (Obj_Param)) /=
N_Access_Definition
then
return False;
end if;
end;
end if;
return Type_Conformant_Parameters (
Parameter_Specifications (Prim_Op_Spec),
Parameter_Specifications (Proc_Spec));
return
Type_Conformant_Parameters (
Parameter_Specifications (Iface_Op_Spec),
Parameter_Specifications (Wrapper_Spec));
end Overriding_Possible;
-----------------------------
-- Replicate_Entry_Formals --
-----------------------------
-----------------------
-- Replicate_Formals --
-----------------------
function Replicate_Entry_Formals
function Replicate_Formals
(Loc : Source_Ptr;
Formals : List_Id) return List_Id
is
......@@ -1802,6 +1891,14 @@ package body Exp_Ch9 is
begin
Formal := First (Formals);
-- Skip the object parameter when dealing with primitives declared
-- between two views.
if Is_Private_Primitive_Subprogram (Subp_Id) then
Formal := Next (Formal);
end if;
while Present (Formal) loop
-- Create an explicit copy of the entry parameter
......@@ -1835,104 +1932,99 @@ package body Exp_Ch9 is
end loop;
return New_Formals;
end Replicate_Entry_Formals;
end Replicate_Formals;
-- Start of processing for Build_Wrapper_Spec
begin
-- The mode is determined by the first parameter of the interface-level
-- procedure that the current entry is trying to override.
pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ)));
-- There is no point in building wrappers for non-tagged concurrent
-- types.
-- We must examine all the protected operations of the implemented
-- interfaces in order to discover a possible overriding candidate.
pragma Assert (Is_Tagged_Type (Obj_Typ));
Iface := Etype (First (Abstract_Interface_List (Obj_Typ)));
-- An entry or a protected procedure can override a routine where the
-- controlling formal is either IN OUT, OUT or is of access-to-variable
-- type. Since the wrapper must have the exact same signature as that of
-- the overridden subprogram, we try to find the overriding candidate
-- and use its controlling formal.
Examine_Parents : loop
if Present (Primitive_Operations (Iface)) then
Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Prim_Op_Elmt) loop
Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then
while Present (Alias (Iface_Prim_Op)) loop
Iface_Prim_Op := Alias (Iface_Prim_Op);
end loop;
First_Param := Empty;
-- The current primitive operation can be overridden by the
-- generated entry wrapper.
-- Check every implemented interface
if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
First_Param := First (Parameter_Specifications
(Parent (Iface_Prim_Op)));
goto Found;
end if;
end if;
Next_Elmt (Iface_Prim_Op_Elmt);
end loop;
end if;
exit Examine_Parents when Etype (Iface) = Iface;
Iface := Etype (Iface);
end loop Examine_Parents;
if Present (Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))))
then
Iface_Elmt := First_Elmt
(Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))));
Examine_Interfaces : while Present (Iface_Elmt) loop
if Present (Interfaces (Obj_Typ)) then
Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
Search : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- Check every interface primitive
if Present (Primitive_Operations (Iface)) then
Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Prim_Op_Elmt) loop
Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Iface_Op_Elmt) loop
Iface_Op := Node (Iface_Op_Elmt);
if not Is_Predefined_Dispatching_Operation
(Iface_Prim_Op)
then
while Present (Alias (Iface_Prim_Op)) loop
Iface_Prim_Op := Alias (Iface_Prim_Op);
end loop;
-- Ignore predefined primitives
if not Is_Predefined_Dispatching_Operation (Iface_Op) then
Iface_Op := Ultimate_Alias (Iface_Op);
-- The current primitive operation can be overridden by
-- the generated entry wrapper.
if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
First_Param := First (Parameter_Specifications
(Parent (Iface_Prim_Op)));
if Overriding_Possible (Iface_Op, Subp_Id) then
First_Param :=
First (Parameter_Specifications (Parent (Iface_Op)));
goto Found;
exit Search;
end if;
end if;
Next_Elmt (Iface_Prim_Op_Elmt);
Next_Elmt (Iface_Op_Elmt);
end loop;
end if;
Next_Elmt (Iface_Elmt);
end loop Examine_Interfaces;
end loop Search;
end if;
-- Return if no interface primitive can be overridden
-- If the subprogram to be wrapped is not overriding anything or is not
-- a primitive declared between two views, do not produce anything. This
-- avoids spurious errors involving overriding.
if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id)
then
return Empty;
end if;
<<Found>>
declare
Wrapper_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Subp_Id));
New_Formals : List_Id;
Obj_Param : Node_Id;
Obj_Param_Typ : Entity_Id;
New_Formals := Replicate_Entry_Formals (Loc, Formals);
begin
-- Minimum decoration is needed to catch the entity in
-- Sem_Ch6.Override_Dispatching_Operation.
-- ??? Certain source packages contain protected or task types that do
-- not implement any interfaces and are compiled with the -gnat05
-- switch. In this case, a default first parameter is created.
if Ekind (Subp_Id) = E_Function then
Set_Ekind (Wrapper_Id, E_Function);
else
Set_Ekind (Wrapper_Id, E_Procedure);
end if;
Set_Is_Primitive_Wrapper (Wrapper_Id);
Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
Set_Is_Private_Primitive (Wrapper_Id,
Is_Private_Primitive_Subprogram (Subp_Id));
-- Process the formals
New_Formals := Replicate_Formals (Loc, Formals);
-- Routine Subp_Id has been found to override an interface primitive.
-- If the interface operation has an access parameter, create a copy
-- of it, with the same null exclusion indicator if present.
......@@ -1957,45 +2049,112 @@ package body Exp_Ch9 is
Out_Present => Out_Present (First_Param),
Parameter_Type => Obj_Param_Typ);
else
-- If we are dealing with a primitive declared between two views,
-- create a default parameter.
else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
Obj_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
In_Present => True,
Out_Present => True,
Out_Present => Ekind (Subp_Id) /= E_Function,
Parameter_Type => New_Reference_To (Obj_Typ, Loc));
end if;
Prepend_To (New_Formals, Obj_Param);
-- Minimum decoration needed to catch the entity in
-- Sem_Ch6.Override_Dispatching_Operation
if Ekind (Proc_Nam) = E_Procedure
or else Ekind (Proc_Nam) = E_Entry
then
Set_Ekind (New_Name_Id, E_Procedure);
Set_Is_Primitive_Wrapper (New_Name_Id);
Set_Wrapped_Entity (New_Name_Id, Proc_Nam);
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => New_Name_Id,
Parameter_Specifications => New_Formals);
else pragma Assert (Ekind (Proc_Nam) = E_Function);
Set_Ekind (New_Name_Id, E_Function);
-- Build the final spec
if Ekind (Subp_Id) = E_Function then
return
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Name_Id,
Defining_Unit_Name => Wrapper_Id,
Parameter_Specifications => New_Formals,
Result_Definition =>
New_Copy (Result_Definition (Parent (Proc_Nam))));
New_Copy (Result_Definition (Parent (Subp_Id))));
else
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Wrapper_Id,
Parameter_Specifications => New_Formals);
end if;
end;
end Build_Wrapper_Spec;
-------------------------
-- Build_Wrapper_Specs --
-------------------------
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Typ : Entity_Id;
N : in out Node_Id)
is
Def : Node_Id;
Rec_Typ : Entity_Id;
begin
if Is_Protected_Type (Typ) then
Def := Protected_Definition (Parent (Typ));
else pragma Assert (Is_Task_Type (Typ));
Def := Task_Definition (Parent (Typ));
end if;
Rec_Typ := Corresponding_Record_Type (Typ);
-- Generate wrapper specs for a concurrent type which implements an
-- interface and has visible entries and/or protected procedures.
if Present (Interfaces (Rec_Typ))
and then Present (Def)
and then Present (Visible_Declarations (Def))
then
declare
Decl : Node_Id;
Wrap_Decl : Node_Id;
Wrap_Spec : Node_Id;
begin
Decl := First (Visible_Declarations (Def));
while Present (Decl) loop
Wrap_Spec := Empty;
if Nkind (Decl) = N_Entry_Declaration
and then Ekind (Defining_Identifier (Decl)) = E_Entry
then
Wrap_Spec :=
Build_Wrapper_Spec (Loc,
Subp_Id => Defining_Identifier (Decl),
Obj_Typ => Rec_Typ,
Formals => Parameter_Specifications (Decl));
elsif Nkind (Decl) = N_Subprogram_Declaration then
Wrap_Spec :=
Build_Wrapper_Spec (Loc,
Subp_Id => Defining_Unit_Name (Specification (Decl)),
Obj_Typ => Rec_Typ,
Formals =>
Parameter_Specifications (Specification (Decl)));
end if;
if Present (Wrap_Spec) then
Wrap_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Wrap_Spec);
Insert_After (N, Wrap_Decl);
N := Wrap_Decl;
Analyze (Wrap_Decl);
end if;
Next (Decl);
end loop;
end;
end if;
end Build_Wrapper_Specs;
---------------------------
-- Build_Find_Body_Index --
---------------------------
......@@ -6903,13 +7062,13 @@ package body Exp_Ch9 is
procedure Expand_N_Protected_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N);
Op_Body : Node_Id;
Op_Decl : Node_Id;
Op_Id : Entity_Id;
Current_Node : Node_Id;
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
Current_Node : Node_Id;
Num_Entries : Natural := 0;
Op_Body : Node_Id;
Op_Decl : Node_Id;
Op_Id : Entity_Id;
function Build_Dispatching_Subprogram_Body
(N : Node_Id;
......@@ -7002,14 +7161,12 @@ package body Exp_Ch9 is
return;
end if;
if Nkind (Parent (N)) = N_Subunit then
-- This is the proper body corresponding to a stub. The declarations
-- must be inserted at the point of the stub, which is in the decla-
-- rative part of the parent unit.
-- must be inserted at the point of the stub, which in turn is in the
-- declarative part of the parent unit.
if Nkind (Parent (N)) = N_Subunit then
Current_Node := Corresponding_Stub (Parent (N));
else
Current_Node := N;
end if;
......@@ -7171,63 +7328,12 @@ package body Exp_Ch9 is
Analyze (New_Op_Body);
end if;
-- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
-- the protected body. At this point the entry specs have been created,
-- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
-- protected body. At this point all wrapper specs have been created,
-- frozen and included in the dispatch table for the protected type.
pragma Assert (Present (Corresponding_Record_Type (Pid)));
if Ada_Version >= Ada_05
and then Present (Protected_Definition (Parent (Pid)))
and then Present (Interfaces (Corresponding_Record_Type (Pid)))
then
declare
Vis_Decl : Node_Id :=
First (Visible_Declarations
(Protected_Definition (Parent (Pid))));
Wrap_Body : Node_Id;
begin
-- Examine the visible declarations of the protected type, looking
-- for an entry declaration. We do not consider entry families
-- since they cannot have dispatching operations, thus they do not
-- need entry wrappers.
while Present (Vis_Decl) loop
if Nkind (Vis_Decl) = N_Entry_Declaration then
Wrap_Body :=
Build_Wrapper_Body (Loc,
Proc_Nam => Defining_Identifier (Vis_Decl),
Obj_Typ => Corresponding_Record_Type (Pid),
Formals => Parameter_Specifications (Vis_Decl));
if Wrap_Body /= Empty then
Insert_After (Current_Node, Wrap_Body);
Current_Node := Wrap_Body;
Analyze (Wrap_Body);
end if;
elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
Wrap_Body :=
Build_Wrapper_Body (Loc,
Proc_Nam => Defining_Unit_Name
(Specification (Vis_Decl)),
Obj_Typ => Corresponding_Record_Type (Pid),
Formals => Parameter_Specifications
(Specification (Vis_Decl)));
if Wrap_Body /= Empty then
Insert_After (Current_Node, Wrap_Body);
Current_Node := Wrap_Body;
Analyze (Wrap_Body);
end if;
end if;
Next (Vis_Decl);
end loop;
end;
if Ada_Version >= Ada_05 then
Build_Wrapper_Bodies (Loc, Pid, Current_Node);
end if;
end Expand_N_Protected_Body;
......@@ -7625,67 +7731,11 @@ package body Exp_Ch9 is
Analyze (Rec_Decl, Suppress => All_Checks);
-- Ada 2005 (AI-345): Construct the primitive entry wrappers before
-- the corresponding record is frozen
-- the corresponding record is frozen. If any wrappers are generated,
-- Current_Node is updated accordingly.
if Ada_Version >= Ada_05
and then Present (Visible_Declarations (Pdef))
and then Present (Corresponding_Record_Type
(Defining_Identifier (Parent (Pdef))))
and then Present (Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Pdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
Vis_Decl : Node_Id;
Wrap_Spec : Node_Id;
New_N : Node_Id;
begin
-- Examine the visible declarations of the protected type, looking
-- for declarations of entries, and subprograms. We do not
-- consider entry families since they cannot have dispatching
-- operations, thus they do not need entry wrappers.
Vis_Decl := First (Visible_Declarations (Pdef));
while Present (Vis_Decl) loop
Wrap_Spec := Empty;
if Nkind (Vis_Decl) = N_Entry_Declaration
and then No (Discrete_Subtype_Definition (Vis_Decl))
then
Wrap_Spec :=
Build_Wrapper_Spec (Loc,
Proc_Nam => Defining_Identifier (Vis_Decl),
Obj_Typ => Defining_Identifier (Rec_Decl),
Formals => Parameter_Specifications (Vis_Decl));
elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
Wrap_Spec :=
Build_Wrapper_Spec (Loc,
Proc_Nam => Defining_Unit_Name
(Specification (Vis_Decl)),
Obj_Typ => Defining_Identifier (Rec_Decl),
Formals => Parameter_Specifications
(Specification (Vis_Decl)));
end if;
if Wrap_Spec /= Empty then
New_N := Make_Subprogram_Declaration (Loc,
Specification => Wrap_Spec);
Insert_After (Current_Node, New_N);
Current_Node := New_N;
Analyze (New_N);
end if;
Next (Vis_Decl);
end loop;
end;
if Ada_Version >= Ada_05 then
Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
end if;
-- Collect pointers to entry bodies and their barriers, to be placed
......@@ -7694,9 +7744,7 @@ package body Exp_Ch9 is
-- this array. The array is declared after all protected subprograms.
if Has_Entries (Prot_Typ) then
Entries_Aggr :=
Make_Aggregate (Loc, Expressions => New_List);
Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
else
Entries_Aggr := Empty;
end if;
......@@ -9461,6 +9509,9 @@ package body Exp_Ch9 is
Call : Node_Id;
New_N : Node_Id;
Insert_Nod : Node_Id;
-- Used to determine the proper location of wrapper body insertions
begin
-- Add renaming declarations for discriminals and a declaration for the
-- entry family index (if applicable).
......@@ -9527,56 +9578,17 @@ package body Exp_Ch9 is
end if;
-- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
-- the task body. At this point the entry specs have been created,
-- the task body. At this point all wrapper specs have been created,
-- frozen and included in the dispatch table for the task type.
pragma Assert (Present (Corresponding_Record_Type (Ttyp)));
if Ada_Version >= Ada_05
and then Present (Task_Definition (Parent (Ttyp)))
and then Present (Interfaces (Corresponding_Record_Type (Ttyp)))
then
declare
Current_Node : Node_Id;
Vis_Decl : Node_Id :=
First (Visible_Declarations (Task_Definition (Parent (Ttyp))));
Wrap_Body : Node_Id;
begin
if Ada_Version >= Ada_05 then
if Nkind (Parent (N)) = N_Subunit then
Current_Node := Corresponding_Stub (Parent (N));
Insert_Nod := Corresponding_Stub (Parent (N));
else
Current_Node := N;
end if;
-- Examine the visible declarations of the task type, looking for
-- an entry declaration. We do not consider entry families since
-- they cannot have dispatching operations, thus they do not need
-- entry wrappers.
while Present (Vis_Decl) loop
if Nkind (Vis_Decl) = N_Entry_Declaration
and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
then
-- Create the specification of the wrapper
Wrap_Body :=
Build_Wrapper_Body (Loc,
Proc_Nam => Defining_Identifier (Vis_Decl),
Obj_Typ => Corresponding_Record_Type (Ttyp),
Formals => Parameter_Specifications (Vis_Decl));
if Wrap_Body /= Empty then
Insert_After (Current_Node, Wrap_Body);
Current_Node := Wrap_Body;
Analyze (Wrap_Body);
end if;
Insert_Nod := N;
end if;
Next (Vis_Decl);
end loop;
end;
Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
end if;
end Expand_N_Task_Body;
......@@ -10025,51 +10037,8 @@ package body Exp_Ch9 is
-- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
-- the corresponding record has been frozen.
if Ada_Version >= Ada_05
and then Present (Taskdef)
and then Present (Corresponding_Record_Type
(Defining_Identifier (Parent (Taskdef))))
and then Present (Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Taskdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
Vis_Decl : Node_Id := First (Visible_Declarations (Taskdef));
Wrap_Spec : Node_Id;
New_N : Node_Id;
begin
-- Examine the visible declarations of the task type, looking for
-- an entry declaration. We do not consider entry families since
-- they cannot have dispatching operations, thus they do not need
-- entry wrappers.
while Present (Vis_Decl) loop
if Nkind (Vis_Decl) = N_Entry_Declaration
and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
then
Wrap_Spec :=
Build_Wrapper_Spec (Loc,
Proc_Nam => Defining_Identifier (Vis_Decl),
Obj_Typ => Etype (Rec_Ent),
Formals => Parameter_Specifications (Vis_Decl));
if Wrap_Spec /= Empty then
New_N :=
Make_Subprogram_Declaration (Loc,
Specification => Wrap_Spec);
Insert_After (Current_Node, New_N);
Current_Node := New_N;
Analyze (New_N);
end if;
end if;
Next (Vis_Decl);
end loop;
end;
if Ada_Version >= Ada_05 then
Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
end if;
-- Ada 2005 (AI-345): We must defer freezing to allow further
......@@ -11408,6 +11377,17 @@ package body Exp_Ch9 is
or else Denotes_Discriminant (Hi, True));
end Is_Potentially_Large_Family;
-------------------------------------
-- Is_Private_Primitive_Subprogram --
-------------------------------------
function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
begin
return
(Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
and then Is_Private_Primitive (Id);
end Is_Private_Primitive_Subprogram;
------------------
-- Index_Object --
------------------
......
gcc/ada/exp_ch9.ads
......@@ -153,6 +153,18 @@ package Exp_Ch9 is
-- aggregate. It replaces the call to Init (Args) done by
-- Build_Task_Allocate_Block.
function Build_Wrapper_Spec
(Loc : Source_Ptr;
Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id;
-- Ada 2005 (AI-345): Build the specification of a primitive operation
-- associated with a protected or task type. This is required to implement
-- dispatching calls through interfaces. Subp_Id is the primitive to be
-- wrapped, Obj_Typ is the type of the newly added formal parameter to
-- handle object notation, Formals are the original entry formals that
-- will be explicitly replicated.
function Concurrent_Ref (N : Node_Id) return Node_Id;
-- Given the name of a concurrent object (task or protected object), or
-- the name of an access to a concurrent object, this function returns an
......
gcc/ada/sem_ch3.adb
......@@ -31,6 +31,7 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
......@@ -15811,48 +15812,117 @@ package body Sem_Ch3 is
-- If the private view was tagged, copy the new primitive operations
-- from the private view to the full view.
-- Note: Subprograms covering interface primitives were previously
-- propagated to the full view by Derive_Progenitor_Primitives
if Is_Tagged_Type (Full_T)
and then not Is_Concurrent_Type (Full_T)
then
if Is_Tagged_Type (Full_T) then
declare
Priv_List : Elist_Id;
Full_List : constant Elist_Id := Primitive_Operations (Full_T);
P1, P2 : Elmt_Id;
Disp_Typ : Entity_Id;
Full_List : Elist_Id;
Prim : Entity_Id;
D_Type : Entity_Id;
Prim_Elmt : Elmt_Id;
Priv_List : Elist_Id;
function Contains
(E : Entity_Id;
L : Elist_Id) return Boolean;
-- Determine whether list L contains element E
--------------
-- Contains --
--------------
function Contains
(E : Entity_Id;
L : Elist_Id) return Boolean
is
List_Elmt : Elmt_Id;
begin
List_Elmt := First_Elmt (L);
while Present (List_Elmt) loop
if Node (List_Elmt) = E then
return True;
end if;
Next_Elmt (List_Elmt);
end loop;
return False;
end Contains;
-- Start of processing
begin
if Is_Tagged_Type (Priv_T) then
Priv_List := Primitive_Operations (Priv_T);
Prim_Elmt := First_Elmt (Priv_List);
P1 := First_Elmt (Priv_List);
while Present (P1) loop
Prim := Node (P1);
-- In the case of a concurrent type completing a private tagged
-- type, primivies may have been declared in between the two
-- views. These subprograms need to be wrapped the same way
-- entries and protected procedures are handled because they
-- cannot be directly shared by the two views.
-- Transfer explicit primitives, not those inherited from
-- parent of partial view, which will be re-inherited on
-- the full view.
if Is_Concurrent_Type (Full_T) then
declare
Conc_Typ : constant Entity_Id :=
Corresponding_Record_Type (Full_T);
Loc : constant Source_Ptr := Sloc (Conc_Typ);
Curr_Nod : Node_Id := Parent (Conc_Typ);
Wrap_Spec : Node_Id;
begin
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Comes_From_Source (Prim)
and then not Is_Abstract_Subprogram (Prim)
then
Wrap_Spec :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Wrapper_Spec (Loc,
Subp_Id => Prim,
Obj_Typ => Conc_Typ,
Formals =>
Parameter_Specifications (
Parent (Prim))));
if Comes_From_Source (Prim) then
P2 := First_Elmt (Full_List);
while Present (P2) and then Node (P2) /= Prim loop
Next_Elmt (P2);
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
end if;
Next_Elmt (Prim_Elmt);
end loop;
-- If not found, that is a new one
return;
end;
-- For non-concurrent types, transfer explicit primitives, but
-- omit those inherited from the parent of the private view
-- since they will be re-inherited later on.
else
Full_List := Primitive_Operations (Full_T);
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if No (P2) then
if Comes_From_Source (Prim)
and then not Contains (Prim, Full_List)
then
Append_Elmt (Prim, Full_List);
end if;
end if;
Next_Elmt (P1);
Next_Elmt (Prim_Elmt);
end loop;
end if;
-- Untagged private view
else
Full_List := Primitive_Operations (Full_T);
-- In this case the partial view is untagged, so here we locate
-- all of the earlier primitives that need to be treated as
-- dispatching (those that appear between the two views). Note
......@@ -15871,10 +15941,9 @@ package body Sem_Ch3 is
or else
Ekind (Prim) = E_Function
then
Disp_Typ := Find_Dispatching_Type (Prim);
D_Type := Find_Dispatching_Type (Prim);
if D_Type = Full_T
if Disp_Typ = Full_T
and then (Chars (Prim) /= Name_Op_Ne
or else Comes_From_Source (Prim))
then
......@@ -15887,13 +15956,13 @@ package body Sem_Ch3 is
end if;
elsif Is_Dispatching_Operation (Prim)
and then D_Type /= Full_T
and then Disp_Typ /= Full_T
then
-- Verify that it is not otherwise controlled by a
-- formal or a return value of type T.
Check_Controlling_Formals (D_Type, Prim);
Check_Controlling_Formals (Disp_Typ, Prim);
end if;
end if;
......
gcc/ada/sem_ch6.adb
......@@ -1306,6 +1306,17 @@ package body Sem_Ch6 is
-- If pragma does not appear after the body, check whether there is
-- an inline pragma before any local declarations.
function Disambiguate_Spec return Entity_Id;
-- When a primitive is declared between the private view and the full
-- view of a concurrent type which implements an interface, a special
-- mechanism is used to find the corresponding spec of the primitive
-- body.
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view.
procedure Set_Trivial_Subprogram (N : Node_Id);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the
-- subprogram whose body is being analyzed. N is the statement node
......@@ -1457,6 +1468,128 @@ package body Sem_Ch6 is
end if;
end Check_Inline_Pragma;
-----------------------
-- Disambiguate_Spec --
-----------------------
function Disambiguate_Spec return Entity_Id is
Priv_Spec : Entity_Id;
Spec_N : Entity_Id;
procedure Replace_Types (To_Corresponding : Boolean);
-- Depending on the flag, replace the type of formal parameters of
-- Body_Id if it is a concurrent type implementing interfaces with
-- the corresponding record type or the other way around.
procedure Replace_Types (To_Corresponding : Boolean) is
Formal : Entity_Id;
Formal_Typ : Entity_Id;
begin
Formal := First_Formal (Body_Id);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
-- From concurrent type to corresponding record
if To_Corresponding then
if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Interfaces (
Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
end if;
-- From corresponding record to concurrent type
else
if Is_Concurrent_Record_Type (Formal_Typ)
and then Present (Interfaces (Formal_Typ))
then
Set_Etype (Formal,
Corresponding_Concurrent_Type (Formal_Typ));
end if;
end if;
Next_Formal (Formal);
end loop;
end Replace_Types;
-- Start of processing for Disambiguate_Spec
begin
-- Try to retrieve the specification of the body as is. All error
-- messages are suppressed because the body may not have a spec in
-- its current state.
Spec_N := Find_Corresponding_Spec (N, False);
-- It is possible that this is the body of a primitive declared
-- between a private and a full view of a concurrent type. The
-- controlling parameter of the spec carries the concurrent type,
-- not the corresponding record type as transformed by Analyze_
-- Subprogram_Specification. In such cases, we undo the change
-- made by the analysis of the specification and try to find the
-- spec again.
if No (Spec_N) then
-- Restore all references of corresponding record types to the
-- original concurrent types.
Replace_Types (To_Corresponding => False);
Priv_Spec := Find_Corresponding_Spec (N, False);
-- The current body truly belongs to a primitive declared between
-- a private and a full view. We leave the modified body as is,
-- and return the true spec.
if Present (Priv_Spec)
and then Is_Private_Primitive (Priv_Spec)
then
return Priv_Spec;
end if;
-- In case that this is some sort of error, restore the original
-- state of the body.
Replace_Types (To_Corresponding => True);
end if;
return Spec_N;
end Disambiguate_Spec;
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean
is
Formal_Typ : Entity_Id;
begin
if Present (First_Formal (Subp_Id)) then
Formal_Typ := Etype (First_Formal (Subp_Id));
if Is_Concurrent_Record_Type (Formal_Typ) then
Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
end if;
-- The type of the first formal is a concurrent tagged type with
-- a private view.
return
Is_Concurrent_Type (Formal_Typ)
and then Is_Tagged_Type (Formal_Typ)
and then Has_Private_Declaration (Formal_Typ);
end if;
return False;
end Is_Private_Concurrent_Primitive;
----------------------------
-- Set_Trivial_Subprogram --
----------------------------
......@@ -1581,7 +1714,11 @@ package body Sem_Ch6 is
if Nkind (N) = N_Subprogram_Body_Stub
or else No (Corresponding_Spec (N))
then
if Is_Private_Concurrent_Primitive (Body_Id) then
Spec_Id := Disambiguate_Spec;
else
Spec_Id := Find_Corresponding_Spec (N);
end if;
-- If this is a duplicate body, no point in analyzing it
......@@ -2322,6 +2459,22 @@ package body Sem_Ch6 is
New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator);
-- If the type of the first formal of the current subprogram is a non
-- generic tagged private type , mark the subprogram as being a private
-- primitive.
if Present (First_Formal (Designator)) then
declare
Formal_Typ : constant Entity_Id :=
Etype (First_Formal (Designator));
begin
Set_Is_Private_Primitive (Designator,
Is_Tagged_Type (Formal_Typ)
and then Is_Private_Type (Formal_Typ)
and then not Is_Generic_Actual_Type (Formal_Typ));
end;
end if;
-- Ada 2005 (AI-251): Abstract interface primitives must be abstract
-- or null.
......@@ -2435,8 +2588,6 @@ package body Sem_Ch6 is
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
Designator : constant Entity_Id := Defining_Entity (N);
Formals : constant List_Id := Parameter_Specifications (N);
Formal : Entity_Id;
Formal_Typ : Entity_Id;
-- Start of processing for Analyze_Subprogram_Specification
......@@ -2466,21 +2617,29 @@ package body Sem_Ch6 is
-- record, to match the proper signature of an overriding operation.
if Ada_Version >= Ada_05 then
declare
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Rec_Typ : Entity_Id;
begin
Formal := First_Formal (Designator);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Interfaces
(Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
Rec_Typ := Corresponding_Record_Type (Formal_Typ);
if Present (Interfaces (Rec_Typ)) then
Set_Etype (Formal, Rec_Typ);
end if;
end if;
Formal := Next_Formal (Formal);
Next_Formal (Formal);
end loop;
end;
end if;
End_Scope;
......@@ -5161,7 +5320,10 @@ package body Sem_Ch6 is
-- Find_Corresponding_Spec --
-----------------------------
function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
function Find_Corresponding_Spec
(N : Node_Id;
Post_Error : Boolean := True) return Entity_Id
is
Spec : constant Node_Id := Specification (N);
Designator : constant Entity_Id := Defining_Entity (Spec);
......@@ -5205,7 +5367,6 @@ package body Sem_Ch6 is
end if;
if not Has_Completion (E) then
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, E);
end if;
......@@ -5250,14 +5411,15 @@ package body Sem_Ch6 is
return Empty;
end if;
-- If body already exists, this is an error unless the
-- previous declaration is the implicit declaration of
-- a derived subprogram, or this is a spurious overloading
-- in an instance.
-- If the body already exists, then this is an error unless
-- the previous declaration is the implicit declaration of a
-- derived subprogram, or this is a spurious overloading in an
-- instance.
elsif No (Alias (E))
and then not Is_Intrinsic_Subprogram (E)
and then not In_Instance
and then Post_Error
then
Error_Msg_Sloc := Sloc (E);
if Is_Imported (E) then
......@@ -5269,16 +5431,17 @@ package body Sem_Ch6 is
end if;
end if;
-- Child units cannot be overloaded, so a conformance mismatch
-- between body and a previous spec is an error.
elsif Is_Child_Unit (E)
and then
Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
and then
Nkind (Parent (Unit_Declaration_Node (Designator))) =
N_Compilation_Unit
and then Post_Error
then
-- Child units cannot be overloaded, so a conformance mismatch
-- between body and a previous spec is an error.
Error_Msg_N
("body of child unit does not match previous declaration", N);
end if;
......
gcc/ada/sem_ch6.ads
......@@ -136,8 +136,8 @@ package Sem_Ch6 is
Get_Inst : Boolean := False) return Boolean;
-- Check that the types of two formal parameters are conforming. In most
-- cases this is just a name comparison, but within an instance it involves
-- generic actual types, and in the presence of anonymous access types
-- it must examine the designated types.
-- generic actual types, and in the presence of anonymous access types it
-- must examine the designated types.
procedure Create_Extra_Formals (E : Entity_Id);
-- For each parameter of a subprogram or entry that requires an additional
......@@ -147,7 +147,9 @@ package Sem_Ch6 is
-- the end of Subp's parameter list (with each subsequent extra formal
-- being attached to the preceding extra formal).
function Find_Corresponding_Spec (N : Node_Id) return Entity_Id;
function Find_Corresponding_Spec
(N : Node_Id;
Post_Error : Boolean := True) return Entity_Id;
-- Use the subprogram specification in the body to retrieve the previous
-- subprogram declaration, if any.
......
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