OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_res.adb (Resolve_Allocator): Warning on allocation of tasks on a subpool and rewrite the allocator into a... 

2011-12-20  Hristian Kirtchev  <kirtchev@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.

From-SVN: r182533
This commit is contained in:
Hristian Kirtchev 2011-12-20 13:41:00 +00:00 committed by Arnaud Charlet
parent 9a417f117e
commit 7b2aafc959
4 changed files with 62 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/ChangeLog
View File

@ -1,3 +1,15 @@
2011-12-20 Hristian Kirtchev <kirtchev@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.
2011-12-20 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* gcc-interface/Makefile.in (%86 linux%):

24
gcc/ada/s-stposu.adb
View File

@ -431,6 +431,19 @@ package body System.Storage_Pools.Subpools is
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 @@ package body System.Storage_Pools.Subpools is
---------------------
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 @@ package body System.Storage_Pools.Subpools is
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 @@ package body System.Storage_Pools.Subpools is
-- 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 @@ package body System.Storage_Pools.Subpools is
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.

42
gcc/ada/s-stposu.ads
View File

@ -38,7 +38,7 @@ with System.Finalization_Masters;
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 @@ package System.Storage_Pools.Subpools is
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 @@ package System.Storage_Pools.Subpools is
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

21
gcc/ada/sem_res.adb
View File

@ -4469,23 +4469,26 @@ package body Sem_Res is
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;