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

	* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
	types and dispatching calls in Alfa mode.
	* lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
	correspondance between body and spec scopes, to reuse utility functions
	(Traverse_Declarations_Or_Statements): Protect access to body for stub
	by testing the presence of the library unit for the body
	* sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
	mode the expansion of accept statements is skipped
	* sem_util.adb, sem_util.ads (Unique_Entity): New function returning
	the unique entity corresponding to the one returned by
	Unique_Defining_Entity applied to the enclosing declaration of the
	argument.

2011-08-29  Bob Duff  <duff@adacore.com>

	* treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
	gdb when x is not a node (it can be a node list, name_id, etc). pp is
	an alias for pn. ppp is an alias for pt.

2011-08-29  Javier Miranda  <miranda@adacore.com>

	* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
	aggregate to take a consistent decision on the need to convert into
	assignments aggregates that initialize constant objects.

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_Allocator_Expression): Add a call to
	Build_Allocate_Deallocate_Proc in order to handle allocation of
	non-controlled objects on subpools.
	* impunit.adb: Remove s-finmas and s-spsufi since they were never meant
	to be end-user visible.
	* s-finmas.adb: Add with and use clause for System.HTable.
	Add an instantiation of Simple_HTable which provides a mapping between
	the address of a controlled object and the corresponding
	Finalize_Address used to clean up the object. The table is used when a
	master is operating in heterogeneous mode.
	(Attach): Explain why the input node is not verified on being already
	attached.
	(Delete_Finalize_Address): New routine.
	(Detach): Add pragma Assert which ensures that a node is already
	attached.
	(Finalize): Add local variable Cleanup. Rewrite the iteration scheme
	since nodes are no longer removed on traversal. Explain why node
	detachment is undesirable in this case.
	(Get_Finalize_Address): New routine.
	(Hash): New routine.
	(Is_Empty_List): Removed.
	(pm): Renamed to Print_Master. Add output for discriminant
	Is_Homogeneous.
	Comment reformatting.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-finmas.ads: Various comments additions / improvements.
	Type Finalization_Master has a discriminant which determines the mode of
	operation.
	(Delete_Finalize_Address): New routine.
	(Get_Finalize_Address): New routine.
	(pm): Renamed to Print_Master.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-stposu.adb: Add with clause for System.Address_Image; Add with and
	use clause for System.IO.
	(Allocate_Any_Controlled): Add machinery to set TSS primitive
	Finalize_Address depending on the mode of allocation and the mode of
	the master.
	(Deallocate_Any_Controlled): Remove the relation pair object -
	Finalize_Address regardless of the master mode. Add comment explaining
	the reason.
	(Detach): Ensure that fields Prev and Next are null after detachment.
	(Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
	scheme to check whether the list of subpools is empty. There is no
	longer need to store the next subpool or advance the current pointer.
	(Is_Empty_List): New routine.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.
	* s-stposu.ads: Various comments additions / improvements.
	Field Master of type Root_Subpool is now a heterogeneous collection.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
	forms, using aspects of container types.
	* sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
	Has_Implicit_Dereference flags, that may be set on the partial view.
	* sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
	container type with an indexing aspect.
	(Analyze_Quantified_Expression): Analyze construct with expansion
	disabled, because it will be rewritten as a loop during expansion.
	(Try_Container_Indexing): The prefix itself may be a container type
	with an indexing aspect, as with a vector of vectors.
	* sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
	the original doamin of iteration, for name capture.
	(Analyze_Iterator_Specification): If the domain is an expression that
	needs finalization, create a separate declaration for it.
	For an iterator with "of" retrieve default iterator info from aspect of
	container type. For "in" iterator, retrieve type of Iterate function.
	* sem_ch13.adb (Check_Iterator_Function): Fix typo.
	(Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
	analysis, to prevent spurious errors about late attributes.
	* sprint.adb: Handle quantified expression with either loop or iterator
	specification.
	* a-convec.ads, a-convec.adb: Iterate function returns a reversible
	iterator.



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

23 files changed, 934 insertions, 270 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 42da6aed86d..be0713a634a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,110 @@
+2011-08-29  Yannick Moy  <moy@adacore.com>
+
+	* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
+	types and dispatching calls in Alfa mode.
+	* lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
+	correspondance between body and spec scopes, to reuse utility functions
+	(Traverse_Declarations_Or_Statements): Protect access to body for stub
+	by testing the presence of the library unit for the body
+	* sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
+	mode the expansion of accept statements is skipped
+	* sem_util.adb, sem_util.ads (Unique_Entity): New function returning
+	the unique entity corresponding to the one returned by
+	Unique_Defining_Entity applied to the enclosing declaration of the
+	argument.
+
+2011-08-29  Bob Duff  <duff@adacore.com>
+
+	* treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
+	gdb when x is not a node (it can be a node list, name_id, etc). pp is
+	an alias for pn. ppp is an alias for pt.
+
+2011-08-29  Javier Miranda  <miranda@adacore.com>
+
+	* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
+	aggregate to take a consistent decision on the need to convert into
+	assignments aggregates that initialize constant objects.
+
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch4.adb (Expand_Allocator_Expression): Add a call to
+	Build_Allocate_Deallocate_Proc in order to handle allocation of
+	non-controlled objects on subpools.
+	* impunit.adb: Remove s-finmas and s-spsufi since they were never meant
+	to be end-user visible.
+	* s-finmas.adb: Add with and use clause for System.HTable.
+	Add an instantiation of Simple_HTable which provides a mapping between
+	the address of a controlled object and the corresponding
+	Finalize_Address used to clean up the object. The table is used when a
+	master is operating in heterogeneous mode.
+	(Attach): Explain why the input node is not verified on being already
+	attached.
+	(Delete_Finalize_Address): New routine.
+	(Detach): Add pragma Assert which ensures that a node is already
+	attached.
+	(Finalize): Add local variable Cleanup. Rewrite the iteration scheme
+	since nodes are no longer removed on traversal. Explain why node
+	detachment is undesirable in this case.
+	(Get_Finalize_Address): New routine.
+	(Hash): New routine.
+	(Is_Empty_List): Removed.
+	(pm): Renamed to Print_Master. Add output for discriminant
+	Is_Homogeneous.
+	Comment reformatting.
+	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
+	* s-finmas.ads: Various comments additions / improvements.
+	Type Finalization_Master has a discriminant which determines the mode of
+	operation.
+	(Delete_Finalize_Address): New routine.
+	(Get_Finalize_Address): New routine.
+	(pm): Renamed to Print_Master.
+	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
+	* s-stposu.adb: Add with clause for System.Address_Image; Add with and
+	use clause for System.IO.
+	(Allocate_Any_Controlled): Add machinery to set TSS primitive
+	Finalize_Address depending on the mode of allocation and the mode of
+	the master.
+	(Deallocate_Any_Controlled): Remove the relation pair object -
+	Finalize_Address regardless of the master mode. Add comment explaining
+	the reason.
+	(Detach): Ensure that fields Prev and Next are null after detachment.
+	(Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
+	scheme to check whether the list of subpools is empty. There is no
+	longer need to store the next subpool or advance the current pointer.
+	(Is_Empty_List): New routine.
+	(Print_Pool): New routine.
+	(Print_Subpool): New routine.
+	* s-stposu.ads: Various comments additions / improvements.
+	Field Master of type Root_Subpool is now a heterogeneous collection.
+	(Print_Pool): New routine.
+	(Print_Subpool): New routine.
+
+2011-08-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
+	forms, using aspects of container types.
+	* sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
+	Has_Implicit_Dereference flags, that may be set on the partial view.
+	* sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
+	container type with an indexing aspect.
+	(Analyze_Quantified_Expression): Analyze construct with expansion
+	disabled, because it will be rewritten as a loop during expansion.
+	(Try_Container_Indexing): The prefix itself may be a container type
+	with an indexing aspect, as with a vector of vectors.
+	* sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
+	the original doamin of iteration, for name capture.
+	(Analyze_Iterator_Specification): If the domain is an expression that
+	needs finalization, create a separate declaration for it.
+	For an iterator with "of" retrieve default iterator info from aspect of
+	container type. For "in" iterator, retrieve type of Iterate function.
+	* sem_ch13.adb (Check_Iterator_Function): Fix typo.
+	(Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
+	analysis, to prevent spurious errors about late attributes.
+	* sprint.adb: Handle quantified expression with either loop or iterator
+	specification.
+	* a-convec.ads, a-convec.adb: Iterate function returns a reversible
+	iterator.
+
 2011-08-29  Vincent Celier  <celier@adacore.com>
 
 	* make.adb (Scan_Make_Arg): Take any option as is in packages Compiler,
diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb
index 3587b2d06af..08220e9e36b 100644
--- a/gcc/ada/a-convec.adb
+++ b/gcc/ada/a-convec.adb
@@ -2042,7 +2042,7 @@ package body Ada.Containers.Vectors is
    end Iterate;
 
    function Iterate (Container : Vector; Start : Cursor)
-      return Vector_Iterator_Interfaces.Forward_Iterator'Class
+      return Vector_Iterator_Interfaces.Reversible_Iterator'class
    is
       It : constant Iterator :=
              (Container'Unchecked_Access, Start.Index);
diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads
index bf9a0d42e01..e2532f85803 100644
--- a/gcc/ada/a-convec.ads
+++ b/gcc/ada/a-convec.ads
@@ -358,7 +358,7 @@ package Ada.Containers.Vectors is
       return Vector_Iterator_Interfaces.Reversible_Iterator'Class;
 
    function Iterate (Container : Vector; Start : Cursor)
-      return Vector_Iterator_Interfaces.Forward_Iterator'Class;
+      return Vector_Iterator_Interfaces.Reversible_Iterator'class;
 
    generic
       with function "<" (Left, Right : Element_Type) return Boolean is <>;
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 2240b2f6b84..fe9cef08289 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -5099,6 +5099,16 @@ package body Exp_Aggr is
       --  semantics of Ada complicate the analysis and lead to anomalies in
       --  the gcc back-end if the aggregate is not expanded into assignments.
 
+      function Has_Visible_Private_Ancestor (Id : E) return Boolean;
+      --  If any ancestor of the current type is private, the aggregate
+      --  cannot be built in place. We canot rely on Has_Private_Ancestor,
+      --  because it will not be set when type and its parent are in the
+      --  same scope, and the parent component needs expansion.
+
+      function Top_Level_Aggregate (N : Node_Id) return Node_Id;
+      --  For nested aggregates return the ultimate enclosing aggregate; for
+      --  non-nested aggregates return N.
+
       ----------------------------------
       -- Component_Not_OK_For_Backend --
       ----------------------------------
@@ -5178,18 +5188,6 @@ package body Exp_Aggr is
          return False;
       end Component_Not_OK_For_Backend;
 
-      --  Remaining Expand_Record_Aggregate variables
-
-      Tag_Value : Node_Id;
-      Comp      : Entity_Id;
-      New_Comp  : Node_Id;
-
-      function Has_Visible_Private_Ancestor (Id : E) return Boolean;
-      --  If any ancestor of the current type is private, the aggregate
-      --  cannot be built in place. We canot rely on Has_Private_Ancestor,
-      --  because it will not be set when type and its parent are in the
-      --  same scope, and the parent component needs expansion.
-
       -----------------------------------
       --  Has_Visible_Private_Ancestor --
       -----------------------------------
@@ -5197,6 +5195,7 @@ package body Exp_Aggr is
       function Has_Visible_Private_Ancestor (Id : E) return Boolean is
          R  : constant Entity_Id := Root_Type (Id);
          T1 : Entity_Id := Id;
+
       begin
          loop
             if Is_Private_Type (T1) then
@@ -5211,6 +5210,31 @@ package body Exp_Aggr is
          end loop;
       end Has_Visible_Private_Ancestor;
 
+      -------------------------
+      -- Top_Level_Aggregate --
+      -------------------------
+
+      function Top_Level_Aggregate (N : Node_Id) return Node_Id is
+         Aggr : Node_Id := N;
+
+      begin
+         while Present (Parent (Aggr))
+           and then Nkind_In (Parent (Aggr), N_Component_Association,
+                                             N_Aggregate)
+         loop
+            Aggr := Parent (Aggr);
+         end loop;
+
+         return Aggr;
+      end Top_Level_Aggregate;
+
+      --  Local variables
+
+      Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
+      Tag_Value      : Node_Id;
+      Comp           : Entity_Id;
+      New_Comp       : Node_Id;
+
    --  Start of processing for Expand_Record_Aggregate
 
    begin
@@ -5317,8 +5341,8 @@ package body Exp_Aggr is
 
       elsif Has_Mutable_Components (Typ)
         and then
-          (Nkind (Parent (N)) /= N_Object_Declaration
-            or else not Constant_Present (Parent (N)))
+          (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
+            or else not Constant_Present (Parent (Top_Level_Aggr)))
       then
          Convert_To_Assignments (N, Typ);
 
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 8ac78ac1f5e..4824df02583 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1137,6 +1137,8 @@ package body Exp_Ch4 is
             Rewrite (Exp, New_Copy (Expression (Exp)));
          end if;
       else
+         Build_Allocate_Deallocate_Proc (N, True);
+
          --  If we have:
          --    type A is access T1;
          --    X : A := new T2'(...);
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 0420e741c0d..21b14d725fc 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2825,6 +2825,7 @@ package body Exp_Ch5 is
       Container     : constant Node_Id   := Name (I_Spec);
       Container_Typ : constant Entity_Id := Etype (Container);
       Cursor        : Entity_Id;
+      Iterator      : Entity_Id;
       New_Loop      : Node_Id;
       Stats         : List_Id := Statements (N);
 
@@ -2839,10 +2840,10 @@ package body Exp_Ch5 is
          --  the array.
 
          if Of_Present (I_Spec) then
-            Cursor := Make_Temporary (Loc, 'C');
+            Iterator := Make_Temporary (Loc, 'C');
 
             --  Generate:
-            --    Element : Component_Type renames Container (Cursor);
+            --    Element : Component_Type renames Container (Iterator);
 
             Prepend_To (Stats,
               Make_Object_Renaming_Declaration (Loc,
@@ -2853,19 +2854,19 @@ package body Exp_Ch5 is
                   Make_Indexed_Component (Loc,
                     Prefix => Relocate_Node (Container),
                     Expressions => New_List (
-                      New_Reference_To (Cursor, Loc)))));
+                      New_Reference_To (Iterator, Loc)))));
 
          --  for Index in Array loop
          --
-         --  This case utilizes the already given cursor name
+         --  This case utilizes the already given iterator name
 
          else
-            Cursor := Id;
+            Iterator := Id;
          end if;
 
          --  Generate:
-         --    for Cursor in [reverse] Container'Range loop
-         --       Element : Component_Type renames Container (Cursor);
+         --    for Iterator in [reverse] Container'Range loop
+         --       Element : Component_Type renames Container (Iterator);
          --       --  for the "of" form
          --
          --       <original loop statements>
@@ -2877,7 +2878,7 @@ package body Exp_Ch5 is
                Make_Iteration_Scheme (Loc,
                  Loop_Parameter_Specification =>
                    Make_Loop_Parameter_Specification (Loc,
-                     Defining_Identifier => Cursor,
+                     Defining_Identifier => Iterator,
                        Discrete_Subtype_Definition =>
                          Make_Attribute_Reference (Loc,
                            Prefix => Relocate_Node (Container),
@@ -2889,21 +2890,28 @@ package body Exp_Ch5 is
       --  Processing for containers
 
       else
+         --  For an iterator of the form "Of" then name is some expression,
+         --  which is transformed into a call to the default iterator.
+
+         --  For an iterator of the form "in" then name is a function call
+         --  that delivers an iterator.
+
          --  The for loop is expanded into a while loop which uses a container
          --  specific cursor to examine each element.
 
-         --    Cursor : Pack.Cursor := Container.First;
-         --    while Cursor /= Pack.No_Element loop
+         --    Iter : Iterator_Type := Container.Iterate;
+         --    Cursor : Cursor_type := First (Iter);
+         --    while Has_Element (Iter) loop
          --       declare
          --       --  the block is added when Element_Type is controlled
 
-         --          Obj : Pack.Element_Type := Element (Cursor);
+         --          Obj : Pack.Element_Type := Element (Iterator);
          --          --  for the "of" loop form
          --       begin
          --          <original loop statements>
          --       end;
 
-         --       Pack.Next (Cursor);
+         --       Cursor := Iter.Next (Cursor);
          --    end loop;
 
          --  If "reverse" is present, then the initialization of the cursor
@@ -2912,30 +2920,48 @@ package body Exp_Ch5 is
 
          declare
             Element_Type : constant Entity_Id := Etype (Id);
-            Pack         : constant Entity_Id :=
-                             Scope (Base_Type (Container_Typ));
+            Pack         : Entity_Id;
             Decl         : Node_Id;
-            Cntr         : Node_Id;
             Name_Init    : Name_Id;
             Name_Step    : Name_Id;
 
          begin
-            --  The "of" case uses an internally generated cursor
+            if Is_Entity_Name (Container) then
+               Pack := Scope (Etype (Container));
+
+            else
+               Pack := Scope (Entity (Name (Container)));
+            end if;
+
+            --  The "of" case uses an internally generated cursor whose type
+            --  is found in the container package.
 
             if Of_Present (I_Spec) then
-               Cursor := Make_Temporary (Loc, 'C');
+               Cursor := Make_Temporary (Loc, 'I');
+
+               declare
+                  Ent : Entity_Id;
+               begin
+                  Ent := First_Entity (Pack);
+                  while Present (Ent) loop
+                     if Chars (Ent) = Name_Cursor then
+                        Set_Etype (Cursor, Etype (Ent));
+                        exit;
+                     end if;
+                     Next_Entity (Ent);
+                  end loop;
+               end;
+
             else
                Cursor := Id;
             end if;
 
-            --  The code below only handles containers where Element is not a
-            --  primitive operation of the container. This excludes for now the
-            --  Hi-Lite formal containers.
+            Iterator := Make_Temporary (Loc, 'I');
 
             if Of_Present (I_Spec) then
 
                --  Generate:
-               --    Id : Element_Type := Pack.Element (Cursor);
+               --    Id : Element_Type renames Pack.Element (Cursor);
 
                Decl :=
                  Make_Object_Renaming_Declaration (Loc,
@@ -2951,18 +2977,18 @@ package body Exp_Ch5 is
                            Selector_Name =>
                              Make_Identifier (Loc, Chars => Name_Element)),
                        Expressions => New_List (
-                         New_Reference_To (Cursor, Loc))));
+                          New_Occurrence_Of (Cursor, Loc))));
 
                --  When the container holds controlled objects, wrap the loop
                --  statements and element renaming declaration with a block.
