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

4 files changed, 63 insertions, 38 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1ddb5bb..74d7309 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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%):
diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb
index 7895841..53f65cb 100644
--- a/gcc/ada/s-stposu.adb
+++ b/gcc/ada/s-stposu.adb
@@ -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.
diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads
index 38f8cfc..d5819ca 100644
--- a/gcc/ada/s-stposu.ads
+++ b/gcc/ada/s-stposu.ads
@@ -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.
-
-   function Pool_Of_Subpool
-     (Subpool : not null Subpool_Handle)
-   return access Root_Storage_Pool_With_Subpools'Class;
+     (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;
    --  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
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 55a5e36..3a8d7d7 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -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;