sem_ch13.adb (Analyze_Attribute_Definition_Clause, [...]): enhance, document &…

sem_ch13.adb (Analyze_Attribute_Definition_Clause, [...]): enhance, document & limit detection of non-sharable internal pools.

2004-10-26  Cyrille Comar  <comar@act-europe.fr>

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
	'Storage_Pool): enhance, document & limit detection of non-sharable
	internal pools.

	* impunit.adb: Make System.Pool_Global and System.Pool_Local visible.

	* s-pooglo.ads: Add more documentation now that this pool is properly
	documented.

From-SVN: r89669

gcc/ada/impunit.adb

@@ -297,6 +297,8 @@ package body Impunit is
      "s-assert",    -- System.Assertions
      "s-memory",    -- System.Memory
      "s-parint",    -- System.Partition_Interface
+     "s-pooglo",    -- System.Pool_Global
+     "s-pooloc",    -- System.Pool_Local
      "s-restri",    -- System.Restrictions
      "s-rident",    -- System.Rident
      "s-tasinf",    -- System.Task_Info

gcc/ada/s-pooglo.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---        Copyright (C) 1992,1993,1994 Free Software Foundation, Inc.       --
+--        Copyright (C) 1992-1994, 2004 Free Software Foundation, Inc.      --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -47,7 +47,8 @@ pragma Elaborate_Body;
    --    no automatic reclaim
    --    minimal overhead
 
-   --  Default pool in the compiler for access types globally declared
+   --  Pool simulating the allocation/deallocation strategy used by the
+   --  compiler for access types globally declared.
 
    type Unbounded_No_Reclaim_Pool is new
      System.Storage_Pools.Root_Storage_Pool with null record;
@@ -68,7 +69,10 @@ pragma Elaborate_Body;
       Storage_Size : System.Storage_Elements.Storage_Count;
       Alignment    : System.Storage_Elements.Storage_Count);
 
-   --  Pool object for the compiler
+   --  Pool object used by the compiler when implicit Storage Pool objects are
+   --  explicitly referred to. For instance when writing something like:
+   --     for T'Storage_Pool use Q'Storage_Pool;
+   --  and Q'Storage_Pool hasn't been defined explicitly.
 
    Global_Pool_Object : Unbounded_No_Reclaim_Pool;
 

gcc/ada/sem_ch13.adb

@@ -1250,6 +1250,7 @@ package body Sem_Ch13 is
 
          when Attribute_Storage_Pool => Storage_Pool : declare
             Pool : Entity_Id;
+            T    : Entity_Id;
 
          begin
             if Ekind (U_Ent) /= E_Access_Type
@@ -1276,6 +1277,26 @@ package body Sem_Ch13 is
             Analyze_And_Resolve
               (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
 
+            if Nkind (Expr) = N_Type_Conversion then
+               T := Etype (Expression (Expr));
+            else
+               T := Etype (Expr);
+            end if;
+
+            --  The Stack_Bounded_Pool is used internally for implementing
+            --  access types with a Storage_Size. Since it only work
+            --  properly when used on one specific type, we need to check
+            --  that it is not highjacked improperly:
+            --    type T is access Integer;
+            --    for T'Storage_Size use n;
+            --    type Q is access Float;
+            --    for Q'Storage_Size use T'Storage_Size; -- incorrect
+
+            if Base_Type (T) = RTE (RE_Stack_Bounded_Pool) then
+               Error_Msg_N ("non-sharable internal Pool", Expr);
+               return;
+            end if;
+
             --  If the argument is a name that is not an entity name, then
             --  we construct a renaming operation to define an entity of
             --  type storage pool.
@@ -1320,33 +1341,14 @@ package body Sem_Ch13 is
                   Pool := Entity (Expression (Renamed_Object (Pool)));
                end if;
 
-               if Present (Etype (Pool))
-                 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
-                 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
-               then
-                  Set_Associated_Storage_Pool (U_Ent, Pool);
-               else
-                  Error_Msg_N ("Non sharable GNAT Pool", Expr);
-               end if;
-
-            --  The pool may be specified as the Storage_Pool of some other
-            --  type. It is rewritten as a class_wide conversion of the
-            --  corresponding pool entity.
+               Set_Associated_Storage_Pool (U_Ent, Pool);
 
             elsif Nkind (Expr) = N_Type_Conversion
               and then Is_Entity_Name (Expression (Expr))
               and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
             then
                Pool := Entity (Expression (Expr));
-
-               if Present (Etype (Pool))
-                 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
-                 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
-               then
-                  Set_Associated_Storage_Pool (U_Ent, Pool);
-               else
-                  Error_Msg_N ("Non sharable GNAT Pool", Expr);
-               end if;
+               Set_Associated_Storage_Pool (U_Ent, Pool);
 
             else
                Error_Msg_N ("incorrect reference to a Storage Pool", Expr);