-               --  This ensures that the transient result of Element (Cursor)
+               --  This ensures that the transient result of Element (Iterator)
                --  is cleaned up after each iteration of the loop.
 
                if Needs_Finalization (Element_Type) then
 
                   --  Generate:
                   --    declare
-                  --       Id : Element_Type := Pack.Element (Cursor);
+                  --       Id : Element_Type := Pack.Element (Iterator);
                   --    begin
                   --       <original loop statements>
                   --    end;
@@ -2994,22 +3020,38 @@ package body Exp_Ch5 is
             --  For both iterator forms, add a call to the step operation to
             --  advance the cursor. Generate:
             --
-            --    Pack.[Next | Prev] (Cursor);
+            --    Cursor := Iterator.Next (Cursor);
+            --   or else
+            --    Cursor := Next (Cursor);
 
-            Append_To (Stats,
-              Make_Procedure_Call_Statement (Loc,
-                Name =>
-                  Make_Selected_Component (Loc,
-                    Prefix =>
-                      New_Reference_To (Pack, Loc),
-                    Selector_Name =>
-                      Make_Identifier (Loc, Name_Step)),
+            declare
+               Rhs : Node_Id;
+            begin
+               if Of_Present (I_Spec) then
+                  Rhs :=
+                    Make_Function_Call (Loc,
+                      Name => Make_Identifier (Loc, Name_Step),
+                      Parameter_Associations =>
+                        New_List (New_Reference_To (Cursor, Loc)));
+               else
+                  Rhs :=
+                    Make_Function_Call (Loc,
+                      Name =>
+                        Make_Selected_Component (Loc,
+                          Prefix => New_Reference_To (Iterator, Loc),
+                          Selector_Name => Make_Identifier (Loc, Name_Step)),
+                      Parameter_Associations => New_List (
+                         New_Reference_To (Cursor, Loc)));
+               end if;
 
-                Parameter_Associations => New_List (
-                  New_Reference_To (Cursor, Loc))));
+               Append_To (Stats,
+                 Make_Assignment_Statement (Loc,
+                    Name       => New_Occurrence_Of (Cursor, Loc),
+                    Expression => Rhs));
+            end;
 
             --  Generate:
