+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
* 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,
-- 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
-- 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
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'(...);
"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
-- 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
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 --
---------------------------
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 --
------------
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;
--------------
--------------
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;
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;
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 --
-----------------
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;
-- 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
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
-- 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;
N_Ptr := N_Ptr.Next;
end loop;
- end pm;
+ end Print_Master;
-------------------
-- Set_Base_Pool --
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;
------------------------------------------------------------------------------
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
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.
-- 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.
-- 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);
-- 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."+".
(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;
------------------------------------------------------------------------------
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
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
-- 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;
-- +- 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;
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.
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
+ N.Prev := null;
+ N.Next := null;
Unlock_Task.all;
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.
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:
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
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 --
-------------------------
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;
------------------------------------------------------------------------------
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;
-- 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.
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;
OSDN Git Service
