[Ada] Check that Storage_Pool/Storage_Size not both given for same entity

Arnaud Charlet charlet@adacore.com
Wed Jan 22 15:41:00 GMT 2014


This patch implements fully the rule of 13.11(3) that forbids having both
a Storage_Pool and Storage_Size attribute specified for the same type, as
shown by the following example:

     1. with System.Storage_Elements; use System.Storage_Elements;
     2. with System.Storage_Pools;    use System.Storage_Pools;
     3.
     4. package Pool is
     5.    type Pool_Element is record
     6.       Element : Storage_Element;
     7.    end record;
     8.
     9.    type Contents_Array is
    10.      array (Storage_Offset range <>) of Pool_Element;
    11.
    12.    type My_Pool (Size : Storage_Offset) is
    13.      new Root_Storage_Pool with record
    14.       Contents : Contents_Array (1 .. Size);
    15.    end record;
    16.
    17.    overriding procedure Allocate
    18.      (Pool                     : in out My_Pool;
    19.       Storage_Address          : out System.Address;
    20.       Size_In_Storage_Elements : Storage_Count;
    21.       Alignment                : Storage_Count);
    22.
    23.    overriding procedure Deallocate
    24.      (Pool                     : in out My_Pool;
    25.       Storage_Address          : System.Address;
    26.       Size_In_Storage_Elements : Storage_Count;
    27.       Alignment                : Storage_Count);
    28.
    29.    overriding function Storage_Size
    30.      (Pool: My_Pool) return Storage_Count
    31.    is (Pool.Size);
    32. end Pool;

     1. package body Pool is
     2.    procedure Allocate
     3.      (Pool                     : in out My_Pool;
     4.       Storage_Address          : out System.Address;
     5.       Size_In_Storage_Elements : Storage_Count;
     6.       Alignment                : Storage_Count)
     7.    is
     8.       pragma Unreferenced
     9.         (Pool, Storage_Address,
    10.          Size_In_Storage_Elements, Alignment);
    11.    begin
    12.       null;
    13.    end Allocate;
    14.
    15.    procedure Deallocate
    16.      (Pool                     : in out My_Pool;
    17.       Storage_Address          : in System.Address;
    18.       Size_In_Storage_Elements : Storage_Count;
    19.       Alignment                : Storage_Count)
    20.    is
    21.       pragma Unreferenced
    22.         (Pool, Storage_Address,
    23.          Size_In_Storage_Elements, Alignment);
    24.    begin
    25.       null;
    26.    end Deallocate;
    27. end Pool;

     1. with Pool; use Pool;
     2.
     3. package Mix_Of_Attributes is
     4.    Pool : My_Pool (16);
     5.
     6.    type Rec is record
     7.       Comp : Integer := 123;
     8.    end record;
     9.
    10.    type Ptr_1 is access all Rec;
    11.    for Ptr_1'Storage_Size use 16;
    12.    for Ptr_1'Storage_Pool use Pool;
           |
        >>> Storage_Size previously given for "Ptr_1" at line 11
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    13.
    14.    type Ptr_2 is access all Rec;
    15.    for Ptr_2'Storage_Pool use Pool;
    16.    for Ptr_2'Storage_Size use 16;
           |
        >>> Storage_Pool previously given for "Ptr_2" at line 15
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    17.
    18.    type Ptr_3 is access all Rec with Storage_Pool => Pool;
    19.    for Ptr_3'Storage_Size use 16;
           |
        >>> Storage_Pool previously given for "Ptr_3" at line 18
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    20.
    21.    type Ptr_4 is access all Rec with Storage_Size => 16;
    22.    for Ptr_4'Storage_Pool use Pool;
           |
        >>> Storage_Size previously given for "Ptr_4" at line 21
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    23.
    24.    type Ptr_5 is access all Rec
    25.      with Storage_Pool => Pool,
    26.           Storage_Size => 16;
                  |
        >>> Storage_Pool previously given for "Ptr_5" at line 25
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    27.
    28.    type Ptr_6 is access all Rec
    29.      with Storage_Size => 16,
    30.           Storage_Pool => Pool;
                  |
        >>> Storage_Size previously given for "Ptr_6" at line 29
        >>> cannot have Storage_Size and Storage_Pool (RM 13.11(3))

    31.
    32. end Mix_Of_Attributes;

