[Ada] Implementation of Default_Pool pragma

[Arnaud Charlet <charlet at adacore dot com>]

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  <schonberg@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.

Attachment: difs
Description: Text document