Patchwork [Ada] 2012 rule on aliasing

login
register
mail settings
Submitter Arnaud Charlet
Date Jan. 3, 2013, 11:05 a.m.
Message ID <20130103110538.GA22531@adacore.com>
Download mbox | patch
Permalink /patch/209218/
State New
Headers show

Comments

Arnaud Charlet - Jan. 3, 2013, 11:05 a.m.
Ongoing work to implement AI05-0144. No test needed.

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-01-03  Javier Miranda  <miranda@adacore.com>

	* sem_warn.adb (Warn_On_Overlapping_Actuals): Adding documentation
	plus restricting the functionality of this routine to cover the
	cases described in the Ada 2012 reference manual. The previous
	extended support is now available under -gnatX.
	* s-tassta.adb (Finalize_Global_Tasks): Addition of a dummy
	variable to call Timed_Sleep.  Required to avoid warning on
	overlapping out-mode actuals.
	* opt.ads (Extensions_Allowed): Update documentation.

Patch

Index: s-tassta.adb
===================================================================
--- s-tassta.adb	(revision 194841)
+++ s-tassta.adb	(working copy)
@@ -806,8 +806,9 @@ 
    procedure Finalize_Global_Tasks is
       Self_ID : constant Task_Id := STPO.Self;
 
-      Ignore  : Boolean;
-      pragma Unreferenced (Ignore);
+      Ignore_1 : Boolean;
+      Ignore_2 : Boolean;
+      pragma Unreferenced (Ignore_1, Ignore_2);
 
       function State
         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
@@ -877,7 +878,7 @@ 
 
             Timed_Sleep
               (Self_ID, 0.01, System.OS_Primitives.Relative,
-               Self_ID.Common.State, Ignore, Ignore);
+               Self_ID.Common.State, Ignore_1, Ignore_2);
          end loop;
       end if;
 
@@ -886,7 +887,7 @@ 
 
       Timed_Sleep
         (Self_ID, 0.01, System.OS_Primitives.Relative,
-         Self_ID.Common.State, Ignore, Ignore);
+         Self_ID.Common.State, Ignore_1, Ignore_2);
 
       Unlock (Self_ID);
 
Index: sem_warn.adb
===================================================================
--- sem_warn.adb	(revision 194841)
+++ sem_warn.adb	(working copy)
@@ -3292,41 +3292,89 @@ 
       Act1, Act2   : Node_Id;
       Form1, Form2 : Entity_Id;
 
+      function Is_Covered_Formal (Formal : Node_Id) return Boolean;
+      --  Return True if Formal is covered by the Ada 2012 rule. Under -gnatX
+      --  the rule is extended to cover record and array types.
+
+      function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean;
+      --  Two names are known to refer to the same object if the two names
+      --  are known to denote the same object; or one of the names is a
+      --  selected_component, indexed_component, or slice and its prefix is
+      --  known to refer to the same object as the other name; or one of the
+      --  two names statically denotes a renaming declaration whose renamed
+      --  object_name is known to refer to the same object as the other name
+      --  (RM 6.4.1(6.11/3))
+
+      -----------------------
+      -- Refer_Same_Object --
+      -----------------------
+
+      function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean is
+      begin
+         return Denotes_Same_Object (Act1, Act2)
+           or else Denotes_Same_Prefix (Act1, Act2);
+      end Refer_Same_Object;
+
+      -----------------------
+      -- Is_Covered_Formal --
+      -----------------------
+
+      function Is_Covered_Formal (Formal : Node_Id) return Boolean is
+      begin
+         --  Ada 2012 rule
+
+         if not Extensions_Allowed then
+            return
+              Ekind_In (Formal, E_Out_Parameter,
+                                E_In_Out_Parameter)
+                and then Is_Elementary_Type (Etype (Formal));
+
+         --  Under -gnatX the rule is extended to cover array and record types
+
+         else
+            return
+              Ekind_In (Formal, E_Out_Parameter,
+                                E_In_Out_Parameter)
+                and then (Is_Elementary_Type (Etype (Formal))
+                            or else Is_Record_Type (Etype (Formal))
+                            or else Is_Array_Type (Etype (Formal)));
+         end if;
+      end Is_Covered_Formal;
+
    begin
