This patch incorporates support in the compiler to detect conflicts
in declarations of primitives of concurrent tagged types (see full
documentation in AI05-0090-1). In addition the patch also performs
a minor code cleanup in order to factorize the code which reports
an error on wrong formal of protected type entity. After this
patch the following test must report an error.
package Synch_Pkg is
type Synch_Interface is synchronized interface;
end Synch_Pkg;
with Synch_Pkg; use Synch_Pkg;
package Task_Pkg is
task type Task_Type is new Synch_Interface with
entry Other_Prim;
end Task_Type;
procedure Other_Prim (Tsk : in out Task_Type); -- Legal? (No.)
end Task_Pkg;
Command: gcc -c -gnat05 task_pkg.ads
task_pkg.ads:8:14: "Other_Prim" conflicts with declaration at line 5
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-30 Javier Miranda <mira...@adacore.com>
* sem_ch3.adb (Check_Abstract_Overriding): Code cleanup: replace code
which emits an error by a call to a new routine which report the error.
* exp_ch9.adb (Build_Wrapper_Spec): Build the wrapper even if the
entity does not cover an existing interface.
* errout.ads, errout.adb (Error_Msg_PT): New routine. Used to factorize
code.
* sem_ch6.adb (Check_Conformance): Add specific error for wrappers of
protected procedures or entries whose mode is not conformant.
(Check_Synchronized_Overriding): Code cleanup: replace code which emits
an error by a call to a new routine which report the error.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 178305)
+++ sem_ch3.adb (working copy)
@@ -9162,9 +9162,6 @@
-- The controlling formal of Subp must be of mode "out",
-- "in out" or an access-to-variable to be overridden.
- -- Error message below needs rewording (remember comma
- -- in -gnatj mode) ???
-
if Ekind (First_Formal (Subp)) = E_In_Parameter
and then Ekind (Subp) /= E_Function
then
@@ -9172,12 +9169,7 @@
and then Is_Protected_Type
(Corresponding_Concurrent_Type (T))
then
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, " &
- "`IN OUT` or access-to-variable", T, Subp);
- Error_Msg_N
- ("\in order to be overridden by protected procedure "
- & "or entry (RM 9.4(11.9/2))", T);
+ Error_Msg_PT (T, Subp);
end if;
-- Some other kind of overriding failure
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 178304)
+++ exp_ch9.adb (working copy)
@@ -2263,14 +2263,42 @@
end loop Search;
end if;
- -- If the subprogram to be wrapped is not overriding anything or is not
- -- a primitive declared between two views, do not produce anything. This
- -- avoids spurious errors involving overriding.
+ -- 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.
if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id)
then
- return Empty;
+ if Is_Task_Type
+ (Corresponding_Concurrent_Type (Obj_Typ))
+ then
+ First_Param :=
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_uO),
+ In_Present => True,
+ Out_Present => False,
+ Parameter_Type => New_Reference_To (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_Reference_To (Obj_Typ, Loc));
+ end if;
end if;
declare
Index: errout.adb
===================================================================
--- errout.adb (revision 178293)
+++ errout.adb (working copy)
@@ -617,6 +617,23 @@
Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
end Error_Msg_CRT;
+ ------------------
+ -- Error_Msg_PT --
+ ------------------
+
+ procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is
+ begin
+ -- Error message below needs rewording (remember comma in -gnatj
+ -- mode) ???
+
+ Error_Msg_NE
+ ("first formal of & must be of mode `OUT`, `IN OUT` or " &
+ "access-to-variable", Typ, Subp);
+ Error_Msg_N
+ ("\in order to be overridden by protected procedure or entry " &
+ "(RM 9.4(11.9/2))", Typ);
+ end Error_Msg_PT;
+
-----------------
-- Error_Msg_F --
-----------------
Index: errout.ads
===================================================================
--- errout.ads (revision 178293)
+++ errout.ads (working copy)
@@ -801,6 +801,10 @@
-- run-time mode or no run-time mode (as appropriate). In the former case,
-- the name of the library is output if available.
+ procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id);
+ -- Posts an error on the protected type declaration Typ indicating wrong
+ -- mode of the first formal of protected type primitive Subp.
+
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 178304)
+++ sem_ch6.adb (working copy)
@@ -4226,7 +4226,26 @@
if Ctype >= Mode_Conformant then
if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
- Conformance_Error ("\mode of & does not match!", New_Formal);
+ if not Ekind_In (New_Id, E_Function, E_Procedure)
+ or else not Is_Primitive_Wrapper (New_Id)
+ then
+ Conformance_Error ("\mode of & does not match!", New_Formal);
+ else
+ declare
+ T : constant Entity_Id :=
+ Find_Dispatching_Type (New_Id);
+ begin
+ if Is_Protected_Type
+ (Corresponding_Concurrent_Type (T))
+ then
+ Error_Msg_PT (T, New_Id);
+ else
+ Conformance_Error
+ ("\mode of & does not match!", New_Formal);
+ end if;
+ end;
+ end if;
+
return;
-- Part of mode conformance for access types is having the same
@@ -7971,6 +7990,7 @@
-- 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);
@@ -8102,12 +8122,7 @@
or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ))
then
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, `IN OUT`"
- & " or access-to-variable", Typ, Candidate);
- Error_Msg_N
- ("\in order to be overridden by protected procedure or "
- & "entry (RM 9.4(11.9/2))", Typ);
+ Error_Msg_PT (Parent (Typ), Candidate);
end if;
end if;
