2011-08-02 Yannick Moy <moy@adacore.com>

	* sem_aggr.adb (Check_Qualified_Aggregate): new procedure which checks
	qualification of aggregates in formal mode
	(Is_Top_Level_Aggregate): returns True for an aggregate not contained in
	another aggregate
	(Resolve_Aggregate): complete the test that an aggregate is adequately
	qualified in formal mode

2011-08-02  Pascal Obry  <obry@adacore.com>

	* make.adb, bindgen.adb, gnatbind.adb: Minor reformatting.
	* mlib-prj.adb: Supress warning when compiling binder generated file.
	(Build_Library): Supress all warnings when compiling the binder
	generated file.



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

13 files changed, 166 insertions, 80 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b50d02af143..2eae3c872d1 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,21 @@
 2011-08-02  Yannick Moy  <moy@adacore.com>
 
+	* sem_aggr.adb (Check_Qualified_Aggregate): new procedure which checks
+	qualification of aggregates in formal mode
+	(Is_Top_Level_Aggregate): returns True for an aggregate not contained in
+	another aggregate
+	(Resolve_Aggregate): complete the test that an aggregate is adequately
+	qualified in formal mode
+
+2011-08-02  Pascal Obry  <obry@adacore.com>
+
+	* make.adb, bindgen.adb, gnatbind.adb: Minor reformatting.
+	* mlib-prj.adb: Supress warning when compiling binder generated file.
+	(Build_Library): Supress all warnings when compiling the binder
+	generated file.
+
+2011-08-02  Yannick Moy  <moy@adacore.com>
+
 	* errout.adb, errout.ads (Check_Formal_Restriction): move procedure
 	from here...
 	* restrict.adb, restrict.ads (Check_Formal_Restriction): ...to here
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 3617bea7b77..ed7ec12c150 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -92,11 +92,11 @@ GNATRTL_NONTASKING_OBJS= \
   a-cbdlli$(objext) \
   a-cborma$(objext) \
   a-cdlili$(objext) \
+  a-cfdlli$(objext) \
   a-cfhama$(objext) \
   a-cfhase$(objext) \
-  a-cforse$(objext) \
-  a-cfdlli$(objext) \
   a-cforma$(objext) \
+  a-cforse$(objext) \
   a-cgaaso$(objext) \
   a-cgarso$(objext) \
   a-cgcaso$(objext) \
diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb
index 4f70f8174f6..ed34d0e3f27 100644
--- a/gcc/ada/a-cfdlli.adb
+++ b/gcc/ada/a-cfdlli.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb
index 34a8a43f1fc..bc83c9d140a 100644
--- a/gcc/ada/a-cfhama.adb
+++ b/gcc/ada/a-cfhama.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb
index ed514c826d6..0df686d303a 100644
--- a/gcc/ada/a-cfhase.adb
+++ b/gcc/ada/a-cfhase.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb
index 705fd618e9f..f4519173095 100644
--- a/gcc/ada/a-cforma.adb
+++ b/gcc/ada/a-cforma.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb
index 30a0f97a31d..229af23996b 100644
--- a/gcc/ada/a-cforse.adb
+++ b/gcc/ada/a-cforse.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb
index fd30ca9cda7..a0fddf97ffc 100644
--- a/gcc/ada/a-cofove.adb
+++ b/gcc/ada/a-cofove.adb
@@ -8,6 +8,10 @@
 --                                                                          --
 --          Copyright (C) 2010, Free Software Foundation, Inc.              --
 --                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
 -- 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index b17d7b9a1af..5d1928df2c0 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -1442,7 +1442,6 @@ package body Bindgen is
             end if;
          end;
       end loop;
-
    end Gen_Elab_Calls_C;
 
    ----------------------
@@ -3030,6 +3029,10 @@ package body Bindgen is
       procedure Increment_Ubuf;
       --  Little procedure to increment the serial number
 
+      --------------------
+      -- Increment_Ubuf --
+      --------------------
+
       procedure Increment_Ubuf is
       begin
          for J in reverse Ubuf'Range loop
@@ -3081,7 +3084,6 @@ package body Bindgen is
             Write_Statement_Buffer;
          end if;
       end loop;
-
    end Gen_Versions_Ada;
 
    --------------------
