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