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

	* exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a
	container of a derived type.

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

	* impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb,
	s-finmas.ads: Revert previous change.

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

	* a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads,
	a-ciorse.adb, a-ciorse.ads: Add iterator machinery to containers.



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

14 files changed, 636 insertions, 386 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 82b72fec4b1..1c72508894a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2011-08-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a
+	container of a derived type.
+
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb,
+	s-finmas.ads: Revert previous change.
+
+2011-08-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads,
+	a-ciorse.adb, a-ciorse.ads: Add iterator machinery to containers.
+
 2011-08-29  Pascal Obry  <obry@adacore.com>
 
 	* exp_disp.adb: Minor comment fix.
diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb
index 8d1f8e36439..780efad4f41 100644
--- a/gcc/ada/a-cidlli.adb
+++ b/gcc/ada/a-cidlli.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-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- --
@@ -35,6 +35,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
    procedure Free is
      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 
+   type Iterator is new
+     List_Iterator_Interfaces.Reversible_Iterator with record
+        Container : List_Access;
+        Node      : Node_Access;
+   end record;
+
+   overriding function First    (Object : Iterator) return Cursor;
+   overriding function Last     (Object : Iterator) return Cursor;
+   overriding function Next     (Object : Iterator; Position : Cursor)
+     return Cursor;
+   overriding function Previous (Object : Iterator; Position : Cursor)
+     return Cursor;
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -431,6 +444,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       return Cursor'(Container'Unchecked_Access, Container.First);
    end First;
 
+   function First (Object : Iterator) return Cursor is
+   begin
+      return Cursor'(Object.Container, Object.Container.First);
+   end First;
+
    -------------------
    -- First_Element --
    -------------------
@@ -820,6 +838,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       B := B - 1;
    end Iterate;
 
+   function Iterate (Container : List)
+     return List_Iterator_Interfaces.Reversible_Iterator'class
+   is
+      It : constant Iterator := (Container'Unchecked_Access, Container.First);
+   begin
+      return It;
+   end Iterate;
+
+   function Iterate (Container : List; Start : Cursor)
+     return List_Iterator_Interfaces.Reversible_Iterator'class
+   is
+      It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+   begin
+      return It;
+   end Iterate;
+
    ----------
    -- Last --
    ----------
@@ -833,6 +867,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       return Cursor'(Container'Unchecked_Access, Container.Last);
    end Last;
 
+   function Last (Object : Iterator) return Cursor is
+   begin
+      if Object.Container.Last = null then
+         return No_Element;
+      end if;
+
+      return Cursor'(Object.Container, Object.Container.Last);
+   end Last;
+
    ------------------
    -- Last_Element --
    ------------------
@@ -910,6 +953,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       end;
    end Next;
 
+   function Next (Object : Iterator; Position : Cursor) return Cursor is
+   begin
+      if Position.Node = Object.Container.Last then
+         return No_Element;
+
+      else
+         return (Object.Container, Position.Node.Next);
+      end if;
+   end Next;
+
    -------------
    -- Prepend --
    -------------
@@ -951,6 +1004,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       end;
    end Previous;
 
+   function Previous (Object : Iterator; Position : Cursor) return Cursor is
+   begin
+      if Position.Node = Position.Container.First then
+         return No_Element;
+
+      else
+         return (Object.Container, Position.Node.Prev);
+      end if;
+   end Previous;
+
    -------------------
    -- Query_Element --
    -------------------
@@ -1056,6 +1119,50 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       raise Program_Error with "attempt to stream list cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   ---------------
+   -- Reference --
+   ---------------
+
+   function Constant_Reference (Container : List; Position : Cursor)
+   return Constant_Reference_Type is
+   begin
+      pragma Unreferenced (Container);
+
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element => Position.Node.Element.all'Access);
+   end Constant_Reference;
+
+   function Reference (Container : List; Position : Cursor)
+   return Reference_Type is
+   begin
+      pragma Unreferenced (Container);
+
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element => Position.Node.Element.all'Access);
+   end Reference;
+
    ---------------------
    -- Replace_Element --
    ---------------------