Tested on x86_64-pc-linux-gnu, committed on trunk

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb (Check_Pool_Size_Clash): New procedure
	(Analyze_Attribute_Definition_Clause, case Storage_Pool): call
	Check_Pool_Size_Clash (Analyze_Attribute_Definition_Clause,
	case Storage_Size): call Check_Pool_Size_Clash.

-------------- next part --------------
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 206918)
+++ sem_ch13.adb	(working copy)
@@ -112,6 +112,10 @@
    --  list is stored in Static_Predicate (Typ), and the Expr is rewritten as
    --  a canonicalized membership operation.
 
+   procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
+   --  Called if both Storage_Pool and Storage_Size attribute definition
+   --  clauses (SP and SS) are present for entity Ent. Issue error message.
+
    procedure Freeze_Entity_Checks (N : Node_Id);
    --  Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
    --  to generate appropriate semantic checks that are delayed until this
@@ -1698,8 +1702,8 @@
                   end if;
 
                   --  If the type is private, indicate that its completion
-                  --  has a freeze node, because that is the one that will be
-                  --  visible at freeze time.
+                  --  has a freeze node, because that is the one that will
+                  --  be visible at freeze time.
 
                   if Is_Private_Type (E) and then Present (Full_View (E)) then
                      Set_Has_Predicates (Full_View (E));
@@ -4629,6 +4633,20 @@
                return;
             end if;
 
+            --  Check for Storage_Size previously given
+
+            declare
+               SS : constant Node_Id :=
+                      Get_Attribute_Definition_Clause
+                        (U_Ent, Attribute_Storage_Size);
+            begin
+               if Present (SS) then
+                  Check_Pool_Size_Clash (U_Ent, N, SS);
+               end if;
+            end;
+
+            --  Storage_Pool case
+
             if Id = Attribute_Storage_Pool then
                Analyze_And_Resolve
                  (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
@@ -4788,11 +4806,22 @@
                Analyze_And_Resolve (Expr, Any_Integer);
 
                if Is_Access_Type (U_Ent) then
-                  if Present (Associated_Storage_Pool (U_Ent)) then
-                     Error_Msg_N ("storage pool already given for &", Nam);
-                     return;
-                  end if;
 
+                  --  Check for Storage_Pool previously given
+
+                  declare
+                     SP : constant Node_Id :=
+                            Get_Attribute_Definition_Clause
+                              (U_Ent, Attribute_Storage_Pool);
+
+                  begin
+                     if Present (SP) then
+                        Check_Pool_Size_Clash (U_Ent, SP, N);
+                     end if;
+                  end;
+
+                  --  Special case of for x'Storage_Size use 0
+
                   if Is_OK_Static_Expression (Expr)
                     and then Expr_Value (Expr) = 0
                   then
@@ -8307,6 +8336,33 @@
       end if;
    end Check_Constant_Address_Clause;
 
+   ---------------------------
+   -- Check_Pool_Size_Clash --
+   ---------------------------
+
+   procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id) is
+      Post : Node_Id;
+
+   begin
+      --  We need to find out which one came first. Note that in the case of
+      --  aspects mixed with pragmas there are cases where the processing order
+      --  is reversed, which is why we do the check here.
+
+      if Sloc (SP) < Sloc (SS) then
+         Error_Msg_Sloc := Sloc (SP);
+         Post := SS;
+         Error_Msg_NE ("Storage_Pool previously given for&#", Post, Ent);
+
+      else
+         Error_Msg_Sloc := Sloc (SS);
+         Post := SP;
+         Error_Msg_NE ("Storage_Size previously given for&#", Post, Ent);
+      end if;
+
+      Error_Msg_N
+        ("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post);
+   end Check_Pool_Size_Clash;
+
    ----------------------------------------
    -- Check_Record_Representation_Clause --
    ----------------------------------------
@@ -9580,7 +9636,6 @@
    -------------------------------------
 
    procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
-
       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
         (Rep_Item : Node_Id) return Boolean;
       --  This routine checks if Rep_Item is either a pragma or an aspect


More information about the Gcc-patches mailing list