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;