-            --    while Cursor /= Pack.No_Element loop
+            --    while Iterator.Has_Element loop
             --       <Stats>
             --    end loop;
 
@@ -3018,71 +3060,61 @@ package body Exp_Ch5 is
                 Iteration_Scheme =>
                   Make_Iteration_Scheme (Loc,
                     Condition =>
-                      Make_Op_Ne (Loc,
-                        Left_Opnd =>
-                          New_Reference_To (Cursor, Loc),
-                        Right_Opnd =>
+                      Make_Function_Call (Loc,
+                        Name =>
                           Make_Selected_Component (Loc,
-                            Prefix =>
-                              New_Reference_To (Pack, Loc),
-                            Selector_Name =>
-                              Make_Identifier (Loc, Name_No_Element)))),
+                           Prefix => New_Occurrence_Of (Pack, Loc),
+                           Selector_Name =>
+                             Make_Identifier (Loc,  Name_Has_Element)),
+
+                        Parameter_Associations =>
+                          New_List (
+                            New_Reference_To (Cursor, Loc)))),
                 Statements => Stats,
                 End_Label  => Empty);
 
-            Cntr := Relocate_Node (Container);
-
-            --  When the container is provided by a function call, create an
-            --  explicit renaming of the function result. Generate:
-            --
-            --    Cnn : Container_Typ renames Func_Call (...);
+            --  Create the declarations for Iterator and cursor and insert then
+            --  before the source loop. Generate:
             --
-            --  The renaming avoids the generation of a transient scope when
-            --  initializing the cursor and the premature finalization of the
-            --  container.
+            --    I : Iterator_Type := Iterate (Container);
+            --    C : Pack.Cursor_Type := Container.[First | Last];
 
-            if Nkind (Cntr) = N_Function_Call then
-               declare
-                  Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'C');
+            declare
+               Decl1 : Node_Id;
+               Decl2 : Node_Id;
+            begin
+               Decl1 :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Iterator,
+                 Object_Definition =>
+                   New_Occurrence_Of (Etype (Name (I_Spec)), Loc),
 
-               begin
-                  Insert_Action (N,
-                    Make_Object_Renaming_Declaration (Loc,
-                      Defining_Identifier => Ren_Id,
-                      Subtype_Mark =>
-                        New_Reference_To (Container_Typ, Loc),
-                      Name => Cntr));
-
-                  Cntr := New_Reference_To (Ren_Id, Loc);
-               end;
-            end if;
+                 Expression => Relocate_Node (Name (I_Spec)));
+               Set_Assignment_OK (Decl1);
 
-            --  Create the declaration of the cursor and insert it before the
-            --  source loop. Generate:
-            --
-            --    C : Pack.Cursor_Type := Container.[First | Last];
+               Decl2 :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Cursor,
+                   Object_Definition =>
+                     New_Occurrence_Of (Etype (Cursor), Loc),
 
-            Insert_Action (N,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Cursor,
-                Object_Definition =>
-                  Make_Selected_Component (Loc,
-                    Prefix =>
-                      New_Reference_To (Pack, Loc),
-                    Selector_Name =>
-                      Make_Identifier (Loc, Name_Cursor)),
+                   Expression =>
+                     Make_Selected_Component (Loc,
+                       Prefix => New_Reference_To (Iterator, Loc),
+                       Selector_Name =>
+                         Make_Identifier (Loc, Name_Init)));
 
-                Expression =>
-                  Make_Selected_Component (Loc,
-                    Prefix => Cntr,
-                    Selector_Name =>
-                      Make_Identifier (Loc, Name_Init))));
+               Set_Assignment_OK (Decl2);
+
+               Insert_Actions (N,
+                 New_List (Decl1, Decl2));
+            end;
 
-            --  The cursor is not modified in the source, but of course will
+            --  The Iterator is not modified in the source, but of course will
             --  be updated in the generated code. Indicate that it is actually
             --  set to prevent spurious warnings.
 
-            Set_Never_Set_In_Source (Cursor, False);
+            Set_Never_Set_In_Source (Iterator, False);
 
             --  If the range of iteration is given by a function call that
             --  returns a container, the finalization actions have been saved
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index daab3d0be30..8ec020437ef 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -476,9 +476,12 @@ procedure Gnat1drv is
 
          Global_Discard_Names := True;
 
-         --  Suppress the expansion of tagged types and dispatching calls
+         --  We would prefer to suppress the expansion of tagged types and
+         --  dispatching calls, so that one day GNATprove can handle them
+         --  directly. Unfortunately, this is causing problems on H513-015, so
+         --  keep this expansion for the time being.
 
-         Tagged_Type_Expansion := False;
+         Tagged_Type_Expansion := True;
       end if;
    end Adjust_Global_Switches;
 
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index ea636fe8b0a..9aa86d523f6 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -346,7 +346,6 @@ package body Impunit is
 
      "s-addima",    -- System.Address_Image
      "s-assert",    -- System.Assertions
