This patch adds missing semantic checks to the implementation of the Ada2012
aspect Default_Storage_Pool.
Compiling bdb3dbm0.adb must yield:
bdb3dbm0.adb:17:45: default storage pool must be a variable
bdb3dbm0.adb:19:33:
expected type "System.Storage_Pools.Root_Storage_Pool'CLASS"
bdb3dbm0.adb:19:33: found type "Non_Pool_Type" defined at line 11
bdb3dbm0.adb:23:36: default storage pool must be a variable
---
with FDB0A00;
with System.Storage_Elements;
procedure BDB3DBM0 is
Pool : aliased FDB0A00.Stack_Heap (Water_Line => 24);
type Frozen_Pool_Type is access constant FDB0A00.Stack_Heap;
Frozen_Pool : Frozen_Pool_Type := Pool'Access;
type Non_Pool_Type is tagged null record;
Non_Pool : Non_Pool_Type;
pragma Default_Storage_Pool (Pool); -- OK.
pragma Default_Storage_Pool (Frozen_Pool.all); -- ERROR:
pragma Default_Storage_Pool (Non_Pool_Type); -- ERROR:
procedure Constant_Pool (Local_Pool : in FDB0A00.Stack_Heap)
is
pragma Default_Storage_Pool (Local_Pool); -- ERROR:
type String_Access is access String;
S : String_Access;
begin
S := new String'("Hello");
end Constant_Pool;
begin
Constant_Pool (Pool);
end BDB3DBM0;
---
with Report;
with System.Storage_Pools;
with System.Storage_Elements;
package FDB0A00 is
type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
is new System.Storage_Pools.Root_Storage_Pool with private;
procedure Allocate(
Pool : in out Stack_Heap;
Storage_Address : out System.Address;
Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
Alignment : in System.Storage_Elements.Storage_Count);
procedure Deallocate(
Pool : in out Stack_Heap;
Storage_Address : in System.Address;
Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
Alignment : in System.Storage_Elements.Storage_Count);
function Storage_Size( Pool: in Stack_Heap )
return System.Storage_Elements.Storage_Count;
function TC_Largest_Request return System.Storage_Elements.Storage_Count;
Pool_Overflow : exception;
private
type Data_Array is array(System.Storage_Elements.Storage_Count range <>)
of System.Storage_Elements.Storage_Element;
type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
is new System.Storage_Pools.Root_Storage_Pool with record
Data : Data_Array(1..Water_Line);
Avail : System.Storage_Elements.Storage_Count := 1;
end record;
end FDB0A00;
--
pragma Elaboration_Checks (Dynamic);
PACKAGE REPORT IS
pragma Elaborate_Body;
SUBTYPE FILE_NUM IS INTEGER RANGE 1..3;
PROCEDURE TEST (NAME : STRING; DESCR : STRING );
PROCEDURE FAILED (DESCR : STRING );
PROCEDURE NOT_APPLICABLE (DESCR : STRING );
PROCEDURE SPECIAL_ACTION (DESCR : STRING );
PROCEDURE COMMENT (DESCR : STRING );
PROCEDURE RESULT;
FUNCTION IDENT_INT (X : INTEGER ) RETURN INTEGER;
FUNCTION IDENT_CHAR (X : CHARACTER ) RETURN CHARACTER;
FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER;
FUNCTION IDENT_BOOL (X : BOOLEAN ) RETURN BOOLEAN;
FUNCTION IDENT_STR (X : STRING ) RETURN STRING;
FUNCTION IDENT_WIDE_STR (X : WIDE_STRING ) RETURN WIDE_STRING;
FUNCTION EQUAL (X, Y : INTEGER ) RETURN BOOLEAN;
FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1;
NAM : STRING := "")
RETURN STRING;
END REPORT;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-31 Ed Schonberg <schonb...@adacore.com>
* freeze.adb (Freeze_Entity): A default_pool does not apply to
internal access types generated for 'access references.
* sem_prag (Analyze_Pragma, case Default_Pool): If the name is
not null it must designate a variable.
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 216925)
+++ sem_prag.adb (working copy)
@@ -12945,11 +12945,16 @@
end if;
-- The expected type for a non-"null" argument is
- -- Root_Storage_Pool'Class.
+ -- Root_Storage_Pool'Class, and the pool must be a variable.
Analyze_And_Resolve
(Get_Pragma_Arg (Arg1),
Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ if not Is_Variable (Expression (Arg1)) then
+ Error_Pragma_Arg
+ ("default storage pool must be a variable", Arg1);
+ end if;
end if;
-- Finally, record the pool name (or null). Freeze.Freeze_Entity
Index: freeze.adb
===================================================================
--- freeze.adb (revision 216956)
+++ freeze.adb (working copy)
@@ -5383,8 +5383,13 @@
Check_Suspicious_Modulus (E);
end if;
+ -- the pool applies to named and anonymous access types, but not
+ -- to subprogram and to internal types generated for 'Access
+ -- references.
+
elsif Is_Access_Type (E)
and then not Is_Access_Subprogram_Type (E)
+ and then Ekind (E) /= E_Access_Attribute_Type
then
-- If a pragma Default_Storage_Pool applies, and this type has no
-- Storage_Pool or Storage_Size clause (which must have occurred