@@ -1907,4 +2014,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       raise Program_Error with "attempt to stream list cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
 end Ada.Containers.Indefinite_Doubly_Linked_Lists;
diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads
index 7d572a8cc93..a6fd7106321 100644
--- a/gcc/ada/a-cidlli.ads
+++ b/gcc/ada/a-cidlli.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -31,8 +31,9 @@
 -- This unit was originally developed by Matthew J Heaney.                  --
 ------------------------------------------------------------------------------
 
+with Ada.Iterator_Interfaces;
+with Ada.Streams; use Ada.Streams;
 private with Ada.Finalization;
-private with Ada.Streams;
 
 generic
    type Element_Type (<>) is private;
@@ -44,7 +45,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
    pragma Preelaborate;
    pragma Remote_Types;
 
-   type List is tagged private;
+   type List is tagged private
+   with
+      Constant_Indexing => Constant_Reference,
+      Variable_Indexing => Reference,
+      Default_Iterator  => Iterate,
+      Iterator_Element  => Element_Type;
+
    pragma Preelaborable_Initialization (List);
 
    type Cursor is private;
@@ -53,6 +60,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
    Empty_List : constant List;
 
    No_Element : constant Cursor;
+   function Has_Element (Position : Cursor) return Boolean;
+
+   package List_Iterator_Interfaces is new
+     Ada.Iterator_Interfaces (Cursor, Has_Element);
 
    function "=" (Left, Right : List) return Boolean;
 
@@ -170,8 +181,6 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
      (Container : List;
       Item      : Element_Type) return Boolean;
 
-   function Has_Element (Position : Cursor) return Boolean;
-
    procedure Iterate
      (Container : List;
       Process   : not null access procedure (Position : Cursor));
@@ -180,6 +189,54 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
      (Container : List;
       Process   : not null access procedure (Position : Cursor));
 
+   function Iterate (Container : List)
+      return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+   function Iterate (Container : List; Start : Cursor)
+      return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   type Reference_Type (Element : not null access Element_Type) is
+   private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type);
+
+   for Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type);
+
+   for Reference_Type'Read use Read;
+
+   function Constant_Reference
+     (Container : List; Position : Cursor)    --  SHOULD BE ALIASED
+   return Constant_Reference_Type;
+
+   function Reference
+     (Container : List; Position : Cursor)    --  SHOULD BE ALIASED
+   return Reference_Type;
+
    generic
       with function "<" (Left, Right : Element_Type) return Boolean is <>;
    package Generic_Sorting is
@@ -220,12 +277,16 @@ private
         Lock   : Natural := 0;
      end record;
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is null record;
+
+   type Reference_Type
+      (Element : not null access Element_Type) is null record;
+
    overriding procedure Adjust (Container : in out List);
 
    overriding procedure Finalize (Container : in out List) renames Clear;
 
-   use Ada.Streams;
-
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
       Item   : out List);
diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb
index b487394b366..783fdf421b1 100644
--- a/gcc/ada/a-cihama.adb
+++ b/gcc/ada/a-cihama.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-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- --
@@ -43,6 +43,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
    procedure Free_Element is
       new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 
+   type Iterator is new
+     Map_Iterator_Interfaces.Forward_Iterator with record
+      Container : Map_Access;
+      Node      : Node_Access;
+   end record;
+
+   overriding function First (Object : Iterator) return Cursor;
+   overriding function Next  (Object : Iterator; Position : Cursor)
+     return Cursor;
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -398,6 +408,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       return Cursor'(Container'Unchecked_Access, Node);
    end First;
 
+   function First (Object : Iterator) return Cursor is
+      M : constant Map_Access  := Object.Container;
+      N : constant Node_Access := HT_Ops.First (M.HT);
+   begin
+      if N = null then
+         return No_Element;
+      end if;
+
+      return Cursor'(Object.Container.all'Unchecked_Access, N);
+   end First;
+
    ----------
    -- Free --
    ----------
@@ -626,6 +647,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       B := B - 1;
    end Iterate;
 
