[multiple changes]

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

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

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

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

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

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

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

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

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

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

From-SVN: r178235

1 files changed, 122 insertions, 28 deletions

diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb
index 857db69..4ab8a30 100644
--- a/gcc/ada/s-finmas.adb
+++ b/gcc/ada/s-finmas.adb
@@ -31,12 +31,32 @@
 
 with Ada.Exceptions;          use Ada.Exceptions;
 with System.Address_Image;
+with System.HTable;           use System.HTable;
 with System.IO;               use System.IO;
 with System.Soft_Links;       use System.Soft_Links;
 with System.Storage_Elements; use System.Storage_Elements;
 
 package body System.Finalization_Masters is
 
+   --  Finalize_Address hash table types. In general, masters are homogeneous
+   --  collections of controlled objects. Rare cases such as allocations on a
+   --  subpool require heterogeneous masters. The following table provides a
+   --  relation between object address and its Finalize_Address routine.
+
+   type Header_Num is range 0 .. 127;
+
+   function Hash (Key : System.Address) return Header_Num;
+
+   --  Address --> Finalize_Address_Ptr
+
+   package Finalize_Address_Table is new Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Finalize_Address_Ptr,
+      No_Element => null,
+      Key        => System.Address,
+      Hash       => Hash,
+      Equal      => "=");
+
    ---------------------------
    -- Add_Offset_To_Address --
    ---------------------------
@@ -79,6 +99,17 @@ package body System.Finalization_Masters is
       return Master.Base_Pool;
    end Base_Pool;
 
+   -----------------------------
+   -- Delete_Finalize_Address --
+   -----------------------------
+
+   procedure Delete_Finalize_Address (Obj : System.Address) is
+   begin
+      Lock_Task.all;
+      Finalize_Address_Table.Remove (Obj);
+      Unlock_Task.all;
+   end Delete_Finalize_Address;
+
    ------------
    -- Detach --
    ------------
@@ -94,10 +125,10 @@ package body System.Finalization_Masters is
          N.Next := null;
 
          Unlock_Task.all;
-      end if;
 
-      --  Note: No need to unlock in case of an exception because the above
-      --  code can never raise one.
+         --  Note: No need to unlock in case of an exception because the above
+         --  code can never raise one.
+      end if;
    end Detach;
 
    --------------
@@ -105,6 +136,7 @@ package body System.Finalization_Masters is
    --------------
 
    overriding procedure Finalize (Master : in out Finalization_Master) is
+      Cleanup  : Finalize_Address_Ptr;
       Curr_Ptr : FM_Node_Ptr;
       Ex_Occur : Exception_Occurrence;
       Obj_Addr : Address;
@@ -144,23 +176,41 @@ package body System.Finalization_Masters is
 
          Detach (Curr_Ptr);
 
-         if Master.Finalize_Address /= null then
+         --  Skip the list header in order to offer proper object layout for
+         --  finalization.
+
+         Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+
+         --  Retrieve TSS primitive Finalize_Address depending on the master's
+         --  mode of operation.
+
+         if Master.Is_Homogeneous then
+            Cleanup := Master.Finalize_Address;
+         else
+            Cleanup := Get_Finalize_Address (Obj_Addr);
+         end if;
+
+         --  If Finalize_Address is not available, then this is most likely an
+         --  error in the expansion of the designated type or the allocator.
+
+         pragma Assert (Cleanup /= null);
 
-            --  Skip the list header in order to offer proper object layout for
-            --  finalization and call Finalize_Address.
+         begin
+            Cleanup (Obj_Addr);
 
-            Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+         exception
+            when Fin_Occur : others =>
+               if not Raised then
+                  Raised := True;
+                  Save_Occurrence (Ex_Occur, Fin_Occur);
+               end if;
+         end;
 
-            begin
-               Master.Finalize_Address (Obj_Addr);
+         --  When the master is a heterogeneous collection, destroy the object
+         --  - Finalize_Address pair since it is no longer needed.
 
-            exception
-               when Fin_Occur : others =>
-                  if not Raised then
-                     Raised := True;
-                     Save_Occurrence (Ex_Occur, Fin_Occur);
-                  end if;
-            end;
+         if not Master.Is_Homogeneous then
+            Delete_Finalize_Address (Obj_Addr);
          end if;
       end loop;
 
