[multiple changes]

2012-07-16  Robert Dewar  <dewar@adacore.com>

	* a-direct.adb, g-dirope.adb: Minor reformatting.

2012-07-16  Tristan Gingold  <gingold@adacore.com>

	* a-except.ads, a-except-2005.ads: Remove outdated comment.

2012-07-16  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb (Subprogram_Name_Greater): Fix algorithm to
	conform to documentation.

2012-07-16  Ed Schonberg  <schonberg@adacore.com>

	* gnat1drv.adb (Check_Library_Items): Removed, no longer used.

2012-07-16  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Array_Type_Declaration): if component type has
	invariants, the array type itself requires an invariant procedure.
	* exp_ch3.ads, exp_ch3.adb (Build_Array_Invariant_Proc): new
	procedure, to build a checking procedure that applies the
	invariant check on some type T to each component of an array
	of T's.  Code is similar to the construction of the init_proc
	for an array, and handles multidimensional arrays by recursing
	over successive dimensions.

2012-07-16  Hristian Kirtchev  <kirtchev@adacore.com>

	* g-debpoo.adb: Revert previous change.

2012-07-16  Hristian Kirtchev  <kirtchev@adacore.com>

	* freeze.adb (Freeze_Entity): Insert the itype reference to a
	library-level class-wide subtype after the freeze node of the
	equivalent record type.

From-SVN: r189526

12 files changed, 226 insertions, 83 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ccf4dc..18126f4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,41 @@
+2012-07-16  Robert Dewar  <dewar@adacore.com>
+
+	* a-direct.adb, g-dirope.adb: Minor reformatting.
+
+2012-07-16  Tristan Gingold  <gingold@adacore.com>
+
+	* a-except.ads, a-except-2005.ads: Remove outdated comment.
+
+2012-07-16  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch6.adb (Subprogram_Name_Greater): Fix algorithm to
+	conform to documentation.
+
+2012-07-16  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat1drv.adb (Check_Library_Items): Removed, no longer used.
+
+2012-07-16  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Array_Type_Declaration): if component type has
+	invariants, the array type itself requires an invariant procedure.
+	* exp_ch3.ads, exp_ch3.adb (Build_Array_Invariant_Proc): new
+	procedure, to build a checking procedure that applies the
+	invariant check on some type T to each component of an array
+	of T's.  Code is similar to the construction of the init_proc
+	for an array, and handles multidimensional arrays by recursing
+	over successive dimensions.
+
+2012-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* g-debpoo.adb: Revert previous change.
+
+2012-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* freeze.adb (Freeze_Entity): Insert the itype reference to a
+	library-level class-wide subtype after the freeze node of the
+	equivalent record type.
+
 2012-07-16  Pascal Obry  <obry@adacore.com>
 
 	* s-crtl.ads (mkdir): New routine, support encoding.
diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb
index 42a19b0..e166c9f 100644
--- a/gcc/ada/a-direct.adb
+++ b/gcc/ada/a-direct.adb
@@ -408,25 +408,22 @@ package body Ada.Directories is
          --  Acquire setting of encoding parameter
 
          declare
-            Formstr  : constant String := To_Lower (Form);
+            Formstr : constant String := To_Lower (Form);
 
             Encoding : CRTL.Filename_Encoding;
             --  Filename encoding specified into the form parameter
 
-            V1, V2   : Natural;
+            V1, V2 : Natural;
 
          begin
             Form_Parameter (Formstr, "encoding", V1, V2);
 
             if V1 = 0 then
                Encoding := CRTL.Unspecified;
-
             elsif Formstr (V1 .. V2) = "utf8" then
                Encoding := CRTL.UTF8;
-
             elsif Formstr (V1 .. V2) = "8bits" then
                Encoding := CRTL.ASCII_8bits;
-
             else
                raise Use_Error with "invalid Form";
             end if;
diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads
index 3f4b17a..e346a27 100644
--- a/gcc/ada/a-except-2005.ads
+++ b/gcc/ada/a-except-2005.ads
@@ -301,10 +301,6 @@ private
    type Exception_Occurrence is record
       Id : Exception_Id;
       --  Exception_Identity for this exception occurrence
-      --
-      --  WARNING System.System.Finalization_Implementation.Finalize_List
-      --  relies on the fact that this field is always first in the exception
-      --  occurrence
 
       Msg_Length : Natural := 0;
       --  Length of message (zero = no message)
diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads
index 0561fb7..e395cf4 100644
--- a/gcc/ada/a-except.ads
+++ b/gcc/ada/a-except.ads
@@ -271,9 +271,6 @@ private
    type Exception_Occurrence is record
       Id : Exception_Id;
       --  Exception_Identity for this exception occurrence
-      --  WARNING System.System.Finalization_Implementation.Finalize_List
-      --  relies on the fact that this field is always first in the exception
-      --  occurrence
 
       Msg_Length : Natural := 0;
       --  Length of message (zero = no message)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 318a2dd..f64524e 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -768,6 +768,140 @@ package body Exp_Ch3 is
    end Build_Array_Init_Proc;
 
    --------------------------------
+   -- Build_Array_Invariant_Proc --
+   --------------------------------
+
+   procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is
+      Loc              : constant Source_Ptr := Sloc (Nod);
+      Object_Name      : constant Name_Id := New_Internal_Name ('I');
+      --  Name for argument of invariant procedure
+
+      Object_Entity : constant Node_Id :=
+                        Make_Defining_Identifier (Loc, Object_Name);
+      --  The procedure declaration entity for the argument
+
+      Body_Stmts       : List_Id;
+      Index_List       : List_Id;
+      Proc_Id          : Entity_Id;
+      Proc_Body        : Node_Id;
+
+      function Build_Component_Invariant_Call return Node_Id;
+      --  Create one statement to verify invariant on one array component,
+      --  designated by a full set of indexes.
+
+      function Check_One_Dimension (N : Int) return List_Id;
+      --  Create loop to check on one dimension of the array. The single
+      --  statement in the loop body checks the inner dimensions if any, or
+      --  else a single component. This procedure is called recursively, with
+      --  N being the dimension to be initialized. A call with N greater than
+      --  the number of dimensions generates the component initialization
+      --  and terminates the recursion.
+
+      ------------------------------------
+      -- Build_Component_Invariant_Call --
+      ------------------------------------
+
+      function Build_Component_Invariant_Call return Node_Id is
+         Comp : Node_Id;
+
+      begin
+         Comp :=
+           Make_Indexed_Component (Loc,
+             Prefix      => New_Occurrence_Of (Object_Entity, Loc),
+                                   Expressions => Index_List);
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name                   =>
+               New_Occurrence_Of
+                 (Invariant_Procedure (Component_Type (A_Type)), Loc),
+             Parameter_Associations => New_List (Comp));
+
+      end Build_Component_Invariant_Call;
+
+      -------------------------
+      -- Check_One_Dimension --
+      -------------------------
+
+      function Check_One_Dimension (N : Int) return List_Id is
+         Index : Entity_Id;
+
+      begin
+         --  If all dimensions dealt with, we simply check invariant of
+         --  the component
+
+         if N > Number_Dimensions (A_Type) then
+            return New_List (Build_Component_Invariant_Call);
+
+         --  Else generate one loop and recurse
+
+         else
+            Index :=
+              Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+
+            Append (New_Reference_To (Index, Loc), Index_List);
+
+            return New_List (
+              Make_Implicit_Loop_Statement (Nod,
+                Identifier => Empty,
+                Iteration_Scheme =>
+                  Make_Iteration_Scheme (Loc,
+                    Loop_Parameter_Specification =>
+                      Make_Loop_Parameter_Specification (Loc,
+                        Defining_Identifier => Index,
+                        Discrete_Subtype_Definition =>
+                          Make_Attribute_Reference (Loc,
+                            Prefix => New_Occurrence_Of (Object_Entity, Loc),
+                            Attribute_Name  => Name_Range,
+                            Expressions     => New_List (
+                              Make_Integer_Literal (Loc, N))))),
+                Statements =>  Check_One_Dimension (N + 1)));
+         end if;
+      end Check_One_Dimension;
+
+   --  Start of processing for Build_Array_Invariant_Proc
+
+   begin
+      Index_List := New_List;
+
+      Proc_Id :=
+        Make_Defining_Identifier (Loc,
+           Chars => New_External_Name (Chars (A_Type), "Invariant"));
+      Set_Has_Invariants (Proc_Id);
+      Set_Invariant_Procedure (A_Type, Proc_Id);
+
+      Body_Stmts := Check_One_Dimension (1);
+
+      Proc_Body :=
+        Make_Subprogram_Body (Loc,
+          Specification =>
+            Make_Procedure_Specification (Loc,
+              Defining_Unit_Name => Proc_Id,
+              Parameter_Specifications => New_List (
+                Make_Parameter_Specification (Loc,
+                  Defining_Identifier => Object_Entity,
+                  Parameter_Type      => New_Occurrence_Of (A_Type, Loc)))),
+
+          Declarations => New_List,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => Body_Stmts));
+
+      Set_Ekind          (Proc_Id, E_Procedure);
+      Set_Is_Public      (Proc_Id, Is_Public (A_Type));
+      Set_Is_Internal    (Proc_Id);
+      Set_Has_Completion (Proc_Id);
+
+      if not Debug_Generated_Code then
+         Set_Debug_Info_Off (Proc_Id);
+      end if;
+
+      --  The procedure body is placed after the freeze node for the type.
+
+      Insert_After (Nod, Proc_Body);
+      Analyze (Proc_Body);
+   end Build_Array_Invariant_Proc;
+
+   --------------------------------
    -- Build_Discr_Checking_Funcs --
    --------------------------------
 