+   function Iterate (Container : Map)
+      return Map_Iterator_Interfaces.Forward_Iterator'class
+   is
+      Node : constant Node_Access := HT_Ops.First (Container.HT);
+      It   : constant Iterator := (Container'Unrestricted_Access, Node);
+   begin
+      return It;
+   end Iterate;
+
    ---------
    -- Key --
    ---------
@@ -709,6 +739,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       end;
    end Next;
 
+   function Next (Object : Iterator; Position : Cursor) return Cursor is
+   begin
+      if Position.Node = null then
+         return No_Element;
+
+      else
+         return (Object.Container, Next (Position).Node);
+      end if;
+   end Next;
+
    -------------------
    -- Query_Element --
    -------------------
@@ -784,6 +824,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       raise Program_Error with "attempt to stream map cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
    ---------------
    -- Read_Node --
    ---------------
@@ -814,6 +870,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       return Node;
    end Read_Node;
 
+   ---------------
+   -- Reference --
+   ---------------
+
+   function Constant_Reference (Container : Map; Key : Key_Type)
+   return Constant_Reference_Type is
+   begin
+      return (Element =>
+        Container.Find (Key).Node.Element.all'Unrestricted_Access);
+   end Constant_Reference;
+
+   function Reference (Container : Map; Key : Key_Type)
+   return Reference_Type is
+   begin
+      return (Element =>
+         Container.Find (Key).Node.Element.all'Unrestricted_Access);
+   end Reference;
+
    -------------
    -- Replace --
    -------------
@@ -1064,6 +1138,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
       raise Program_Error with "attempt to stream map cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
    ----------------
    -- Write_Node --
    ----------------
diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads
index 8a27c7e2619..2e089677112 100644
--- a/gcc/ada/a-cihama.ads
+++ b/gcc/ada/a-cihama.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -32,8 +32,9 @@
 ------------------------------------------------------------------------------
 
 private with Ada.Containers.Hash_Tables;
-private with Ada.Streams;
 private with Ada.Finalization;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
 
 generic
    type Key_Type (<>) is private;
@@ -47,7 +48,13 @@ package Ada.Containers.Indefinite_Hashed_Maps is
    pragma Preelaborate;
    pragma Remote_Types;
 
-   type Map is tagged private;
+   type Map is tagged private
+   with
+      Constant_Indexing => Constant_Reference,
+      Variable_Indexing => Reference,
+      Default_Iterator  => Iterate,
+      Iterator_Element  => Element_Type;
+
    pragma Preelaborable_Initialization (Map);
 
    type Cursor is private;
@@ -61,6 +68,12 @@ package Ada.Containers.Indefinite_Hashed_Maps is
    --  Cursor objects declared without an initialization expression are
    --  initialized to the value No_Element.
 
+   function Has_Element (Position : Cursor) return Boolean;
+   --  Equivalent to Position /= No_Element
+
+   package Map_Iterator_Interfaces is new
+     Ada.Iterator_Interfaces (Cursor, Has_Element);
+
    overriding function "=" (Left, Right : Map) return Boolean;
    --  For each key/element pair in Left, equality attempts to find the key in
    --  Right; if a search fails the equality returns False. The search works by
@@ -227,9 +240,6 @@ package Ada.Containers.Indefinite_Hashed_Maps is
    function Element (Container : Map; Key : Key_Type) return Element_Type;
    --  Equivalent to Element (Find (Container, Key))
 
-   function Has_Element (Position : Cursor) return Boolean;
-   --  Equivalent to Position /= No_Element
-
    function Equivalent_Keys (Left, Right : Cursor) return Boolean;
    --  Returns the result of calling Equivalent_Keys with the keys of the nodes
    --  designated by cursors Left and Right.
@@ -242,11 +252,54 @@ package Ada.Containers.Indefinite_Hashed_Maps is
    --  Returns the result of calling Equivalent_Keys with key Left and the node
    --  designated by Right.
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   type Reference_Type (Element : not null access Element_Type) is private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type);
+
+   for Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type);
+
+   for Reference_Type'Read use Read;
+
+   function Constant_Reference
+     (Container : Map; Key : Key_Type)    --  SHOULD BE ALIASED
+   return Constant_Reference_Type;
+
+   function Reference (Container : Map; Key : Key_Type)
+   return Reference_Type;
+
    procedure Iterate
      (Container : Map;
       Process   : not null access procedure (Position : Cursor));
    --  Calls Process for each node in the map
 
+   function Iterate (Container : Map)
+      return Map_Iterator_Interfaces.Forward_Iterator'class;
+
 private
    pragma Inline ("=");
    pragma Inline (Length);
@@ -283,7 +336,6 @@ private
 
    use HT_Types;
    use Ada.Finalization;
-   use Ada.Streams;
 
    overriding procedure Adjust (Container : in out Map);
 
@@ -303,6 +355,12 @@ private
 
    for Cursor'Write use Write;
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is null record;
+
+   type Reference_Type
+      (Element : not null access Element_Type) is null record;
+
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
       Item   : out Cursor);
diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb
index 7153c6dd235..7a782189708 100644
--- a/gcc/ada/a-ciorse.adb
+++ b/gcc/ada/a-ciorse.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-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- --
@@ -40,6 +40,19 @@ with Ada.Unchecked_Deallocation;
 
 package body Ada.Containers.Indefinite_Ordered_Sets is
 
+   type Iterator is new
+     Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record
+      Container : access constant Set;
+      Node      : Node_Access;
+   end record;
+
+   overriding function First (Object : Iterator) return Cursor;
+   overriding function Last  (Object : Iterator) return Cursor;
+   overriding function Next  (Object : Iterator; Position : Cursor)
+     return Cursor;
+   overriding function Previous (Object : Iterator; Position : Cursor)
+     return Cursor;
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -566,6 +579,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
    end First;
 
+   function First (Object : Iterator) return Cursor is
+   begin
+      return Cursor'(
+       Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
+   end First;
+
    -------------------
    -- First_Element --
    -------------------
@@ -1190,6 +1209,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       B := B - 1;
    end Iterate;
 
+   function Iterate (Container : Set)
+     return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+   is
+      It : constant Iterator :=
+             (Container'Unchecked_Access, Container.Tree.First);
+   begin
+      return It;
+   end Iterate;
+
+   function Iterate (Container : Set; Start : Cursor)
+     return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+   is
+      It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+   begin
+      return It;
+   end Iterate;
+
    ----------
    -- Last --
    ----------
@@ -1203,6 +1239,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
    end Last;
 
+   function Last (Object : Iterator) return Cursor is
+   begin
+      if Object.Container.Tree.Last = null then
+         return No_Element;
+      end if;
+
+      return Cursor'(
+        Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last);
+   end Last;
+
    ------------------
    -- Last_Element --
    ------------------
@@ -1281,6 +1327,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       end;
    end Next;
 
+   function Next  (Object : Iterator; Position : Cursor)
+   return Cursor
+   is
+      pragma Unreferenced (Object);
+   begin
+      return Next (Position);
+   end Next;
+
    -------------
    -- Overlap --
    -------------
@@ -1334,6 +1388,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       end;
    end Previous;
 
+   function Previous (Object : Iterator; Position : Cursor)
+   return Cursor
+   is
+      pragma Unreferenced (Object);
+   begin
+      return Previous (Position);
+   end Previous;
+
    -------------------
    -- Query_Element --
    -------------------
@@ -1426,6 +1488,50 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       raise Program_Error with "attempt to stream set cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   ---------------
+   -- Reference --
+   ---------------
+
+   function Constant_Reference (Container : Set; Position : Cursor)
+   return Constant_Reference_Type
+   is
+      pragma Unreferenced (Container);
+   begin
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element => Position.Node.Element.all'Access);
+   end Constant_Reference;
+
+   function Reference (Container : Set; Position : Cursor)
+   return Reference_Type
+   is
+      pragma Unreferenced (Container);
+   begin
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element => Position.Node.Element.all'Access);
+   end Reference;
+
    -------------
    -- Replace --
    -------------
@@ -1758,4 +1864,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       raise Program_Error with "attempt to stream set cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
 end Ada.Containers.Indefinite_Ordered_Sets;
diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads
index 9d60bdcac89..3700c15e6b3 100644
--- a/gcc/ada/a-ciorse.ads
+++ b/gcc/ada/a-ciorse.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -33,7 +33,8 @@
 
 private with Ada.Containers.Red_Black_Trees;
 private with Ada.Finalization;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
 
 generic
    type Element_Type (<>) is private;
@@ -47,7 +48,13 @@ package Ada.Containers.Indefinite_Ordered_Sets is
 
    function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
 
-   type Set is tagged private;
+   type Set is tagged private
+   with
+     Constant_Indexing => Constant_Reference,
+     Variable_Indexing => Reference,
+     Default_Iterator  => Iterate,
+     Iterator_Element  => Element_Type;
+
    pragma Preelaborable_Initialization (Set);
 
    type Cursor is private;
@@ -56,6 +63,52 @@ package Ada.Containers.Indefinite_Ordered_Sets is
    Empty_Set : constant Set;
 
    No_Element : constant Cursor;
+   function Has_Element (Position : Cursor) return Boolean;
+
+   package Ordered_Set_Iterator_Interfaces is new
+     Ada.Iterator_Interfaces (Cursor, Has_Element);
+
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is
+   private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
+   function Constant_Reference
+     (Container : Set; Position : Cursor)
+   return Constant_Reference_Type;
+
+   type Reference_Type (Element : not null access Element_Type) is private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type);
+
+   for Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type);
+
+   for Reference_Type'Read use Read;
+
+   function Reference
+     (Container : Set; Position : Cursor)
+   return Reference_Type;
 
    function "=" (Left, Right : Set) return Boolean;
 
@@ -168,8 +221,6 @@ package Ada.Containers.Indefinite_Ordered_Sets is
 
    function Contains (Container : Set; Item : Element_Type) return Boolean;
 
-   function Has_Element (Position : Cursor) return Boolean;
-
    function "<" (Left, Right : Cursor) return Boolean;
 
    function ">" (Left, Right : Cursor) return Boolean;
@@ -190,6 +241,12 @@ package Ada.Containers.Indefinite_Ordered_Sets is
      (Container : Set;
       Process   : not null access procedure (Position : Cursor));
 
+   function Iterate (Container : Set)
+      return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
+   function Iterate (Container : Set; Start : Cursor)
+      return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
    generic
       type Key_Type (<>) is private;
 
@@ -271,7 +328,6 @@ private
    use Red_Black_Trees;
    use Tree_Types;
    use Ada.Finalization;
-   use Ada.Streams;
 
    type Set_Access is access all Set;
    for Set_Access'Storage_Size use 0;
@@ -307,6 +363,12 @@ private
 
    for Set'Read use Read;
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is null record;
+
+   type Reference_Type
+      (Element : not null access Element_Type) is null record;
+
    Empty_Set : constant Set :=
                  (Controlled with Tree => (First  => null,
                                            Last   => null,
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 4824df02583..8ac78ac1f5e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1137,8 +1137,6 @@ 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 29399d790f8..4da232e5f9d 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2952,9 +2952,12 @@ package body Exp_Ch5 is
 
             if Of_Present (I_Spec) then
                declare
-                  Default_Iter : constant Entity_Id :=
-                    Find_Aspect (Etype (Container), Aspect_Default_Iterator);
-                  Ent : Entity_Id;
+                  Default_Iter  : constant Entity_Id :=
+                    Entity (
+                      Find_Aspect
+                         (Etype (Container), Aspect_Default_Iterator));
+                  Container_Arg : Node_Id;
+                  Ent           : Entity_Id;
 
                begin
                   Cursor := Make_Temporary (Loc, 'I');
@@ -2963,23 +2966,39 @@ package body Exp_Ch5 is
                      null;
 
                   else
-                     Iter_Type :=
-                        Etype
-                         (Find_Aspect
-                              (Etype (Container), Aspect_Default_Iterator));
+                     Iter_Type := Etype (Default_Iter);
 
                      --  Rewrite domain of iteration as a call to the default
-                     --  iterator for the container type.
+                     --  iterator for the container type. If the container is
+                     --  a derived type and the aspect is inherited, convert
+                     --  container to parent type. The Cursor type is also
+                     --  inherited from the scope of the parent.
+
+                     if Base_Type (Etype (Container)) =
+                       Base_Type (Etype (First_Formal (Default_Iter)))
+                     then
+                        Container_Arg := New_Copy_Tree (Container);
+
+                     else
+                        Pack := Scope (Default_Iter);
+
+                        Container_Arg :=
+                          Make_Type_Conversion (Loc,
+                            Subtype_Mark =>
+                              New_Occurrence_Of (
+                                Etype (First_Formal (Default_Iter)), Loc),
+                            Expression => New_Copy_Tree (Container));
+                     end if;
 
                      Rewrite (Name (I_Spec),
                        Make_Function_Call (Loc,
-                         Name => Default_Iter,
+                         Name => New_Occurrence_Of (Default_Iter, Loc),
                          Parameter_Associations =>
-                           New_List (Relocate_Node (Name (I_Spec)))));
+                           New_List (Container_Arg)));
                      Analyze_And_Resolve (Name (I_Spec));
                   end if;
 
