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)
After this patch the error is reported in the following example:
procedure by30015_01p is
package pack is
type Iface is protected interface;
function Prim1_1
(M : in out Iface; Value : Integer) return Natural is abstract;
protected type PO_T1 is new Iface with
function Prim1_1 (Value : Integer) return Natural; -- ERROR
end PO_T1;
end pack;
package body Pack is
protected body PO_T1 is
function Prim1_1 (Value : Integer) return Natural is
begin return 0; end;
end PO_T1;
end Pack;
begin
null;
end;
Command: gcc -c -gnat12 by30015_01p.adb
Output:
by30015_01p.adb:9:19: illegal overriding of subprogram inherited from
interface
by30015_01p.adb:9:19: first formal of "Prim1_1" declared at line 5 must
be of mode "in" or access-to-constant
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-02-05 Javier Miranda <mira...@adacore.com>
* errout.adb (Error_Msg_PT): Add missing error.
* sem_ch6.adb (Check_Synchronized_Overriding): Check the missing
RM rule. Code cleanup.
* exp_ch9.adb (Build_Wrapper_Spec): Propagate "constant" in
anonymous access types. Found working on the tests. Code cleanup.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 220439)
+++ exp_ch9.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2640,10 +2640,11 @@
Obj_Param_Typ :=
Make_Access_Definition (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Obj_Typ, Loc));
- Set_Null_Exclusion_Present (Obj_Param_Typ,
- Null_Exclusion_Present (Parameter_Type (First_Param)));
-
+ New_Occurrence_Of (Obj_Typ, Loc),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Parameter_Type (First_Param)),
+ Constant_Present =>
+ Constant_Present (Parameter_Type (First_Param)));
else
Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
end if;
Index: errout.adb
===================================================================
--- errout.adb (revision 220450)
+++ errout.adb (working copy)
@@ -686,9 +686,16 @@
("illegal overriding of subprogram inherited from interface", E);
Error_Msg_Sloc := Sloc (Iface_Prim);
- Error_Msg_N
- ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " &
- "or access-to-variable", E);
+
+ if Ekind (E) = E_Function then
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `IN` " &
+ "or access-to-constant", E);
+ else
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " &
+ "or access-to-variable", E);
+ end if;
end Error_Msg_PT;
-----------------
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 220439)
+++ sem_ch6.adb (working copy)
@@ -9259,7 +9259,6 @@
declare
Candidate : Entity_Id := Empty;
Hom : Entity_Id := Empty;
- Iface_Typ : Entity_Id;
Subp : Entity_Id := Empty;
begin
@@ -9334,8 +9333,23 @@
and then Etype (Result_Definition (Parent (Def_Id))) =
Etype (Result_Definition (Parent (Subp)))
then
- Overridden_Subp := Subp;
- return;
+ 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);
@@ -9343,29 +9357,9 @@
-- After examining all candidates for overriding, we are left with
-- the best match which is a mode incompatible interface routine.
- -- Do not emit an error if the Expander is active since this error
- -- will be detected later on after all concurrent types are
- -- expanded and all wrappers are built. This check is meant for
- -- spec-only compilations.
- if Present (Candidate) and then not Expander_Active then
- Iface_Typ :=
- Find_Parameter_Type (Parent (First_Formal (Candidate)));
-
- -- Def_Id is primitive of a protected type, declared inside the
- -- type, and the candidate is primitive of a limited or
- -- synchronized interface.
-
- if In_Scope
- and then Is_Protected_Type (Typ)
- and then
- (Is_Limited_Interface (Iface_Typ)
- or else Is_Protected_Interface (Iface_Typ)
- or else Is_Synchronized_Interface (Iface_Typ)
- or else Is_Task_Interface (Iface_Typ))
- then
- Error_Msg_PT (Def_Id, Candidate);
- end if;
+ if In_Scope and then Present (Candidate) then
+ Error_Msg_PT (Def_Id, Candidate);
end if;
Overridden_Subp := Candidate;