-      if not Warn_On_Overlap then
+      if Ada_Version < Ada_2012 and then not Warn_On_Overlap then
          return;
       end if;
 
       --  Exclude calls rewritten as enumeration literals
 
-      if Nkind (N) not in N_Subprogram_Call then
+      if Nkind (N) not in N_Subprogram_Call
+        and then Nkind (N) /= N_Entry_Call_Statement
+      then
          return;
       end if;
 
-      --  Exclude calls to library subprograms. Container operations specify
-      --  safe behavior when source and target coincide.
+      --  If a call C has two or more parameters of mode in out or out that are
+      --  of an elementary type, then the call is legal only if for each name
+      --  N that is passed as a parameter of mode in out or out to the call C,
+      --  there is no other name among the other parameters of mode in out or
+      --  out to C that is known to denote the same object (RM 6.4.1(6.15/3))
 
-      if Is_Predefined_File_Name
-           (Unit_File_Name (Get_Source_Unit (Sloc (Subp))))
-      then
-         return;
-      end if;
+      --  Under -gnatX the rule is extended to cover array and record types.
 
       Form1 := First_Formal (Subp);
       Act1  := First_Actual (N);
       while Present (Form1) and then Present (Act1) loop
-         if Ekind (Form1) /= E_In_Parameter then
+
+         if Is_Covered_Formal (Form1) then
             Form2 := First_Formal (Subp);
             Act2  := First_Actual (N);
             while Present (Form2) and then Present (Act2) loop
                if Form1 /= Form2
-                 and then Ekind (Form2) /= E_Out_Parameter
-                 and then
-                   (Denotes_Same_Object (Act1, Act2)
-                      or else
-                    Denotes_Same_Prefix (Act1, Act2))
+                 and then Is_Covered_Formal (Form2)
+                 and then Refer_Same_Object (Act1, Act2)
                then
-                  --  Exclude generic types and guard against previous errors
+                  --  Guard against previous errors
 
                   if Error_Posted (N)
                     or else No (Etype (Act1))
@@ -3334,15 +3382,9 @@ 
                   then
                      null;
 
-                  elsif Is_Generic_Type (Etype (Act1))
-                          or else
-                        Is_Generic_Type (Etype (Act2))
-                  then
-                     null;
+                  --  If the actual is a function call in prefix notation,
+                  --  there is no real overlap.
 
-                     --  If the actual is a function call in prefix notation,
-                     --  there is no real overlap.
-
                   elsif Nkind (Act2) = N_Function_Call then
                      null;
 
@@ -3350,11 +3392,20 @@ 
                   --  intended.
 
                   elsif
-                    Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
+                    Present (Underlying_Type (Etype (Form1)))
+                      and then
+                        (Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
+                           or else
+                             Convention (Underlying_Type (Etype (Form1)))
+                               = Convention_Ada_Pass_By_Reference)
                   then
                      null;
 
+                  --  Here we may need to issue message
+
                   else
+                     Error_Msg_Warn := Ada_Version < Ada_2012;
+
                      declare
                         Act  : Node_Id;
                         Form : Entity_Id;
Index: opt.ads
===================================================================
--- opt.ads	(revision 194841)
+++ opt.ads	(working copy)
@@ -563,7 +563,7 @@ 
    Extensions_Allowed : Boolean := False;
    --  GNAT
    --  Set to True by switch -gnatX if GNAT specific language extensions
-   --  are allowed. Currently there are no such defined extensions.
+   --  are allowed.
 
    type External_Casing_Type is (
      As_Is,       -- External names cased as they appear in the Ada source