===================================================================
@@ -6488,32 +6488,48 @@
---------------------
function Make_Range_Test return Node_Id is
- Temp : constant Node_Id := Duplicate_Subexpr (Pref);
+ Temp : Node_Id;
begin
- -- The value whose validity is being checked has been captured in
- -- an object declaration. We certainly don't want this object to
- -- appear valid because the declaration initializes it.
+ -- The prefix of attribute 'Valid should always denote an object
+ -- reference. The reference is either coming directly from source
+ -- or is produced by validity check expansion.
- if Is_Entity_Name (Temp) then
- Set_Is_Known_Valid (Entity (Temp), False);
+ -- If the prefix denotes a variable which captures the value of
+ -- an object for validation purposes, use the variable in the
+ -- range test. This ensures that no extra copies or extra reads
+ -- are produced as part of the test. Generate:
+
+ -- Temp : ... := Object;
+ -- if not Temp in ... then
+
+ if Is_Validation_Variable_Reference (Pref) then
+ Temp := New_Occurrence_Of (Entity (Pref), Loc);
+
+ -- Otherwise the prefix is either a source object or a constant
+ -- produced by validity check expansion. Generate:
+
+ -- Temp : constant ... := Pref;
+ -- if not Temp in ... then
+
+ else
+ Temp := Duplicate_Subexpr (Pref);
end if;
return
Make_In (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Btyp, Temp),
+ Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Make_Range (Loc,
- Low_Bound =>
+ Low_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
High_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))));
end Make_Range_Test;
===================================================================
@@ -270,6 +270,8 @@
-- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
+ -- Validated_Object Node36
+
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
@@ -3477,6 +3479,12 @@
return Flag95 (Id);
end Uses_Sec_Stack;
+ function Validated_Object (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ return Node36 (Id);
+ end Validated_Object;
+
function Warnings_Off (Id : E) return B is
begin
return Flag96 (Id);
@@ -6618,6 +6626,12 @@
Set_Flag95 (Id, V);
end Set_Uses_Sec_Stack;
+ procedure Set_Validated_Object (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ Set_Node36 (Id, V);
+ end Set_Validated_Object;
+
procedure Set_Warnings_Off (Id : E; V : B := True) is
begin
Set_Flag96 (Id, V);
@@ -10881,9 +10895,14 @@
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
begin
- Write_Str ("Field36??");
+ case Ekind (Id) is
+ when E_Variable =>
+ Write_Str ("Validated_Object");
+
+ when others =>
+ Write_Str ("Field36??");
+ end case;
end Write_Field36_Name;
------------------------
===================================================================
@@ -4514,6 +4514,10 @@
-- task). Set to True when secondary stack is used in this scope and must
-- be released on exit unless Sec_Stack_Needed_For_Return is set.
+-- Validated_Object (Node36)
+-- Defined in variables. Contains the object whose value is captured by
+-- the variable for validity check purposes.
+
-- Warnings_Off (Flag96)
-- Defined in all entities. Set if a pragma Warnings (Off, entity-name)
-- is used to suppress warnings for a given entity. It is also used by
@@ -6609,6 +6613,7 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Anonymous_Designated_Type (Node35)
+ -- Validated_Object (Node36)
-- SPARK_Pragma (Node40)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
@@ -7342,6 +7347,7 @@
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
+ function Validated_Object (Id : E) return N;
function Warnings_Off (Id : E) return B;
function Warnings_Off_Used (Id : E) return B;
function Warnings_Off_Used_Unmodified (Id : E) return B;
@@ -8029,6 +8035,7 @@
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
+ procedure Set_Validated_Object (Id : E; V : N);
procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (Id : E; V : B := True);
procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True);
@@ -8871,6 +8878,7 @@
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
+ pragma Inline (Validated_Object);
pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used);
pragma Inline (Warnings_Off_Used_Unmodified);
@@ -9346,6 +9354,7 @@
pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack);
+ pragma Inline (Set_Validated_Object);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used);
pragma Inline (Set_Warnings_Off_Used_Unmodified);
===================================================================
@@ -7180,52 +7180,93 @@
Exp := Expression (Exp);
end loop;
+ -- Do not generate a check for a variable which already validates the
+ -- value of an assignable object.
+
+ if Is_Validation_Variable_Reference (Exp) then
+ return;
+ end if;
+
-- We are about to insert the validity check for Exp. We save and
-- reset the Do_Range_Check flag over this validity check, and then
-- put it back for the final original reference (Exp may be rewritten).
declare
DRC : constant Boolean := Do_Range_Check (Exp);
+ CE : Node_Id;
+ Obj : Node_Id;
PV : Node_Id;
- CE : Node_Id;
+ Var : Entity_Id;
begin
Set_Do_Range_Check (Exp, False);
- -- Force evaluation to avoid multiple reads for atomic/volatile
+ -- If the expression denotes an assignable object, capture its value
+ -- in a variable and replace the original expression by the variable.
+ -- This approach has several effects:
- -- Note: we set Name_Req to False. We used to set it to True, with
- -- the thinking that a name is required as the prefix of the 'Valid
- -- call, but in fact the check that the prefix of an attribute is
- -- a name is in the parser, and we just don't require it here.
- -- Moreover, when we set Name_Req to True, that interfered with the
- -- checking for Volatile, since we couldn't just capture the value.
+ -- 1) The evaluation of the object results in only one read in the
+ -- case where the object is atomic or volatile.
- if Is_Entity_Name (Exp)
- and then Is_Volatile (Entity (Exp))
- then
- -- Same reasoning as above for setting Name_Req to False
+ -- Temp ... := Object; -- read
- Force_Evaluation (Exp, Name_Req => False);
- end if;
+ -- 2) The captured value is the one verified by attribute 'Valid.
+ -- As a result the object is not evaluated again, which would
+ -- result in an unwanted read in the case where the object is
+ -- atomic or volatile.
- -- Build the prefix for the 'Valid call. If the expression denotes
- -- a non-volatile name, use a renaming to alias it, otherwise use a
- -- constant to capture the value of the expression.
+ -- if not Temp'Valid then -- OK, no read of Object
- -- Temp : ... renames Expr; -- non-volatile name
- -- Temp : constant ... := Expr; -- all other cases
+ -- if not Object'Valid then -- Wrong, extra read of Object
- PV :=
- Duplicate_Subexpr_No_Checks
- (Exp => Exp,
- Name_Req => False,
- Renaming_Req =>
- Is_Name_Reference (Exp) and then not Is_Volatile (Typ),
- Related_Id => Related_Id,
- Is_Low_Bound => Is_Low_Bound,
- Is_High_Bound => Is_High_Bound);
+ -- 3) The captured value replaces the original object reference.
+ -- As a result the object is not evaluated again, in the same
+ -- vein as 2).
+ -- ... Temp ... -- OK, no read of Object
+
+ -- ... Object ... -- Wrong, extra read of Object
+
+ -- 4) The use of a variable to capture the value of the object
+ -- allows the propagation of any changes back to the original
+ -- object.
+
+ -- procedure Call (Val : in out ...);
+
+ -- Temp : ... := Object; -- read Object
+ -- if not Temp'Valid then -- validity check
+ -- Call (Temp); -- modify Temp
+ -- Object := Temp; -- update Object
+
+ if Is_Variable (Exp) then
+ Obj := New_Copy_Tree (Exp);
+ Var := Make_Temporary (Loc, 'T', Exp);
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Var,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Exp)));
+ Set_Validated_Object (Var, Obj);
+
+ Rewrite (Exp, New_Occurrence_Of (Var, Loc));
+ PV := New_Occurrence_Of (Var, Loc);
+
+ -- Otherwise the expression does not denote a variable. Force its
+ -- evaluation by capturing its value in a constant. Generate:
+
+ -- Temp : constant ... := Exp;
+
+ else
+ Force_Evaluation
+ (Exp => Exp,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound);
+
+ PV := New_Copy_Tree (Exp);
+ end if;
+
-- A rather specialized test. If PV is an analyzed expression which
-- is an indexed component of a packed array that has not been
-- properly expanded, turn off its Analyzed flag to make sure it
===================================================================
@@ -15277,6 +15277,19 @@
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
+ --------------------------------------
+ -- Is_Validation_Variable_Reference --
+ --------------------------------------
+
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Variable
+ and then Present (Validated_Object (Entity (N)));
+ end Is_Validation_Variable_Reference;
+
----------------------------
-- Is_Variable_Size_Array --
----------------------------
@@ -15643,7 +15656,6 @@
------------------------
function Is_Volatile_Object (N : Node_Id) return Boolean is
-
function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-- If prefix is an implicit dereference, examine designated type
===================================================================
@@ -1786,6 +1786,10 @@
pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
+ -- Determine whether N denotes a reference to a variable which captures the
+ -- value of an object for validation purposes.
+
function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
===================================================================
@@ -1901,6 +1901,21 @@
then
Add_Call_By_Copy_Code;
+ -- The actual denotes a variable which captures the value of an
+ -- object for validation purposes. Add a copy-back to reflect any
+ -- potential changes in value back into the original object.
+
+ -- Temp : ... := Object;
+ -- if not Temp'Valid then ...
+ -- Call (Temp);
+ -- Object := Temp;
+
+ elsif Is_Validation_Variable_Reference (Actual) then
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => Validated_Object (Entity (Actual)),
+ Expression => New_Occurrence_Of (Entity (Actual), Loc)));
+
elsif Nkind (Actual) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Actual))
and then Has_Volatile_Components (Entity (Prefix (Actual)))