[Ada] Completion of private types with synchronized types
Arnaud Charlet
charlet@adacore.com
Wed Jul 30 16:44:00 GMT 2008
This patch adds code to properly handle any primitives declared between the
private and the full view of a concurrent type that implements an interface.
Such primitives receive wrappers similar to those used for protected procedures
and entries to ensure proper overriding of interface primitives.
Source:
package Types is
type Task_Iface is task interface;
procedure Stop (Obj : in out Task_Iface) is abstract;
procedure Wink (Obj : in out Task_Iface) is abstract;
type T is synchronized new Task_Iface with private;
procedure Prev (Obj : in out T);
procedure Wink (Obj : in out T);
private
task type T is new Task_Iface with
entry Stop;
end T;
procedure Post (Obj : in out T);
end Types;
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
task body T is
begin
accept Stop do
Put_Line ("Stop");
end Stop;
end T;
procedure Prev (Obj : in out T) is
begin
Put_Line ("Prev");
end Prev;
procedure Post (Obj : in out T) is
begin
Put_Line ("Post");
end Post;
procedure Wink (Obj : in out T) is
begin
Put_Line ("Wink");
end Wink;
end Types;
with Types; use Types;
procedure Test1 is
procedure Dispatch_Wink (Obj : in out Task_Iface'Class);
procedure Dispatch_Stop (Obj : in out Task_Iface'Class);
procedure Dispatch_Wink (Obj : in out Task_Iface'Class) is
begin
Obj.Wink;
end Dispatch_Wink;
procedure Dispatch_Stop (Obj : in out Task_Iface'Class) is
begin
Obj.Stop;
end Dispatch_Stop;
Obj_T : T;
begin
Prev (Obj_T);
Dispatch_Wink (Obj_T);
Dispatch_Stop (Obj_T);
end Test1;
Compilation:
gnatmake -q -gnat05 test1.adb
Execution and output:
$ ./test1
Prev
Wink
Stop
Tested on i686-pc-linux-gnu, committed on trunk.
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.
-------------- next part --------------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 138305)
+++ einfo.adb (working copy)
@@ -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,8 +2709,9 @@ package body Einfo is
function Wrapped_Entity (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Procedure
- and then Is_Primitive_Wrapper (Id));
+ 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,8 +5184,9 @@ package body Einfo is
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Procedure
- and then Is_Primitive_Wrapper (Id));
+ 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));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 138305)
+++ einfo.ads (working copy)
@@ -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);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 138305)
+++ exp_ch9.adb (working copy)
@@ -152,29 +152,25 @@ package body Exp_Ch9 is
-- <formalN> : AnnN;
-- end record;
- function Build_Wrapper_Body
- (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.
+ procedure Build_Wrapper_Bodies
+ (Loc : Source_Ptr;
+ 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.
- function Build_Wrapper_Spec
- (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.
+ procedure Build_Wrapper_Specs
+ (Loc : Source_Ptr;
+ 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,144 +1541,241 @@ package body Exp_Ch9 is
return Rec_Nam;
end Build_Parameter_Block;
- ------------------------
- -- Build_Wrapper_Body --
- ------------------------
+ --------------------------
+ -- Build_Wrapper_Bodies --
+ --------------------------
- function Build_Wrapper_Body
- (Loc : Source_Ptr;
- Proc_Nam : Entity_Id;
- Obj_Typ : Entity_Id;
- Formals : List_Id) return Node_Id
+ procedure Build_Wrapper_Bodies
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ N : Node_Id)
is
- Actuals : List_Id := No_List;
- Body_Spec : Node_Id;
- Conv_Id : Node_Id;
- First_Formal : Node_Id;
- Formal : Node_Id;
+ Rec_Typ : Entity_Id;
- begin
- Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals);
+ 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 --
+ ------------------------
- -- If we did not generate the specification do have nothing else to do
+ function Build_Wrapper_Body
+ (Loc : Source_Ptr;
+ Subp_Id : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Formals : List_Id) return Node_Id
+ is
+ Body_Spec : Node_Id;
- if Body_Spec = Empty then
- return Empty;
- end if;
+ begin
+ Body_Spec := Build_Wrapper_Spec (Loc, Subp_Id, Obj_Typ, Formals);
- -- Map formals to actuals. Use the list built for the wrapper spec,
- -- skipping the object notation parameter.
+ -- The subprogram is not overriding or is not a primitive declared
+ -- between two views.
- First_Formal := First (Parameter_Specifications (Body_Spec));
+ if No (Body_Spec) then
+ return Empty;
+ end if;
- Formal := First_Formal;
- Next (Formal);
+ declare
+ Actuals : List_Id := No_List;
+ Conv_Id : Node_Id;
+ First_Formal : Node_Id;
+ Formal : Node_Id;
+ Nam : Node_Id;
- if Present (Formal) then
- Actuals := New_List;
+ begin
+ -- Map formals to actuals. Use the list built for the wrapper
+ -- spec, skipping the object notation parameter.
- while Present (Formal) loop
- Append_To (Actuals,
- Make_Identifier (Loc, Chars =>
- Chars (Defining_Identifier (Formal))));
+ First_Formal := First (Parameter_Specifications (Body_Spec));
+ Formal := First_Formal;
Next (Formal);
- 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.
-
- -- SubprgName (O.all).Proc_Nam (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));
+ if Present (Formal) then
+ Actuals := New_List;
+
+ while Present (Formal) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars =>
+ Chars (Defining_Identifier (Formal))));
+
+ Next (Formal);
+ end loop;
+ end if;
+
+ -- 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)));
+
+ Nam := New_Reference_To (Subp_Id, Loc);
+
+ 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, Name_uO));
+ else
+ Conv_Id := Make_Identifier (Loc, Name_uO);
+ end if;
+
+ 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 (
+ Make_Simple_Return_Statement (Loc,
+ Make_Function_Call (Loc,
+ Name => Nam,
+ Parameter_Associations => Actuals)))));
+
+ else
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (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
- Conv_Id :=
- Make_Identifier (Loc, Chars => Name_uO);
+ Rec_Typ := Typ;
end if;
- if Ekind (Proc_Nam) = 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 (
- 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)),
- Parameter_Associations => Actuals)))));
- else
- return
- Make_Subprogram_Body (Loc,
- Specification => Body_Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- 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)),
- Parameter_Associations => Actuals))));
+ -- 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_Body;
+ end Build_Wrapper_Bodies;
------------------------
-- Build_Wrapper_Spec --
------------------------
function Build_Wrapper_Spec
- (Loc : Source_Ptr;
- Proc_Nam : Entity_Id;
- Obj_Typ : Entity_Id;
- Formals : List_Id) return Node_Id
+ (Loc : Source_Ptr;
+ 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;
- 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;
+ First_Param : Node_Id;
+ Iface : Entity_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
-
- 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 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.
- if not Is_Out_Present
- and then not Is_Access_To_Variable
- then
- return False;
- end if;
+ 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));
+
+ 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,166 +1932,228 @@ 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)));
-
- -- We must examine all the protected operations of the implemented
- -- interfaces in order to discover a possible overriding candidate.
-
- Iface := Etype (First (Abstract_Interface_List (Obj_Typ)));
-
- 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);
+ -- There is no point in building wrappers for non-tagged concurrent
+ -- types.
- 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;
+ pragma Assert (Is_Tagged_Type (Obj_Typ));
- -- The current primitive operation can be overridden by the
- -- generated entry wrapper.
+ -- 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.
- if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
- First_Param := First (Parameter_Specifications
- (Parent (Iface_Prim_Op)));
+ First_Param := Empty;
- goto Found;
- end if;
- end if;
+ -- Check every implemented interface
- 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.
- return Empty;
+ 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;
- -- If the interface operation has an access parameter, create a copy
- -- of it, with the same null exclusion indicator if present.
+ 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));
- if Present (First_Param) then
- if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
- Obj_Param_Typ :=
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Reference_To (Obj_Typ, Loc));
- Set_Null_Exclusion_Present (Obj_Param_Typ,
- Null_Exclusion_Present (Parameter_Type (First_Param)));
+ -- 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.
+
+ if Present (First_Param) then
+ if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
+ Obj_Param_Typ :=
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Reference_To (Obj_Typ, Loc));
+ Set_Null_Exclusion_Present (Obj_Param_Typ,
+ Null_Exclusion_Present (Parameter_Type (First_Param)));
+ else
+ Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
+ end if;
+
+ Obj_Param :=
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ In_Present => In_Present (First_Param),
+ Out_Present => Out_Present (First_Param),
+ Parameter_Type => Obj_Param_Typ);
+
+ -- 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 => Ekind (Subp_Id) /= E_Function,
+ Parameter_Type => New_Reference_To (Obj_Typ, Loc));
+ end if;
+
+ Prepend_To (New_Formals, Obj_Param);
+
+ -- Build the final spec
+
+ if Ekind (Subp_Id) = E_Function then
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => New_Formals,
+ Result_Definition =>
+ New_Copy (Result_Definition (Parent (Subp_Id))));
else
- Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => New_Formals);
end if;
+ end;
+ end Build_Wrapper_Spec;
- Obj_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uO),
- In_Present => In_Present (First_Param),
- Out_Present => Out_Present (First_Param),
- Parameter_Type => Obj_Param_Typ);
+ -------------------------
+ -- Build_Wrapper_Specs --
+ -------------------------
- else
- Obj_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uO),
- In_Present => True,
- Out_Present => True,
- Parameter_Type => New_Reference_To (Obj_Typ, Loc));
+ 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;
- Prepend_To (New_Formals, Obj_Param);
+ Rec_Typ := Corresponding_Record_Type (Typ);
- -- Minimum decoration needed to catch the entity in
- -- Sem_Ch6.Override_Dispatching_Operation
+ -- Generate wrapper specs for a concurrent type which implements an
+ -- interface and has visible entries and/or protected procedures.
- if Ekind (Proc_Nam) = E_Procedure
- or else Ekind (Proc_Nam) = E_Entry
+ if Present (Interfaces (Rec_Typ))
+ and then Present (Def)
+ and then Present (Visible_Declarations (Def))
then
- Set_Ekind (New_Name_Id, E_Procedure);
- Set_Is_Primitive_Wrapper (New_Name_Id);
- Set_Wrapped_Entity (New_Name_Id, Proc_Nam);
+ declare
+ Decl : Node_Id;
+ Wrap_Decl : Node_Id;
+ Wrap_Spec : Node_Id;
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => New_Name_Id,
- Parameter_Specifications => New_Formals);
+ begin
+ Decl := First (Visible_Declarations (Def));
+ while Present (Decl) loop
+ Wrap_Spec := Empty;
- else pragma Assert (Ekind (Proc_Nam) = E_Function);
- Set_Ekind (New_Name_Id, E_Function);
+ 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));
- return
- Make_Function_Specification (Loc,
- Defining_Unit_Name => New_Name_Id,
- Parameter_Specifications => New_Formals,
- Result_Definition =>
- New_Copy (Result_Definition (Parent (Proc_Nam))));
+ 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_Spec;
+ 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.
+ -- This is the proper body corresponding to a stub. The declarations
+ -- 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
-
- 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)));
+ -- the corresponding record is frozen. If any wrappers are generated,
+ -- Current_Node is updated accordingly.
- 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 Nkind (Parent (N)) = N_Subunit then
- Current_Node := 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;
- end if;
+ if Ada_Version >= Ada_05 then
+ if Nkind (Parent (N)) = N_Subunit then
+ Insert_Nod := Corresponding_Stub (Parent (N));
+ else
+ 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 --
------------------
Index: exp_ch9.ads
===================================================================
--- exp_ch9.ads (revision 138305)
+++ exp_ch9.ads (working copy)
@@ -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
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 138305)
+++ sem_ch3.adb (working copy)
@@ -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);
+
+ -- 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.
+
+ 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);
- P1 := First_Elmt (Priv_List);
- while Present (P1) loop
- Prim := Node (P1);
-
- -- Transfer explicit primitives, not those inherited from
- -- parent of partial view, which will be re-inherited on
- -- the full view.
-
- if Comes_From_Source (Prim) then
- P2 := First_Elmt (Full_List);
- while Present (P2) and then Node (P2) /= Prim loop
- Next_Elmt (P2);
+ 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))));
+
+ 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);
- if No (P2) then
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ 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);
- end loop;
+ 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;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 138305)
+++ sem_ch6.adb (working copy)
@@ -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
- Spec_Id := Find_Corresponding_Spec (N);
+ 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
- Formal := First_Formal (Designator);
- while Present (Formal) loop
- Formal_Typ := Etype (Formal);
+ declare
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Rec_Typ : Entity_Id;
- 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;
+ begin
+ Formal := First_Formal (Designator);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
- Formal := Next_Formal (Formal);
- end loop;
+ if Is_Concurrent_Type (Formal_Typ)
+ and then Present (Corresponding_Record_Type (Formal_Typ))
+ then
+ Rec_Typ := Corresponding_Record_Type (Formal_Typ);
+
+ if Present (Interfaces (Rec_Typ)) then
+ Set_Etype (Formal, Rec_Typ);
+ end if;
+ end if;
+
+ 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
+ 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;
Index: sem_ch6.ads
===================================================================
--- sem_ch6.ads (revision 138305)
+++ sem_ch6.ads (working copy)
@@ -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.
More information about the Gcc-patches
mailing list