[multiple changes]

2009-10-27  Robert Dewar  <dewar@adacore.com>

	* s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor
	reformatting.

2009-10-27  Ed Schonberg  <schonberg@adacore.com>

	* sem.util.ads, sem_util.adb (Denotes_Same_Object,
	Denotes_Same_Prefix): New functions to detect overlap between actuals
	that are not by-copy in a call, when one of them is in-out.
	* sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New
	procedure,  called on a subprogram call to warn when an in-out actual
	that is not by-copy overlaps with another actual, thus leadind to
	potentially dangerous aliasing in the body of the called subprogram.
	Currently the warning is under control of the -gnatX switch.
	* sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals.

From-SVN: r153594

10 files changed, 345 insertions, 29 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index de24ed1..cabdaee 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2009-10-27  Robert Dewar  <dewar@adacore.com>
+
+	* s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor
+	reformatting.
+
+2009-10-27  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem.util.ads, sem_util.adb (Denotes_Same_Object,
+	Denotes_Same_Prefix): New functions to detect overlap between actuals
+	that are not by-copy in a call, when one of them is in-out.
+	* sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New
+	procedure,  called on a subprogram call to warn when an in-out actual
+	that is not by-copy overlaps with another actual, thus leadind to
+	potentially dangerous aliasing in the body of the called subprogram.
+	Currently the warning is under control of the -gnatX switch.
+	* sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals.
+
 2009-10-27  Thomas Quinot  <quinot@adacore.com>
 
 	* sem_ch12.adb (Install_Formal_Packages): Do not omit installation of
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index bf8c1cd..f977549 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -220,9 +220,9 @@ package body Makeutl is
                --  (and then will be for the same unit).
 
                if Find_Source
-                 (In_Tree   => Project_Tree,
-                  Project   => No_Project,
-                  Base_Name => SD.Sfile) = No_Source
+                    (In_Tree   => Project_Tree,
+                     Project   => No_Project,
+                     Base_Name => SD.Sfile) = No_Source
                then
                   --  If this is not a runtime file or if, when gnatmake switch
                   --  -a is used, we are not able to find this subunit in the
@@ -230,8 +230,8 @@ package body Makeutl is
 
                   if not Fname.Is_Internal_File_Name (SD.Sfile)
                     or else
-                      (Check_Readonly_Files and then
-                       Find_File (SD.Sfile, Osint.Source) = No_File)
+                      (Check_Readonly_Files
+                        and then Find_File (SD.Sfile, Osint.Source) = No_File)
                   then
                      if Verbose_Mode then
                         Write_Line
@@ -242,6 +242,7 @@ package body Makeutl is
                            & " but this does not match what was found while"
                            & " parsing the project. Will recompile");
                      end if;
+
                      return False;
                   end if;
                end if;
diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb
index cf76c8f..3728c9e 100644
--- a/gcc/ada/prj-err.adb
+++ b/gcc/ada/prj-err.adb
@@ -24,8 +24,8 @@
 ------------------------------------------------------------------------------
 
 with Err_Vars;
-with Output;  use Output;
-with Stringt; use Stringt;
+with Output;   use Output;
+with Stringt;  use Stringt;
 
 package body Prj.Err is
 
