This patch corrects the transient object machinery to disregard aliasing when
the associated context is a Boolean expression with actions. This is because
the Boolean result is always known after the action list has been evaluated,
therefore the transient objects must be finalized at that point.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Limited_Controlled with record
Val : Integer := 0;
end record;
function F1 (Obj : Ctrl) return Integer;
function F2 (Val : Integer) return Ctrl'Class;
procedure Finalize (Obj : in out Ctrl);
procedure Test (Flag : Boolean; Obj : Ctrl);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line ("fin" & Obj.Val'Img);
end Finalize;
function F1 (Obj : Ctrl) return Integer is
begin
return Obj.Val + 1;
end F1;
function F2 (Val : Integer) return Ctrl'Class is
begin
Put_Line ("ini" & Val'Img);
return Ctrl'(Limited_Controlled with Val => Val);
end F2;
procedure Test (Flag : Boolean; Obj : Ctrl) is
begin
if Flag and then F2 (F1 (Obj)).Val = 42 then
raise Program_Error;
end if;
end Test;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
declare
Obj : Ctrl;
begin
Obj.Val := 1;
Test (True, Obj);
exception
when others =>
Put_Line ("ERROR: unexpected exception 1");
end;
declare
Obj : Ctrl;
begin
Obj.Val := 41;
Test (True, Obj);
Put_Line ("ERROR: exception not raised");
exception
when Program_Error =>
null;
when others =>
Put_Line ("ERROR: unexpected exception 2");
end;
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
ini 2
fin 2
fin 1
ini 42
fin 42
fin 41
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-29 Hristian Kirtchev <[email protected]>
* exp_ch4.adb (Process_Transient_Object): Remove constant
In_Cond_Expr, use its initialization expression in place.
* exp_ch7.adb (Process_Declarations): There is no need to check
that a transient object being hooked is controlled as it would
not have been hooked in the first place.
* exp_util.adb (Is_Aliased): 'Reference-d or renamed transient
objects are not considered aliased when the related context is
a Boolean expression_with_actions.
(Requires_Cleanup_Actions): There is no need to check that a transient
object being hooked is controlled as it would not have been hooked in
the first place.
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 213156)
+++ exp_ch4.adb (working copy)
@@ -12616,9 +12616,6 @@
-- If False, call to finalizer includes a test of whether the hook
-- pointer is null.
- In_Cond_Expr : constant Boolean :=
- Within_Case_Or_If_Expression (Rel_Node);
-
begin
-- Step 0: determine where to attach finalization actions in the tree
@@ -12636,10 +12633,10 @@
-- conditional expression.
Finalize_Always :=
- not (In_Cond_Expr
- or else
- Nkind_In (Original_Node (Rel_Node), N_Case_Expression,
- N_If_Expression));
+ not Within_Case_Or_If_Expression (Rel_Node)
+ and then not Nkind_In
+ (Original_Node (Rel_Node), N_Case_Expression,
+ N_If_Expression);
declare
Loc : constant Source_Ptr := Sloc (Rel_Node);
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 213157)
+++ exp_ch7.adb (working copy)
@@ -1817,9 +1817,7 @@
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
- and then Is_Finalizable_Transient
- (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ N_Object_Declaration
then
Processing_Actions (Has_No_Init => True);
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 213156)
+++ exp_util.adb (working copy)
@@ -3435,9 +3435,8 @@
or else Etype (Assoc_Node) /= Standard_Void_Type)
and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
and then (Nkind (Assoc_Node) /= N_Attribute_Reference
- or else
- not Is_Procedure_Attribute_Name
- (Attribute_Name (Assoc_Node)))
+ or else not Is_Procedure_Attribute_Name
+ (Attribute_Name (Assoc_Node)))
then
N := Assoc_Node;
P := Parent (Assoc_Node);
@@ -4557,6 +4556,17 @@
-- Start of processing for Is_Aliased
begin
+ -- 'Reference-d or renamed transient objects are not consider aliased
+ -- when the related context is a Boolean expression_with_actions. The
+ -- Boolean result is always known after the action list is evaluated,
+ -- therefore the transient objects must be finalized at that point.
+
+ if Nkind (Rel_Node) = N_Expression_With_Actions
+ and then Is_Boolean_Type (Etype (Rel_Node))
+ then
+ return False;
+ end if;
+
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration then
@@ -4652,8 +4662,7 @@
if Nkind (Stmt) = N_Object_Declaration
and then Present (Expression (Stmt))
and then Nkind (Expression (Stmt)) = N_Reference
- and then Nkind (Prefix (Expression (Stmt))) =
- N_Function_Call
+ and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
then
Call := Prefix (Expression (Stmt));
@@ -7441,9 +7450,7 @@
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
- and then Is_Finalizable_Transient
- (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ N_Object_Declaration
then
return True;
@@ -7464,9 +7471,8 @@
-- treated as controlled since they require manual cleanup.
elsif Ekind (Obj_Id) = E_Variable
- and then
- (Is_Simple_Protected_Type (Obj_Typ)
- or else Has_Simple_Protected_Object (Obj_Typ))
+ and then (Is_Simple_Protected_Type (Obj_Typ)
+ or else Has_Simple_Protected_Object (Obj_Typ))
then
return True;
end if;
@@ -7529,9 +7535,7 @@
and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
- or else
- (Is_Type (Typ)
- and then Needs_Finalization (Typ)))
+ or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
and then Requires_Cleanup_Actions
(Actions (Decl), Lib_Level, Nested_Constructs)
then
@@ -7756,7 +7760,8 @@
if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
return True;
- elsif Ialign /= No_Uint and then Oalign /= No_Uint
+ elsif Ialign /= No_Uint
+ and then Oalign /= No_Uint
and then Ialign <= Oalign
then
return True;
@@ -8327,7 +8332,7 @@
when N_Range =>
return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
- and then
+ and then
Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
-- A slice is side effect free if it is a side effect free