@@ -5513,6 +5647,10 @@ package body Exp_Ch3 is
       then
          Build_Array_Init_Proc (Base, N);
       end if;
+
+      if Has_Invariants (Component_Type (Base)) then
+         Build_Array_Invariant_Proc (Base, N);
+      end if;
    end Expand_Freeze_Array_Type;
 
    -----------------------------------
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 8cedc0b..1abc456 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -46,6 +46,12 @@ package Exp_Ch3 is
    procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
    --  Add a field _parent in the extension part of the record
 
+   procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id);
+   --  If the component of type of array type has invariants, build procedure
+   --  that checks invariant on all components of the array. Ada 2012 specifies
+   --  that an invariant on some type T must be applied to in-out parameters
+   --  and return values that include a part of type T.
+
    procedure Build_Discr_Checking_Funcs (N : Node_Id);
    --  Builds function which checks whether the component name is consistent
    --  with the current discriminants. N is the full type declaration node,
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 7b5ecd9..d9bd919 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3860,11 +3860,19 @@ package body Freeze is
                return Result;
             end if;
 
-            --  If the Class_Wide_Type is an Itype (when type is the anonymous
-            --  parent of a derived type) and it is a library-level entity,
-            --  generate an itype reference for it. Otherwise, its first
-            --  explicit reference may be in an inner scope, which will be
-            --  rejected by the back-end.
+            --  The equivalent type associated with a class-wide subtype needs
+            --  to be frozen to ensure that its layout is done.
+
+            if Ekind (E) = E_Class_Wide_Subtype
+              and then Present (Equivalent_Type (E))
+            then
+               Freeze_And_Append (Equivalent_Type (E), N, Result);
+            end if;
+
+            --  Generate an itype reference for a library-level class-wide type
+            --  at the freeze point. Otherwise the first explicit reference to
+            --  the type may appear in an inner scope which will be rejected by
+            --  the back-end.
 
             if Is_Itype (E)
               and then Is_Compilation_Unit (Scope (E))
@@ -3874,17 +3882,20 @@ package body Freeze is
 
                begin
                   Set_Itype (Ref, E);
-                  Add_To_Result (Ref);
-               end;
-            end if;
 
-            --  The equivalent type associated with a class-wide subtype needs
-            --  to be frozen to ensure that its layout is done.
+                  --  From a gigi point of view, a class-wide subtype derives
+                  --  from its record equivalent type. As a result, the itype
+                  --  reference must appear after the freeze node of the
+                  --  equivalent type or gigi will reject the reference.
 
-            if Ekind (E) = E_Class_Wide_Subtype
-              and then Present (Equivalent_Type (E))
-            then
-               Freeze_And_Append (Equivalent_Type (E), N, Result);
+                  if Ekind (E) = E_Class_Wide_Subtype
+                    and then Present (Equivalent_Type (E))
+                  then
+                     Insert_After (Freeze_Node (Equivalent_Type (E)), Ref);
+                  else
+                     Add_To_Result (Ref);
+                  end if;
+               end;
             end if;
 
          --  For a record (sub)type, freeze all the component types (RM
diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb
index ac3a928..95c3913 100644
--- a/gcc/ada/g-debpoo.adb
+++ b/gcc/ada/g-debpoo.adb
@@ -668,8 +668,6 @@ package body GNAT.Debug_Pools is
       --  terms of wasted memory). To do that, all we should have to do it to
       --  set the size of this array to the page size. See mprotect().
 
-      No_Element : constant Storage_Element := 0;
-
       Current : Byte_Count;
       P       : Ptr;
       Trace   : Traceback_Htable_Elem_Ptr;