@@ -118,12 +118,13 @@ package body Prj.Err is
       if Flags.Report_Error /= null then
          Flags.Report_Error
            (Project,
-            Is_Warning => Msg (Msg'First) = '?'
-            or else (Msg (Msg'First) = '<'
-              and then Err_Vars.Error_Msg_Warn)
-            or else (Msg (Msg'First) = '\'
-              and then Msg (Msg'First + 1) = '<'
-                and then Err_Vars.Error_Msg_Warn));
+            Is_Warning =>
+              Msg (Msg'First) = '?'
+                or else (Msg (Msg'First) = '<'
+                          and then Err_Vars.Error_Msg_Warn)
+                or else (Msg (Msg'First) = '\'
+                          and then Msg (Msg'First + 1) = '<'
+                          and then Err_Vars.Error_Msg_Warn));
       end if;
    end Error_Msg;
 
diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb
index a3e51cd..f734136 100755
--- a/gcc/ada/s-os_lib.adb
+++ b/gcc/ada/s-os_lib.adb
@@ -77,13 +77,13 @@ package body System.OS_Lib is
    -----------------------
 
    function Args_Length (Args : Argument_List) return Natural;
-   --  Returns total number of characters needed to create a string
-   --  of all Args terminated by ASCII.NUL characters
+   --  Returns total number of characters needed to create a string of all Args
+   --  terminated by ASCII.NUL characters.
 
    procedure Create_Temp_File_Internal
-     (FD        : out File_Descriptor;
-      Name      : out String_Access;
-      Stdout    : Boolean);
+     (FD     : out File_Descriptor;
+      Name   : out String_Access;
+      Stdout : Boolean);
    --  Internal routine to implement two Create_Temp_File routines. If Stdout
    --  is set to True the created descriptor is stdout-compatible, otherwise
    --  it might not be depending on the OS (VMS is one example). The first two
diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads
index fcf0d5f..341a279 100755
--- a/gcc/ada/s-os_lib.ads
+++ b/gcc/ada/s-os_lib.ads
@@ -257,15 +257,14 @@ package System.OS_Lib is
    --  temp files at the same time in the same directory.
 
    procedure Create_Temp_Output_File
-     (FD        : out File_Descriptor;
-      Name      : out String_Access);
+     (FD   : out File_Descriptor;
+      Name : out String_Access);
    --  Create and open for writing a temporary file in the current working
-   --  directory suitable to redirect standard output. The name of the file
-   --  and the File Descriptor are returned.
-   --  It is the responsibility of the caller to deallocate the access value
-   --  returned in Name.
+   --  directory suitable to redirect standard output. The name of the file and
+   --  the File Descriptor are returned. It is the responsibility of the caller
+   --  to deallocate the access value returned in Name.
    --
-   --  The file is opened in text mode.
+   --  The file is opened in text mode
    --
    --  This procedure will always succeed if the current working directory is
    --  writable. If the current working directory is not writable, then
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c6a5a5a..75e98c0 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2935,10 +2935,8 @@ package body Sem_Res is
                --  anomalies: the subtype was first built in the subprogram
                --  declaration, and the current call may be nested.
 
-               if Nkind (Actval) = N_Aggregate
-                 and then Has_Discriminants (Etype (Actval))
-               then
-                  Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+               if Nkind (Actval) = N_Aggregate then
+                  Analyze_And_Resolve (Actval, Etype (F));
                else
                   Analyze_And_Resolve (Actval, Etype (Actval));
                end if;
@@ -5390,6 +5388,7 @@ package body Sem_Res is
 
       Eval_Call (N);
       Check_Elab_Call (N);
+      Warn_On_Overlapping_Actuals (Nam, N);
    end Resolve_Call;
 
    -------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 37965af..5dcd715 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2137,6 +2137,164 @@ package body Sem_Util is
 
    end Denotes_Discriminant;
 
+   -------------------------
+   -- Denotes_Same_Object --
+   -------------------------
+
+   function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+
+   begin
+      if Is_Entity_Name (A1) then
+         if Is_Entity_Name (A2)then
+            return  Entity (A1) = Entity (A2);
+         else
+            return False;
+         end if;
+
+      elsif Nkind (A1) /= Nkind (A2) then
+         return False;
+
+      elsif Nkind (A1) = N_Selected_Component then
+         return Denotes_Same_Object (Prefix (A1), Prefix (A2))
+           and then
+         Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+
+      elsif Nkind (A1) = N_Explicit_Dereference then
+         return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+
+      elsif Nkind (A1) = N_Indexed_Component then
+         if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+            declare
+               Indx1 : Node_Id;
+               Indx2 : Node_Id;
+
+            begin
+               Indx1 := First (Expressions (A1));
+               Indx2 := First (Expressions (A2));
+               while Present (Indx1) loop
+                  if not Denotes_Same_Object (Indx1, Indx2) then
+                     return False;
+                  end if;
+
+                  Next (Indx1);
+                  Next (Indx2);
+               end loop;
+
+               return True;
+            end;
+         else
+            return False;
+         end if;
+
+      elsif Nkind (A1) = N_Slice
+        and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
+      then
+         declare
+            Lo1, Lo2, Hi1, Hi2 : Node_Id;
+
+         begin
+            Get_Index_Bounds (Etype (A1), Lo1, Hi1);
+            Get_Index_Bounds (Etype (A2), Lo2, Hi2);
+
+            --  Check whether bounds are statically identical
+            --  No attempt to detect partial overlap of slices.
+
+            return Denotes_Same_Object (Lo1, Lo2)
+              and then Denotes_Same_Object (Hi1, Hi2);
+         end;
+
+         --  Literals will appear as indices.
+
+      elsif Nkind (A1) = N_Integer_Literal then
+         return Intval (A1) = Intval (A2);
+
+      else
+         return False;
+      end if;
+   end Denotes_Same_Object;
+
+   -------------------------
+   -- Denotes_Same_Prefix --
+   -------------------------
+
+   function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
+
+   begin
+      if Is_Entity_Name (A1) then
+         if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+            return Denotes_Same_Object (A1, Prefix (A2))
+              or else Denotes_Same_Prefix (A1, Prefix (A2));
+         else
+            return False;
+         end if;
+
+      elsif Is_Entity_Name (A2) then
+         return Denotes_Same_Prefix (A2, A1);
+
+      elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
+        and then
+          Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
+      then
+         declare
+            Root1, Root2 : Node_Id;
+            Depth1, Depth2 : Int := 0;
+
+         begin
+            Root1 := Prefix (A1);
+            while not Is_Entity_Name (Root1) loop
+               if not Nkind_In
+                 (Root1, N_Selected_Component, N_Indexed_Component)
+               then
+                  return False;
+               else
+                  Root1 := Prefix (Root1);
+               end if;
+
+               Depth1 := Depth1 + 1;
+            end loop;
+
+            Root2 := Prefix (A2);
+            while not Is_Entity_Name (Root2) loop
+               if not Nkind_In
+                 (Root2, N_Selected_Component, N_Indexed_Component)
+               then
+                  return False;
+               else
+                  Root2 := Prefix (Root2);
+               end if;
+
+               Depth2 := Depth2 + 1;
+            end loop;
+
+            --  If both have the same depth and they do not denote the same
+            --  object, they are disjoint and not warning is needed.
+
+            if Depth1 = Depth2 then
+               return False;
+
+            elsif Depth1 > Depth2 then
+               Root1 := Prefix (A1);
+               for I in 1 .. Depth1 - Depth2 - 1 loop
+                  Root1 := Prefix (Root1);
+               end loop;
+
+               return Denotes_Same_Object (Root1, A2);
+
+            else
+               Root2 := Prefix (A2);
+               for I in 1 .. Depth2 - Depth1 - 1 loop
+                  Root2 := Prefix (Root2);
+               end loop;
+
+               return Denotes_Same_Object (A1, Root2);
+            end if;
+         end;
+
+      else
+         return False;
+      end if;
+   end Denotes_Same_Prefix;
+
    ----------------------
    -- Denotes_Variable --
    ----------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 0e3dde6..b9a52ed 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -251,6 +251,12 @@ package Sem_Util is
    --  components of protected types, and constraint checks on entry
    --  families constrained by discriminants.
 
+   function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean;
+   function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean;
+   --  Functions to detect suspicious overlapping between actuals in a call,
+   --  when one of them is writable. The predicates are those  proposed in
+   --  AI05-0144, to detect dangerous order dependence in complex calls.
+
    function Denotes_Variable (N : Node_Id) return Boolean;
    --  Returns True if node N denotes a single variable without parentheses
 
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 407171f..f9e82cc1 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -3535,6 +3535,136 @@ package body Sem_Warn is
            or else Warn_On_All_Unread_Out_Parameters;
    end Warn_On_Modified_As_Out_Parameter;
 
+   ---------------------------------
+   -- Warn_On_Overlapping_Actuals --
+   ---------------------------------
+
+   procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
+      Act1, Act2   : Node_Id;
+      Form1, Form2 : Entity_Id;
+
+   begin
+
+      --  For now, treat this warning as an extension.
+
+      if not Extensions_Allowed then
+         return;
+      end if;
+
+      --  Exclude calls rewritten as enumeration literals
+
+      if not Nkind_In
+        (N, N_Function_Call, N_Procedure_Call_Statement)
+      then
+         return;
+      end if;
+
+      --  Exclude calls to library subprograms. Container operations
+      --  specify safe behavior when source and target coincide.
+
+      if Is_Predefined_File_Name (
+         Unit_File_Name (Get_Source_Unit (Sloc (Subp))))
+      then
+         return;
+      end if;
+
+      Form1 := First_Formal (Subp);
+      Act1  := First_Actual (N);
+
+      while Present (Form1) and then Present (Act1) loop
+         if Ekind (Form1) = E_In_Out_Parameter 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))
+               then
+
+                  --  Exclude generic types and guard against previous errors.
+                  --  If either type is elementary the aliasing is harmless
+
+                  if Error_Posted (N)
+                    or else No (Etype (Act1))
+                    or else No (Etype (Act2))
+                  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.
+
+                  elsif Nkind (Act2) = N_Function_Call then
+                     null;
+
+                  elsif Is_Elementary_Type (Underlying_Type (Etype (Form1)))
+                    or else
+                      Is_Elementary_Type (Underlying_Type (Etype (Form2)))
+                  then
+                     null;
+                  else
+                     declare
+                        Act  : Node_Id;
+                        Form : Entity_Id;
+                     begin
+                        Act  := First_Actual (N);
+                        Form := First_Formal (Subp);
+                        while Act /= Act2 loop
+                           Next_Formal (Form);
+                           Next_Actual (Act);
+                        end loop;
+
+                        --  If the call was written in prefix notation, count
+                        --  only the visible actuals in the call.
+
+                        if Is_Entity_Name (First_Actual (N))
+                          and then Nkind (Original_Node (N)) = Nkind (N)
+                          and then
+                            Nkind (Name (Original_Node (N))) =
+                              N_Selected_Component
+                          and then
+                            Is_Entity_Name (Prefix (Name (Original_Node (N))))
+                          and then
+                            Entity (Prefix (Name (Original_Node (N)))) =
+                              Entity (First_Actual (N))
+                        then
+                           if Act1 = First_Actual (N) then
+                              Error_Msg_FE
+                                ("in-out prefix overlaps with actual for&?",
+                                 Act1, Form);
+                           else
+                              Error_Msg_FE
+                             ("writable actual overlaps with actual for&?",
+                              Act1, Form);
+                           end if;
+
+                        else
+                           Error_Msg_FE
+                             ("writable actual overlaps with actual for&?",
+                              Act1, Form);
+                        end if;
+                     end;
+                  end if;
+                  return;
+               end if;
+
+               Next_Formal (Form2);
+               Next_Actual (Act2);
+            end loop;
+         end if;
+
+         Next_Formal (Form1);
+         Next_Actual (Act1);
+      end loop;
+   end Warn_On_Overlapping_Actuals;
+
    ------------------------------
    -- Warn_On_Suspicious_Index --
    ------------------------------
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index 4ab97be..57d565c 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -210,6 +210,11 @@ package Sem_Warn is
    --  as an out parameter. True if either Warn_On_Modified_Unread is set for
    --  an only OUT parameter, or if Warn_On_All_Unread_Out_Parameters is set.
 
+   procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id);
+   --  Called on a subprogram call. Checks whether an in-out actual that is
+   --  not by-copy may overlap with another actual, thus leadind to aliasing
+   --  in the body of the called subprogram.
+
    procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id);
    --  This is called after resolving an indexed component or a slice. Name
    --  is the entity for the name of the indexed array, and X is the subscript