* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178306
138bc75d-0d04-0410-961f-
82ee72b054a4
+2011-08-30 Javier Miranda <miranda@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.
+
2011-08-30 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Minor change.
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 --
-----------------
-- 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
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
-- 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
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
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
-- 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);
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;
OSDN Git Service
