A special rule was introduced in Ada 2005 (RM 13.5.2(2/2-4/2)) that
specifies that if Position, First_Bit or Last_Bit are applied to
a component with a component clause, and the default record bit
ordering applies, then the results correspond to the exact values
given in the component clause, not normalized versions of them.
This patch implements this feature.
The following test program (compiled with -gnatws)
1. pragma Ada_2005;
2.
3. with Ada.Streams;
4. with Ada.Streams.Stream_Io;
5. with Ada.Text_Io; use Ada.Text_IO;
6. with system;
7.
8. procedure Bit_Test is
9.
10. subtype Int_16 is Standard.Short_Integer;
11. type Int_10 is new Int_16 range 0 .. 9;
12. type Int_22 is new Int_16 range 10 .. 31;
13.
14. type A_Rec_Base is
15. record
16. Comp_A : Int_16;
17. Comp_B : Int_16;
18. Comp_C : Int_10;
19. Comp_D : Int_22;
20. end record;
21.
22. type B_Rec is new A_Rec_Base;
23. type C_Rec is new A_Rec_Base;
24.
25. for B_Rec use
26. record
27. Comp_A at 0 range 0 .. 15;
28. Comp_B at 0 range 16 .. 31;
29. Comp_C at 4 range 0 .. 9;
30. Comp_D at 4 range 11 .. 31;
31. end record;
32.
33. for C_Rec use
34. record
35. Comp_A at 0 range 0 .. 15;
36. Comp_B at 0 range 16 .. 31;
37. Comp_C at 4 range 0 .. 9;
38. Comp_D at 4 range 11 .. 31;
39. end record;
40.
41. for B_Rec'Bit_Order use
42. System.Default_Bit_Order;
43.
44. for C_Rec'Bit_Order use
45. System.Bit_Order'Val
46. (1 - System.Bit_Order'Pos
47. (System.Default_Bit_Order));
48.
49. Obj_1 : B_Rec;
50. Obj_2 : C_Rec;
51.
52. begin
53. Obj_1.Comp_A := 1;
54. Obj_1.Comp_B := 2;
55. Obj_1.Comp_C := 3;
56. Obj_1.Comp_D := 11;
57.
58. Obj_2.Comp_A := 1;
59. Obj_2.Comp_B := 2;
60. Obj_2.Comp_C := 3;
61. Obj_2.Comp_D := 12;
62.
63. Put_Line ("B_Rec: ");
64. Put_Line ("Comp_A Pos: " &
65. Integer'Image (Obj_1.Comp_A'Position));
66. Put_Line (" FB: " &
67. Integer'Image (Obj_1.Comp_A'First_Bit));
68. Put_Line (" LB: " &
69. Integer'Image (Obj_1.Comp_A'Last_Bit));
70. Put_Line ("Comp_B Pos: " &
71. Integer'Image (Obj_1.Comp_B'Position));
72. Put_Line (" FB: " &
73. Integer'Image (Obj_1.Comp_B'First_Bit));
74. Put_Line (" LB: " &
75. Integer'Image (Obj_1.Comp_B'Last_Bit));
76. Put_Line ("Comp_C Pos: " &
77. Integer'Image (Obj_1.Comp_C'Position));
78. Put_Line (" FB: " &
79. Integer'Image (Obj_1.Comp_C'First_Bit));
80. Put_Line (" LB: " &
81. Integer'Image (Obj_1.Comp_C'Last_Bit));
82. Put_Line ("Comp_D Pos: " &
83. Integer'Image (Obj_1.Comp_D'Position));
84. Put_Line (" FB: " &
85. Integer'Image (Obj_1.Comp_D'First_Bit));
86. Put_Line (" LB: " &
87. Integer'Image (Obj_1.Comp_D'Last_Bit));
88.
89. Put_Line ("C_Rec: ");
90. Put_Line ("Comp_A Pos: " &
91. Integer'Image (Obj_2.Comp_A'Position));
92. Put_Line (" FB: " &
93. Integer'Image (Obj_2.Comp_A'First_Bit));
94. Put_Line (" LB: " &
95. Integer'Image (Obj_2.Comp_A'Last_Bit));
96. Put_Line ("Comp_B Pos: " &
97. Integer'Image (Obj_2.Comp_B'Position));
98. Put_Line (" FB: " &
99. Integer'Image (Obj_2.Comp_B'First_Bit));
100. Put_Line (" LB: " &
101. Integer'Image (Obj_2.Comp_B'Last_Bit));
102. Put_Line ("Comp_C Pos: " &
103. Integer'Image (Obj_2.Comp_C'Position));
104. Put_Line (" FB: " &
105. Integer'Image (Obj_2.Comp_C'First_Bit));
106. Put_Line (" LB: " &
107. Integer'Image (Obj_2.Comp_C'Last_Bit));
108. Put_Line ("Comp_D Pos: " &
109. Integer'Image (Obj_2.Comp_D'Position));
110. Put_Line (" FB: " &
111. Integer'Image (Obj_2.Comp_D'First_Bit));
112. Put_Line (" LB: " &
113. Integer'Image (Obj_2.Comp_D'Last_Bit));
114.
115. end Bit_Test;
115 lines: No errors
Generates the output:
B_Rec:
Comp_A Pos: 0
FB: 0
LB: 15
Comp_B Pos: 0
FB: 16
LB: 31
Comp_C Pos: 4
FB: 0
LB: 9
Comp_D Pos: 4
FB: 11
LB: 31
C_Rec:
Comp_A Pos: 2
FB: 0
LB: 15
Comp_B Pos: 0
FB: 0
LB: 15
Comp_C Pos: 6
FB: 6
LB: 15
Comp_D Pos: 4
FB: 0
LB: 20
And as seen in these results, for B_Rec, which has the default
bit_ordering, the output matches exactly the values given in the
component clauses of the record representation clause (in Ada 95
mode these values would be normalized).
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-11-21 Robert Dewar <de...@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case First_Bit,
Last_Bit, Position): Handle 2005 case.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 181556)
+++ exp_attr.adb (working copy)
@@ -2117,21 +2117,38 @@
-- computation to be completed in the back-end, since we don't know what
-- layout will be chosen.
- when Attribute_First_Bit => First_Bit : declare
+ when Attribute_First_Bit => First_Bit_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
- if Known_Static_Component_Bit_Offset (CE) then
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(3/2)).
+
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
Rewrite (N,
Make_Integer_Literal (Loc,
+ Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
+ Analyze_And_Resolve (N, Typ);
+
+ -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
+ -- rewrite with normalized value if we know it statically.
+
+ elsif Known_Static_Component_Bit_Offset (CE) then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
Component_Bit_Offset (CE) mod System_Storage_Unit));
-
Analyze_And_Resolve (N, Typ);
+ -- Otherwise left to back end, just do universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end First_Bit;
+ end First_Bit_Attr;
-----------------
-- Fixed_Value --
@@ -2680,24 +2697,41 @@
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Last_Bit => Last_Bit : declare
+ when Attribute_Last_Bit => Last_Bit_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
- if Known_Static_Component_Bit_Offset (CE)
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(4/2)).
+
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
+ Analyze_And_Resolve (N, Typ);
+
+ -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
+ -- rewrite with normalized value if we know it statically.
+
+ elsif Known_Static_Component_Bit_Offset (CE)
and then Known_Static_Esize (CE)
then
Rewrite (N,
Make_Integer_Literal (Loc,
Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
+ Esize (CE) - 1));
-
Analyze_And_Resolve (N, Typ);
+ -- Otherwise leave to back end, just apply universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Last_Bit;
+ end Last_Bit_Attr;
------------------
-- Leading_Part --
@@ -3495,21 +3529,41 @@
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Position => Position :
+ when Attribute_Position => Position_Attr :
declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
if Present (Component_Clause (CE)) then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
+
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(2/2)).
+
+ if Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Value (Position (Component_Clause (CE)))));
+
+ -- Otherwise (Ada 83 or 95, or reverse bit order specified in
+ -- later Ada version), return the normalized value.
+
+ else
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
+ end if;
+
Analyze_And_Resolve (N, Typ);
+ -- If back end is doing things, just apply universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Position;
+ end Position_Attr;
----------
-- Pred --
