Patchwork [Ada] Add support to detect conflicting overriding primitive

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 30, 2011, 1:50 p.m.
Message ID <20110830135037.GA21977@adacore.com>
Download mbox | patch
Permalink /patch/112312/
State New
Headers show

Comments

Arnaud Charlet - Aug. 30, 2011, 1:50 p.m.
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  <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.

Patch

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;