Commit 42f11e4c by Arnaud Charlet

[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
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.
......
...@@ -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 =>
......
...@@ -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.
......
...@@ -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;
......
...@@ -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);
......
...@@ -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
......
...@@ -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);
......
...@@ -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);
......
...@@ -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);
......
...@@ -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
......
...@@ -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