@@ -3129,7 +3131,6 @@ package body Bindgen is
             Write_Statement_Buffer;
          end if;
       end loop;
-
    end Gen_Versions_C;
 
    ------------------------
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index de3084f0267..2c83bf2262d 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -469,12 +469,11 @@ procedure Gnatbind is
    end Scan_Bind_Arg;
 
    procedure Check_Version_And_Help is
-      new Check_Version_And_Help_G (Bindusg.Display);
+     new Check_Version_And_Help_G (Bindusg.Display);
 
 --  Start of processing for Gnatbind
 
 begin
-
    --  Set default for Shared_Libgnat option
 
    declare
@@ -876,9 +875,8 @@ begin
                   -- Put_In_Sources --
                   --------------------
 
-                  function Put_In_Sources (S : File_Name_Type)
-                                           return Boolean
-                  is
+                  function Put_In_Sources
+                    (S : File_Name_Type) return Boolean is
                   begin
                      for J in 1 .. Closure_Sources.Last loop
                         if Closure_Sources.Table (J) = S then
@@ -978,5 +976,4 @@ begin
 
       null;
    end if;
-
 end Gnatbind;
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 5bf466633fc..5fe7c7454c3 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -2213,7 +2213,6 @@ package body Make is
             Check_File (Name_Find);
          end if;
       end loop;
-
    end Check_Linker_Options;
 
    -----------------
@@ -6066,21 +6065,19 @@ package body Make is
                      end loop;
 
                      for Index in 1 .. Library_Projs.Last loop
-                        if Library_Projs.Table
-                          (Index).Library_Kind = Static
+                        if Library_Projs.Table (Index).Library_Kind = Static
                           and then not Targparm.OpenVMS_On_Target
                         then
                            Linker_Switches.Increment_Last;
                            Linker_Switches.Table (Linker_Switches.Last) :=
                              new String'
                                (Get_Name_String
-                                    (Library_Projs.Table (Index).
-                                       Library_Dir.Display_Name) &
+                                 (Library_Projs.Table
+                                   (Index).Library_Dir.Display_Name) &
                                 Directory_Separator &
                                 "lib" &
                                 Get_Name_String
-                                    (Library_Projs.Table (Index).
-                                     Library_Name) &
+                                  (Library_Projs.Table (Index). Library_Name) &
                                 "." &
                                 MLib.Tgt.Archive_Ext);
 
@@ -6109,7 +6106,7 @@ package body Make is
                   if Libraries_Present then
 
                      --  If Path_Option is not null, create the switch
-                     --  ("-Wl,-rpath," or equivalent) with all the non static
+                     --  ("-Wl,-rpath," or equivalent) with all the non-static
                      --  library dirs plus the standard GNAT library dir.
                      --  We do that only if Run_Path_Option is True
                      --  (not disabled by -R switch).
@@ -6134,17 +6131,19 @@ package body Make is
                               loop
                                  Linker_Switches.Increment_Last;
                                  Linker_Switches.Table
-                                   (Linker_Switches.Last) := new String'
-                                   (Path_Option.all &
-                                    Library_Paths.Table (Index).all);
+                                   (Linker_Switches.Last) :=
+                                     new String'
+                                       (Path_Option.all &
+                                        Library_Paths.Table (Index).all);
                               end loop;
 
                               --  One switch for the standard GNAT library dir
 
                               Linker_Switches.Increment_Last;
                               Linker_Switches.Table
-                                (Linker_Switches.Last) := new String'
-                                (Path_Option.all & MLib.Utl.Lib_Directory);
+                                (Linker_Switches.Last) :=
+                                  new String'
+                                    (Path_Option.all & MLib.Utl.Lib_Directory);
 
                            else
                               --  We are going to create one switch of the form
@@ -6178,8 +6177,8 @@ package body Make is
                               loop
                                  Option
                                    (Current + 1 ..
-                                      Current +
-                                        Library_Paths.Table (Index)'Length) :=
+                                     Current +
+                                       Library_Paths.Table (Index)'Length) :=
                                    Library_Paths.Table (Index).all;
                                  Current :=
                                    Current +
@@ -6351,19 +6350,19 @@ package body Make is
                                                  not Unique_Compile);
 
                   The_Packages : constant Package_Id :=