@@ -172,6 +222,23 @@ package body System.Finalization_Masters is
       end if;
    end Finalize;
 
+   --------------------------
+   -- Get_Finalize_Address --
+   --------------------------
+
+   function Get_Finalize_Address
+     (Obj : System.Address) return Finalize_Address_Ptr
+   is
+      Result : Finalize_Address_Ptr;
+
+   begin
+      Lock_Task.all;
+      Result := Finalize_Address_Table.Get (Obj);
+      Unlock_Task.all;
+
+      return Result;
+   end Get_Finalize_Address;
+
    -----------------
    -- Header_Size --
    -----------------
@@ -181,6 +248,17 @@ package body System.Finalization_Masters is
       return FM_Node'Size / Storage_Unit;
    end Header_Size;
 
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (Key : System.Address) return Header_Num is
+   begin
+      return
+        Header_Num
+          (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
+   end Hash;
+
    -------------------
    -- Header_Offset --
    -------------------
@@ -202,11 +280,11 @@ package body System.Finalization_Masters is
       Master.Objects.Prev := Master.Objects'Unchecked_Access;
    end Initialize;
 
-   --------
-   -- pm --
-   --------
+   ------------------
+   -- Print_Master --
+   ------------------
 
-   procedure pm (Master : Finalization_Master) is
+   procedure Print_Master (Master : Finalization_Master) is
       Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
       Head_Seen : Boolean := False;
       N_Ptr     : FM_Node_Ptr;
@@ -215,6 +293,7 @@ package body System.Finalization_Masters is
       --  Output the basic contents of a master
 
       --    Master   : 0x123456789
+      --    Is_Hmgen : TURE <or> FALSE
       --    Base_Pool: null <or> 0x123456789
       --    Fin_Addr : null <or> 0x123456789
       --    Fin_Start: TRUE <or> FALSE
@@ -222,16 +301,17 @@ package body System.Finalization_Masters is
       Put ("Master   : ");
       Put_Line (Address_Image (Master'Address));
 
-      Put ("Base_Pool: ");
+      Put ("Is_Hmgen : ");
+      Put_Line (Master.Is_Homogeneous'Img);
 
+      Put ("Base_Pool: ");
       if Master.Base_Pool = null then
-         Put_Line (" null");
+         Put_Line ("null");
       else
          Put_Line (Address_Image (Master.Base_Pool'Address));
       end if;
 
       Put ("Fin_Addr : ");
-
       if Master.Finalize_Address = null then
          Put_Line ("null");
       else
@@ -255,17 +335,17 @@ package body System.Finalization_Masters is
 
       --  Header - the address of the list header
       --  Prev   - the address of the list header which the current element
-      --         - points back to
+      --           points back to
       --  Next   - the address of the list header which the current element
-      --         - points to
+      --           points to
       --  (dummy head) - present if dummy head
 
       N_Ptr := Head;
-      while N_Ptr /= null loop -- Should never be null; we being defensive
+      while N_Ptr /= null loop  --  Should never be null
          Put_Line ("V");
 
          --  We see the head initially; we want to exit when we see the head a
-         --  SECOND time.
+         --  second time.
 
          if N_Ptr = Head then
             exit when Head_Seen;
@@ -321,7 +401,7 @@ package body System.Finalization_Masters is
 
          N_Ptr := N_Ptr.Next;
       end loop;
-   end pm;
+   end Print_Master;
 
    -------------------
    -- Set_Base_Pool --
@@ -347,4 +427,18 @@ package body System.Finalization_Masters is
       Master.Finalize_Address := Fin_Addr_Ptr;
    end Set_Finalize_Address;
 
+   --------------------------
+   -- Set_Finalize_Address --
+   --------------------------
+
+   procedure Set_Finalize_Address
+     (Obj          : System.Address;
+      Fin_Addr_Ptr : Finalize_Address_Ptr)
+   is
+   begin
+      Lock_Task.all;
+      Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
+      Unlock_Task.all;
+   end Set_Finalize_Address;
+
 end System.Finalization_Masters;