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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178306 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 89 insertions, 20 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 45904350732..91367c8d9e2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+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.
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 39d73027840..ac880eca235 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -617,6 +617,23 @@ package body Errout is
       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 --
    -----------------
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index ef3dcc47c29..7005cc11092 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -801,6 +801,10 @@ package Errout is
    --  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
 
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 2e11a278995..b30254df350 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -2263,14 +2263,42 @@ package body Exp_Ch9 is
          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
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9ecfb72f74a..67aff229e29 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9162,9 +9162,6 @@ package body Sem_Ch3 is
                   --  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 @@ package body Sem_Ch3 is
                        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
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 07c625d17a1..174a7dfd009 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4226,7 +4226,26 @@ package body Sem_Ch6 is
 
          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 @@ package body Sem_Ch6 is
             --  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 @@ package body Sem_Ch6 is
                       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;