-     "s-finmas",    -- System.Finalization_Masters
      "s-memory",    -- System.Memory
      "s-parint",    -- System.Partition_Interface
      "s-pooglo",    -- System.Pool_Global
@@ -529,7 +528,6 @@ package body Impunit is
    -- GNAT Defined Additions to Ada 20012 --
    -----------------------------------------
 
-     "s-spsufi",    -- System.Storage_Pools.Subpools.Finalization
      "a-cofove",    -- Ada.Containers.Formal_Vectors
      "a-cfdlli",    -- Ada.Containers.Formal_Doubly_Linked_Lists
      "a-cforse",    -- Ada.Containers.Formal_Ordered_Sets
diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb
index 9aabe7cf95c..70d5062f103 100644
--- a/gcc/ada/lib-xref-alfa.adb
+++ b/gcc/ada/lib-xref-alfa.adb
@@ -835,38 +835,22 @@ package body ALFA is
             declare
                Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S);
 
-               Body_Entity : Entity_Id;
-               Spec_Entity : Entity_Id;
-               Spec_Scope  : Scope_Index;
+               Spec_Entity : constant Entity_Id :=
+                               Unique_Entity (Srec.Scope_Entity);
+               Spec_Scope  : constant Scope_Index :=
+                               Entity_Hash_Table.Get (Spec_Entity);
 
             begin
-               if Ekind (Srec.Scope_Entity) = E_Subprogram_Body then
-                  Body_Entity := Parent (Parent (Srec.Scope_Entity));
-               elsif Ekind (Srec.Scope_Entity) = E_Package_Body then
-                  Body_Entity := Parent (Srec.Scope_Entity);
-               else
-                  Body_Entity := Empty;
-               end if;
-
-               if Present (Body_Entity) then
-                  if Nkind (Body_Entity) = N_Defining_Program_Unit_Name then
-                     Body_Entity := Parent (Body_Entity);
-                  elsif Nkind (Body_Entity) = N_Subprogram_Body_Stub then
-                     Body_Entity :=
-                       Proper_Body (Unit (Library_Unit (Body_Entity)));
-                  end if;
-
-                  Spec_Entity := Corresponding_Spec (Body_Entity);
-                  Spec_Scope := Entity_Hash_Table.Get (Spec_Entity);
-
-                  --  Spec of generic may be missing
+               --  Spec of generic may be missing, in which case Spec_Scope is
+               --  zero.
 
-                  if Spec_Scope /= 0 then
-                     Srec.Spec_File_Num :=
-                       ALFA_Scope_Table.Table (Spec_Scope).File_Num;
-                     Srec.Spec_Scope_Num :=
-                       ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
-                  end if;
+               if Spec_Entity /= Srec.Scope_Entity
+                 and then Spec_Scope /= 0
+               then
+                  Srec.Spec_File_Num :=
+                    ALFA_Scope_Table.Table (Spec_Scope).File_Num;
+                  Srec.Spec_Scope_Num :=
+                    ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
                end if;
             end;
          end loop;
@@ -1019,16 +1003,18 @@ package body ALFA is
                end if;
 
             when N_Package_Body_Stub =>
-               declare
-                  Body_N : constant Node_Id := Get_Body_From_Stub (N);
-               begin
-                  if Inside_Stubs
-                    and then
-                      Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
-                  then
-                     Traverse_Package_Body (Body_N, Process, Inside_Stubs);
-                  end if;
-               end;
+               if Present (Library_Unit (N)) then
+                  declare
+                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
+                  begin
+                     if Inside_Stubs
+                       and then
+                         Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
+                     then
+                        Traverse_Package_Body (Body_N, Process, Inside_Stubs);
+                     end if;
+                  end;
+               end if;
 
             --  Subprogram declaration
 
@@ -1048,16 +1034,19 @@ package body ALFA is
                end if;
 
             when N_Subprogram_Body_Stub =>
-               declare
-                  Body_N : constant Node_Id := Get_Body_From_Stub (N);
-               begin
-                  if Inside_Stubs
-                    and then
-                      not Is_Generic_Subprogram (Defining_Entity (Body_N))
-                  then
-                     Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
-                  end if;
-               end;
+               if Present (Library_Unit (N)) then
+                  declare
+                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
+                  begin
+                     if Inside_Stubs
+                       and then
+                         not Is_Generic_Subprogram (Defining_Entity (Body_N))
+                     then
+                        Traverse_Subprogram_Body
+                          (Body_N, Process, Inside_Stubs);
+                     end if;
+                  end;
+               end if;
 
             --  Block statement
 
diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb
index 857db696b00..4ab8a301b67 100644
--- a/gcc/ada/s-finmas.adb
+++ b/gcc/ada/s-finmas.adb
@@ -31,12 +31,32 @@
 
 with Ada.Exceptions;          use Ada.Exceptions;
 with System.Address_Image;
+with System.HTable;           use System.HTable;
 with System.IO;               use System.IO;
 with System.Soft_Links;       use System.Soft_Links;
 with System.Storage_Elements; use System.Storage_Elements;
 
 package body System.Finalization_Masters is
 
+   --  Finalize_Address hash table types. In general, masters are homogeneous
+   --  collections of controlled objects. Rare cases such as allocations on a
+   --  subpool require heterogeneous masters. The following table provides a
+   --  relation between object address and its Finalize_Address routine.
+
+   type Header_Num is range 0 .. 127;
+
+   function Hash (Key : System.Address) return Header_Num;
+
+   --  Address --> Finalize_Address_Ptr
+
+   package Finalize_Address_Table is new Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Finalize_Address_Ptr,
+      No_Element => null,
+      Key        => System.Address,
+      Hash       => Hash,
+      Equal      => "=");
+
    ---------------------------
    -- Add_Offset_To_Address --
    ---------------------------
@@ -79,6 +99,17 @@ package body System.Finalization_Masters is
       return Master.Base_Pool;
    end Base_Pool;
 
+   -----------------------------
+   -- Delete_Finalize_Address --
+   -----------------------------
+
+   procedure Delete_Finalize_Address (Obj : System.Address) is
+   begin
+      Lock_Task.all;
+      Finalize_Address_Table.Remove (Obj);
+      Unlock_Task.all;
+   end Delete_Finalize_Address;
+
    ------------
    -- Detach --
    ------------
@@ -94,10 +125,10 @@ package body System.Finalization_Masters is
          N.Next := null;
 
          Unlock_Task.all;
-      end if;
 
-      --  Note: No need to unlock in case of an exception because the above
-      --  code can never raise one.
+         --  Note: No need to unlock in case of an exception because the above
+         --  code can never raise one.
+      end if;
    end Detach;
 
    --------------
@@ -105,6 +136,7 @@ package body System.Finalization_Masters is
    --------------
 
    overriding procedure Finalize (Master : in out Finalization_Master) is
+      Cleanup  : Finalize_Address_Ptr;
       Curr_Ptr : FM_Node_Ptr;
       Ex_Occur : Exception_Occurrence;
       Obj_Addr : Address;
@@ -144,23 +176,41 @@ package body System.Finalization_Masters is
 
          Detach (Curr_Ptr);
 
-         if Master.Finalize_Address /= null then
+         --  Skip the list header in order to offer proper object layout for
+         --  finalization.
+
+         Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+
+         --  Retrieve TSS primitive Finalize_Address depending on the master's
+         --  mode of operation.
+
+         if Master.Is_Homogeneous then
+            Cleanup := Master.Finalize_Address;
+         else
+            Cleanup := Get_Finalize_Address (Obj_Addr);
+         end if;
+
+         --  If Finalize_Address is not available, then this is most likely an
+         --  error in the expansion of the designated type or the allocator.
+
+         pragma Assert (Cleanup /= null);
 
-            --  Skip the list header in order to offer proper object layout for
-            --  finalization and call Finalize_Address.
+         begin
+            Cleanup (Obj_Addr);
 
-            Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+         exception
+            when Fin_Occur : others =>
+               if not Raised then
+                  Raised := True;
+                  Save_Occurrence (Ex_Occur, Fin_Occur);
+               end if;
+         end;
 
-            begin
-               Master.Finalize_Address (Obj_Addr);
+         --  When the master is a heterogeneous collection, destroy the object
+         --  - Finalize_Address pair since it is no longer needed.
 
-            exception
-               when Fin_Occur : others =>
-                  if not Raised then
-                     Raised := True;
-                     Save_Occurrence (Ex_Occur, Fin_Occur);
-                  end if;
-            end;
+         if not Master.Is_Homogeneous then
+            Delete_Finalize_Address (Obj_Addr);
          end if;
       end loop;
 