-                  --  Find cursor type in container package.
+                  --  Find cursor type in proper container package.
 
                   Ent := First_Entity (Pack);
                   while Present (Ent) loop
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 9aa86d523f6..ea636fe8b0a 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -346,6 +346,7 @@ 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
@@ -528,6 +529,7 @@ 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/s-finmas.adb b/gcc/ada/s-finmas.adb
index 4ab8a301b67..857db696b00 100644
--- a/gcc/ada/s-finmas.adb
+++ b/gcc/ada/s-finmas.adb
@@ -31,32 +31,12 @@
 
 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 --
    ---------------------------
@@ -99,17 +79,6 @@ 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 --
    ------------
@@ -125,10 +94,10 @@ package body System.Finalization_Masters is
          N.Next := null;
 
          Unlock_Task.all;
-
-         --  Note: No need to unlock in case of an exception because the above
-         --  code can never raise one.
       end if;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
    end Detach;
 
    --------------
@@ -136,7 +105,6 @@ 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;
@@ -176,41 +144,23 @@ package body System.Finalization_Masters is
 
          Detach (Curr_Ptr);
 
-         --  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);
+         if Master.Finalize_Address /= null then
 
-         begin
-            Cleanup (Obj_Addr);
+            --  Skip the list header in order to offer proper object layout for
+            --  finalization and call Finalize_Address.
 
-         exception
-            when Fin_Occur : others =>
-               if not Raised then
-                  Raised := True;
-                  Save_Occurrence (Ex_Occur, Fin_Occur);
-               end if;
-         end;
+            Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
 
-         --  When the master is a heterogeneous collection, destroy the object
-         --  - Finalize_Address pair since it is no longer needed.
+            begin
+               Master.Finalize_Address (Obj_Addr);
 
-         if not Master.Is_Homogeneous then
-            Delete_Finalize_Address (Obj_Addr);
+            exception
+               when Fin_Occur : others =>
+                  if not Raised then
+                     Raised := True;
+                     Save_Occurrence (Ex_Occur, Fin_Occur);
+                  end if;
+            end;
          end if;
       end loop;
 
@@ -222,23 +172,6 @@ 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 --
    -----------------
@@ -248,17 +181,6 @@ 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 --
    -------------------
@@ -280,11 +202,11 @@ package body System.Finalization_Masters is
       Master.Objects.Prev := Master.Objects'Unchecked_Access;
    end Initialize;
 
-   ------------------
-   -- Print_Master --
-   ------------------
+   --------
+   -- pm --
+   --------
 
-   procedure Print_Master (Master : Finalization_Master) is
+   procedure pm (Master : Finalization_Master) is
       Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
       Head_Seen : Boolean := False;
       N_Ptr     : FM_Node_Ptr;
