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

1 files changed, 14 insertions, 200 deletions

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 --
    -------------------------