The standard storage pool can be specified in a Default_Storage_Pool
pragma or aspect. This new feature is documented in AI12-0003-1.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_prag.adb (Analyze_Pragma): Adding semantic support of
Standard to Default_Storage_Pool.
* freeze.adb (Freeze_Entity): If pragma Default_Storage_Pool
applies and it is set to Standard then use the global pool as
the associated storage pool of the access type.diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6387,7 +6387,7 @@ package body Freeze is
end if;
-- The pool applies to named and anonymous access types, but not
- -- to subprogram and to internal types generated for 'Access
+ -- to subprogram and to internal types generated for 'Access
-- references.
elsif Is_Access_Type (E)
@@ -6412,6 +6412,11 @@ package body Freeze is
if Nkind (Default_Pool) = N_Null then
Set_No_Pool_Assigned (E);
+ -- Case of pragma Default_Storage_Pool (Standard)
+
+ elsif Entity (Default_Pool) = Standard_Standard then
+ Set_Associated_Storage_Pool (E, RTE (RE_Global_Pool_Object));
+
-- Case of pragma Default_Storage_Pool (storage_pool_NAME)
else
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -15314,7 +15314,7 @@ package body Sem_Prag is
-- Default_Storage_Pool --
--------------------------
- -- pragma Default_Storage_Pool (storage_pool_NAME | null);
+ -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
Pool : Node_Id;
@@ -15355,6 +15355,18 @@ package body Sem_Prag is
Set_Etype (Pool, Empty);
+ -- Case of Default_Storage_Pool (Standard);
+
+ elsif Nkind (Pool) = N_Identifier
+ and then Chars (Pool) = Name_Standard
+ then
+ Analyze (Pool);
+
+ if Entity (Pool) /= Standard_Standard then
+ Error_Pragma_Arg
+ ("package Standard is not directly visible", Arg1);
+ end if;
+
-- Case of Default_Storage_Pool (storage_pool_NAME);
else
@@ -15362,7 +15374,7 @@ package body Sem_Prag is
-- argument is "null".
if Is_Configuration_Pragma then
- Error_Pragma_Arg ("NULL expected", Arg1);
+ Error_Pragma_Arg ("NULL or Standard expected", Arg1);
end if;
-- The expected type for a non-"null" argument is
