This patch updates s-stposu.ads and s-stposu.adb to reflect the final version
of the Ada 2012 Reference Manual.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-12-20 Hristian Kirtchev <kirtc...@adacore.com>
* sem_res.adb (Resolve_Allocator): Warning on allocation
of tasks on a subpool and rewrite the allocator into a raise
Program_Error statement.
* s-stposu.ads, s-stposu.adb: Code reformatting.
(Create_Subpool): Remove formal parameter Storage_Size.
(Default_Subpool_For_Pool): Add the default implementation of this
routine.
(Set_Pool_Of_Subpool): Rename formal parameter Pool to To. Update
all the uses of the parameter.
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 182532)
+++ sem_res.adb (working copy)
@@ -4469,23 +4469,26 @@
and then Ekind (Current_Scope) = E_Package
and then not In_Package_Body (Current_Scope)
then
- Error_Msg_N ("cannot activate task before body seen?", N);
- Error_Msg_N ("\Program_Error will be raised at run time?", N);
+ Error_Msg_N ("?cannot activate task before body seen", N);
+ Error_Msg_N ("\?Program_Error will be raised at run time", N);
end if;
- -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task
- -- or a type containing tasks on a subpool since the deallocation of
- -- the subpool may lead to undefined task behavior. Perform the check
- -- only when the allocator has not been converted into a Program_Error
- -- due to a previous error.
+ -- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a
+ -- type with a task component on a subpool. This action must raise
+ -- Program_Error at runtime.
if Ada_Version >= Ada_2012
and then Nkind (N) = N_Allocator
and then Present (Subpool_Handle_Name (N))
and then Has_Task (Desig_T)
then
- Error_Msg_N ("?allocation of task on subpool may lead to " &
- "undefined behavior", N);
+ Error_Msg_N ("?cannot allocate task on subpool", N);
+ Error_Msg_N ("\?Program_Error will be raised at run time", N);
+
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Explicit_Raise));
+ Set_Etype (N, Typ);
end if;
end Resolve_Allocator;
Index: s-stposu.adb
===================================================================
--- s-stposu.adb (revision 182532)
+++ s-stposu.adb (working copy)
@@ -431,6 +431,19 @@
Deallocate (Pool, N_Addr, N_Size, Alignment);
end Deallocate_Any_Controlled;
+ ------------------------------
+ -- Default_Subpool_For_Pool --
+ ------------------------------
+
+ function Default_Subpool_For_Pool
+ (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
+ is
+ begin
+ raise Program_Error;
+
+ return Pool.Subpools.Subpool;
+ end Default_Subpool_For_Pool;
+
------------
-- Detach --
------------
@@ -607,7 +620,8 @@
---------------------
function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
- return access Root_Storage_Pool_With_Subpools'Class is
+ return access Root_Storage_Pool_With_Subpools'Class
+ is
begin
return Subpool.Owner;
end Pool_Of_Subpool;
@@ -762,7 +776,7 @@
procedure Set_Pool_Of_Subpool
(Subpool : not null Subpool_Handle;
- Pool : in out Root_Storage_Pool_With_Subpools'Class)
+ To : in out Root_Storage_Pool_With_Subpools'Class)
is
N_Ptr : SP_Node_Ptr;
@@ -777,12 +791,12 @@
-- Prevent the creation of a new subpool while the owner is being
-- finalized. This is a serious error.
- if Pool.Finalization_Started then
+ if To.Finalization_Started then
raise Program_Error
with "subpool creation after finalization started";
end if;
- Subpool.Owner := Pool'Unchecked_Access;
+ Subpool.Owner := To'Unchecked_Access;
-- Create a subpool node and decorate it. Since this node is not
-- allocated on the owner's pool, it must be explicitly destroyed by
@@ -792,7 +806,7 @@
N_Ptr.Subpool := Subpool;
Subpool.Node := N_Ptr;
- Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
+ Attach (N_Ptr, To.Subpools'Unchecked_Access);
-- Mark the subpool's master as being a heterogeneous collection of
-- controlled objects.
Index: s-stposu.ads
===================================================================
--- s-stposu.ads (revision 182532)
+++ s-stposu.ads (working copy)
@@ -38,7 +38,7 @@
with System.Storage_Elements;
package System.Storage_Pools.Subpools is
- pragma Preelaborate;
+ pragma Preelaborate (Subpools);
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with private;
@@ -70,21 +70,16 @@
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
- Subpool : not null Subpool_Handle)
- is abstract;
+ Subpool : not null Subpool_Handle) is abstract;
-- ??? This precondition causes errors in simple tests, disabled for now
--- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Allocate an object described by
-- Size_In_Storage_Elements and Alignment on a subpool.
- function Create_Subpool
- (Pool : in out Root_Storage_Pool_With_Subpools;
- Storage_Size : Storage_Elements.Storage_Count :=
- Storage_Elements.Storage_Count'Last)
- return not null Subpool_Handle
- is abstract;
+ function Create_Subpool (Pool : in out Root_Storage_Pool_With_Subpools)
+ return not null Subpool_Handle is abstract;
-- This routine requires implementation. Create a subpool within the given
-- pool_with_subpools.
@@ -93,39 +88,40 @@
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
- is null;
+ is null;
procedure Deallocate_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
- Subpool : in out Subpool_Handle)
- is abstract;
+ Subpool : in out Subpool_Handle) is abstract;
-- ??? This precondition causes errors in simple tests, disabled for now
--- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Reclaim the storage a particular
-- subpool occupies in a pool_with_subpools. This routine is called by
-- Ada.Unchecked_Deallocate_Subpool.
function Default_Subpool_For_Pool
- (Pool : Root_Storage_Pool_With_Subpools)
- return not null Subpool_Handle
- is abstract;
- -- This routine requires implementation. Returns a common subpool used for
- -- allocations without Subpool_Handle_name in the allocator.
+ (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle;
+ -- Return a common subpool which is used for object allocations without a
+ -- Subpool_Handle_name in the allocator. The default implementation of this
+ -- routine raises Program_Error.
- function Pool_Of_Subpool
- (Subpool : not null Subpool_Handle)
- return access Root_Storage_Pool_With_Subpools'Class;
+ function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
+ return access Root_Storage_Pool_With_Subpools'Class;
-- Return the owner of the subpool
procedure Set_Pool_Of_Subpool
(Subpool : not null Subpool_Handle;
- Pool : in out Root_Storage_Pool_With_Subpools'Class);
+ To : in out Root_Storage_Pool_With_Subpools'Class);
-- Set the owner of the subpool. This is intended to be called from
-- Create_Subpool or similar subpool constructors. Raises Program_Error
-- if the subpool already belongs to a pool.
+ overriding function Storage_Size (Pool : Root_Storage_Pool_With_Subpools)
+ return System.Storage_Elements.Storage_Count is
+ (System.Storage_Elements.Storage_Count'Last);
+
private
-- Model
-- Pool_With_Subpools SP_Node SP_Node SP_Node
