===================================================================
@@ -5039,12 +5039,49 @@
--------------------------------------
procedure Expand_N_Expression_With_Actions (N : Node_Id) is
+ Acts : constant List_Id := Actions (N);
+
+ procedure Force_Boolean_Evaluation (Expr : Node_Id);
+ -- Force the evaluation of Boolean expression Expr
+
function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for
-- transient controlled objects. If such objects are found, the routine
-- generates code to clean them up when the context of the expression is
-- evaluated or elaborated.
+ ------------------------------
+ -- Force_Boolean_Evaluation --
+ ------------------------------
+
+ procedure Force_Boolean_Evaluation (Expr : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Flag_Decl : Node_Id;
+ Flag_Id : Entity_Id;
+
+ begin
+ -- Relocate the expression to the actions list by capturing its value
+ -- in a Boolean flag. Generate:
+ -- Flag : constant Boolean := Expr;
+
+ Flag_Id := Make_Temporary (Loc, 'F');
+
+ Flag_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => Relocate_Node (Expr));
+
+ Append (Flag_Decl, Acts);
+ Analyze (Flag_Decl);
+
+ -- Replace the expression with a reference to the flag
+
+ Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
+ Analyze (Expression (N));
+ end Force_Boolean_Evaluation;
+
--------------------
-- Process_Action --
--------------------
@@ -5077,9 +5114,7 @@
-- Local variables
- Acts : constant List_Id := Actions (N);
- Expr : constant Node_Id := Expression (N);
- Act : Node_Id;
+ Act : Node_Id;
-- Start of processing for Expand_N_Expression_With_Actions
@@ -5087,7 +5122,7 @@
-- Do not evaluate the expression when it denotes an entity because the
-- expression_with_actions node will be replaced by the reference.
- if Is_Entity_Name (Expr) then
+ if Is_Entity_Name (Expression (N)) then
null;
-- Do not evaluate the expression when there are no actions because the
@@ -5117,11 +5152,23 @@
-- <finalize Trans_Id>
-- in Val end;
- -- It is now safe to finalize the transient controlled object at the end
- -- of the actions list.
+ -- Once this transformation is performed, it is safe to finalize the
+ -- transient controlled object at the end of the actions list.
+ -- Note that Force_Evaluation does not remove side effects in operators
+ -- because it assumes that all operands are evaluated and side effect
+ -- free. This is not the case when an operand depends implicitly on the
+ -- transient controlled object through the use of access types.
+
+ elsif Is_Boolean_Type (Etype (Expression (N))) then
+ Force_Boolean_Evaluation (Expression (N));
+
+ -- The expression of an expression_with_actions node may not necessarely
+ -- be Boolean when the node appears in an if expression. In this case do
+ -- the usual forced evaluation to encapsulate potential aliasing.
+
else
- Force_Evaluation (Expr);
+ Force_Evaluation (Expression (N));
end if;
-- Process all transient controlled objects found within the actions of
This patch modifies the expansion of expression_with_actions nodes to force the evaluation of the expression when its type is Boolean. This prevents "leaks" of dependencies on transient controlled objects which lead to incorrect results in short circuit operators. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type FS_String is new String; Empty_FS_String : aliased FS_String := "ERROR"; type FS_String_Access is access all FS_String; type File_Record is tagged record Normalized : FS_String_Access; Ref_Count : Natural := 0; end record; type File_Access is access all File_Record'Class; procedure Ref (Obj : File_Access); procedure Unref (Obj : in out File_Access); type Virtual_File is new Controlled with record Value : File_Access; end record; procedure Adjust (Obj : in out Virtual_File); function Create (Str : FS_String) return Virtual_File; procedure Finalize (Obj : in out Virtual_File); function Full_Name (Obj : Virtual_File) return FS_String_Access; end Types; -- types.adb with Ada.Unchecked_Deallocation; package body Types is procedure Adjust (Obj : in out Virtual_File) is begin if Obj.Value /= null then Ref (Obj.Value); end if; end Adjust; function Create (Str : FS_String) return Virtual_File is begin return (Controlled with Value => new File_Record'(Ref_Count => 1, Normalized => new FS_String'(Str))); end Create; procedure Finalize (Obj : in out Virtual_File) is Value : File_Access := Obj.Value; begin Obj.Value := null; if Value /= null then Unref (Value); end if; end Finalize; function Full_Name (Obj : Virtual_File) return FS_String_Access is begin if Obj.Value /= null then return Obj.Value.Normalized; else return Empty_FS_String'Access; end if; end Full_Name; procedure Ref (Obj : File_Access) is begin Obj.Ref_Count := Obj.Ref_Count + 1; end Ref; procedure Unref (Obj : in out File_Access) is procedure Free_FA is new Ada.Unchecked_Deallocation (File_Record'Class, File_Access); procedure Free_FS is new Ada.Unchecked_Deallocation (FS_String, FS_String_Access); begin if Obj.Ref_Count > 0 then Obj.Ref_Count := Obj.Ref_Count - 1; if Obj.Ref_Count = 0 then Free_FS (Obj.all.Normalized); Free_FA (Obj); end if; end if; end Unref; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is function Return_Self (Flag : Boolean) return Boolean is begin return Flag; end Return_Self; begin if Return_Self (True) and then Create ("hello").Full_Name.all = "hello" then Put_Line ("OK"); else Put_Line ("ERROR: premature finalization"); end if; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main OK Tested on x86_64-pc-linux-gnu, committed on trunk 2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch4.adb (Expand_N_Expression_With_Actions): Force the evaluation of the expression when its type is Boolean. (Force_Boolean_Evaluation): New routine.