[Ada] Implementation of Default_Pool pragma

[Arnaud Charlet]

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.

-------------- next part --------------
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