[multiple changes]

2011-08-29  Johannes Kanig  <kanig@adacore.com>

	* debug.adb: Add comments.

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: Redo previous change.

From-SVN: r178247

gcc/ada/ChangeLog

+2011-08-29  Johannes Kanig  <kanig@adacore.com>
+
+	* debug.adb: Add comments.
+
 2011-08-29  Thomas Quinot  <quinot@adacore.com>
 
 	* a-except.adb, a-except-2005.adb: Minor comment rewording and
@@ -118,11 +122,6 @@
 	* 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,

gcc/ada/debug.adb

@@ -128,7 +128,7 @@ package body Debug is
    --  d.H  Standard package only mode for gnat2why
    --  d.I  SCIL generation mode
    --  d.J  Disable parallel SCIL generation mode
-   --  d.K
+   --  d.K  Alfa detection only mode for gnat2why
    --  d.L  Depend on back end for limited types in conditional expressions
    --  d.M
    --  d.N
@@ -600,6 +600,9 @@ package body Debug is
    --       done in parallel to speed processing. This switch disables this
    --       behavior.
 
+   --  d.K  Alfa detection only mode for gnat2why. In this mode, gnat2why
+   --       will only generate the .alfa file, but no Why code.
+
    --  d.L  Normally the front end generates special expansion for conditional
    --       expressions of a limited type. This debug flag removes this special
    --       case expansion, leaving it up to the back end to handle conditional

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'(...);

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

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.
 
-            --  Skip the list header in order to offer proper object layout for
-            --  finalization and call Finalize_Address.
+         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 := Finalize_Address (Obj_Addr);
+         end if;
 
-            Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+         --  If Finalize_Address is not available, then this is most likely an
+         --  error in the expansion of the designated type or the allocator.
 
-            begin
-               Master.Finalize_Address (Obj_Addr);
+         pragma Assert (Cleanup /= null);
 
-            exception
-               when Fin_Occur : others =>
-                  if not Raised then
-                     Raised := True;
-                     Save_Occurrence (Ex_Occur, Fin_Occur);
-                  end if;
-            end;
+         begin
+            Cleanup (Obj_Addr);
+
+         exception
+            when Fin_Occur : others =>
+               if not Raised then
+                  Raised := True;
+                  Save_Occurrence (Ex_Occur, Fin_Occur);
+               end if;
+         end;
+
+         --  When the master is a heterogeneous collection, destroy the object
+         --  - Finalize_Address pair since it is no longer needed.
+
+         if not Master.Is_Homogeneous then
+            Delete_Finalize_Address (Obj_Addr);
          end if;
       end loop;
 
@@ -172,6 +222,56 @@ package body System.Finalization_Masters is
       end if;
    end Finalize;
 
+   ----------------------
+   -- Finalize_Address --
+   ----------------------
+
+   function Finalize_Address
+     (Master : Finalization_Master) return Finalize_Address_Ptr
+   is
+   begin
+      return Master.Finalize_Address;
+   end Finalize_Address;
+
+   ----------------------
+   -- Finalize_Address --
+   ----------------------
+
+   function 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 Finalize_Address;
+
+   --------------------------
+   -- Finalization_Started --
+   --------------------------
+
+   function Finalization_Started
+     (Master : Finalization_Master) return Boolean
+   is
+   begin
+      return Master.Finalization_Started;
+   end Finalization_Started;
+
+   ----------
+   -- 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_Size --
    -----------------
@@ -202,11 +302,29 @@ package body System.Finalization_Masters is
       Master.Objects.Prev := Master.Objects'Unchecked_Access;
    end Initialize;
 
-   --------
-   -- pm --
-   --------
+   --------------------
+   -- Is_Homogeneous --
+   --------------------
+
+   function Is_Homogeneous (Master : Finalization_Master) return Boolean is
+   begin
+      return Master.Is_Homogeneous;
+   end Is_Homogeneous;
 
-   procedure pm (Master : Finalization_Master) is
+   -------------
+   -- Objects --
+   -------------
+
+   function Objects (Master : Finalization_Master) return FM_Node_Ptr is
+   begin
+      return Master.Objects'Unrestricted_Access;
+   end Objects;
+
+   ------------------
+   -- Print_Master --
+   ------------------
+
+   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 +333,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 +341,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 +375,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 +441,7 @@ package body System.Finalization_Masters is
 
          N_Ptr := N_Ptr.Next;
       end loop;
-   end pm;
+   end Print_Master;
 
    -------------------
    -- Set_Base_Pool --
@@ -347,4 +467,27 @@ 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;
+
+   --------------------------
+   -- Set_Is_Heterogeneous --
+   --------------------------
+
+   procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
+   begin
+      Master.Is_Homogeneous := False;
+   end Set_Is_Heterogeneous;
+
 end System.Finalization_Masters;

