This patch modifies the generation of validity checks to generate a renaming of
the expression being verified when the expression denotes a name. For all other
kinds of expressions, the validity check machinery creates a constant to store
the value of the expression. The use of renaming prevents the generation of a
redundant copy and acts as a proper alias of the name.
------------
-- Source --
------------
-- pack.ads
package Pack is
type Int is mod 2 ** 32;
for Int'Size use 32;
function Swap_All_Bits (Val : Int) return Int;
end Pack;
-- pack.adb
package body Pack is
type Bit_Map is record
Bit_1 : Boolean;
Bit_2 : Boolean;
Bit_3 : Boolean;
Bit_4 : Boolean;
Bit_5 : Boolean;
Bit_6 : Boolean;
Bit_7 : Boolean;
Bit_8 : Boolean;
Bit_9 : Boolean;
Bit_10 : Boolean;
Bit_11 : Boolean;
Bit_12 : Boolean;
Bit_13 : Boolean;
Bit_14 : Boolean;
Bit_15 : Boolean;
Bit_16 : Boolean;
Bit_17 : Boolean;
Bit_18 : Boolean;
Bit_19 : Boolean;
Bit_20 : Boolean;
Bit_21 : Boolean;
Bit_22 : Boolean;
Bit_23 : Boolean;
Bit_24 : Boolean;
Bit_25 : Boolean;
Bit_26 : Boolean;
Bit_27 : Boolean;
Bit_28 : Boolean;
Bit_29 : Boolean;
Bit_30 : Boolean;
Bit_31 : Boolean;
Bit_32 : Boolean;
end record;
for Bit_Map'Size use 32;
for Bit_Map use record
Bit_1 at 0 range 0 .. 0;
Bit_2 at 0 range 1 .. 1;
Bit_3 at 0 range 2 .. 2;
Bit_4 at 0 range 3 .. 3;
Bit_5 at 0 range 4 .. 4;
Bit_6 at 0 range 5 .. 5;
Bit_7 at 0 range 6 .. 6;
Bit_8 at 0 range 7 .. 7;
Bit_9 at 0 range 8 .. 8;
Bit_10 at 0 range 9 .. 9;
Bit_11 at 0 range 10 .. 10;
Bit_12 at 0 range 11 .. 11;
Bit_13 at 0 range 12 .. 12;
Bit_14 at 0 range 13 .. 13;
Bit_15 at 0 range 14 .. 14;
Bit_16 at 0 range 15 .. 15;
Bit_17 at 0 range 16 .. 16;
Bit_18 at 0 range 17 .. 17;
Bit_19 at 0 range 18 .. 18;
Bit_20 at 0 range 19 .. 19;
Bit_21 at 0 range 20 .. 20;
Bit_22 at 0 range 21 .. 21;
Bit_23 at 0 range 22 .. 22;
Bit_24 at 0 range 23 .. 23;
Bit_25 at 0 range 24 .. 24;
Bit_26 at 0 range 25 .. 25;
Bit_27 at 0 range 26 .. 26;
Bit_28 at 0 range 27 .. 27;
Bit_29 at 0 range 28 .. 28;
Bit_30 at 0 range 29 .. 29;
Bit_31 at 0 range 30 .. 30;
Bit_32 at 0 range 31 .. 31;
end record;
function Swap_All_Bits (Val : Int) return Int is
procedure Swap_One_Bit (L : in out Boolean; R : in out Boolean) is
Temp : Boolean := L;
begin
L := R;
R := Temp;
end Swap_One_Bit;
Result : Int;
Map : Bit_Map;
for Map'Address use Result'Address;
pragma Volatile (Map);
begin
Result := Val;
Swap_One_Bit (Map.Bit_1, Map.Bit_8);
Swap_One_Bit (Map.Bit_2, Map.Bit_7);
Swap_One_Bit (Map.Bit_3, Map.Bit_6);
Swap_One_Bit (Map.Bit_4, Map.Bit_5);
Swap_One_Bit (Map.Bit_9, Map.Bit_16);
Swap_One_Bit (Map.Bit_10, Map.Bit_15);
Swap_One_Bit (Map.Bit_11, Map.Bit_14);
Swap_One_Bit (Map.Bit_12, Map.Bit_13);
Swap_One_Bit (Map.Bit_17, Map.Bit_24);
Swap_One_Bit (Map.Bit_18, Map.Bit_23);
Swap_One_Bit (Map.Bit_19, Map.Bit_22);
Swap_One_Bit (Map.Bit_20, Map.Bit_21);
Swap_One_Bit (Map.Bit_25, Map.Bit_32);
Swap_One_Bit (Map.Bit_26, Map.Bit_31);
Swap_One_Bit (Map.Bit_27, Map.Bit_30);
Swap_One_Bit (Map.Bit_28, Map.Bit_29);
return Result;
end Swap_All_Bits;
end Pack;
-- swapper.adb
with Ada.Text_IO; use Ada.Text_IO;
with Pack; use Pack;
procedure Swapper is
Expect : constant Int := 16#55555555#;
Output : constant Int := Swap_All_Bits (16#AAAAAAAA#);
begin
if Output /= Expect then
Put_Line ("ERROR");
end if;
end Swapper;
-----------------
-- Compilation --
-----------------
$ gnatmake -q -gnatVa swapper.adb
$ ./swapper
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-23 Hristian Kirtchev <kirtc...@adacore.com>
* checks.adb (Insert_Valid_Check): Ensure that the prefix of
attribute 'Valid is a renaming of the original expression when
the expression denotes a name. For all other kinds of expression,
use a constant to capture the value.
* exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
* sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 244790)
+++ exp_util.adb (working copy)
@@ -9014,12 +9014,6 @@
-- is present (xxx is taken from the Chars field of Related_Nod),
-- otherwise it generates an internal temporary.
- function Is_Name_Reference (N : Node_Id) return Boolean;
- -- Determine if the tree referenced by N represents a name. This is
- -- similar to Is_Object_Reference but returns true only if N can be
- -- renamed without the need for a temporary, the typical example of
- -- an object not in this category being a function call.
-
---------------------
-- Build_Temporary --
---------------------
@@ -9050,61 +9044,6 @@
end if;
end Build_Temporary;
- -----------------------
- -- Is_Name_Reference --
- -----------------------
-
- function Is_Name_Reference (N : Node_Id) return Boolean is
- begin
- if Is_Entity_Name (N) then
- return Present (Entity (N)) and then Is_Object (Entity (N));
- end if;
-
- case Nkind (N) is
- when N_Indexed_Component
- | N_Slice
- =>
- return
- Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N)));
-
- -- Attributes 'Input, 'Old and 'Result produce objects
-
- when N_Attribute_Reference =>
- return
- Nam_In
- (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
-
- when N_Selected_Component =>
- return
- Is_Name_Reference (Selector_Name (N))
- and then
- (Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
-
- when N_Explicit_Dereference =>
- return True;
-
- -- A view conversion of a tagged name is a name reference
-
- when N_Type_Conversion =>
- return
- Is_Tagged_Type (Etype (Subtype_Mark (N)))
- and then Is_Tagged_Type (Etype (Expression (N)))
- and then Is_Name_Reference (Expression (N));
-
- -- An unchecked type conversion is considered to be a name if
- -- the operand is a name (this construction arises only as a
- -- result of expansion activities).
-
- when N_Unchecked_Type_Conversion =>
- return Is_Name_Reference (Expression (N));
-
- when others =>
- return False;
- end case;
- end Is_Name_Reference;
-
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
Index: checks.adb
===================================================================
--- checks.adb (revision 244782)
+++ checks.adb (working copy)
@@ -7206,12 +7206,18 @@
Force_Evaluation (Exp, Name_Req => False);
end if;
- -- Build the prefix for the 'Valid call
+ -- Build the prefix for the 'Valid call. If the expression denotes
+ -- a name, use a renaming to alias it, otherwise use a constant to
+ -- capture the value of the expression.
+ -- Temp : ... renames Expr; -- reference to a name
+ -- Temp : constant ... := Expr; -- all other cases
+
PV :=
Duplicate_Subexpr_No_Checks
(Exp => Exp,
Name_Req => False,
+ Renaming_Req => Is_Name_Reference (Exp),
Related_Id => Related_Id,
Is_Low_Bound => Is_Low_Bound,
Is_High_Bound => Is_High_Bound);
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 244789)
+++ sem_util.adb (working copy)
@@ -13405,6 +13405,60 @@
end if;
end Is_Local_Variable_Reference;
+ -----------------------
+ -- Is_Name_Reference --
+ -----------------------
+
+ function Is_Name_Reference (N : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (N) then
+ return Present (Entity (N)) and then Is_Object (Entity (N));
+ end if;
+
+ case Nkind (N) is
+ when N_Indexed_Component
+ | N_Slice
+ =>
+ return
+ Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N)));
+
+ -- Attributes 'Input, 'Old and 'Result produce objects
+
+ when N_Attribute_Reference =>
+ return
+ Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
+
+ when N_Selected_Component =>
+ return
+ Is_Name_Reference (Selector_Name (N))
+ and then
+ (Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N))));
+
+ when N_Explicit_Dereference =>
+ return True;
+
+ -- A view conversion of a tagged name is a name reference
+
+ when N_Type_Conversion =>
+ return
+ Is_Tagged_Type (Etype (Subtype_Mark (N)))
+ and then Is_Tagged_Type (Etype (Expression (N)))
+ and then Is_Name_Reference (Expression (N));
+
+ -- An unchecked type conversion is considered to be a name if the
+ -- operand is a name (this construction arises only as a result of
+ -- expansion activities).
+
+ when N_Unchecked_Type_Conversion =>
+ return Is_Name_Reference (Expression (N));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Name_Reference;
+
---------------------------------
-- Is_Nontrivial_DIC_Procedure --
---------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 244773)
+++ sem_util.ads (working copy)
@@ -1548,6 +1548,12 @@
-- parameter of the current enclosing subprogram.
-- Why are OUT parameters not considered here ???
+ function Is_Name_Reference (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N is a reference to a name. This is
+ -- similar to Is_Object_Reference but returns True only if N can be renamed
+ -- without the need for a temporary, the typical example of an object not
+ -- in this category being a function call.
+
function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean;
-- Determine whether entity Id denotes the procedure that verifies the
-- assertion expression of pragma Default_Initial_Condition and if it does,