@@ -694,16 +692,15 @@ package body GNAT.Debug_Pools is
       --  Use standard (i.e. through malloc) allocations. This automatically
       --  raises Storage_Error if needed. We also try once more to physically
       --  release memory, so that even marked blocks, in the advanced scanning,
-      --  are freed. Initialize the storage array to avoid bogus warnings by
-      --  valgrind.
+      --  are freed.
 
       begin
-         P := new Local_Storage_Array'(others => No_Element);
+         P := new Local_Storage_Array;
 
       exception
          when Storage_Error =>
             Free_Physically (Pool);
-            P := new Local_Storage_Array'(others => No_Element);
+            P := new Local_Storage_Array;
       end;
 
       Storage_Address :=
diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb
index e38481c..bf579f5 100644
--- a/gcc/ada/g-dirope.adb
+++ b/gcc/ada/g-dirope.adb
@@ -604,7 +604,6 @@ package body GNAT.Directory_Operations is
 
    procedure Make_Dir (Dir_Name : Dir_Name_Str) is
       C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
-
    begin
       if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then
          raise Directory_Error;
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 2416717..4cc6a49 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -104,11 +104,6 @@ procedure Gnat1drv is
    --  Called when we are not generating code, to check if -gnatR was requested
    --  and if so, explain that we will not be honoring the request.
 
-   procedure Check_Library_Items;
-   --  For debugging -- checks the behavior of Walk_Library_Items
-   pragma Warnings (Off, Check_Library_Items);
-   --  In case the call below is commented out
-
    ----------------------------
    -- Adjust_Global_Switches --
    ----------------------------
@@ -659,35 +654,6 @@ procedure Gnat1drv is
       end if;
    end Check_Bad_Body;
 
-   -------------------------
-   -- Check_Library_Items --
-   -------------------------
-
-   --  Walk_Library_Items has plenty of assertions, so all we need to do is
-   --  call it, just for these assertions, not actually doing anything else.
-
-   procedure Check_Library_Items is
-
-      procedure Action (Item : Node_Id);
-      --  Action passed to Walk_Library_Items to do nothing
-
-      ------------
-      -- Action --
-      ------------
-
-      procedure Action (Item : Node_Id) is
-      begin
-         null;
-      end Action;
-
-      procedure Walk is new Sem.Walk_Library_Items (Action);
-
-   --  Start of processing for Check_Library_Items
-
-   begin
-      Walk;
-   end Check_Library_Items;
-
    --------------------
    -- Check_Rep_Info --
    --------------------
@@ -1136,14 +1102,6 @@ begin
       Namet.Lock;
       Stringt.Lock;
 
-      --  ???Check_Library_Items under control of a debug flag, because it
-      --  currently does not work if the -gnatn switch (back end inlining) is
-      --  used.
-
-      if Debug_Flag_Dot_WW then
-         Check_Library_Items;
-      end if;
-
       --  Here we call the back end to generate the output code
 
       Generating_Code := True;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index b58c21f..71c0755 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4973,6 +4973,13 @@ package body Sem_Ch3 is
            ("the type of a component cannot be abstract",
             Subtype_Indication (Component_Def));
       end if;
+
+      --  Ada 2012: if the element type has invariants we must create an
+      --  invariant procedure for the array type as well.
+
+      if Has_Invariants (Element_Type) then
+         Set_Has_Invariants (T);
+      end if;
    end Array_Type_Declaration;
 
    ------------------------------------------------------
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index b9243f9..e622683 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -7238,7 +7238,9 @@ package body Sem_Ch6 is
          N1, N2 : Natural;
 
       begin
-         --  Remove trailing numeric parts
+         --  Deal with special case where names are identical except for a
+         --  numerical suffix. These are handled specially, taking the numeric
+         --  ordering from the suffix into account.
 
          L1 := S1'Last;
          while S1 (L1) in '0' .. '9' loop
@@ -7250,13 +7252,10 @@ package body Sem_Ch6 is
             L2 := L2 - 1;
          end loop;
 
-         --  If non-numeric parts non-equal, that's decisive
+         --  If non-numeric parts non-equal, do straight compare
 
-         if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
-            return False;
-
-         elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
-            return True;
+         if S1 (S1'First .. L1) /= S2 (S2'First .. L2) then
+            return S1 > S2;
 
          --  If non-numeric parts equal, compare suffixed numeric parts. Note
          --  that a missing suffix is treated as numeric zero in this test.