-                    Main_Project.Decl.Packages;
+                                   Main_Project.Decl.Packages;
 
                   Binder_Package : constant Prj.Package_Id :=
-                               Prj.Util.Value_Of
-                                 (Name        => Name_Binder,
-                                  In_Packages => The_Packages,
-                                  In_Tree     => Project_Tree);
+                                     Prj.Util.Value_Of
+                                       (Name        => Name_Binder,
+                                        In_Packages => The_Packages,
+                                        In_Tree     => Project_Tree);
 
                   Linker_Package : constant Prj.Package_Id :=
-                               Prj.Util.Value_Of
-                                 (Name        => Name_Linker,
-                                  In_Packages => The_Packages,
-                                  In_Tree     => Project_Tree);
+                                     Prj.Util.Value_Of
+                                       (Name        => Name_Linker,
+                                        In_Packages => The_Packages,
+                                        In_Tree     => Project_Tree);
 
                begin
                   --  We fail if we cannot find the main source file
diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb
index 8feffc019c6..4050382e1c6 100644
--- a/gcc/ada/mlib-prj.adb
+++ b/gcc/ada/mlib-prj.adb
@@ -91,6 +91,9 @@ package body MLib.Prj is
    Compile_Switch_String : aliased String := "-c";
    Compile_Switch : constant String_Access := Compile_Switch_String'Access;
 
+   No_Warning_String : aliased String := "-gnatws";
+   No_Warning : constant String_Access := No_Warning_String'Access;
+
    Auto_Initialize : constant String := "-a";
 
    --  List of objects to put inside the library
@@ -1184,8 +1187,9 @@ package body MLib.Prj is
                Arguments := new String_List (1 .. Initial_Argument_Max);
             end if;
 
-            Argument_Number := 1;
+            Argument_Number := 2;
             Arguments (1) := Compile_Switch;
+            Arguments (2) := No_Warning;
 
             if OpenVMS_On_Target then
                B_Start := new String'("b__");
@@ -1258,7 +1262,7 @@ package body MLib.Prj is
 
             --  Process binder generated file for pragmas Linker_Options
 
-            Process_Binder_File (Arguments (2).all & ASCII.NUL);
+            Process_Binder_File (Arguments (3).all & ASCII.NUL);
          end if;
       end if;
 
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 2835caf0b41..566995d4cfd 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -98,6 +98,15 @@ package body Sem_Aggr is
    --  expressions allowed for a limited component association (namely, an
    --  aggregate, function call, or <> notation). Report error for violations.
 
+   procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id);
+   --  Given aggregate Expr, check that sub-aggregates of Expr that are nested
+   --  at Level are qualified. If Level = 0, this applies to Expr directly.
+   --  Only issue errors in formal verification mode.
+
+   function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean;
+   --  Return True of Expr is an aggregate not contained directly in another
+   --  aggregate.
+
    ------------------------------------------------------
    -- Subprograms used for RECORD AGGREGATE Processing --
    ------------------------------------------------------
@@ -789,6 +798,41 @@ package body Sem_Aggr is
       end if;
    end Check_Expr_OK_In_Limited_Aggregate;
 
+   -------------------------------
+   -- Check_Qualified_Aggregate --
+   -------------------------------
+
+   procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is
+      Comp_Expr : Node_Id;
+      Comp_Assn : Node_Id;
+   begin
+      if Level = 0 then
+         if Nkind (Parent (Expr)) /= N_Qualified_Expression then
+            Check_Formal_Restriction ("aggregate should be qualified", Expr);
+         end if;
+      else
+         Comp_Expr := First (Expressions (Expr));
+         while Present (Comp_Expr) loop
+            if Nkind (Comp_Expr) = N_Aggregate then
+               Check_Qualified_Aggregate (Level - 1, Comp_Expr);
+            end if;
+
+            Comp_Expr := Next (Comp_Expr);
+         end loop;
+
+         Comp_Assn := First (Component_Associations (Expr));
+         while Present (Comp_Assn) loop
+            Comp_Expr := Expression (Comp_Assn);
+
+            if Nkind (Comp_Expr) = N_Aggregate then
+               Check_Qualified_Aggregate (Level - 1, Comp_Expr);
+            end if;
+
+            Comp_Assn := Next (Comp_Assn);
+         end loop;
+      end if;
+   end Check_Qualified_Aggregate;
+
    ----------------------------------------
    -- Check_Static_Discriminated_Subtype --
    ----------------------------------------
@@ -861,6 +905,17 @@ package body Sem_Aggr is
             = N_Others_Choice;
    end Is_Others_Aggregate;
 
+   ----------------------------
+   -- Is_Top_Level_Aggregate --
+   ----------------------------
+
+   function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean is
+   begin
+      return Nkind (Parent (Expr)) /= N_Aggregate
+        and then (Nkind (Parent (Expr)) /= N_Component_Association
+                   or else Nkind (Parent (Parent (Expr))) /= N_Aggregate);
+   end Is_Top_Level_Aggregate;
+
    --------------------------------
    -- Make_String_Into_Aggregate --
    --------------------------------
@@ -921,6 +976,39 @@ package body Sem_Aggr is
          return;
       end if;
 
+      --  An unqualified aggregate is restricted in SPARK or ALFA to:
+
+      --    An aggregate item inside an aggregate for a multi-dimensional array
+
+      --    An expression being assigned to an unconstrained array, but only if
+      --    the aggregate specifies a value for OTHERS only.
+
+      if Nkind (Parent (N)) = N_Qualified_Expression then
+         if Is_Array_Type (Typ) then
+            Check_Qualified_Aggregate (Number_Dimensions (Typ), N);
+         else
+            Check_Qualified_Aggregate (1, N);
+         end if;
+      else
+         if Is_Array_Type (Typ)
+           and then Nkind (Parent (N)) = N_Assignment_Statement
+           and then not Is_Constrained (Etype (Name (Parent (N))))
+           and then not Is_Others_Aggregate (N)
+         then
+            Check_Formal_Restriction
+              ("array aggregate should have only OTHERS", N);
+         elsif Is_Top_Level_Aggregate (N) then
+            Check_Formal_Restriction ("aggregate should be qualified", N);
+
+         --  The legality of this unqualified aggregate is checked by calling
+         --  Check_Qualified_Aggregate from one of its enclosing aggregate,
+         --  unless one of these already causes an error to be issued.
+
+         else
+            null;
+         end if;
+      end if;
+
       --  Check for aggregates not allowed in configurable run-time mode.
       --  We allow all cases of aggregates that do not come from source, since
       --  these are all assumed to be small (e.g. bounds of a string literal).
@@ -1098,49 +1186,6 @@ package body Sem_Aggr is
          Error_Msg_N ("illegal context for aggregate", N);
       end if;
 
-      --  An unqualified aggregate is restricted in SPARK or ALFA to:
-
-      --    An aggregate item inside an aggregate for a multi-dimensional array
-
-      --    An expression being assigned to an unconstrained array, but only if
-      --    the aggregate specifies a value for OTHERS only.
-
-      if Nkind (Parent (N)) /= N_Qualified_Expression then
-         if Is_Array_Type (Etype (N)) then
-            if Nkind (Parent (N)) = N_Assignment_Statement
-              and then not Is_Constrained (Etype (Name (Parent (N))))
-            then
-               if not Is_Others_Aggregate (N) then
-                  Check_Formal_Restriction
-                    ("array aggregate should have only OTHERS", N);
-               end if;
-
-               --  The following check is disabled until a proper place is
-               --  found where the type of the parent node can be inspected???
-
---              elsif not (Nkind (Parent (N)) = N_Aggregate
---                         and then Is_Array_Type (Etype (Parent (N)))
---                         and then Number_Dimensions (Etype (Parent (N))) > 1)
---              then
---                 Check_Formal_Restriction
---                   ("array aggregate should be qualified", N);
-            else
-               null;
-            end if;
-
-         elsif Is_Record_Type (Etype (N)) then
-            Check_Formal_Restriction
-              ("record aggregate should be qualified", N);
-
-         --  The type of aggregate is neither array nor record, so an error
-         --  must have occurred during resolution. Do not report an additional
-         --  message here.
-
-         else
-            null;
-         end if;
-      end if;
-
       --  If we can determine statically that the evaluation of the aggregate
       --  raises Constraint_Error, then replace the aggregate with an
       --  N_Raise_Constraint_Error node, but set the Etype to the right