gcc/ada/s-finmas.ads

@@ -30,15 +30,13 @@
 ------------------------------------------------------------------------------
 
 with Ada.Finalization;
-with Ada.Unchecked_Conversion;
-
 with System.Storage_Elements;
 with System.Storage_Pools;
 
 pragma Compiler_Unit;
 
 package System.Finalization_Masters is
-   pragma Preelaborate (System.Finalization_Masters);
+   pragma Preelaborate;
 
    --  A reference to primitive Finalize_Address. The expander generates an
    --  implementation of this procedure for each controlled and class-wide
@@ -48,17 +46,11 @@ package System.Finalization_Masters is
 
    type Finalize_Address_Ptr is access procedure (Obj : System.Address);
 
-   --  Heterogeneous collection type structure. The implementation allows for
-   --  finalizable objects of different base types to be serviced by the same
-   --  master.
+   --  Heterogeneous collection type structure
 
-   type FM_Node;
+   type FM_Node is private;
    type FM_Node_Ptr is access all FM_Node;
-
-   type FM_Node is record
-      Prev : FM_Node_Ptr := null;
-      Next : FM_Node_Ptr := null;
-   end record;
+   pragma No_Strict_Aliasing (FM_Node_Ptr);
 
    --  A reference to any derivation from Root_Storage_Pool. Since this type
    --  may not be used to allocate objects, its storage size is zero.
@@ -69,11 +61,95 @@ 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
+     new Ada.Finalization.Limited_Controlled with private;
+
+   --  A reference to a finalization master. Since this type may not be used
+   --  to allocate objects, its storage size is zero.
+
+   type Finalization_Master_Ptr is access all Finalization_Master;
+   for Finalization_Master_Ptr'Storage_Size use 0;
+
+   procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
+   --  Prepend a node to a specific finalization master
+
+   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
+
+   overriding procedure Finalize (Master : in out Finalization_Master);
+   --  Lock the master to prevent allocations during finalization. Iterate over
+   --  the list of allocated controlled objects, finalizing each one by calling
+   --  its specific Finalize_Address. In the end, deallocate the dummy head.
+
+   function Finalize_Address
+     (Master : Finalization_Master) return Finalize_Address_Ptr;
+   --  Return a reference to the TSS primitive Finalize_Address associated with
+   --  a master.
+
+   function Finalize_Address
+     (Obj : System.Address) return Finalize_Address_Ptr;
+   --  Retrieve the Finalize_Address primitive associated with a particular
+   --  object.
+
+   function Finalization_Started (Master : Finalization_Master) return Boolean;
+   --  Return the finalization status of a master
+
+   function Header_Offset return System.Storage_Elements.Storage_Offset;
+   --  Return the size of type FM_Node as Storage_Offset
+
+   function Header_Size return System.Storage_Elements.Storage_Count;
+   --  Return the size of type FM_Node as Storage_Count
+
+   function Is_Homogeneous (Master : Finalization_Master) return Boolean;
+   --  Return the behavior flag of a master
+
+   function Objects (Master : Finalization_Master) return FM_Node_Ptr;
+   --  Return the header of the doubly-linked list of controlled objects
+
+   procedure Print_Master (Master : Finalization_Master);
+   --  Debug routine, outputs the contents of a master
+
+   procedure Set_Finalize_Address
+     (Master       : in out Finalization_Master;
+      Fin_Addr_Ptr : Finalize_Address_Ptr);
+   --  Set the clean up routine of a finalization master. Note: this routine
+   --  must precede the one below since RTSfind needs to match this one.
+
+   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
+
+   procedure Set_Is_Heterogeneous (Master : in out Finalization_Master);
+   --  Mark the master as being a heterogeneous collection of objects
+
+private
+   --  Heterogeneous collection type structure
+
+   type FM_Node is record
+      Prev : FM_Node_Ptr := null;
+      Next : FM_Node_Ptr := null;
+   end record;
+
+   --  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.
 
    type Finalization_Master is
      new Ada.Finalization.Limited_Controlled with
    record
+      Is_Homogeneous : Boolean := True;
+      --  A flag which controls the behavior of the master. A value of False
+      --  denotes a heterogeneous collection.
+
       Base_Pool : Any_Storage_Pool_Ptr := null;
       --  A reference to the pool which this finalization master services. This
       --  field is used in conjunction with the build-in-place machinery.
@@ -83,7 +159,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);
@@ -93,9 +170,6 @@ package System.Finalization_Masters is
       --  is accessed without Lock_Task / Unlock_Task.
    end record;
 