@@ -293,7 +215,6 @@ 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
@@ -301,17 +222,16 @@ package body System.Finalization_Masters is
       Put ("Master   : ");
       Put_Line (Address_Image (Master'Address));
 
-      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
@@ -335,17 +255,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
+      while N_Ptr /= null loop -- Should never be null; we being defensive
          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;
@@ -401,7 +321,7 @@ package body System.Finalization_Masters is
 
          N_Ptr := N_Ptr.Next;
       end loop;
-   end Print_Master;
+   end pm;
 
    -------------------
    -- Set_Base_Pool --
@@ -427,18 +347,4 @@ 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 6dd5e38fba7..87a607678bc 100644
--- a/gcc/ada/s-finmas.ads
+++ b/gcc/ada/s-finmas.ads
@@ -31,6 +31,7 @@
 
 with Ada.Finalization;
 with Ada.Unchecked_Conversion;
+
 with System.Storage_Elements;
 with System.Storage_Pools;
 
@@ -68,10 +69,9 @@ 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. By default, a master contains objects of the
-   --  same designated type but it may also accomodate heterogeneous objects.
+   --  as components of subpools.
 
-   type Finalization_Master (Is_Homogeneous : Boolean := True) is
+   type Finalization_Master is
      new Ada.Finalization.Limited_Controlled with
    record
       Base_Pool : Any_Storage_Pool_Ptr := null;
@@ -83,8 +83,7 @@ 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. This
-      --  is used only when the master is in homogeneous mode.
+      --  A reference to the routine reponsible for object finalization
 
       Finalization_Started : Boolean := False;
       pragma Atomic (Finalization_Started);
@@ -115,10 +114,6 @@ 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
 
@@ -127,11 +122,6 @@ 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
 
@@ -141,7 +131,7 @@ package System.Finalization_Masters is
    overriding procedure Initialize (Master : in out Finalization_Master);
    --  Initialize the dummy head of a finalization master
 
-   procedure Print_Master (Master : Finalization_Master);
+   procedure pm (Master : Finalization_Master);
    --  Debug routine, outputs the contents of a master
 
    procedure Set_Base_Pool
@@ -154,9 +144,4 @@ 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 9a6c2310996..bf3a87e662f 100644
--- a/gcc/ada/s-stposu.adb
+++ b/gcc/ada/s-stposu.adb
@@ -31,19 +31,13 @@
 
 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;
 
 package body System.Storage_Pools.Subpools is
 
-   Finalize_Address_Table_In_Use : Boolean := False;
-   --  This flag should be set only when a successfull allocation on a subpool
-   --  has been performed and the associated Finalize_Address has been added to
-   --  the hash table in System.Finalization_Masters.
-
    procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
    --  Attach a subpool node to a pool
 
@@ -254,40 +248,21 @@ 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);
-            Finalize_Address_Table_In_Use := True;
-
-         --  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;
@@ -340,13 +315,6 @@ 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 Finalize_Address_Table_In_Use then
-            Delete_Finalize_Address (Addr);
-         end if;
-
          --  Account for possible padding space before the header due to a
          --  larger alignment.
 
@@ -414,8 +382,6 @@ 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;
 
@@ -439,22 +405,9 @@ 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.
@@ -470,8 +423,11 @@ package body System.Storage_Pools.Subpools is
 
       Pool.Finalization_Started := True;
 
-      while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
-         Curr_Ptr := Pool.Subpools.Next;
+      --  Skip the dummy head
+
+      Curr_Ptr := Pool.Subpools.Next;
+      while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
+         Next_Ptr := Curr_Ptr.Next;
 
          --  Perform the following actions:
 
@@ -490,6 +446,8 @@ 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
@@ -579,150 +537,6 @@ 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 79ff97cfdce..bd268186926 100644
--- a/gcc/ada/s-stposu.ads
+++ b/gcc/ada/s-stposu.ads
@@ -34,6 +34,7 @@
 ------------------------------------------------------------------------------
 
 with Ada.Finalization;
+
 with System.Finalization_Masters;
 with System.Storage_Elements;
 
@@ -240,8 +241,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 (False);
-      --  A heterogeneous collection of controlled objects
+      Master : aliased System.Finalization_Masters.Finalization_Master;
+      --  A collection of controlled objects
 
       Node : SP_Node_Ptr := null;
       --  A link to the doubly linked list node which contains the subpool.
@@ -335,10 +336,4 @@ 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;