Skip to content

R
riscv-gcc-1
Commit 42f11e4c by Arnaud Charlet
Options

[multiple changes] 

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_prag.adb, comperr.adb: Minor reformatting.

2016-05-02  Ed Schonberg  <schonberg@adacore.com>

	* exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an
	unchecked conversion if the source size is 0 (indicating that
	its RM size is unknown). This will happen with packed arrays of
	non-discrete types, in which case the component type is known
	to match.

2016-05-02  Arnaud Charlet  <charlet@adacore.com>

	* debug.adb: Reserve -gnatd.V.

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.

From-SVN: r235739
parent 331e5015
Showing with 791 additions and 371 deletions
gcc/ada/ChangeLog
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb, comperr.adb: Minor reformatting.
2016-05-02 Ed Schonberg <schonberg@adacore.com>
* exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an
unchecked conversion if the source size is 0 (indicating that
its RM size is unknown). This will happen with packed arrays of
non-discrete types, in which case the component type is known
to match.
2016-05-02 Arnaud Charlet <charlet@adacore.com>
* debug.adb: Reserve -gnatd.V.
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.
2016-05-02 Jerome Lambourg <lambourg@adacore.com> 2016-05-02 Jerome Lambourg <lambourg@adacore.com>
* s-unstyp.ads: Code cleanups. * s-unstyp.ads: Code cleanups.
......
gcc/ada/comperr.adb
...@@ -467,8 +467,9 @@ package body Comperr is ...@@ -467,8 +467,9 @@ package body Comperr is
Main := Unit (Cunit (Main_Unit)); Main := Unit (Cunit (Main_Unit));
case Nkind (Main) is case Nkind (Main) is
when N_Subprogram_Declaration | N_Subprogram_Body | when N_Package_Declaration |
N_Package_Declaration => N_Subprogram_Body |
N_Subprogram_Declaration =>
Unit_Name := Defining_Unit_Name (Specification (Main)); Unit_Name := Defining_Unit_Name (Specification (Main));
when N_Package_Body => when N_Package_Body =>
......
gcc/ada/debug.adb
...@@ -139,7 +139,7 @@ package body Debug is ...@@ -139,7 +139,7 @@ package body Debug is
-- d.S Force Optimize_Alignment (Space) -- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time) -- d.T Force Optimize_Alignment (Time)
-- d.U Ignore indirect calls for static elaboration -- d.U Ignore indirect calls for static elaboration
-- d.V -- d.V Do not verify validity of SCIL files (CodePeer mode)
-- d.W Print out debugging information for Walk_Library_Items -- d.W Print out debugging information for Walk_Library_Items
-- d.X Old treatment of indexing aspects -- d.X Old treatment of indexing aspects
-- d.Y -- d.Y
...@@ -686,6 +686,12 @@ package body Debug is ...@@ -686,6 +686,12 @@ package body Debug is
-- reverts to the behavior of earlier compilers, which ignored -- reverts to the behavior of earlier compilers, which ignored
-- indirect calls. -- indirect calls.
-- d.V Do not verify the validity of SCIL files (CodePeer mode). When
-- generating SCIL files for CodePeer, by default we verify that the
-- SCIL is well formed before saving it on disk. This switch can be
-- used to disable this checking, either to improve speed or to shut
-- down a false positive detected during the verification.
-- d.W Print out debugging information for Walk_Library_Items, including -- d.W Print out debugging information for Walk_Library_Items, including
-- the order in which units are walked. This is primarily for use in -- the order in which units are walked. This is primarily for use in
-- debugging CodePeer mode. -- debugging CodePeer mode.
......
gcc/ada/einfo.adb
...@@ -274,6 +274,7 @@ package body Einfo is ...@@ -274,6 +274,7 @@ package body Einfo is
-- SPARK_Pragma Node40 -- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
-- SPARK_Aux_Pragma Node41 -- SPARK_Aux_Pragma Node41
--------------------------------------------- ---------------------------------------------
...@@ -2837,6 +2838,11 @@ package body Einfo is ...@@ -2837,6 +2838,11 @@ package body Einfo is
return Node21 (Id); return Node21 (Id);
end Original_Array_Type; 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 function Original_Record_Component (Id : E) return E is
begin begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
...@@ -5900,6 +5906,12 @@ package body Einfo is ...@@ -5900,6 +5906,12 @@ package body Einfo is
Set_Node21 (Id, V); Set_Node21 (Id, V);
end Set_Original_Array_Type; 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 procedure Set_Original_Record_Component (Id : E; V : E) is
begin begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
...@@ -10483,6 +10495,10 @@ package body Einfo is ...@@ -10483,6 +10495,10 @@ package body Einfo is
E_Task_Type => E_Task_Type =>
Write_Str ("SPARK_Aux_Pragma"); Write_Str ("SPARK_Aux_Pragma");
when E_Function |
E_Procedure =>
Write_Str ("Original_Protected_Subprogram");
when others => when others =>
Write_Str ("Field41??"); Write_Str ("Field41??");
end case; end case;
......
gcc/ada/einfo.ads
...@@ -3647,6 +3647,11 @@ package Einfo is ...@@ -3647,6 +3647,11 @@ package Einfo is
-- points to the original array type for which this is the packed -- points to the original array type for which this is the packed
-- array implementation type. -- 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) -- Original_Record_Component (Node22)
-- Defined in components, including discriminants. The usage depends -- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged. -- on whether the record is a base type and whether it is tagged.
...@@ -5923,6 +5928,7 @@ package Einfo is ...@@ -5923,6 +5928,7 @@ package Einfo is
-- Class_Wide_Preconds (List38) -- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39) -- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40) -- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40) -- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279) -- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108) -- Default_Expressions_Processed (Flag108)
...@@ -6234,6 +6240,7 @@ package Einfo is ...@@ -6234,6 +6240,7 @@ package Einfo is
-- Class_Wide_Preconds (List38) -- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39) -- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40) -- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40) -- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279) -- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114) -- Delay_Cleanups (Flag114)
...@@ -7127,6 +7134,7 @@ package Einfo is ...@@ -7127,6 +7134,7 @@ package Einfo is
function Optimize_Alignment_Time (Id : E) return B; function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E; function Original_Access_Type (Id : E) return E;
function Original_Array_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 Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B; function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E; function Overridden_Operation (Id : E) return E;
...@@ -7801,6 +7809,7 @@ package Einfo is ...@@ -7801,6 +7809,7 @@ package Einfo is
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True); procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E); procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_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_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True); procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E); procedure Set_Overridden_Operation (Id : E; V : E);
...@@ -8628,6 +8637,7 @@ package Einfo is ...@@ -8628,6 +8637,7 @@ package Einfo is
pragma Inline (Optimize_Alignment_Time); pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type); pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type); pragma Inline (Original_Array_Type);
pragma Inline (Original_Protected_Subprogram);
pragma Inline (Original_Record_Component); pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant); pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation); pragma Inline (Overridden_Operation);
...@@ -9093,6 +9103,7 @@ package Einfo is ...@@ -9093,6 +9103,7 @@ package Einfo is
pragma Inline (Set_Optimize_Alignment_Time); pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type); pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Protected_Subprogram);
pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant); pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation); pragma Inline (Set_Overridden_Operation);
......
gcc/ada/exp_ch9.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2443,13 +2443,6 @@ package body Exp_Ch9 is ...@@ -2443,13 +2443,6 @@ package body Exp_Ch9 is
Obj_Typ : Entity_Id; Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id Formals : List_Id) return Node_Id
is 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 function Overriding_Possible
(Iface_Op : Entity_Id; (Iface_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean; Wrapper : Entity_Id) return Boolean;
...@@ -2631,6 +2624,16 @@ package body Exp_Ch9 is ...@@ -2631,6 +2624,16 @@ package body Exp_Ch9 is
return New_Formals; return New_Formals;
end Replicate_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 -- Start of processing for Build_Wrapper_Spec
begin begin
...@@ -2638,17 +2641,24 @@ package body Exp_Ch9 is ...@@ -2638,17 +2641,24 @@ package body Exp_Ch9 is
pragma Assert (Is_Tagged_Type (Obj_Typ)); 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 -- 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 -- 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 -- type. Since the wrapper must have the exact same signature as that of
-- the overridden subprogram, we try to find the overriding candidate -- the overridden subprogram, we try to find the overriding candidate
-- and use its controlling formal. -- and use its controlling formal.
First_Param := Empty;
-- Check every implemented interface -- Check every implemented interface
if Present (Interfaces (Obj_Typ)) then elsif Present (Interfaces (Obj_Typ)) then
Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
Search : while Present (Iface_Elmt) loop Search : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt); Iface := Node (Iface_Elmt);
...@@ -2684,40 +2694,14 @@ package body Exp_Ch9 is ...@@ -2684,40 +2694,14 @@ package body Exp_Ch9 is
end loop Search; end loop Search;
end if; end if;
-- Ada 2012 (AI05-0090-1): If no interface primitive is covered by -- Do not generate the wrapper if no interface primitive is covered by
-- this subprogram and this is not a primitive declared between two -- the subprogram and it is not a primitive declared declared between
-- views then force the generation of a wrapper. As an optimization, -- two views (see Process_Full_View).
-- 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.
if No (First_Param) if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id) and then not Is_Private_Primitive_Subprogram (Subp_Id)
then then
if Is_Task_Type return Empty;
(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;
end if; end if;
declare declare
...@@ -4229,6 +4213,15 @@ package body Exp_Ch9 is ...@@ -4229,6 +4213,15 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 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 -- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does -- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step -- not come from source. It is also convenient to allow gdb to step
...@@ -9653,22 +9646,50 @@ package body Exp_Ch9 is ...@@ -9653,22 +9646,50 @@ package body Exp_Ch9 is
Current_Node := Sub; Current_Node := Sub;
-- Generate an overriding primitive operation specification for -- 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 if Ada_Version >= Ada_2005
and then and then
Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then then
Sub := declare
Make_Subprogram_Declaration (Loc, Prim_Elmt : Elmt_Id;
Specification => Prim_Op : Node_Id;
Build_Protected_Sub_Specification Found : Boolean := False;
(Comp, Prot_Typ, Dispatching_Mode));
Insert_After (Current_Node, Sub); begin
Analyze (Sub); 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; end if;
-- If a pragma Interrupt_Handler applies, build and add a call to -- If a pragma Interrupt_Handler applies, build and add a call to
......
gcc/ada/exp_pakd.adb
...@@ -2298,9 +2298,12 @@ package body Exp_Pakd is ...@@ -2298,9 +2298,12 @@ package body Exp_Pakd is
-- convert to a modular type of the source length, since otherwise, on -- convert to a modular type of the source length, since otherwise, on
-- a big-endian machine, we get left-justification. We do it for little- -- a big-endian machine, we get left-justification. We do it for little-
-- endian machines as well, because there might be junk bits that are -- endian machines as well, because there might be junk bits that are
-- not cleared if the type is not numeric. -- not cleared if the type is not numeric. This can be done only if the
-- source siz is different from 0 (i.e. known), otherwise we must trust
-- the type declarations (case of non-discrete components).
if Source_Siz /= Target_Siz if Source_Siz /= 0
and then Source_Siz /= Target_Siz
and then not Is_Discrete_Type (Source_Typ) and then not Is_Discrete_Type (Source_Typ)
then then
Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
......
gcc/ada/exp_prag.adb
...@@ -884,8 +884,8 @@ package body Exp_Prag is ...@@ -884,8 +884,8 @@ package body Exp_Prag is
Set_Expression (Decl, Pref); Set_Expression (Decl, Pref);
Analyze (Decl); Analyze (Decl);
-- Otherwise add an assignment statement to temporary -- Otherwise add an assignment statement to temporary using
-- using prefix as RHS. -- prefix as RHS.
else else
Analyze (Decl); Analyze (Decl);
......
gcc/ada/sem_ch3.adb
...@@ -19835,6 +19835,13 @@ package body Sem_Ch3 is ...@@ -19835,6 +19835,13 @@ package body Sem_Ch3 is
Curr_Nod := Wrap_Spec; Curr_Nod := Wrap_Spec;
Analyze (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; end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
......
gcc/ada/sem_ch4.adb
...@@ -8817,6 +8817,15 @@ package body Sem_Ch4 is ...@@ -8817,6 +8817,15 @@ package body Sem_Ch4 is
-- is visible a direct call to it will dispatch to the private one, -- is visible a direct call to it will dispatch to the private one,
-- which is therefore a valid candidate. -- 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; function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid -- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals -- controlling argument in a call to Op. The remaining actuals
...@@ -8993,6 +9002,34 @@ package body Sem_Ch4 is ...@@ -8993,6 +9002,34 @@ package body Sem_Ch4 is
and then not Is_Hidden (Visible_Op); and then not Is_Hidden (Visible_Op);
end Is_Private_Overriding; 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 -- -- Valid_First_Argument_Of --
----------------------------- -----------------------------
...@@ -9059,7 +9096,7 @@ package body Sem_Ch4 is ...@@ -9059,7 +9096,7 @@ package body Sem_Ch4 is
while Present (Elmt) loop while Present (Elmt) loop
Prim_Op := Node (Elmt); 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 Present (First_Formal (Prim_Op))
and then Valid_First_Argument_Of (Prim_Op) and then Valid_First_Argument_Of (Prim_Op)
and then and then
......
gcc/ada/sem_ch6.adb
...@@ -6463,6 +6463,341 @@ package body Sem_Ch6 is ...@@ -6463,6 +6463,341 @@ package body Sem_Ch6 is
Get_Inst => Get_Inst); Get_Inst => Get_Inst);
end Check_Subtype_Conformant; 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 -- -- Check_Type_Conformant --
--------------------------- ---------------------------
...@@ -9000,14 +9335,14 @@ package body Sem_Ch6 is ...@@ -9000,14 +9335,14 @@ package body Sem_Ch6 is
-- type, and set Is_Primitive to True (otherwise set to False). Set the -- type, and set Is_Primitive to True (otherwise set to False). Set the
-- corresponding flag on the entity itself for later use. -- corresponding flag on the entity itself for later use.
procedure Check_Synchronized_Overriding function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean;
(Def_Id : Entity_Id; -- True if a) E is a subprogram whose first formal is a concurrent type
Overridden_Subp : out Entity_Id); -- defined in the scope of E that has some entry or subprogram whose
-- First determine if Def_Id is an entry or a subprogram either defined -- profile matches E, or b) E is an internally built dispatching
-- in the scope of a task or protected type, or is a primitive of such -- subprogram of a protected type and there is a matching subprogram
-- a type. Check whether Def_Id overrides a subprogram of an interface -- defined in the enclosing scope of the protected type, or c) E is
-- implemented by the synchronized type, return the overridden entity -- an entry of a synchronized type and a matching procedure has been
-- or Empty. -- previously defined in the enclosing scope of the synchronized type.
function Is_Private_Declaration (E : Entity_Id) return Boolean; function Is_Private_Declaration (E : Entity_Id) return Boolean;
-- Check that E is declared in the private part of the current package, -- Check that E is declared in the private part of the current package,
...@@ -9025,6 +9360,9 @@ package body Sem_Ch6 is ...@@ -9025,6 +9360,9 @@ package body Sem_Ch6 is
-- function is conservative given that the converse is only true within -- function is conservative given that the converse is only true within
-- instances that contain accidental overloadings. -- 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 -- -- Check_For_Primitive_Subprogram --
------------------------------------ ------------------------------------
...@@ -9350,340 +9688,256 @@ package body Sem_Ch6 is ...@@ -9350,340 +9688,256 @@ package body Sem_Ch6 is
end if; end if;
end Check_For_Primitive_Subprogram; end Check_For_Primitive_Subprogram;
----------------------------------- --------------------------------------
-- Check_Synchronized_Overriding -- -- Has_Matching_Entry_Or_Subprogram --
----------------------------------- --------------------------------------
procedure Check_Synchronized_Overriding function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean
(Def_Id : Entity_Id;
Overridden_Subp : out Entity_Id)
is is
Ifaces_List : Elist_Id; function Check_Conforming_Parameters
In_Scope : Boolean; (E1_Param : Node_Id;
Typ : Entity_Id; E2_Param : Node_Id) return Boolean;
-- Starting from the given parameters, check that all the parameters
function Matches_Prefixed_View_Profile -- of two entries or subprograms are are subtype conformant. Used to
(Prim_Params : List_Id; -- skip the check on the controlling argument.
Iface_Params : List_Id) return Boolean;
-- Determine whether a subprogram's parameter profile Prim_Params function Matching_Entry_Or_Subprogram
-- matches that of a potentially overridden interface subprogram (Conc_Typ : Entity_Id;
-- Iface_Params. Also determine if the type of first parameter of Subp : Entity_Id) return Entity_Id;
-- Iface_Params is an implemented interface. -- 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;
function Matches_Prefixed_View_Profile Ent : Entity_Id) return Entity_Id;
(Prim_Params : List_Id; -- Return the first dispatching primitive of Conc_Type defined in the
Iface_Params : List_Id) return Boolean -- 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 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.
---------------------------------
-- Check_Confirming_Parameters --
---------------------------------
function Check_Conforming_Parameters
(E1_Param : Node_Id;
E2_Param : Node_Id) return Boolean
is is
Iface_Id : Entity_Id; Param_E1 : Node_Id := E1_Param;
Iface_Param : Node_Id; Param_E2 : Node_Id := E2_Param;
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 begin
Iface_Param := First (Iface_Params); while Present (Param_E1) and then Present (Param_E2) loop
Iface_Typ := Etype (Defining_Identifier (Iface_Param)); if Ekind (Defining_Identifier (Param_E1))
/= Ekind (Defining_Identifier (Param_E2))
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 or else not
Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) Conforming_Types (Find_Parameter_Type (Param_E1),
Find_Parameter_Type (Param_E2),
Subtype_Conformant)
then then
return False; return False;
end if; end if;
Next (Iface_Param); Next (Param_E1);
Next (Prim_Param); Next (Param_E2);
end loop; end loop;
-- One of the two lists contains more parameters than the other -- The candidate is not valid if one of the two lists contains
-- more parameters than the other
if Present (Iface_Param) or else Present (Prim_Param) then return No (Param_E1) and then No (Param_E2);
return False; end Check_Conforming_Parameters;
end if;
return True; ----------------------------------
end Matches_Prefixed_View_Profile; -- Matching_Entry_Or_Subprogram --
----------------------------------
-- 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 function Matching_Entry_Or_Subprogram
-- of all implemented interfaces. In this case, the subprogram is (Conc_Typ : Entity_Id;
-- declared within the scope of a protected or a task type. Subp : Entity_Id) return Entity_Id
is
if Present (Scope (Def_Id)) E : Entity_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 begin
-- concurrent type. 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 E;
end if;
else Next_Entity (E);
Typ := Etype (First_Formal (Def_Id)); end loop;
if Is_Access_Type (Typ) then return Empty;
Typ := Directly_Designated_Type (Typ); end Matching_Entry_Or_Subprogram;
end if;
if Is_Concurrent_Type (Typ) -------------------------------------
and then not Is_Generic_Actual_Type (Typ) -- Matching_Dispatching_Subprogram --
then -------------------------------------
In_Scope := False;
-- This case occurs when the concurrent type is declared within function Matching_Dispatching_Subprogram
-- a generic unit. As a result the corresponding record has been (Conc_Typ : Entity_Id;
-- built and used as the type of the first formal, we just have Ent : Entity_Id) return Entity_Id
-- to retrieve the corresponding concurrent type. is
E : Entity_Id;
elsif Is_Concurrent_Record_Type (Typ) begin
and then not Is_Class_Wide_Type (Typ) -- Search for entities in the enclosing scope of this synchonized
and then Present (Corresponding_Concurrent_Type (Typ)) -- type
then
Typ := Corresponding_Concurrent_Type (Typ);
In_Scope := False;
else pragma Assert (Is_Concurrent_Type (Conc_Typ));
return; Push_Scope (Scope (Conc_Typ));
end if; E := Current_Entity_In_Scope (Ent);
end if; Pop_Scope;
-- There is no overriding to check if is an inherited operation in a while Present (E) loop
-- type derivation on for a generic actual. 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;
Collect_Interfaces (Typ, Ifaces_List); E := Homonym (E);
end loop;
if Is_Empty_Elmt_List (Ifaces_List) then return Empty;
return; end Matching_Dispatching_Subprogram;
end if;
-- Determine whether entry or subprogram Def_Id overrides a primitive --------------------------------------------
-- operation that belongs to one of the interfaces in Ifaces_List. -- Matching_Original_Protected_Subprogram --
--------------------------------------------
declare function Matching_Original_Protected_Subprogram
Candidate : Entity_Id := Empty; (Prot_Typ : Entity_Id;
Hom : Entity_Id := Empty; Subp : Entity_Id) return Entity_Id
Subp : Entity_Id := Empty; is
ICF : constant Boolean :=
Is_Controlling_Formal (First_Entity (Subp));
E : Entity_Id;
begin begin
-- Traverse the homonym chain, looking for a potentially -- Temporarily decorate the first parameter of Subp as controlling
-- overridden subprogram that belongs to an implemented -- formal; required to invoke Subtype_Conformant()
-- 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 Set_Is_Controlling_Formal (First_Entity (Subp));
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 E :=
-- of its first parameter is correct depending on the kind Current_Entity_In_Scope (Original_Protected_Subprogram (Subp));
-- 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 while Present (E) loop
-- does not have a restriction on the mode of the first if Scope (E) = Scope (Prot_Typ)
-- parameter of the overridden interface routine. 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
Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
return E;
end if;
else E := Homonym (E);
Overridden_Subp := Candidate; end loop;
return;
end if;
end;
-- Functions can override abstract interface functions Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
return Empty;
end Matching_Original_Protected_Subprogram;
elsif Ekind (Def_Id) = E_Function -- Start of processing for Has_Matching_Entry_Or_Subprogram
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 begin
-- function, then the first parameter of the inherited -- Case 1: E is a subprogram whose first formal is a concurrent type
-- subprogram shall be of mode in, but not an -- defined in the scope of E that has an entry or subprogram whose
-- access-to-variable parameter (RM 9.4(11/9) -- profile matches E.
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;
if Present (First_Formal (Subp)) -- Case 2: E is an internally built dispatching subprogram of a
and then Ekind (First_Formal (Subp)) = E_In_Parameter -- protected type and there is a subprogram defined in the enclosing
and then -- scope of the protected type that has the original name of E and
(not Is_Access_Type (Etype (First_Formal (Subp))) -- its profile is conformant with the profile of E. We check the
or else -- name of the original protected subprogram associated with E since
Is_Access_Constant (Etype (First_Formal (Subp)))) -- the expander builds dispatching primitives of protected functions
then -- and procedures with other name (see Exp_Ch9.Build_Selected_Name).
Overridden_Subp := Subp;
return;
end if;
end if;
Hom := Homonym (Hom); elsif not Comes_From_Source (E)
end loop; 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;
-- After examining all candidates for overriding, we are left with -- Case : E is an entry of a synchronized type and a matching
-- the best match which is a mode incompatible interface routine. -- procedure has been previously defined in the enclosing scope
-- of the synchronzed type.
if In_Scope and then Present (Candidate) then elsif Comes_From_Source (E)
Error_Msg_PT (Def_Id, Candidate); and then Ekind (E) = E_Entry
end if; and then
Present (Matching_Dispatching_Subprogram (Current_Scope, E))
then
Report_Conflict (E,
Matching_Dispatching_Subprogram (Current_Scope, E));
return True;
end if;
Overridden_Subp := Candidate; return False;
return; end Has_Matching_Entry_Or_Subprogram;
end;
end Check_Synchronized_Overriding;
---------------------------- ----------------------------
-- Is_Private_Declaration -- -- Is_Private_Declaration --
...@@ -9732,6 +9986,24 @@ package body Sem_Ch6 is ...@@ -9732,6 +9986,24 @@ package body Sem_Ch6 is
or else DT_Position (AO) = DT_Position (AN); or else DT_Position (AO) = DT_Position (AN);
end Is_Overriding_Alias; 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 -- Start of processing for New_Overloaded_Entity
begin begin
...@@ -9788,6 +10060,15 @@ package body Sem_Ch6 is ...@@ -9788,6 +10060,15 @@ package body Sem_Ch6 is
return; return;
end if; 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 there is no homonym then this is definitely not overriding
if No (E) then if No (E) then
...@@ -9864,17 +10145,7 @@ package body Sem_Ch6 is ...@@ -9864,17 +10145,7 @@ package body Sem_Ch6 is
return; return;
else else
Error_Msg_Sloc := Sloc (E); Report_Conflict (S, 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;
return; return;
end if; end if;
......
gcc/ada/sem_ch6.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -122,6 +122,15 @@ package Sem_Ch6 is ...@@ -122,6 +122,15 @@ package Sem_Ch6 is
-- formal access-to-subprogram type, indicating that mapping of types -- formal access-to-subprogram type, indicating that mapping of types
-- is needed. -- 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 procedure Check_Type_Conformant
(New_Id : Entity_Id; (New_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment