[multiple changes]

2010-06-23  Javier Miranda  <miranda@adacore.com>

	* atree.ads (Set_Reporting_Proc): New subprogram.
	* atree.adb: Remove dependency on packages Opt and SCIL_LL.
	(Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls
	to routines of package Scil_ll by indirect call to the registered
	subprogram.
	(Set_Reporting_Proc): New subprogram. Used to register a subprogram
	that is invoked when a node is allocated, replaced or rewritten.
	* scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying
	the SCIL node. Used as argument for Set_Reporting_Proc.
	(Initialize): Register Copy_SCIL_Node as the reporting routine that
	is invoked by atree.

2010-06-23  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.ads: Minor reformatting.

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode,
	always analyze the generic body and instance, because it may be needed
	downstream.
	(Mark_Context): Prepend the with clauses for needed generic units, so
	they appear in a better order for CodePeer.
	* sem_util.adb, sem_util.ads: Prototype code for AI05-0144.

2010-06-23  Emmanuel Briot  <briot@adacore.com>

	* prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram.

From-SVN: r161252

10 files changed, 238 insertions, 82 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ea344cb..ba3b9e9 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,34 @@
+2010-06-23  Javier Miranda  <miranda@adacore.com>
+
+	* atree.ads (Set_Reporting_Proc): New subprogram.
+	* atree.adb: Remove dependency on packages Opt and SCIL_LL.
+	(Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls
+	to routines of package Scil_ll by indirect call to the registered
+	subprogram.
+	(Set_Reporting_Proc): New subprogram. Used to register a subprogram
+	that is invoked when a node is allocated, replaced or rewritten.
+	* scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying
+	the SCIL node. Used as argument for Set_Reporting_Proc.
+	(Initialize): Register Copy_SCIL_Node as the reporting routine that
+	is invoked by atree.
+
+2010-06-23  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch3.ads: Minor reformatting.
+
+2010-06-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode,
+	always analyze the generic body and instance, because it may be needed
+	downstream.
+	(Mark_Context): Prepend the with clauses for needed generic units, so
+	they appear in a better order for CodePeer.
+	* sem_util.adb, sem_util.ads: Prototype code for AI05-0144.
+
+2010-06-23  Emmanuel Briot  <briot@adacore.com>
+
+	* prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram.
+
 2010-06-23  Robert Dewar  <dewar@adacore.com>
 
 	* g-pehage.adb, exp_ch13.adb: Minor reformatting.
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index c0c5bd8..8075272 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -38,14 +38,15 @@ pragma Style_Checks (All_Checks);
 
 with Debug;   use Debug;
 with Nlists;  use Nlists;
-with Opt;     use Opt;
 with Output;  use Output;
 with Sinput;  use Sinput;
-with SCIL_LL; use SCIL_LL;
 with Tree_IO; use Tree_IO;
 
 package body Atree is
 
+   Reporting_Proc : Report_Proc := null;
+   --  Record argument to last call to Set_Reporting_Proc
+
    ---------------
    -- Debugging --
    ---------------
@@ -534,10 +535,10 @@ package body Atree is
       Orig_Nodes.Set_Last (Nodes.Last);
       Allocate_List_Tables (Nodes.Last);
 
-      --  Update the SCIL_Node field (if available)
+      --  Invoke the reporting procedure (if available)
 
-      if Generate_SCIL then
-         Set_SCIL_Node (New_Id, Get_SCIL_Node (Src));
+      if Reporting_Proc /= null then
+         Reporting_Proc.all (Target => New_Id, Source => Src);
       end if;
 
       return New_Id;
@@ -925,6 +926,16 @@ package body Atree is
       return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6);
    end Ekind_In;
 
+   ------------------------
+   -- Set_Reporting_Proc --
+   ------------------------
+
+   procedure Set_Reporting_Proc (P : Report_Proc) is
+   begin
+      pragma Assert (Reporting_Proc = null);
+      Reporting_Proc := P;
+   end Set_Reporting_Proc;
+
    ------------------
    -- Error_Posted --
    ------------------
@@ -1580,10 +1591,10 @@ package body Atree is
 
       Orig_Nodes.Table (Old_Node) := Old_Node;
 
-      --  Update the SCIL_Node field (if available)
+      --  Invoke the reporting procedure (if available)
 
-      if Generate_SCIL then
-         Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
+      if Reporting_Proc /= null then
+         Reporting_Proc.all (Target => Old_Node, Source => New_Node);
       end if;
    end Replace;
 
@@ -1644,10 +1655,10 @@ package body Atree is
 
       Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
 
-      --  Update the SCIL_Node field (if available)
+      --  Invoke the reporting procedure (if available)
 
-      if Generate_SCIL then
-         Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
+      if Reporting_Proc /= null then
+         Reporting_Proc.all (Target => Old_Node, Source => New_Node);
       end if;
    end Rewrite;
 
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 7408b0e..11787bc 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -461,6 +461,12 @@ package Atree is
    --  function is used only by Sinfo.CN to change nodes into their
    --  corresponding entities.
 
+   type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
+
+   procedure Set_Reporting_Proc (P : Report_Proc);
+   --  Register a procedure that is invoked when a node is allocated, replaced
+   --  or rewritten.
+
    type Traverse_Result is (Abandon, OK, OK_Orig, Skip);
    --  This is the type of the result returned by the Process function passed
    --  to Traverse_Func and Traverse_Proc. See below for details.
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index f6557f1..b502b2a 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -467,6 +467,32 @@ package body Prj.Nmsc is
    --  Debug print a value for a specific property. Does nothing when not in
    --  debug mode
 
+   procedure Error_Or_Warning
+     (Flags    : Processing_Flags;
+      Kind     : Error_Warning;
+      Msg      : String;
+      Location : Source_Ptr;
+      Project  : Project_Id);
+   --  Emits either an error or warning message (or nothing), depending on Kind
+
+   ----------------------
+   -- Error_Or_Warning --
+   ----------------------
+
+   procedure Error_Or_Warning
+     (Flags    : Processing_Flags;
+      Kind     : Error_Warning;
+      Msg      : String;
+      Location : Source_Ptr;
+      Project  : Project_Id) is
+   begin
+      case Kind is
+         when Error   => Error_Msg (Flags, Msg, Location, Project);
+         when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
+         when Silent  => null;
+      end case;
+   end Error_Or_Warning;
+
    ------------------------------
    -- Replace_Into_Name_Buffer --
    ------------------------------
@@ -5170,8 +5196,8 @@ package body Prj.Nmsc is
             begin
                if Root_Dir'Length = 0 then
                   Err_Vars.Error_Msg_File_1 := Base_Dir;
-                  Error_Msg
-                    (Data.Flags,
+                  Error_Or_Warning
+                    (Data.Flags, Data.Flags.Missing_Source_Files,
                      "{ is not a valid directory.", Location, Project);
 
                else
@@ -5210,8 +5236,8 @@ package body Prj.Nmsc is
 
                if not Dir_Exists then
                   Err_Vars.Error_Msg_File_1 := From;
-                  Error_Msg
-                    (Data.Flags,
+                  Error_Or_Warning
+                    (Data.Flags, Data.Flags.Missing_Source_Files,
                      "{ is not a valid directory", Location, Project);
 
                else
@@ -5291,21 +5317,9 @@ package body Prj.Nmsc is
 
                Err_Vars.Error_Msg_File_1 :=
                  File_Name_Type (Object_Dir.Value);
-
-               case Data.Flags.Require_Obj_Dirs is
-                  when Error =>
-                     Error_Msg
-                       (Data.Flags,
-                        "object directory { not found",
-                        Project.Location, Project);
-                  when Warning =>
-                     Error_Msg
-                       (Data.Flags,
-                        "?object directory { not found",
-                        Project.Location, Project);
-                  when Silent =>
-                     null;
-               end case;
+               Error_Or_Warning
+                 (Data.Flags, Data.Flags.Require_Obj_Dirs,
+                  "object directory { not found", Project.Location, Project);
             end if;
          end if;
 
@@ -6493,8 +6507,8 @@ package body Prj.Nmsc is
                   if not Found then
                      Error_Msg_Name_1 := Name_Id (Source.Display_File);
                      Error_Msg_Name_2 := Name_Id (Source.Unit.Name);
-                     Error_Msg
-                       (Data.Flags,
+                     Error_Or_Warning
+                       (Data.Flags, Data.Flags.Missing_Source_Files,
                         "source file %% for unit %% not found",
                         No_Location, Project.Project);
 
@@ -6536,41 +6550,18 @@ package body Prj.Nmsc is
             while NL /= No_Name_Location loop
                if not NL.Found then
                   Err_Vars.Error_Msg_File_1 := NL.Name;
-
-                  case Data.Flags.Missing_Source_Files is
-                     when Error =>
-                        if First_Error then
-                           Error_Msg
-                             (Data.Flags,
-                              "source file { not found",
-                              NL.Location, Project.Project);
-                           First_Error := False;
-
-                        else
-                           Error_Msg
-                             (Data.Flags,
-                              "\source file { not found",
-                              NL.Location, Project.Project);
-                        end if;
-
-                     when Warning =>
-                        if First_Error then
-                           Error_Msg
-                             (Data.Flags,
-                              "?source file { not found",
-                              NL.Location, Project.Project);
-                           First_Error := False;
-
-                        else
-                           Error_Msg
-                             (Data.Flags,
-                              "?\source file { not found",
-                              NL.Location, Project.Project);
-                        end if;
-
-                     when Silent =>
-                        null;
-                  end case;
+                  if First_Error then
+                     Error_Or_Warning
+                       (Data.Flags, Data.Flags.Missing_Source_Files,
+                        "source file { not found",
+                        NL.Location, Project.Project);
+                     First_Error := False;
+                  else
+                     Error_Or_Warning
+                       (Data.Flags, Data.Flags.Missing_Source_Files,
+                        "\source file { not found",
+                        NL.Location, Project.Project);
+                  end if;
                end if;
 
                NL := Source_Names_Htable.Get_Next (Project.Source_Names);
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index 0cb504a..75bb078 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -1496,7 +1496,8 @@ package Prj is
    --
    --  Missing_Source_Files indicates whether it is an error or a warning that
    --  a source file mentioned in the Source_Files attributes is not actually
-   --  found in the source directories
+   --  found in the source directories. This also impacts errors for missing
+   --  source directories.
 
    Gprbuild_Flags : constant Processing_Flags;
    Gprclean_Flags : constant Processing_Flags;
diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb
index 388abdb..4591d8e 100644
--- a/gcc/ada/scil_ll.adb
+++ b/gcc/ada/scil_ll.adb
@@ -37,6 +37,10 @@ with Table;
 
 package body SCIL_LL is
 
+   procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id);
+   --  Copy the SCIL field from Source to Target (it is used as the argument
+   --  for a call to Set_Reporting_Proc in package atree).
+
    function SCIL_Nodes_Table_Size return Pos;
    --  Used to initialize the table of SCIL nodes because we do not want
    --  to consume memory for this table if it is not required.
@@ -64,6 +68,15 @@ package body SCIL_LL is
    --  This table records the value of attribute SCIL_Node of all the
    --  tree nodes.
 
+   --------------------
+   -- Copy_SCIL_Node --
+   --------------------
+
+   procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is
+   begin
+      Set_SCIL_Node (Target, Get_SCIL_Node (Source));
+   end Copy_SCIL_Node;
+
    ----------------
    -- Initialize --
    ----------------
@@ -71,6 +84,7 @@ package body SCIL_LL is
    procedure Initialize is
    begin
       SCIL_Nodes.Init;
+      Set_Reporting_Proc (Copy_SCIL_Node'Access);
    end Initialize;
 
    -------------------
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index da144b8..757276b 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -3237,7 +3237,8 @@ package body Sem_Ch12 is
                   or else Enclosing_Body_Present
                   or else Present (Corresponding_Body (Gen_Decl)))
                 and then (Is_In_Main_Unit (N)
-                           or else Might_Inline_Subp)
+                           or else Might_Inline_Subp
+                           or else CodePeer_Mode)
                 and then not Is_Actual_Pack
                 and then not Inline_Now
                 and then (Operating_Mode = Generate_Code
@@ -10421,7 +10422,7 @@ package body Sem_Ch12 is
          Set_Implicit_With (Withn);
          Set_Library_Unit (Withn, Cunit (CU));
          Set_Withed_Body (Withn, Cunit (CU));
-         Append (Withn, Context_Items (Cunit (Inst_CU)));
+         Prepend (Withn, Context_Items (Cunit (Inst_CU)));
       end Add_Implicit_With;
 
    begin
@@ -10433,9 +10434,15 @@ package body Sem_Ch12 is
          return;
       end if;
 
-      --  If G is itself declared within an instance, indicate that the generic
-      --  body of that instance is also needed by C. This must be done
-      --  recursively.
+      --  Nothing to do if G is local.
+
+      if Inst_CU = Gen_CU then
+         return;
+      end if;
+
+      --  If G is itself  declared within an instance, indicate that the
+      --  generic body of that instance is also needed by C. This must be
+      --  done recursively.
 
       Scop := Scope (Defining_Entity (Gen_Decl));
 
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 6bfa5284..18b585f 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -84,13 +84,11 @@ package Sem_Ch3 is
    procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id);
    --  Process an access type declaration
 
-   procedure Build_Itype_Reference
-     (Ityp : Entity_Id;
-      Nod  : Node_Id);
+   procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id);
    --  Create a reference to an internal type, for use by Gigi. The back-end
-   --  elaborates itypes on demand, i.e. when their first use is seen. This
-   --  can lead to scope anomalies if the first use is within a scope that is
-   --  nested within the scope that contains  the point of definition of the
+   --  elaborates itypes on demand, i.e. when their first use is seen. This can
+   --  lead to scope anomalies if the first use is within a scope that is
+   --  nested within the scope that contains the point of definition of the
    --  itype. The Itype_Reference node forces the elaboration of the itype
    --  in the proper scope. The node is inserted after Nod, which is the
    --  enclosing declaration that generated Ityp.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index f96b45b..cbc099e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -56,6 +56,7 @@ with Sinput;   use Sinput;
 with Stand;    use Stand;
 with Style;
 with Stringt;  use Stringt;
+with Table;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Ttypes;   use Ttypes;
@@ -93,6 +94,88 @@ package body Sem_Util is
    subtype NCT_Header_Num is Int range 0 .. 511;
    --  Defines range of headers in hash tables (512 headers)
 
+   -----------------------------------
+   -- Order dependence : AI05-0144  --
+   -----------------------------------
+
+   --  Each actual in a call is entered into the table below. A flag
+   --  indicates whether the corresponding formal is out or in out.
+   --  Each top-level call (procedure call, condition, assignment)
+   --  examines all the actuals for a possible order dependence.
+   --  The table is reset after each such check.
+
+   type Actual_Name is record
+      Act  : Node_Id;
+      Is_Writable : Boolean;
+   end record;
+
+   package Actuals_In_Call is new Table.Table (
+      Table_Component_Type => Actual_Name,
+      Table_Index_Type     => Int,
+      Table_Low_Bound      => 0,
+      Table_Initial        => 10,
+      Table_Increment      => 10,
+      Table_Name           => "Actuals");
+
+   procedure Save_Actual (N : Node_Id;  Writable : Boolean := False) is
+   begin
+      if Is_Entity_Name (N)
+        or else Nkind_In (N,
+                          N_Indexed_Component, N_Selected_Component, N_Slice)
+        or else (Nkind (N) = N_Attribute_Reference
+          and then Attribute_Name (N) = Name_Access)
+
+      then
+         --  We are only interested in in out parameters of inner calls.
+
+         if not Writable
+           or else Nkind (Parent (N)) = N_Function_Call
+           or else Nkind (Parent (N)) in N_Op
+         then
+            Actuals_In_Call.Increment_Last;
+            Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
+         end if;
+      end if;
+   end Save_Actual;
+
+   procedure Check_Order_Dependence is
+      Act1, Act2 : Node_Id;
+   begin
+      for J in 0 .. Actuals_In_Call.Last loop
+
+         if Actuals_In_Call.Table (J).Is_Writable then
+            Act1 := Actuals_In_Call.Table (J).Act;
+
+            if Nkind (Act1) = N_Attribute_Reference then
+               Act1 := Prefix (Act1);
+            end if;
+
+            for K in 0 .. Actuals_In_Call.Last loop
+               if K /= J then
+                  Act2 := Actuals_In_Call.Table (K).Act;
+                  if Nkind (Act2) = N_Attribute_Reference then
+                     Act2 := Prefix (Act2);
+                  end if;
+
+                  if Actuals_In_Call.Table (K).Is_Writable
+                    and then K < J
+                  then
+                     --  already checked
+                     null;
+
+                  elsif Denotes_Same_Object (Act1, Act2)
+                    and then False
+                  then
+                     Error_Msg_N ("?,mighty suspicious!!!", Act1);
+                  end if;
+               end if;
+            end loop;
+         end if;
+      end loop;
+
+      Actuals_In_Call.Set_Last (0);
+   end Check_Order_Dependence;
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -2251,7 +2334,9 @@ package body Sem_Util is
 
    begin
       if Is_Entity_Name (A1) then
-         if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+         if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
+           and then not Is_Access_Type (Etype (A1))
+         then
             return Denotes_Same_Object (A1, Prefix (A2))
               or else Denotes_Same_Prefix (A1, Prefix (A2));
          else
@@ -7862,6 +7947,7 @@ package body Sem_Util is
          if Nkind (N) = N_Allocator then
             if Is_Dynamic then
                Set_Is_Dynamic_Coextension (N);
+
             else
                Set_Is_Static_Coextension (N);
             end if;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index dd655c9..daa1c9d 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -141,6 +141,11 @@ package Sem_Util is
    --  is accessed inside a nested procedure, and set Has_Up_Level_Access flag
    --  accordingly. This is currently only enabled for VM_Target /= No_VM.
 
+   procedure Check_Order_Dependence;
+   --  Examine the actuals in a top-level call to determine whether aliasing
+   --  between two actuals, one of which is writable, can make the call
+   --  order-dependent.
+
    procedure Check_Potentially_Blocking_Operation (N : Node_Id);
    --  N is one of the statement forms that is a potentially blocking
    --  operation. If it appears within a protected action, emit warning.
@@ -1168,6 +1173,12 @@ package Sem_Util is
    --  are only partially ordered, so Scope_Within_Or_Same (A,B) and
    --  Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
 
+   procedure Save_Actual (N : Node_Id;  Writable : Boolean := False);
+   --  Enter an actual in a call in a table global, for subsequent check
+   --  of possible order dependence in the presence of in out parameters
+   --  for functions in Ada 2012 (or access parameters in older versions
+   --  of the language).
+
    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
    --  Like Scope_Within_Or_Same, except that this function returns
    --  False in the case where Scope1 and Scope2 are the same scope.