procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
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
This commit is contained in:
Arnaud Charlet 2011-08-29 16:29:25 +02:00
parent 8027b4559b
commit 14f0f659ac
8 changed files with 501 additions and 110 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
gcc/ada/ChangeLog
View file

@ -1,3 +1,7 @@
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,

5
gcc/ada/debug.adb
View file

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

2
gcc/ada/exp_ch4.adb
View file

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

2
gcc/ada/impunit.adb
View file

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

199
gcc/ada/s-finmas.adb
View file

@ -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;
Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
-- Retrieve TSS primitive Finalize_Address depending on the master's
-- mode of operation.
begin
Master.Finalize_Address (Obj_Addr);
if Master.Is_Homogeneous then
Cleanup := Master.Finalize_Address;
else
Cleanup := Finalize_Address (Obj_Addr);
end if;
exception
when Fin_Occur : others =>
if not Raised then
Raised := True;
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
-- 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);
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 --
--------------------
procedure pm (Master : Finalization_Master) is
function Is_Homogeneous (Master : Finalization_Master) return Boolean is
begin
return Master.Is_Homogeneous;
end Is_Homogeneous;
-------------
-- 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;

154
gcc/ada/s-finmas.ads
View file

@ -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,50 +61,24 @@ 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
record
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.
new Ada.Finalization.Limited_Controlled with private;
Objects : aliased FM_Node;
-- A doubly linked list which contains the headers of all controlled
-- objects allocated in a [sub]pool.
Finalize_Address : Finalize_Address_Ptr := null;
-- A reference to the routine reponsible for object finalization
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
-- may arise in a multitask environment. The flag is atomic because it
-- is accessed without Lock_Task / Unlock_Task.
end record;
-- 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;
-- Since RTSfind cannot contain names of the form RE_"+", the following
-- routine serves as a wrapper around System.Storage_Elements."+".
function Add_Offset_To_Address
(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 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
@ -122,26 +88,106 @@ 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 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 : aliased FM_Node;
-- A doubly linked list which contains the headers of all controlled
-- 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.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
-- may arise in a multitask environment. The flag is atomic because it
-- is accessed without Lock_Task / Unlock_Task.
end record;
-- Since RTSfind cannot contain names of the form RE_"+", the following
-- routine serves as a wrapper around System.Storage_Elements."+".
function Add_Offset_To_Address
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address;
function Base_Pool
(Master : Finalization_Master) return Any_Storage_Pool_Ptr;
-- Return a reference to the underlying storage pool on which the master
-- operates.
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;

229
gcc/ada/s-stposu.adb
View file

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

11
gcc/ada/s-stposu.ads
View file

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