@@ -172,6 +222,23 @@ package body System.Finalization_Masters is
       end if;
    end Finalize;
 
+   --------------------------
+   -- Get_Finalize_Address --
+   --------------------------
+
+   function Get_Finalize_Address
+     (Obj : System.Address) return Finalize_Address_Ptr
+   is
+      Result : Finalize_Address_Ptr;
+
+   begin
+      Lock_Task.all;
+      Result := Finalize_Address_Table.Get (Obj);
+      Unlock_Task.all;
+
+      return Result;
+   end Get_Finalize_Address;
+
    -----------------
    -- Header_Size --
    -----------------
@@ -181,6 +248,17 @@ package body System.Finalization_Masters is
       return FM_Node'Size / Storage_Unit;
    end Header_Size;
 
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (Key : System.Address) return Header_Num is
+   begin
+      return
+        Header_Num
+          (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
+   end Hash;
+
    -------------------
    -- Header_Offset --
    -------------------
@@ -202,11 +280,11 @@ package body System.Finalization_Masters is
       Master.Objects.Prev := Master.Objects'Unchecked_Access;
    end Initialize;
 
-   --------
-   -- pm --
-   --------
+   ------------------
+   -- Print_Master --
+   ------------------
 
-   procedure pm (Master : Finalization_Master) is
+   procedure Print_Master (Master : Finalization_Master) is
       Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
       Head_Seen : Boolean := False;
       N_Ptr     : FM_Node_Ptr;
@@ -215,6 +293,7 @@ package body System.Finalization_Masters is
       --  Output the basic contents of a master
 
       --    Master   : 0x123456789
+      --    Is_Hmgen : TURE <or> FALSE
       --    Base_Pool: null <or> 0x123456789
       --    Fin_Addr : null <or> 0x123456789
       --    Fin_Start: TRUE <or> FALSE
@@ -222,16 +301,17 @@ package body System.Finalization_Masters is
       Put ("Master   : ");
       Put_Line (Address_Image (Master'Address));
 
-      Put ("Base_Pool: ");
+      Put ("Is_Hmgen : ");
+      Put_Line (Master.Is_Homogeneous'Img);
 
+      Put ("Base_Pool: ");
       if Master.Base_Pool = null then
-         Put_Line (" null");
+         Put_Line ("null");
       else
          Put_Line (Address_Image (Master.Base_Pool'Address));
       end if;
 
       Put ("Fin_Addr : ");
-
       if Master.Finalize_Address = null then
          Put_Line ("null");
       else
@@ -255,17 +335,17 @@ package body System.Finalization_Masters is
 
       --  Header - the address of the list header
       --  Prev   - the address of the list header which the current element
-      --         - points back to
+      --           points back to
       --  Next   - the address of the list header which the current element
-      --         - points to
+      --           points to
       --  (dummy head) - present if dummy head
 
       N_Ptr := Head;
-      while N_Ptr /= null loop -- Should never be null; we being defensive
+      while N_Ptr /= null loop  --  Should never be null
          Put_Line ("V");
 
          --  We see the head initially; we want to exit when we see the head a
-         --  SECOND time.
+         --  second time.
 
          if N_Ptr = Head then
             exit when Head_Seen;
@@ -321,7 +401,7 @@ package body System.Finalization_Masters is
 
          N_Ptr := N_Ptr.Next;
       end loop;
-   end pm;
+   end Print_Master;
 
    -------------------
    -- Set_Base_Pool --
@@ -347,4 +427,18 @@ package body System.Finalization_Masters is
       Master.Finalize_Address := Fin_Addr_Ptr;
    end Set_Finalize_Address;
 
+   --------------------------
+   -- Set_Finalize_Address --
+   --------------------------
+
+   procedure Set_Finalize_Address
+     (Obj          : System.Address;
+      Fin_Addr_Ptr : Finalize_Address_Ptr)
+   is
+   begin
+      Lock_Task.all;
+      Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
+      Unlock_Task.all;
+   end Set_Finalize_Address;
+
 end System.Finalization_Masters;
diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads
index 87a607678bc..6dd5e38fba7 100644
--- a/gcc/ada/s-finmas.ads
+++ b/gcc/ada/s-finmas.ads
@@ -31,7 +31,6 @@
 
 with Ada.Finalization;
 with Ada.Unchecked_Conversion;
-
 with System.Storage_Elements;
 with System.Storage_Pools;
 
@@ -69,9 +68,10 @@ package System.Finalization_Masters is
 
    --  Finalization master type structure. A unique master is associated with
    --  each access-to-controlled or access-to-class-wide type. Masters also act
-   --  as components of subpools.
+   --  as components of subpools. By default, a master contains objects of the
+   --  same designated type but it may also accomodate heterogeneous objects.
 
-   type Finalization_Master is
+   type Finalization_Master (Is_Homogeneous : Boolean := True) is
      new Ada.Finalization.Limited_Controlled with
    record
       Base_Pool : Any_Storage_Pool_Ptr := null;
@@ -83,7 +83,8 @@ package System.Finalization_Masters is
       --  objects allocated in a [sub]pool.
 
       Finalize_Address : Finalize_Address_Ptr := null;
-      --  A reference to the routine reponsible for object finalization
+      --  A reference to the routine reponsible for object finalization. This
+      --  is used only when the master is in homogeneous mode.
 
       Finalization_Started : Boolean := False;
       pragma Atomic (Finalization_Started);
@@ -114,6 +115,10 @@ package System.Finalization_Masters is
    --  Return a reference to the underlying storage pool on which the master
    --  operates.
 
+   procedure Delete_Finalize_Address (Obj : System.Address);
+   --  Destroy the relation pair object - Finalize_Address from the internal
+   --  hash table.
+
    procedure Detach (N : not null FM_Node_Ptr);
    --  Remove a node from an arbitrary finalization master
 
@@ -122,6 +127,11 @@ package System.Finalization_Masters is
    --  the list of allocated controlled objects, finalizing each one by calling
    --  its specific Finalize_Address. In the end, deallocate the dummy head.
 
+   function Get_Finalize_Address
+     (Obj : System.Address) return Finalize_Address_Ptr;
+   --  Retrieve the Finalize_Address primitive associated with a particular
+   --  object.
+
    function Header_Offset return System.Storage_Elements.Storage_Offset;
    --  Return the size of type FM_Node as Storage_Offset
 
@@ -131,7 +141,7 @@ package System.Finalization_Masters is
    overriding procedure Initialize (Master : in out Finalization_Master);
    --  Initialize the dummy head of a finalization master
 
-   procedure pm (Master : Finalization_Master);
+   procedure Print_Master (Master : Finalization_Master);
    --  Debug routine, outputs the contents of a master
 
    procedure Set_Base_Pool
@@ -144,4 +154,9 @@ package System.Finalization_Masters is
       Fin_Addr_Ptr : Finalize_Address_Ptr);
    --  Set the clean up routine of a finalization master
 
+   procedure Set_Finalize_Address
+     (Obj          : System.Address;
+      Fin_Addr_Ptr : Finalize_Address_Ptr);
+   --  Add a relation pair object - Finalize_Address to the internal hash table
+
 end System.Finalization_Masters;
diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb
index bf3a87e662f..0cdc90b7084 100644
--- a/gcc/ada/s-stposu.adb
+++ b/gcc/ada/s-stposu.adb
@@ -31,8 +31,9 @@
 
 with Ada.Exceptions;              use Ada.Exceptions;
 with Ada.Unchecked_Deallocation;
-
+with System.Address_Image;
 with System.Finalization_Masters; use System.Finalization_Masters;
+with System.IO;                   use System.IO;
 with System.Soft_Links;           use System.Soft_Links;
 with System.Storage_Elements;     use System.Storage_Elements;
 
@@ -248,21 +249,39 @@ package body System.Storage_Pools.Subpools is
          --     +- Header_And_Padding --+
 
          N_Ptr := Address_To_FM_Node_Ptr
-                   (N_Addr + Header_And_Padding - Header_Offset);
+                    (N_Addr + Header_And_Padding - Header_Offset);
 
          --  Prepend the allocated object to the finalization master
 
          Attach (N_Ptr, Master.Objects'Unchecked_Access);
 
-         if Master.Finalize_Address = null then
-            Master.Finalize_Address := Fin_Address;
-         end if;
-
          --  Move the address from the hidden list header to the start of the
          --  object. This operation effectively hides the list header.
 
          Addr := N_Addr + Header_And_Padding;
 
+         --  Subpool allocations use heterogeneous masters to manage various
+         --  controlled objects. Associate a Finalize_Address with the object.
+         --  This relation pair is deleted when the object is deallocated or
+         --  when the associated master is finalized.
+
+         if Is_Subpool_Allocation then
+            pragma Assert (not Master.Is_Homogeneous);
+
+            Set_Finalize_Address (Addr, Fin_Address);
+
+         --  Normal allocations chain objects on homogeneous collections
+
+         else
+            pragma Assert (Master.Is_Homogeneous);
+
+            if Master.Finalize_Address = null then
+               Master.Finalize_Address := Fin_Address;
+            end if;
+         end if;
+
+      --  Non-controlled allocation
+
       else
          Addr := N_Addr;
       end if;
@@ -315,6 +334,14 @@ package body System.Storage_Pools.Subpools is
 
       if Is_Controlled then
 
+         --  Destroy the relation pair object - Finalize_Address since it is no
+         --  longer needed. If the object was chained on a homogeneous master,
+         --  this call does nothing. This is unconditional destruction since we
+         --  do not want to drag in additional data to determine the master
+         --  kind.
+
+         Delete_Finalize_Address (Addr);
+
          --  Account for possible padding space before the header due to a
          --  larger alignment.
 
@@ -382,6 +409,8 @@ package body System.Storage_Pools.Subpools is
 
       N.Prev.Next := N.Next;
       N.Next.Prev := N.Prev;
+      N.Prev := null;
+      N.Next := null;
 
       Unlock_Task.all;
 
@@ -405,9 +434,22 @@ package body System.Storage_Pools.Subpools is
    procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
       Curr_Ptr : SP_Node_Ptr;
       Ex_Occur : Exception_Occurrence;
-      Next_Ptr : SP_Node_Ptr;
       Raised   : Boolean := False;
 
+      function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
+      --  Determine whether a list contains only one element, the dummy head
+
+      -------------------
+      -- Is_Empty_List --
+      -------------------
+
+      function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
+      begin
+         return L.Next = L and then L.Prev = L;
+      end Is_Empty_List;
+
+   --  Start of processing for Finalize_Pool
+
    begin
       --  It is possible for multiple tasks to cause the finalization of a
       --  common pool. Allow only one task to finalize the contents.
@@ -423,11 +465,8 @@ package body System.Storage_Pools.Subpools is
 
       Pool.Finalization_Started := True;
 
-      --  Skip the dummy head
-
-      Curr_Ptr := Pool.Subpools.Next;
-      while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
-         Next_Ptr := Curr_Ptr.Next;
+      while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
+         Curr_Ptr := Pool.Subpools.Next;
 
          --  Perform the following actions:
 
@@ -446,8 +485,6 @@ package body System.Storage_Pools.Subpools is
                   Save_Occurrence (Ex_Occur, Fin_Occur);
                end if;
          end;
-
-         Curr_Ptr := Next_Ptr;
       end loop;
 
       --  If the finalization of a particular master failed, reraise the
@@ -537,6 +574,150 @@ package body System.Storage_Pools.Subpools is
       return Subpool.Owner;
    end Pool_Of_Subpool;
 
+   ----------------
+   -- Print_Pool --
+   ----------------
+
+   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
+      Head      : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
+      Head_Seen : Boolean := False;
+      SP_Ptr    : SP_Node_Ptr;
+
+   begin
+      --  Output the contents of the pool
+
+      --    Pool      : 0x123456789
+      --    Subpools  : 0x123456789
+      --    Fin_Start : TRUE <or> FALSE
+      --    Controller: OK <or> NOK
+
+      Put ("Pool      : ");
+      Put_Line (Address_Image (Pool'Address));
+
+      Put ("Subpools  : ");
+      Put_Line (Address_Image (Pool.Subpools'Address));
+
+      Put ("Fin_Start : ");
+      Put_Line (Pool.Finalization_Started'Img);
+
+      Put ("Controlled: ");
+      if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
+         Put_Line ("OK");
+      else
+         Put_Line ("NOK (ERROR)");
+      end if;
+
+      SP_Ptr := Head;
+      while SP_Ptr /= null loop  --  Should never be null
+         Put_Line ("V");
+
+         --  We see the head initially; we want to exit when we see the head a
+         --  second time.
+
+         if SP_Ptr = Head then
+            exit when Head_Seen;
+
+            Head_Seen := True;
+         end if;
+
+         --  The current element is null. This should never happend since the
+         --  list is circular.
+
+         if SP_Ptr.Prev = null then
+            Put_Line ("null (ERROR)");
+
+         --  The current element points back to the correct element
+
+         elsif SP_Ptr.Prev.Next = SP_Ptr then
+            Put_Line ("^");
+
+         --  The current element points to an erroneous element
+
+         else
+            Put_Line ("? (ERROR)");
+         end if;
+
+         --  Output the contents of the node
+
+         Put ("|Header: ");
+         Put (Address_Image (SP_Ptr.all'Address));
+         if SP_Ptr = Head then
+            Put_Line (" (dummy head)");
+         else
+            Put_Line ("");
+         end if;
+
+         Put ("|  Prev: ");
+
+         if SP_Ptr.Prev = null then
+            Put_Line ("null");
+         else
+            Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
+         end if;
+
+         Put ("|  Next: ");
+
+         if SP_Ptr.Next = null then
+            Put_Line ("null");
+         else
+            Put_Line (Address_Image (SP_Ptr.Next.all'Address));
+         end if;
+
+         Put ("|  Subp: ");
+
+         if SP_Ptr.Subpool = null then
+            Put_Line ("null");
+         else
+            Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
+         end if;
+
+         SP_Ptr := SP_Ptr.Next;
+      end loop;
+   end Print_Pool;
+
+   -------------------
+   -- Print_Subpool --
+   -------------------
+
+   procedure Print_Subpool (Subpool : Subpool_Handle) is
+   begin
+      if Subpool = null then
+         Put_Line ("null");
+         return;
+      end if;
+
+      --  Output the contents of a subpool
+
+      --    Owner : 0x123456789
+      --    Master: 0x123456789
+      --    Node  : 0x123456789
+
+      Put ("Owner : ");
+      if Subpool.Owner = null then
+         Put_Line ("null");
+      else
+         Put_Line (Address_Image (Subpool.Owner'Address));
+      end if;
+
+      Put ("Master: ");
+      Put_Line (Address_Image (Subpool.Master'Address));
+
+      Put ("Node  : ");
+      if Subpool.Node = null then
+         Put ("null");
+
+         if Subpool.Owner = null then
+            Put_Line (" OK");
+         else
+            Put_Line (" (ERROR)");
+         end if;
+      else
+         Put_Line (Address_Image (Subpool.Node'Address));
+      end if;
+
+      Print_Master (Subpool.Master);
+   end Print_Subpool;
+
    -------------------------
    -- Set_Pool_Of_Subpool --
    -------------------------
diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads
index bd268186926..79ff97cfdce 100644
--- a/gcc/ada/s-stposu.ads
+++ b/gcc/ada/s-stposu.ads
@@ -34,7 +34,6 @@
 ------------------------------------------------------------------------------
 
 with Ada.Finalization;
-
 with System.Finalization_Masters;
 with System.Storage_Elements;
 
@@ -241,8 +240,8 @@ private
       Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
       --  A reference to the master pool_with_subpools
 
-      Master : aliased System.Finalization_Masters.Finalization_Master;
-      --  A collection of controlled objects
+      Master : aliased System.Finalization_Masters.Finalization_Master (False);
+      --  A heterogeneous collection of controlled objects
 
       Node : SP_Node_Ptr := null;
       --  A link to the doubly linked list node which contains the subpool.
@@ -336,4 +335,10 @@ private
    procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
    --  Setup the doubly linked list of subpools
 
+   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
+   --  Debug routine, output the contents of a pool_with_subpools
+
+   procedure Print_Subpool (Subpool : Subpool_Handle);
+   --  Debug routine, output the contents of a subpool
+
 end System.Storage_Pools.Subpools;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 5113904ccf9..7b2d9e74f2d 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1904,7 +1904,7 @@ package body Sem_Ch13 is
                Get_First_Interp (Expr, I, It);
                while Present (It.Nam) loop
                   if not Check_Primitive_Function (It.Nam)
-                    or else Valid_Default_Iterator (It.Nam)
+                    or else not Valid_Default_Iterator (It.Nam)
                   then
                      Remove_Interp (I);
 
@@ -5767,8 +5767,13 @@ package body Sem_Ch13 is
             A_Id = Aspect_Default_Iterator  or else
             A_Id = Aspect_Iterator_Element
       then
+         --  Make type unfrozen before analysis, to prevent spurious
+         --  errors about late attributes.
+
+         Set_Is_Frozen (Ent, False);
          Analyze (End_Decl_Expr);
          Analyze (Aspect_Rep_Item (ASN));
+         Set_Is_Frozen (Ent, True);
 
          --  If the end of declarations comes before any other freeze
          --  point, the Freeze_Expr is not analyzed: no check needed.
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 34c063d3c97..c1cd42d2950 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15003,6 +15003,12 @@ package body Sem_Ch3 is
             Set_Has_Private_Declaration (Prev);
             Set_Has_Private_Declaration (Id);
 
+            --  Preserve aspect and iterator flags, that may have been
+            --  set on the partial view.
+
+            Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
+            Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
+
             --  If no error, propagate freeze_node from private to full view.
             --  It may have been generated for an early operational item.
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 09d5b68995f..4b2b9eab260 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -30,6 +30,7 @@ with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Util; use Exp_Util;
+with Expander; use Expander;
 with Fname;    use Fname;
 with Itypes;   use Itypes;
 with Lib;      use Lib;
@@ -2235,6 +2236,10 @@ package body Sem_Ch4 is
                      Check_Implicit_Dereference (N, CT);
                   end;
                end if;
+
+            elsif Try_Container_Indexing (N, P, First (Exprs)) then
+               return;
+
             end if;
 
             Get_Next_Interp (I, It);
@@ -3340,6 +3345,7 @@ package body Sem_Ch4 is
       Iterator : Node_Id;
 
    begin
+      Expander_Mode_Save_And_Set (False);
       Check_SPARK_Restriction ("quantified expression is not allowed", N);
 
       Set_Etype  (Ent,  Standard_Void_Type);
@@ -3373,8 +3379,8 @@ package body Sem_Ch4 is
 
       Analyze (Condition (N));
       End_Scope;
-
       Set_Etype (N, Standard_Boolean);
+      Expander_Mode_Restore;
    end Analyze_Quantified_Expression;
 
    -------------------
@@ -6366,7 +6372,18 @@ package body Sem_Ch4 is
       --  diagnosed in caller.
 
       if No (Func_Name) then
-         return False;
+
+         --  The prefix itself may be an indexing of a container
+         --  rewrite as such and re-analyze.
+
+         if Has_Implicit_Dereference (Etype (Prefix)) then
+            Build_Explicit_Dereference
+              (Prefix, First_Discriminant (Etype (Prefix)));
+            return Try_Container_Indexing (N, Prefix, Expr);
+
+         else
+            return False;
+         end if;
       end if;
 
       if Is_Var
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2e4adcde4a9..ef74ed9df03 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -2005,8 +2006,23 @@ package body Sem_Ch5 is
                   Set_Parent (D_Copy, Parent (DS));
                   Pre_Analyze_Range (D_Copy);
 
+                  --  Ada2012 : if the domain of iteration is a function call,
+                  --  it is the new iterator form.
+
+                  --  We have also implemented the shorter form : for X in S
+                  --  for Alfa use. In this case the attributes Old and Result
+                  --  must be treated as entity names  over which iterators are
+                  --  legal.
+
                   if Nkind (D_Copy) = N_Function_Call
                     or else
+                      (ALFA_Mode
+                       and then (Nkind (D_Copy) = N_Attribute_Reference
+                       and then
+                         (Attribute_Name (D_Copy) = Name_Result
+                            or else Attribute_Name (D_Copy) = Name_Old)))
+
+                    or else
                       (Is_Entity_Name (D_Copy)
                         and then not Is_Type (Entity (D_Copy)))
                   then
@@ -2027,6 +2043,14 @@ package body Sem_Ch5 is
                         Set_Iterator_Specification (N, I_Spec);
                         Set_Loop_Parameter_Specification (N, Empty);
                         Analyze_Iterator_Specification (I_Spec);
+
+                        --  In a generic context, analyze the original
+                        --  domain of iteration, for name capture.
+
+                        if not Expander_Active then
+                           Analyze (DS);
+                        end if;
+
                         return;
                      end;
 
@@ -2207,7 +2231,7 @@ package body Sem_Ch5 is
       Loc       : constant Source_Ptr := Sloc (N);
       Def_Id    : constant Node_Id    := Defining_Identifier (N);
       Subt      : constant Node_Id    := Subtype_Indication (N);
-      Container : constant Node_Id    := Name (N);
+      Iter_Name : constant Node_Id    := Name (N);
 
       Ent : Entity_Id;
       Typ : Entity_Id;
@@ -2220,45 +2244,83 @@ package body Sem_Ch5 is
          Analyze (Subt);
       end if;
 
-      --  If it is an expression, the container is pre-analyzed in the caller.
+      --  If it is an expression, the name is pre-analyzed in the caller.
       --  If it it of a controlled type we need a block for the finalization
       --  actions. As for loop bounds that need finalization, we create a
       --  declaration and an assignment to trigger these actions.
 
-      if Present (Etype (Container))
-        and then Is_Controlled (Etype (Container))
-        and then not Is_Entity_Name (Container)
+      if Present (Etype (Iter_Name))
+        and then Is_Controlled (Etype (Iter_Name))
+        and then not Is_Entity_Name (Iter_Name)
       then
          declare
-            Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
+            Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
 
             Decl   : Node_Id;
-            Assign : Node_Id;
 
          begin
-            Typ := Etype (Container);
+            Typ := Etype (Iter_Name);
 
             Decl :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier => Id,
-                Object_Definition   => New_Occurrence_Of (Typ, Loc));
-
-            Assign :=
-              Make_Assignment_Statement (Loc,
-                Name        => New_Occurrence_Of (Id, Loc),
-                Expression  => Relocate_Node (Container));
-
-            Insert_Actions (Parent (N), New_List (Decl, Assign));
+                Object_Definition   => New_Occurrence_Of (Typ, Loc),
+                Expression          => Relocate_Node (Iter_Name));
+
+            Insert_Actions
+              (Parent (Parent (N)), New_List (Decl));
+            Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
+            Set_Etype (Id, Typ);
+            Set_Etype (Name (N), Typ);
          end;
 
       else
 
-         --  Container is an entity or an array with uncontrolled components
+         --  Container is an entity or an array with uncontrolled components,
+         --  or else it is a container iterator given by a function call,
+         --  typically called Iterate in the case of predefined containers,
+         --  even though Iterate is not a reserved name. What matter is that
+         --  the return type of the function is an iterator type.
+
+         Analyze (Iter_Name);
+         if Nkind (Iter_Name) = N_Function_Call then
+            declare
+               C  : constant Node_Id := Name (Iter_Name);
+               I  : Interp_Index;
+               It : Interp;
+
+            begin
+               if not Is_Overloaded (Iter_Name) then
+                  Resolve (Iter_Name, Etype (C));
+
+               else
+                  Get_First_Interp (C, I, It);
+                  while It.Typ /= Empty loop
+                     if Reverse_Present (N) then
+                        if Is_Reversible_Iterator (It.Typ) then
+                           Resolve (Iter_Name, It.Typ);
+                           exit;
+                        end if;
+
+                     elsif Is_Iterator (It.Typ) then
+                        Resolve (Iter_Name, It.Typ);
+                        exit;
+                     end if;
 
-         Analyze_And_Resolve (Container);
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end;
+
+         else
+
+            --  domain of iteration is not overloaded.
+
+            Resolve (Iter_Name, Etype (Iter_Name));
+         end if;
       end if;
 
-      Typ := Etype (Container);
+      Typ := Etype (Iter_Name);
 
       if Is_Array_Type (Typ) then
          if Of_Present (N) then
@@ -2269,33 +2331,58 @@ package body Sem_Ch5 is
             Set_Etype (Def_Id, Etype (First_Index (Typ)));
          end if;
 
+         --  Check for type error in iterator.
+
+      elsif Typ = Any_Type then
+         return;
+
       --  Iteration over a container
 
       else
          Set_Ekind (Def_Id, E_Loop_Parameter);
 
          if Of_Present (N) then
+            --  If the container has already been rewritten as a
+            --  call to the default iterator, nothing to do. This
+            --  is the case with the expansion of a quantified
+            --  expression.
 
-            --  Find the Element_Type in the package instance that defines the
-            --  container type.
+            if Nkind (Name (N)) = N_Function_Call
+              and then not Comes_From_Source (Name (N))
+            then
+               null;
 
-            Ent := First_Entity (Scope (Base_Type (Typ)));
-            while Present (Ent) loop
-               if Chars (Ent) = Name_Element_Type then
-                  Set_Etype (Def_Id, Ent);
-                  exit;
-               end if;
+            elsif Expander_Active then
 
-               Next_Entity (Ent);
-            end loop;
+               --  Find the Iterator_Element and the default_iterator
+               --   of the container type.
+
+               Set_Etype (Def_Id,
+                 Entity (
+                   Find_Aspect (Typ, Aspect_Iterator_Element)));
+
+               declare
+                  Default_Iter : constant Entity_Id :=
+                    Find_Aspect (Typ, Aspect_Default_Iterator);
+               begin
+                  Rewrite (Name (N),
+                    Make_Function_Call (Loc,
+                      Name => Default_Iter,
+                      Parameter_Associations =>
+                        New_List (Relocate_Node (Iter_Name))));
+                  Analyze_And_Resolve (Name (N));
+               end;
+            end if;
 
          else
-            --  Find the Cursor type in similar fashion
+            --  result type of Iterate function is the classwide
+            --  type of the interface parent. We need the specific
+            --  Cursor type defined in the package.
 
-            Ent := First_Entity (Scope (Base_Type (Typ)));
+            Ent := First_Entity (Scope (Typ));
             while Present (Ent) loop
                if Chars (Ent) = Name_Cursor then
-                  Set_Etype (Def_Id, Ent);
+                  Set_Etype (Def_Id, Etype (Ent));
                   exit;
                end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 877e8b8f7e2..4c196669ccf 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9749,12 +9749,13 @@ package body Sem_Ch6 is
          if AS_Needed then
             if Nkind (N) = N_Accept_Statement then
 
-               --  If expansion is active, The formal is replaced by a local
+               --  If expansion is active, the formal is replaced by a local
                --  variable that renames the corresponding entry of the
                --  parameter block, and it is this local variable that may
-               --  require an actual subtype.
+               --  require an actual subtype. In ALFA mode, expansion of accept
+               --  statements is skipped.
 
-               if Expander_Active then
+               if Expander_Active and not ALFA_Mode then
                   Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
                else
                   Decl := Build_Actual_Subtype (T, Formal);
@@ -9794,6 +9795,7 @@ package body Sem_Ch6 is
 
             if Nkind (N) = N_Accept_Statement
               and then Expander_Active
+              and then not ALFA_Mode
             then
                Set_Actual_Subtype (Renamed_Object (Formal),
                  Defining_Identifier (Decl));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index adbe0ce820a..2b40b63baf3 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12472,21 +12472,56 @@ package body Sem_Util is
 
    function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
    begin
-      case Nkind (N) is
-         when N_Package_Body =>
-            return Corresponding_Spec (N);
+      return Unique_Entity (Defining_Entity (N));
+   end Unique_Defining_Entity;
+
+   -------------------
+   -- Unique_Entity --
+   -------------------
+
+   function Unique_Entity (E : Entity_Id) return Entity_Id is
+      U : Entity_Id := E;
+      P : Node_Id;
+
+   begin
+      case Ekind (E) is
+         when Type_Kind =>
+            if Present (Full_View (E)) then
+               U := Full_View (E);
+            end if;
+
+         when E_Package_Body =>
+            P := Parent (E);
+
+            if Nkind (P) = N_Defining_Program_Unit_Name then
+               P := Parent (P);
+            end if;
+
+            U := Corresponding_Spec (P);
+
+         when E_Subprogram_Body =>
+            P := Parent (E);
 
-         when N_Subprogram_Body =>
-            if Acts_As_Spec (N) then
-               return Defining_Entity (N);
+            if Nkind (P) = N_Defining_Program_Unit_Name then
+               P := Parent (P);
+            end if;
+
+            P := Parent (P);
+
+            if Nkind (P) = N_Subprogram_Body_Stub then
+               if Present (Library_Unit (P)) then
+                  U := Get_Body_From_Stub (P);
+               end if;
             else
-               return Corresponding_Spec (N);
+               U := Corresponding_Spec (P);
             end if;
 
          when others =>
-            return Defining_Entity (N);
+            null;
       end case;
-   end Unique_Defining_Entity;
+
+      return U;
+   end Unique_Entity;
 
    -----------------
    -- Unique_Name --
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e9b4f4392c8..7acc4345757 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1421,8 +1421,16 @@ package Sem_Util is
    --  specified we check only for the given stream operation.
 
    function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
-   --  Return the entity which represents declaration N, so that matching
-   --  declaration and body have the same entity.
+   --  Return the entity which represents declaration N, so that different
+   --  views of the same entity have the same unique defining entity:
+   --  * package spec and body;
+   --  * subprogram declaration, subprogram stub and subprogram body;
+   --  * private view and full view of a type.
+   --  In other cases, return the defining entity for N.
+
+   function Unique_Entity (E : Entity_Id) return Entity_Id;
+   --  Return the unique entity for entity E, which would be returned by
+   --  Unique_Defining_Entity if applied to the enclosing declaration of E.
 
    function Unique_Name (E : Entity_Id) return String;
    --  Return a unique name for entity E, which could be used to identify E
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 0ccd8c2d01a..3c45d789390 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -2709,7 +2709,12 @@ package body Sprint is
                Write_Str (" some ");
             end if;
 
-            Sprint_Node (Loop_Parameter_Specification (Node));
+            if Present (Iterator_Specification (Node)) then
+               Sprint_Node (Iterator_Specification (Node));
+            else
+               Sprint_Node (Loop_Parameter_Specification (Node));
+            end if;
+
             Write_Str (" => ");
             Sprint_Node (Condition (Node));
 
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index fb31f38b0db..c9411e13e38 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, 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- --
@@ -263,11 +263,40 @@ package body Treepr is
    -- pn --
    --------
 
-   procedure pn (N : Node_Id) is
+   procedure pn (N : Union_Id) is
    begin
-      Print_Tree_Node (N);
+      case N is
+         when List_Low_Bound .. List_High_Bound - 1 =>
+            pl (Int (N));
+         when Node_Range =>
+            Print_Tree_Node (Node_Id (N));
+         when Elist_Range =>
+            Print_Tree_Elist (Elist_Id (N));
+         when Elmt_Range =>
+            raise Program_Error;
+         when Names_Range =>
+            Namet.wn (Name_Id (N));
+         when Strings_Range =>
+            Write_String_Table_Entry (String_Id (N));
+         when Uint_Range =>
+            Uintp.pid (From_Union (N));
+         when Ureal_Range =>
+            Urealp.pr (From_Union (N));
+         when others =>
+            Write_Str ("Invalid Union_Id: ");
+            Write_Int (Int (N));
+      end case;
    end pn;
 
+   --------
+   -- pp --
+   --------
+
+   procedure pp (N : Union_Id) is
+   begin
+      pn (N);
+   end pp;
+
    ----------------
    -- Print_Char --
    ----------------
@@ -1471,6 +1500,15 @@ package body Treepr is
       Print_Node_Subtree (N);
    end pt;
 
+   ---------
+   -- ppp --
+   ---------
+
+   procedure ppp (N : Node_Id) is
+   begin
+      pt (N);
+   end ppp;
+
    -------------------
    -- Serial_Number --
    -------------------
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index 3d05748fd78..683eb0db90b 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, 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- --
@@ -57,25 +57,36 @@ package Treepr is
    --  Prints the subtree consisting of the given element list and all its
    --  referenced descendants.
 
+   --  The following debugging procedures are intended to be called from gdb
+
+   procedure pp (N : Union_Id);
+   pragma Export (Ada, pp);
+   --  Prints a node, node list, uint, or anything else that falls under
+   --  Union_Id.
+
+   procedure ppp (N : Node_Id);
+   pragma Export (Ada, ppp);
+   --  Same as Print_Node_Subtree
+
+   --  The following are no longer needed; you can use pp or ppp instead
+
    procedure pe (E : Elist_Id);
    pragma Export (Ada, pe);
-   --  Debugging procedure (to be called within gdb), same as Print_Tree_Elist
+   --  Same as Print_Tree_Elist
 
    procedure pl (L : Int);
    pragma Export (Ada, pl);
-   --  Debugging procedure (to be called within gdb), same as Print_Tree_List,
-   --  except that you can use e.g. 66 instead of -99999966. In other words
-   --  for the positive case we fill out to 8 digits on the left and add a
-   --  minus sign. This just saves some typing in the debugger.
+   --  Same as Print_Tree_List, except that you can use e.g. 66 instead of
+   --  -99999966. In other words for the positive case we fill out to 8 digits
+   --  on the left and add a minus sign. This just saves some typing in the
+   --  debugger.
 
-   procedure pn (N : Node_Id);
+   procedure pn (N : Union_Id);
    pragma Export (Ada, pn);
-   --  Debugging procedure (to be called within gdb)
-   --  same as Print_Tree_Node with Label = ""
+   --  Same as pp
 
    procedure pt (N : Node_Id);
    pragma Export (Ada, pt);
-   --  Debugging procedure (to be called within gdb)
-   --  same as Print_Node_Subtree
+   --  Same as ppp
 
 end Treepr;