-   type Finalization_Master_Ptr is access all Finalization_Master;
-   for Finalization_Master_Ptr'Storage_Size use 0;
-
    --  Since RTSfind cannot contain names of the form RE_"+", the following
    --  routine serves as a wrapper around System.Storage_Elements."+".
 
@@ -103,45 +177,17 @@ package System.Finalization_Masters is
      (Addr   : System.Address;
       Offset : System.Storage_Elements.Storage_Offset) return System.Address;
 
-   function Address_To_FM_Node_Ptr is
-     new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
-
-   procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
-   --  Prepend a node to a specific finalization master
-
    function Base_Pool
      (Master : Finalization_Master) return Any_Storage_Pool_Ptr;
    --  Return a reference to the underlying storage pool on which the master
    --  operates.
 
-   procedure Detach (N : not null FM_Node_Ptr);
-   --  Remove a node from an arbitrary finalization master
-
-   overriding procedure Finalize (Master : in out Finalization_Master);
-   --  Lock the master to prevent allocations during finalization. Iterate over
-   --  the list of allocated controlled objects, finalizing each one by calling
-   --  its specific Finalize_Address. In the end, deallocate the dummy head.
-
-   function Header_Offset return System.Storage_Elements.Storage_Offset;
-   --  Return the size of type FM_Node as Storage_Offset
-
-   function Header_Size return System.Storage_Elements.Storage_Count;
-   --  Return the size of type FM_Node as Storage_Count
-
    overriding procedure Initialize (Master : in out Finalization_Master);
    --  Initialize the dummy head of a finalization master
 
-   procedure pm (Master : Finalization_Master);
-   --  Debug routine, outputs the contents of a master
-
    procedure Set_Base_Pool
      (Master   : in out Finalization_Master;
       Pool_Ptr : Any_Storage_Pool_Ptr);
    --  Set the underlying pool of a finalization master
 
-   procedure Set_Finalize_Address
-     (Master       : in out Finalization_Master;
-      Fin_Addr_Ptr : Finalize_Address_Ptr);
-   --  Set the clean up routine of a finalization master
-
 end System.Finalization_Masters;

gcc/ada/s-stposu.adb

@@ -30,14 +30,24 @@
 ------------------------------------------------------------------------------
 
 with Ada.Exceptions;              use Ada.Exceptions;
+with Ada.Unchecked_Conversion;
 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.
+
+   function Address_To_FM_Node_Ptr is
+     new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
+
    procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
    --  Attach a subpool node to a pool
 
@@ -169,7 +179,7 @@ package body System.Storage_Pools.Subpools is
          Master := Context_Master;
       end if;
 
-      --  Step 2: Master and Finalize_Address-related runtime checks and size
+      --  Step 2: Master, Finalize_Address-related runtime checks and size
       --  calculations.
 
       --  Allocation of a descendant from [Limited_]Controlled, a class-wide
@@ -180,7 +190,7 @@ package body System.Storage_Pools.Subpools is
          --  Do not allow the allocation of controlled objects while the
          --  associated master is being finalized.
 
-         if Master.Finalization_Started then
+         if Finalization_Started (Master.all) then
             raise Program_Error with "allocation after finalization started";
          end if;
 
@@ -248,21 +258,40 @@ 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;
+         Attach (N_Ptr, Objects (Master.all));
 
          --  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 Finalize_Address (Master.all) = null then
+               Set_Finalize_Address (Master.all, Fin_Address);
+            end if;
+         end if;
+
+      --  Non-controlled allocation
+
       else
          Addr := N_Addr;
       end if;
@@ -315,6 +344,13 @@ 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.
 
@@ -382,6 +418,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 +443,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 +474,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 +494,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 +583,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 --
    -------------------------
@@ -574,6 +764,11 @@ package body System.Storage_Pools.Subpools is
       Subpool.Node := N_Ptr;
 
       Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
+
+      --  Mark the subpool's master as being a heterogeneous collection of
+      --  controlled objects.
+
+      Set_Is_Heterogeneous (Subpool.Master);
    end Set_Pool_Of_Subpool;
 
 end System.Storage_Pools.Subpools;

gcc/ada/s-stposu.ads

@@ -34,12 +34,11 @@
 ------------------------------------------------------------------------------
 
 with Ada.Finalization;
-
 with System.Finalization_Masters;
 with System.Storage_Elements;
 
 package System.Storage_Pools.Subpools is
-   pragma Preelaborate (System.Storage_Pools.Subpools);
+   pragma Preelaborate;
 
    type Root_Storage_Pool_With_Subpools is abstract
      new Root_Storage_Pool with private;
@@ -242,7 +241,7 @@ private
       --  A reference to the master pool_with_subpools
 
       Master : aliased System.Finalization_Masters.Finalization_Master;
-      --  A collection of controlled objects
+      --  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;