===================================================================
@@ -19835,6 +19835,13 @@
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
+
+ -- Remove the wrapper from visibility to avoid
+ -- spurious conflict with the wrapped entity.
+
+ Set_Is_Immediately_Visible
+ (Defining_Entity (Specification (Wrap_Spec)),
+ False);
end if;
Next_Elmt (Prim_Elmt);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2443,13 +2443,6 @@
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Subp_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_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean;
@@ -2631,6 +2624,16 @@
return New_Formals;
end Replicate_Formals;
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+ First_Param : Node_Id := Empty;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Op : Entity_Id;
+ Iface_Op_Elmt : Elmt_Id;
+ Overridden_Subp : Entity_Id;
+
-- Start of processing for Build_Wrapper_Spec
begin
@@ -2638,17 +2641,24 @@
pragma Assert (Is_Tagged_Type (Obj_Typ));
+ -- Check if this subprogram has a profile that matches some interface
+ -- primitive
+
+ Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
+
+ if Present (Overridden_Subp) then
+ First_Param :=
+ First (Parameter_Specifications (Parent (Overridden_Subp)));
+
-- 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.
- First_Param := Empty;
-
-- Check every implemented interface
- if Present (Interfaces (Obj_Typ)) then
+ elsif Present (Interfaces (Obj_Typ)) then
Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
Search : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
@@ -2684,40 +2694,14 @@
end loop Search;
end if;
- -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by
- -- this subprogram and this is not a primitive declared between two
- -- views then force the generation of a wrapper. As an optimization,
- -- previous versions of the frontend avoid generating the wrapper;
- -- however, the wrapper facilitates locating and reporting an error
- -- when a duplicate declaration is found later. See example in
- -- AI05-0090-1.
+ -- Do not generate the wrapper if no interface primitive is covered by
+ -- the subprogram and it is not a primitive declared declared between
+ -- two views (see Process_Full_View).
if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id)
then
- if Is_Task_Type
- (Corresponding_Concurrent_Type (Obj_Typ))
- then
- First_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
- In_Present => True,
- Out_Present => False,
- Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
-
- -- For entries and procedures of protected types the mode of
- -- the controlling argument must be in-out.
-
- else
- First_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_uO),
- In_Present => True,
- Out_Present => (Ekind (Subp_Id) /= E_Function),
- Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
- end if;
+ return Empty;
end if;
declare
@@ -4229,6 +4213,15 @@
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
+ -- Reference the original non-dispatching subprogram since the analysis
+ -- of the object.operation notation may need its original name (see
+ -- Sem_Ch4.Names_Match).
+
+ if Mode = Dispatching_Mode then
+ Set_Ekind (New_Id, Ekind (Def_Id));
+ Set_Original_Protected_Subprogram (New_Id, Def_Id);
+ end if;
+
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
@@ -9653,22 +9646,50 @@
Current_Node := Sub;
-- Generate an overriding primitive operation specification for
- -- this subprogram if the protected type implements an interface.
+ -- this subprogram if the protected type implements an interface
+ -- and Build_Wrapper_Spec did not not generate its wrapper.
if Ada_Version >= Ada_2005
and then
Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
- Sub :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification
- (Comp, Prot_Typ, Dispatching_Mode));
+ declare
+ Prim_Elmt : Elmt_Id;
+ Prim_Op : Node_Id;
+ Found : Boolean := False;
- Insert_After (Current_Node, Sub);
- Analyze (Sub);
+ begin
+ Prim_Elmt :=
+ First_Elmt
+ (Primitive_Operations
+ (Corresponding_Record_Type (Prot_Typ)));
- Current_Node := Sub;
+ while Present (Prim_Elmt) loop
+ Prim_Op := Node (Prim_Elmt);
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then (Wrapped_Entity (Prim_Op))
+ = Defining_Entity (Specification (Comp))
+ then
+ Found := True;
+ exit;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ if not Found then
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Comp, Prot_Typ, Dispatching_Mode));
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
+
+ Current_Node := Sub;
+ end if;
+ end;
end if;
-- If a pragma Interrupt_Handler applies, build and add a call to
===================================================================
@@ -274,6 +274,7 @@
-- SPARK_Pragma Node40
+ -- Original_Protected_Subprogram Node41
-- SPARK_Aux_Pragma Node41
---------------------------------------------
@@ -2837,6 +2838,11 @@
return Node21 (Id);
end Original_Array_Type;
+ function Original_Protected_Subprogram (Id : E) return N is
+ begin
+ return Node41 (Id);
+ end Original_Protected_Subprogram;
+
function Original_Record_Component (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
@@ -5900,6 +5906,12 @@
Set_Node21 (Id, V);
end Set_Original_Array_Type;
+ procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Procedure, E_Function));
+ Set_Node41 (Id, V);
+ end Set_Original_Protected_Subprogram;
+
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
@@ -10483,6 +10495,10 @@
E_Task_Type =>
Write_Str ("SPARK_Aux_Pragma");
+ when E_Function |
+ E_Procedure =>
+ Write_Str ("Original_Protected_Subprogram");
+
when others =>
Write_Str ("Field41??");
end case;
===================================================================
@@ -3647,6 +3647,11 @@
-- points to the original array type for which this is the packed
-- array implementation type.
+-- Original_Protected_Subprogram (Node41)
+-- Defined in functions and procedures. Set only on internally built
+-- dispatching subprograms of protected types to reference their original
+-- non-dispatching protected subprogram since their names differ.
+
-- Original_Record_Component (Node22)
-- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged.
@@ -5923,6 +5928,7 @@
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
+ -- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108)
@@ -6234,6 +6240,7 @@
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
+ -- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114)
@@ -7127,6 +7134,7 @@
function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
+ function Original_Protected_Subprogram (Id : E) return N;
function Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E;
@@ -7801,6 +7809,7 @@
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
+ procedure Set_Original_Protected_Subprogram (Id : E; V : N);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E);
@@ -8628,6 +8637,7 @@
pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
+ pragma Inline (Original_Protected_Subprogram);
pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation);
@@ -9093,6 +9103,7 @@
pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
+ pragma Inline (Set_Original_Protected_Subprogram);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation);
===================================================================
@@ -8817,6 +8817,15 @@
-- is visible a direct call to it will dispatch to the private one,
-- which is therefore a valid candidate.
+ function Names_Match
+ (Obj_Type : Entity_Id;
+ Prim_Op : Entity_Id;
+ Subprog : Entity_Id) return Boolean;
+ -- Return True if the names of Prim_Op and Subprog match. If Obj_Type
+ -- is a protected type then compare also the original name of Prim_Op
+ -- with the name of Subprog (since the expander may have added a
+ -- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
+
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
@@ -8993,6 +9002,34 @@
and then not Is_Hidden (Visible_Op);
end Is_Private_Overriding;
+ -----------------
+ -- Names_Match --
+ -----------------
+
+ function Names_Match
+ (Obj_Type : Entity_Id;
+ Prim_Op : Entity_Id;
+ Subprog : Entity_Id) return Boolean is
+ begin
+ -- Common case: exact match
+
+ if Chars (Prim_Op) = Chars (Subprog) then
+ return True;
+
+ -- For protected type primitives the expander may have built the
+ -- name of the dispatching primitive prepending the type name to
+ -- avoid conflicts with the name of the protected subprogram (see
+ -- Exp_Ch9.Build_Selected_Name).
+
+ elsif Is_Protected_Type (Obj_Type) then
+ return Present (Original_Protected_Subprogram (Prim_Op))
+ and then Chars (Original_Protected_Subprogram (Prim_Op))
+ = Chars (Subprog);
+ end if;
+
+ return False;
+ end Names_Match;
+
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
@@ -9059,7 +9096,7 @@
while Present (Elmt) loop
Prim_Op := Node (Elmt);
- if Chars (Prim_Op) = Chars (Subprog)
+ if Names_Match (Obj_Type, Prim_Op, Subprog)
and then Present (First_Formal (Prim_Op))
and then Valid_First_Argument_Of (Prim_Op)
and then
===================================================================
@@ -6463,6 +6463,341 @@
Get_Inst => Get_Inst);
end Check_Subtype_Conformant;
+ -----------------------------------
+ -- Check_Synchronized_Overriding --
+ -----------------------------------
+
+ procedure Check_Synchronized_Overriding
+ (Def_Id : Entity_Id;
+ Overridden_Subp : out Entity_Id)
+ is
+ Ifaces_List : Elist_Id;
+ In_Scope : Boolean;
+ Typ : Entity_Id;
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean;
+ -- Determine whether a subprogram's parameter profile Prim_Params
+ -- matches that of a potentially overridden interface subprogram
+ -- Iface_Params. Also determine if the type of first parameter of
+ -- Iface_Params is an implemented interface.
+
+ -----------------------------------
+ -- Matches_Prefixed_View_Profile --
+ -----------------------------------
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean
+ is
+ Iface_Id : Entity_Id;
+ Iface_Param : Node_Id;
+ Iface_Typ : Entity_Id;
+ Prim_Id : Entity_Id;
+ Prim_Param : Node_Id;
+ Prim_Typ : Entity_Id;
+
+ function Is_Implemented
+ (Ifaces_List : Elist_Id;
+ Iface : Entity_Id) return Boolean;
+ -- Determine if Iface is implemented by the current task or
+ -- protected type.
+
+ --------------------
+ -- Is_Implemented --
+ --------------------
+
+ function Is_Implemented
+ (Ifaces_List : Elist_Id;
+ Iface : Entity_Id) return Boolean
+ is
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ return True;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return False;
+ end Is_Implemented;
+
+ -- Start of processing for Matches_Prefixed_View_Profile
+
+ begin
+ Iface_Param := First (Iface_Params);
+ Iface_Typ := Etype (Defining_Identifier (Iface_Param));
+
+ if Is_Access_Type (Iface_Typ) then
+ Iface_Typ := Designated_Type (Iface_Typ);
+ end if;
+
+ Prim_Param := First (Prim_Params);
+
+ -- The first parameter of the potentially overridden subprogram
+ -- must be an interface implemented by Prim.
+
+ if not Is_Interface (Iface_Typ)
+ or else not Is_Implemented (Ifaces_List, Iface_Typ)
+ then
+ return False;
+ end if;
+
+ -- The checks on the object parameters are done, move onto the
+ -- rest of the parameters.
+
+ if not In_Scope then
+ Prim_Param := Next (Prim_Param);
+ end if;
+
+ Iface_Param := Next (Iface_Param);
+ while Present (Iface_Param) and then Present (Prim_Param) loop
+ Iface_Id := Defining_Identifier (Iface_Param);
+ Iface_Typ := Find_Parameter_Type (Iface_Param);
+
+ Prim_Id := Defining_Identifier (Prim_Param);
+ Prim_Typ := Find_Parameter_Type (Prim_Param);
+
+ if Ekind (Iface_Typ) = E_Anonymous_Access_Type
+ and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
+ and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
+ then
+ Iface_Typ := Designated_Type (Iface_Typ);
+ Prim_Typ := Designated_Type (Prim_Typ);
+ end if;
+
+ -- Case of multiple interface types inside a parameter profile
+
+ -- (Obj_Param : in out Iface; ...; Param : Iface)
+
+ -- If the interface type is implemented, then the matching type
+ -- in the primitive should be the implementing record type.
+
+ if Ekind (Iface_Typ) = E_Record_Type
+ and then Is_Interface (Iface_Typ)
+ and then Is_Implemented (Ifaces_List, Iface_Typ)
+ then
+ if Prim_Typ /= Typ then
+ return False;
+ end if;
+
+ -- The two parameters must be both mode and subtype conformant
+
+ elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+ or else not
+ Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+ then
+ return False;
+ end if;
+
+ Next (Iface_Param);
+ Next (Prim_Param);
+ end loop;
+
+ -- One of the two lists contains more parameters than the other
+
+ if Present (Iface_Param) or else Present (Prim_Param) then
+ return False;
+ end if;
+
+ return True;
+ end Matches_Prefixed_View_Profile;
+
+ -- Start of processing for Check_Synchronized_Overriding
+
+ begin
+ Overridden_Subp := Empty;
+
+ -- Def_Id must be an entry or a subprogram. We should skip predefined
+ -- primitives internally generated by the frontend; however at this
+ -- stage predefined primitives are still not fully decorated. As a
+ -- minor optimization we skip here internally generated subprograms.
+
+ if (Ekind (Def_Id) /= E_Entry
+ and then Ekind (Def_Id) /= E_Function
+ and then Ekind (Def_Id) /= E_Procedure)
+ or else not Comes_From_Source (Def_Id)
+ then
+ return;
+ end if;
+
+ -- Search for the concurrent declaration since it contains the list
+ -- of all implemented interfaces. In this case, the subprogram is
+ -- declared within the scope of a protected or a task type.
+
+ if Present (Scope (Def_Id))
+ and then Is_Concurrent_Type (Scope (Def_Id))
+ and then not Is_Generic_Actual_Type (Scope (Def_Id))
+ then
+ Typ := Scope (Def_Id);
+ In_Scope := True;
+
+ -- The enclosing scope is not a synchronized type and the subprogram
+ -- has no formals.
+
+ elsif No (First_Formal (Def_Id)) then
+ return;
+
+ -- The subprogram has formals and hence it may be a primitive of a
+ -- concurrent type.
+
+ else
+ Typ := Etype (First_Formal (Def_Id));
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ if Is_Concurrent_Type (Typ)
+ and then not Is_Generic_Actual_Type (Typ)
+ then
+ In_Scope := False;
+
+ -- This case occurs when the concurrent type is declared within
+ -- a generic unit. As a result the corresponding record has been
+ -- built and used as the type of the first formal, we just have
+ -- to retrieve the corresponding concurrent type.
+
+ elsif Is_Concurrent_Record_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ and then Present (Corresponding_Concurrent_Type (Typ))
+ then
+ Typ := Corresponding_Concurrent_Type (Typ);
+ In_Scope := False;
+
+ else
+ return;
+ end if;
+ end if;
+
+ -- There is no overriding to check if is an inherited operation in a
+ -- type derivation on for a generic actual.
+
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ if Is_Empty_Elmt_List (Ifaces_List) then
+ return;
+ end if;
+
+ -- Determine whether entry or subprogram Def_Id overrides a primitive
+ -- operation that belongs to one of the interfaces in Ifaces_List.
+
+ declare
+ Candidate : Entity_Id := Empty;
+ Hom : Entity_Id := Empty;
+ Subp : Entity_Id := Empty;
+
+ begin
+ -- Traverse the homonym chain, looking for a potentially
+ -- overridden subprogram that belongs to an implemented
+ -- interface.
+
+ Hom := Current_Entity_In_Scope (Def_Id);
+ while Present (Hom) loop
+ Subp := Hom;
+
+ if Subp = Def_Id
+ or else not Is_Overloadable (Subp)
+ or else not Is_Primitive (Subp)
+ or else not Is_Dispatching_Operation (Subp)
+ or else not Present (Find_Dispatching_Type (Subp))
+ or else not Is_Interface (Find_Dispatching_Type (Subp))
+ then
+ null;
+
+ -- Entries and procedures can override abstract or null
+ -- interface procedures.
+
+ elsif (Ekind (Def_Id) = E_Procedure
+ or else Ekind (Def_Id) = E_Entry)
+ and then Ekind (Subp) = E_Procedure
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ then
+ Candidate := Subp;
+
+ -- For an overridden subprogram Subp, check whether the mode
+ -- of its first parameter is correct depending on the kind
+ -- of synchronized type.
+
+ declare
+ Formal : constant Node_Id := First_Formal (Candidate);
+
+ begin
+ -- In order for an entry or a protected procedure to
+ -- override, the first parameter of the overridden
+ -- routine must be of mode "out", "in out" or
+ -- access-to-variable.
+
+ if Ekind_In (Candidate, E_Entry, E_Procedure)
+ and then Is_Protected_Type (Typ)
+ and then Ekind (Formal) /= E_In_Out_Parameter
+ and then Ekind (Formal) /= E_Out_Parameter
+ and then Nkind (Parameter_Type (Parent (Formal))) /=
+ N_Access_Definition
+ then
+ null;
+
+ -- All other cases are OK since a task entry or routine
+ -- does not have a restriction on the mode of the first
+ -- parameter of the overridden interface routine.
+
+ else
+ Overridden_Subp := Candidate;
+ return;
+ end if;
+ end;
+
+ -- Functions can override abstract interface functions
+
+ elsif Ekind (Def_Id) = E_Function
+ and then Ekind (Subp) = E_Function
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ and then Etype (Result_Definition (Parent (Def_Id))) =
+ Etype (Result_Definition (Parent (Subp)))
+ then
+ Candidate := Subp;
+
+ -- If an inherited subprogram is implemented by a protected
+ -- function, then the first parameter of the inherited
+ -- subprogram shall be of mode in, but not an
+ -- access-to-variable parameter (RM 9.4(11/9)
+
+ if Present (First_Formal (Subp))
+ and then Ekind (First_Formal (Subp)) = E_In_Parameter
+ and then
+ (not Is_Access_Type (Etype (First_Formal (Subp)))
+ or else
+ Is_Access_Constant (Etype (First_Formal (Subp))))
+ then
+ Overridden_Subp := Subp;
+ return;
+ end if;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ -- After examining all candidates for overriding, we are left with
+ -- the best match which is a mode incompatible interface routine.
+
+ if In_Scope and then Present (Candidate) then
+ Error_Msg_PT (Def_Id, Candidate);
+ end if;
+
+ Overridden_Subp := Candidate;
+ return;
+ end;
+ end Check_Synchronized_Overriding;
+
---------------------------
-- Check_Type_Conformant --
---------------------------
@@ -9000,14 +9335,14 @@
-- type, and set Is_Primitive to True (otherwise set to False). Set the
-- corresponding flag on the entity itself for later use.
- procedure Check_Synchronized_Overriding
- (Def_Id : Entity_Id;
- Overridden_Subp : out Entity_Id);
- -- First determine if Def_Id is an entry or a subprogram either defined
- -- in the scope of a task or protected type, or is a primitive of such
- -- a type. Check whether Def_Id overrides a subprogram of an interface
- -- implemented by the synchronized type, return the overridden entity
- -- or Empty.
+ function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean;
+ -- True if a) E is a subprogram whose first formal is a concurrent type
+ -- defined in the scope of E that has some entry or subprogram whose
+ -- profile matches E, or b) E is an internally built dispatching
+ -- subprogram of a protected type and there is a matching subprogram
+ -- defined in the enclosing scope of the protected type, or c) E is
+ -- an entry of a synchronized type and a matching procedure has been
+ -- previously defined in the enclosing scope of the synchronized type.
function Is_Private_Declaration (E : Entity_Id) return Boolean;
-- Check that E is declared in the private part of the current package,
@@ -9025,6 +9360,9 @@
-- function is conservative given that the converse is only true within
-- instances that contain accidental overloadings.
+ procedure Report_Conflict (S : Entity_Id; E : Entity_Id);
+ -- Report conflict between entities S and E.
+
------------------------------------
-- Check_For_Primitive_Subprogram --
------------------------------------
@@ -9350,341 +9688,257 @@
end if;
end Check_For_Primitive_Subprogram;
- -----------------------------------
- -- Check_Synchronized_Overriding --
- -----------------------------------
+ --------------------------------------
+ -- Has_Matching_Entry_Or_Subprogram --
+ --------------------------------------
- procedure Check_Synchronized_Overriding
- (Def_Id : Entity_Id;
- Overridden_Subp : out Entity_Id)
+ function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean
is
- Ifaces_List : Elist_Id;
- In_Scope : Boolean;
- Typ : Entity_Id;
+ function Check_Conforming_Parameters
+ (E1_Param : Node_Id;
+ E2_Param : Node_Id) return Boolean;
+ -- Starting from the given parameters, check that all the parameters
+ -- of two entries or subprograms are are subtype conformant. Used to
+ -- skip the check on the controlling argument.
- function Matches_Prefixed_View_Profile
- (Prim_Params : List_Id;
- Iface_Params : List_Id) return Boolean;
- -- Determine whether a subprogram's parameter profile Prim_Params
- -- matches that of a potentially overridden interface subprogram
- -- Iface_Params. Also determine if the type of first parameter of
- -- Iface_Params is an implemented interface.
+ function Matching_Entry_Or_Subprogram
+ (Conc_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id;
+ -- Return the first entry or subprogram of the given concurrent type
+ -- whose name matches the name of Subp and has a profile conformant
+ -- with Subp; return Empty if not found.
- -----------------------------------
- -- Matches_Prefixed_View_Profile --
- -----------------------------------
+ function Matching_Dispatching_Subprogram
+ (Conc_Typ : Entity_Id;
+ Ent : Entity_Id) return Entity_Id;
+ -- Return the first dispatching primitive of Conc_Type defined in the
+ -- enclosing scope of Conc_Type (ie. before the full definition of
+ -- this concurrent type) whose name matches the entry Ent and has a
+ -- profile conformant with the profile of the corresponding (not yet
+ -- built) dispatching primitive of Ent; return Empty if not found.
- function Matches_Prefixed_View_Profile
- (Prim_Params : List_Id;
- Iface_Params : List_Id) return Boolean
- is
- Iface_Id : Entity_Id;
- Iface_Param : Node_Id;
- Iface_Typ : Entity_Id;
- Prim_Id : Entity_Id;
- Prim_Param : Node_Id;
- Prim_Typ : Entity_Id;
+ function Matching_Original_Protected_Subprogram
+ (Prot_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id;
+ -- Return the first subprogram defined in the enclosing scope of
+ -- Prot_Typ (before the full definition of this protected type)
+ -- whose name matches the original name of Subp and has a profile
+ -- conformant with the profile of Subp; return Empty if not found.
- function Is_Implemented
- (Ifaces_List : Elist_Id;
- Iface : Entity_Id) return Boolean;
- -- Determine if Iface is implemented by the current task or
- -- protected type.
+ ---------------------------------
+ -- Check_Confirming_Parameters --
+ ---------------------------------
- --------------------
- -- Is_Implemented --
- --------------------
+ function Check_Conforming_Parameters
+ (E1_Param : Node_Id;
+ E2_Param : Node_Id) return Boolean
+ is
+ Param_E1 : Node_Id := E1_Param;
+ Param_E2 : Node_Id := E2_Param;
- function Is_Implemented
- (Ifaces_List : Elist_Id;
- Iface : Entity_Id) return Boolean
- is
- Iface_Elmt : Elmt_Id;
-
- begin
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- if Node (Iface_Elmt) = Iface then
- return True;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
-
- return False;
- end Is_Implemented;
-
- -- Start of processing for Matches_Prefixed_View_Profile
-
begin
- Iface_Param := First (Iface_Params);
- Iface_Typ := Etype (Defining_Identifier (Iface_Param));
-
- if Is_Access_Type (Iface_Typ) then
- Iface_Typ := Designated_Type (Iface_Typ);
- end if;
-
- Prim_Param := First (Prim_Params);
-
- -- The first parameter of the potentially overridden subprogram
- -- must be an interface implemented by Prim.
-
- if not Is_Interface (Iface_Typ)
- or else not Is_Implemented (Ifaces_List, Iface_Typ)
- then
- return False;
- end if;
-
- -- The checks on the object parameters are done, move onto the
- -- rest of the parameters.
-
- if not In_Scope then
- Prim_Param := Next (Prim_Param);
- end if;
-
- Iface_Param := Next (Iface_Param);
- while Present (Iface_Param) and then Present (Prim_Param) loop
- Iface_Id := Defining_Identifier (Iface_Param);
- Iface_Typ := Find_Parameter_Type (Iface_Param);
-
- Prim_Id := Defining_Identifier (Prim_Param);
- Prim_Typ := Find_Parameter_Type (Prim_Param);
-
- if Ekind (Iface_Typ) = E_Anonymous_Access_Type
- and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
- and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
+ while Present (Param_E1) and then Present (Param_E2) loop
+ if Ekind (Defining_Identifier (Param_E1))
+ /= Ekind (Defining_Identifier (Param_E2))
+ or else not
+ Conforming_Types (Find_Parameter_Type (Param_E1),
+ Find_Parameter_Type (Param_E2),
+ Subtype_Conformant)
then
- Iface_Typ := Designated_Type (Iface_Typ);
- Prim_Typ := Designated_Type (Prim_Typ);
+ return False;
end if;
- -- Case of multiple interface types inside a parameter profile
+ Next (Param_E1);
+ Next (Param_E2);
+ end loop;
- -- (Obj_Param : in out Iface; ...; Param : Iface)
+ -- The candidate is not valid if one of the two lists contains
+ -- more parameters than the other
- -- If the interface type is implemented, then the matching type
- -- in the primitive should be the implementing record type.
+ return No (Param_E1) and then No (Param_E2);
+ end Check_Conforming_Parameters;
- if Ekind (Iface_Typ) = E_Record_Type
- and then Is_Interface (Iface_Typ)
- and then Is_Implemented (Ifaces_List, Iface_Typ)
- then
- if Prim_Typ /= Typ then
- return False;
- end if;
+ ----------------------------------
+ -- Matching_Entry_Or_Subprogram --
+ ----------------------------------
- -- The two parameters must be both mode and subtype conformant
+ function Matching_Entry_Or_Subprogram
+ (Conc_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ E : Entity_Id;
- elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
- or else not
- Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+ begin
+ E := First_Entity (Conc_Typ);
+ while Present (E) loop
+ if Chars (Subp) = Chars (E)
+ and then (Ekind (E) = E_Entry or else Is_Subprogram (E))
+ and then
+ Check_Conforming_Parameters
+ (First (Parameter_Specifications (Parent (E))),
+ Next (First (Parameter_Specifications (Parent (Subp)))))
then
- return False;
+ return E;
end if;
- Next (Iface_Param);
- Next (Prim_Param);
+ Next_Entity (E);
end loop;
- -- One of the two lists contains more parameters than the other
+ return Empty;
+ end Matching_Entry_Or_Subprogram;
- if Present (Iface_Param) or else Present (Prim_Param) then
- return False;
- end if;
+ -------------------------------------
+ -- Matching_Dispatching_Subprogram --
+ -------------------------------------
- return True;
- end Matches_Prefixed_View_Profile;
+ function Matching_Dispatching_Subprogram
+ (Conc_Typ : Entity_Id;
+ Ent : Entity_Id) return Entity_Id
+ is
+ E : Entity_Id;
- -- Start of processing for Check_Synchronized_Overriding
+ begin
+ -- Search for entities in the enclosing scope of this synchonized
+ -- type
- begin
- Overridden_Subp := Empty;
+ pragma Assert (Is_Concurrent_Type (Conc_Typ));
+ Push_Scope (Scope (Conc_Typ));
+ E := Current_Entity_In_Scope (Ent);
+ Pop_Scope;
- -- Def_Id must be an entry or a subprogram. We should skip predefined
- -- primitives internally generated by the frontend; however at this
- -- stage predefined primitives are still not fully decorated. As a
- -- minor optimization we skip here internally generated subprograms.
+ while Present (E) loop
+ if Scope (E) = Scope (Conc_Typ)
+ and then Comes_From_Source (E)
+ and then Ekind (E) = E_Procedure
+ and then Present (First_Entity (E))
+ and then Is_Controlling_Formal (First_Entity (E))
+ and then Etype (First_Entity (E)) = Conc_Typ
+ and then
+ Check_Conforming_Parameters
+ (First (Parameter_Specifications (Parent (Ent))),
+ Next (First (Parameter_Specifications (Parent (E)))))
+ then
+ return E;
+ end if;
- if (Ekind (Def_Id) /= E_Entry
- and then Ekind (Def_Id) /= E_Function
- and then Ekind (Def_Id) /= E_Procedure)
- or else not Comes_From_Source (Def_Id)
- then
- return;
- end if;
+ E := Homonym (E);
+ end loop;
- -- Search for the concurrent declaration since it contains the list
- -- of all implemented interfaces. In this case, the subprogram is
- -- declared within the scope of a protected or a task type.
+ return Empty;
+ end Matching_Dispatching_Subprogram;
- if Present (Scope (Def_Id))
- and then Is_Concurrent_Type (Scope (Def_Id))
- and then not Is_Generic_Actual_Type (Scope (Def_Id))
- then
- Typ := Scope (Def_Id);
- In_Scope := True;
+ --------------------------------------------
+ -- Matching_Original_Protected_Subprogram --
+ --------------------------------------------
- -- The enclosing scope is not a synchronized type and the subprogram
- -- has no formals.
+ function Matching_Original_Protected_Subprogram
+ (Prot_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ ICF : constant Boolean :=
+ Is_Controlling_Formal (First_Entity (Subp));
+ E : Entity_Id;
- elsif No (First_Formal (Def_Id)) then
- return;
-
- -- The subprogram has formals and hence it may be a primitive of a
- -- concurrent type.
-
- else
- Typ := Etype (First_Formal (Def_Id));
-
- if Is_Access_Type (Typ) then
- Typ := Directly_Designated_Type (Typ);
- end if;
-
- if Is_Concurrent_Type (Typ)
- and then not Is_Generic_Actual_Type (Typ)
- then
- In_Scope := False;
-
- -- This case occurs when the concurrent type is declared within
- -- a generic unit. As a result the corresponding record has been
- -- built and used as the type of the first formal, we just have
- -- to retrieve the corresponding concurrent type.
-
- elsif Is_Concurrent_Record_Type (Typ)
- and then not Is_Class_Wide_Type (Typ)
- and then Present (Corresponding_Concurrent_Type (Typ))
- then
- Typ := Corresponding_Concurrent_Type (Typ);
- In_Scope := False;
-
- else
- return;
- end if;
- end if;
-
- -- There is no overriding to check if is an inherited operation in a
- -- type derivation on for a generic actual.
-
- Collect_Interfaces (Typ, Ifaces_List);
-
- if Is_Empty_Elmt_List (Ifaces_List) then
- return;
- end if;
-
- -- Determine whether entry or subprogram Def_Id overrides a primitive
- -- operation that belongs to one of the interfaces in Ifaces_List.
-
- declare
- Candidate : Entity_Id := Empty;
- Hom : Entity_Id := Empty;
- Subp : Entity_Id := Empty;
-
begin
- -- Traverse the homonym chain, looking for a potentially
- -- overridden subprogram that belongs to an implemented
- -- interface.
+ -- Temporarily decorate the first parameter of Subp as controlling
+ -- formal; required to invoke Subtype_Conformant()
- Hom := Current_Entity_In_Scope (Def_Id);
- while Present (Hom) loop
- Subp := Hom;
+ Set_Is_Controlling_Formal (First_Entity (Subp));
- if Subp = Def_Id
- or else not Is_Overloadable (Subp)
- or else not Is_Primitive (Subp)
- or else not Is_Dispatching_Operation (Subp)
- or else not Present (Find_Dispatching_Type (Subp))
- or else not Is_Interface (Find_Dispatching_Type (Subp))
- then
- null;
+ E :=
+ Current_Entity_In_Scope (Original_Protected_Subprogram (Subp));
- -- Entries and procedures can override abstract or null
- -- interface procedures.
-
- elsif (Ekind (Def_Id) = E_Procedure
- or else Ekind (Def_Id) = E_Entry)
- and then Ekind (Subp) = E_Procedure
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
+ while Present (E) loop
+ if Scope (E) = Scope (Prot_Typ)
+ and then Comes_From_Source (E)
+ and then Ekind (Subp) = Ekind (E)
+ and then Present (First_Entity (E))
+ and then Is_Controlling_Formal (First_Entity (E))
+ and then Etype (First_Entity (E)) = Prot_Typ
+ and then Subtype_Conformant (Subp, E,
+ Skip_Controlling_Formals => True)
then
- Candidate := Subp;
+ Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
+ return E;
+ end if;
- -- For an overridden subprogram Subp, check whether the mode
- -- of its first parameter is correct depending on the kind
- -- of synchronized type.
+ E := Homonym (E);
+ end loop;
- declare
- Formal : constant Node_Id := First_Formal (Candidate);
+ Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
+ return Empty;
+ end Matching_Original_Protected_Subprogram;
- begin
- -- In order for an entry or a protected procedure to
- -- override, the first parameter of the overridden
- -- routine must be of mode "out", "in out" or
- -- access-to-variable.
+ -- Start of processing for Has_Matching_Entry_Or_Subprogram
- if Ekind_In (Candidate, E_Entry, E_Procedure)
- and then Is_Protected_Type (Typ)
- and then Ekind (Formal) /= E_In_Out_Parameter
- and then Ekind (Formal) /= E_Out_Parameter
- and then Nkind (Parameter_Type (Parent (Formal))) /=
- N_Access_Definition
- then
- null;
+ begin
+ -- Case 1: E is a subprogram whose first formal is a concurrent type
+ -- defined in the scope of E that has an entry or subprogram whose
+ -- profile matches E.
- -- All other cases are OK since a task entry or routine
- -- does not have a restriction on the mode of the first
- -- parameter of the overridden interface routine.
+ if Comes_From_Source (E)
+ and then Is_Subprogram (E)
+ and then Present (First_Entity (E))
+ and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ then
+ if Scope (E) =
+ Scope (Corresponding_Concurrent_Type (
+ Etype (First_Entity (E))))
+ and then
+ Present
+ (Matching_Entry_Or_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E))
+ then
+ Report_Conflict (E,
+ Matching_Entry_Or_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E));
+ return True;
+ end if;
- else
- Overridden_Subp := Candidate;
- return;
- end if;
- end;
+ -- Case 2: E is an internally built dispatching subprogram of a
+ -- protected type and there is a subprogram defined in the enclosing
+ -- scope of the protected type that has the original name of E and
+ -- its profile is conformant with the profile of E. We check the
+ -- name of the original protected subprogram associated with E since
+ -- the expander builds dispatching primitives of protected functions
+ -- and procedures with other name (see Exp_Ch9.Build_Selected_Name).
- -- Functions can override abstract interface functions
+ elsif not Comes_From_Source (E)
+ and then Is_Subprogram (E)
+ and then Present (First_Entity (E))
+ and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ and then Present (Original_Protected_Subprogram (E))
+ and then
+ Present
+ (Matching_Original_Protected_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E))
+ then
+ Report_Conflict (E,
+ Matching_Original_Protected_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E));
+ return True;
- elsif Ekind (Def_Id) = E_Function
- and then Ekind (Subp) = E_Function
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- and then Etype (Result_Definition (Parent (Def_Id))) =
- Etype (Result_Definition (Parent (Subp)))
- then
- Candidate := Subp;
+ -- Case : E is an entry of a synchronized type and a matching
+ -- procedure has been previously defined in the enclosing scope
+ -- of the synchronzed type.
- -- If an inherited subprogram is implemented by a protected
- -- function, then the first parameter of the inherited
- -- subprogram shall be of mode in, but not an
- -- access-to-variable parameter (RM 9.4(11/9)
+ elsif Comes_From_Source (E)
+ and then Ekind (E) = E_Entry
+ and then
+ Present (Matching_Dispatching_Subprogram (Current_Scope, E))
+ then
+ Report_Conflict (E,
+ Matching_Dispatching_Subprogram (Current_Scope, E));
+ return True;
+ end if;
- if Present (First_Formal (Subp))
- and then Ekind (First_Formal (Subp)) = E_In_Parameter
- and then
- (not Is_Access_Type (Etype (First_Formal (Subp)))
- or else
- Is_Access_Constant (Etype (First_Formal (Subp))))
- then
- Overridden_Subp := Subp;
- return;
- end if;
- end if;
+ return False;
+ end Has_Matching_Entry_Or_Subprogram;
- Hom := Homonym (Hom);
- end loop;
-
- -- After examining all candidates for overriding, we are left with
- -- the best match which is a mode incompatible interface routine.
-
- if In_Scope and then Present (Candidate) then
- Error_Msg_PT (Def_Id, Candidate);
- end if;
-
- Overridden_Subp := Candidate;
- return;
- end;
- end Check_Synchronized_Overriding;
-
----------------------------
-- Is_Private_Declaration --
----------------------------
@@ -9732,6 +9986,24 @@
or else DT_Position (AO) = DT_Position (AN);
end Is_Overriding_Alias;
+ ---------------------
+ -- Report_Conflict --
+ ---------------------
+
+ procedure Report_Conflict (S : Entity_Id; E : Entity_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (E);
+
+ -- Generate message, with useful additional warning if in generic
+
+ if Is_Generic_Unit (E) then
+ Error_Msg_N ("previous generic unit cannot be overloaded", S);
+ Error_Msg_N ("\& conflicts with declaration#", S);
+ else
+ Error_Msg_N ("& conflicts with declaration#", S);
+ end if;
+ end Report_Conflict;
+
-- Start of processing for New_Overloaded_Entity
begin
@@ -9788,6 +10060,15 @@
return;
end if;
+ -- For synchronized types check conflicts of this entity with
+ -- previously defined entities.
+
+ if Ada_Version >= Ada_2005
+ and then Has_Matching_Entry_Or_Subprogram (S)
+ then
+ return;
+ end if;
+
-- If there is no homonym then this is definitely not overriding
if No (E) then
@@ -9864,17 +10145,7 @@
return;
else
- Error_Msg_Sloc := Sloc (E);
-
- -- Generate message, with useful additional warning if in generic
-
- if Is_Generic_Unit (E) then
- Error_Msg_N ("previous generic unit cannot be overloaded", S);
- Error_Msg_N ("\& conflicts with declaration#", S);
- else
- Error_Msg_N ("& conflicts with declaration#", S);
- end if;
-
+ Report_Conflict (S, E);
return;
end if;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -122,6 +122,15 @@
-- formal access-to-subprogram type, indicating that mapping of types
-- is needed.
+ procedure Check_Synchronized_Overriding
+ (Def_Id : Entity_Id;
+ Overridden_Subp : out Entity_Id);
+ -- First determine if Def_Id is an entry or a subprogram either defined
+ -- in the scope of a task or protected type, or is a primitive of such
+ -- a type. Check whether Def_Id overrides a subprogram of an interface
+ -- implemented by the synchronized type, return the overridden entity
+ -- or Empty.
+
procedure Check_Type_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
This patch minimizes the generation of wrappers of protected type dispatching primitives since they may cause reporting spurious ambiguity in correct code. After this patch the following test compiles without errors: package Ambig is type Lim_Iface is limited interface; type Prot is synchronized new Lim_Iface with private; function Not_Ambiguous (Obj : Prot) return Boolean; private protected type Prot is new Lim_Iface with entry Dummy; end Prot; Obj : Prot; Val : constant Boolean := Not_Ambiguous (Obj); -- OK end Ambig; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-05-02 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Process_Full_View): Remove from visibility wrappers of synchronized types to avoid spurious errors with their wrapped entity. * exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper if no interface primitive is covered by the subprogram and this is not a primitive declared between two views; see Process_Full_View. (Build_Protected_Sub_Specification): Link the dispatching subprogram with its original non-dispatching protected subprogram since their names differ. (Expand_N_Protected_Type_Declaration): If a protected subprogram overrides an interface primitive then do not build a wrapper if it was already built. * einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute. * sem_ch4.adb (Names_Match): New subprogram. * sem_ch6.adb (Check_Synchronized_Overriding): Moved to library level and defined in the public part of the package to invoke it from Exp_Ch9.Build_Wrapper_Spec (Has_Matching_Entry_Or_Subprogram): New subprogram. (Report_Conflict): New subprogram.