===================================================================
@@ -7944,6 +7944,43 @@
end if;
end Type_May_Have_Bit_Aligned_Components;
+ ----------------------------------
+ -- Within_Case_Or_If_Expression --
+ ----------------------------------
+
+ function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Locate an enclosing case or if expression. Note that these constructs
+ -- appear as expression_with_actions, hence the test using the original
+ -- node.
+
+ Par := N;
+ while Present (Par) loop
+ if Nkind_In (Original_Node (Par), N_Case_Expression,
+ N_If_Expression)
+ then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Nkind_In (Par, N_Entry_Body,
+ N_Package_Body,
+ N_Package_Declaration,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ return False;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Within_Case_Or_If_Expression;
+
----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -818,6 +818,9 @@
-- is conservative, in that a result of False is decisive. A result of True
-- means that such a component may or may not be present.
+ function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N is within a case or an if expression
+
procedure Wrap_Cleanup_Procedure (N : Node_Id);
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
-- at the start of the statement sequence, and an Abort_Undefer call at the
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -4984,145 +4984,317 @@
--------------------------------------
procedure Expand_N_Expression_With_Actions (N : Node_Id) is
+ In_Case_Or_If_Expression : constant Boolean :=
+ Within_Case_Or_If_Expression (N);
- procedure Process_Transient_Object (Decl : Node_Id);
- -- Given the declaration of a controlled transient declared inside the
- -- Actions list of an Expression_With_Actions, generate all necessary
- -- types and hooks in order to properly finalize the transient. This
- -- mechanism works in conjunction with Build_Finalizer.
+ function Process_Action (Act : Node_Id) return Traverse_Result;
+ -- Inspect and process a single action of an expression_with_actions
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
+ --------------------
+ -- Process_Action --
+ --------------------
- procedure Process_Transient_Object (Decl : Node_Id) is
+ function Process_Action (Act : Node_Id) return Traverse_Result is
+ procedure Process_Transient_Object (Obj_Decl : Node_Id);
+ -- Obj_Decl denotes the declaration of a transient controlled object.
+ -- Generate all necessary types and hooks to properly finalize the
+ -- result when the enclosing context is elaborated/evaluated.
- function Find_Insertion_Node return Node_Id;
- -- Complex conditions in if statements may be converted into nested
- -- EWAs. In this case, any generated code must be inserted before the
- -- if statement to ensure proper visibility of the hook objects. This
- -- routine returns the top most short circuit operator or the parent
- -- of the EWA if no nesting was detected.
+ ------------------------------
+ -- Process_Transient_Object --
+ ------------------------------
- -------------------------
- -- Find_Insertion_Node --
- -------------------------
+ procedure Process_Transient_Object (Obj_Decl : Node_Id) is
+ function Find_Enclosing_Context return Node_Id;
+ -- Find the context where the expression_with_actions appears
- function Find_Insertion_Node return Node_Id is
- Par : Node_Id;
+ ----------------------------
+ -- Find_Enclosing_Context --
+ ----------------------------
+ function Find_Enclosing_Context return Node_Id is
+ function Is_Body_Or_Unit (N : Node_Id) return Boolean;
+ -- Determine whether N denotes a body or unit declaration
+
+ ---------------------
+ -- Is_Body_Or_Unit --
+ ---------------------
+
+ function Is_Body_Or_Unit (N : Node_Id) return Boolean is
+ begin
+ return Nkind_In (N, N_Entry_Body,
+ N_Package_Body,
+ N_Package_Declaration,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body);
+ end Is_Body_Or_Unit;
+
+ -- Local variables
+
+ Par : Node_Id;
+ Top : Node_Id;
+
+ -- Start of processing for Find_Enclosing_Context
+
+ begin
+ -- The expression_with_action is in a case or if expression and
+ -- the lifetime of any temporary controlled object is therefore
+ -- extended. Find a suitable insertion node by locating the top
+ -- most case or if expressions.
+
+ if In_Case_Or_If_Expression then
+ Par := N;
+ Top := N;
+ while Present (Par) loop
+ if Nkind_In (Original_Node (Par), N_Case_Expression,
+ N_If_Expression)
+ then
+ Top := Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Unit (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ -- The topmost case or if expression is now recovered, but
+ -- it may still not be the correct place to add all the
+ -- generated code. Climb to find a parent that is part of a
+ -- declarative or statement list.
+
+ Par := Top;
+ while Present (Par) loop
+ if Is_List_Member (Par)
+ and then
+ not Nkind_In (Par, N_Component_Association,
+ N_Discriminant_Association,
+ N_Parameter_Association,
+ N_Pragma_Argument_Association)
+ then
+ return Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Unit (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Par;
+
+ -- Shor circuit operators in complex expressions are converted
+ -- into expression_with_actions.
+
+ else
+ -- Take care of the case where the expression_with_actions
+ -- is burried deep inside an if statement. The temporary
+ -- function result must be finalized before the then, elsif
+ -- or else statements are evaluated.
+
+ -- if Something
+ -- and then Ctrl_Func_Call
+ -- then
+ -- <result must be finalized at this point>
+ -- <statements>
+ -- end if;
+
+ -- To achieve this, find the topmost logical operator. The
+ -- generated actions are then inserted before/after it.
+
+ Par := N;
+ while Present (Par) loop
+
+ -- Keep climbing past various operators
+
+ if Nkind (Parent (Par)) in N_Op
+ or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
+ then
+ Par := Parent (Par);
+ else
+ exit;
+ end if;
+ end loop;
+
+ Top := Par;
+
+ -- The expression_with_action might be located in a pragm
+ -- in which case locate the pragma itself:
+
+ -- pragma Precondition (... and then Ctrl_Func_Call ...);
+
+ -- Similar case occurs when the expression_with_actions is
+ -- related to an object declaration or assignment:
+
+ -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
+
+ while Present (Par) loop
+ if Nkind_In (Par, N_Assignment_Statement,
+ N_Object_Declaration,
+ N_Pragma)
+ then
+ return Par;
+
+ elsif Is_Body_Or_Unit (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ -- Return the topmost short circuit operator
+
+ return Top;
+ end if;
+ end Find_Enclosing_Context;
+
+ -- Local variables
+
+ Context : constant Node_Id := Find_Enclosing_Context;
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
+ Obj_Typ : constant Node_Id := Etype (Obj_Id);
+ Desig_Typ : Entity_Id;
+ Expr : Node_Id;
+ Ptr_Id : Entity_Id;
+ Temp_Id : Entity_Id;
+
+ -- Start of processing for Process_Transient_Object
+
begin
- -- Climb up the branches of a complex condition
+ -- Step 1: Create the access type which provides a reference to
+ -- the transient object.
- Par := N;
- while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop
- Par := Parent (Par);
- end loop;
+ if Is_Access_Type (Obj_Typ) then
+ Desig_Typ := Directly_Designated_Type (Obj_Typ);
+ else
+ Desig_Typ := Obj_Typ;
+ end if;
- return Par;
- end Find_Insertion_Node;
+ -- Generate:
+ -- Ann : access [all] <Desig_Typ>;
- -- Local variables
+ Ptr_Id := Make_Temporary (Loc, 'A');
- Ins_Node : constant Node_Id := Find_Insertion_Node;
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Entity_Id := Etype (Obj_Id);
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Ptr_Decl : Node_Id;
- Ptr_Id : Entity_Id;
- Temp_Decl : Node_Id;
- Temp_Id : Node_Id;
+ Insert_Action (Context,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present =>
+ Ekind (Obj_Typ) = E_General_Access_Type,
+ Subtype_Indication => New_Reference_To (Desig_Typ, Loc))));
- -- Start of processing for Process_Transient_Object
+ -- Step 2: Create a temporary which acts as a hook to the
+ -- transient object. Generate:
- begin
- -- Step 1: Create the access type which provides a reference to the
- -- transient object.
+ -- Temp : Ptr_Id := null;
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
+ Temp_Id := Make_Temporary (Loc, 'T');
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
+ Insert_Action (Context,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition => New_Reference_To (Ptr_Id, Loc)));
- Ptr_Id := Make_Temporary (Loc, 'A');
+ -- Mark this temporary as created for the purposes of exporting
+ -- the transient declaration out of the Actions list. This signals
+ -- the machinery in Build_Finalizer to recognize this special
+ -- case.
- Ptr_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication => New_Reference_To (Desig_Typ, Loc)));
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl);
- Insert_Action (Ins_Node, Ptr_Decl);
- Analyze (Ptr_Decl);
+ -- Step 3: Hook the transient object to the temporary
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- object. Generate:
+ if Is_Access_Type (Obj_Typ) then
+ Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
+ else
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
- -- Temp : Ptr_Id := null;
+ -- Generate:
+ -- Temp := Ptr_Id (Obj_Id);
+ -- <or>
+ -- Temp := Obj_Id'Unrestricted_Access;
- Temp_Id := Make_Temporary (Loc, 'T');
+ Insert_After_And_Analyze (Obj_Decl,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Expr));
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Object_Definition => New_Reference_To (Ptr_Id, Loc));
+ -- Step 4: Finalize the function result after the context has been
+ -- evaluated/elaborated. Generate:
- Insert_Action (Ins_Node, Temp_Decl);
- Analyze (Temp_Decl);
+ -- if Temp /= null then
+ -- [Deep_]Finalize (Temp.all);
+ -- Temp := null;
+ -- end if;
- -- Mark this temporary as created for the purposes of exporting the
- -- transient declaration out of the Actions list. This signals the
- -- machinery in Build_Finalizer to recognize this special case.
+ Insert_Action_After (Context,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Reference_To (Temp_Id, Loc),
+ Right_Opnd => Make_Null (Loc)),
- Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
+ Then_Statements => New_List (
+ Make_Final_Call
+ (Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Temp_Id, Loc)),
+ Typ => Desig_Typ),
- -- Step 3: Hook the transient object to the temporary
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Make_Null (Loc)))));
+ end Process_Transient_Object;
- if Is_Access_Type (Obj_Typ) then
- Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
+ -- Start of processing for Process_Action
+
+ begin
+ if Nkind (Act) = N_Object_Declaration
+ and then Is_Finalizable_Transient (Act, N)
+ then
+ Process_Transient_Object (Act);
+
+ -- Avoid processing temporary function results multiple times when
+ -- dealing with nested expression_with_actions.
+
+ elsif Nkind (Act) = N_Expression_With_Actions then
+ return Abandon;
+
+ -- Do not process temporary function results in loops. This is
+ -- done by Expand_N_Loop_Statement and Build_Finalizer.
+
+ elsif Nkind (Act) = N_Loop_Statement then
+ return Abandon;
end if;
- -- Generate:
- -- Temp := Ptr_Id (Obj_Id);
- -- <or>
- -- Temp := Obj_Id'Unrestricted_Access;
+ return OK;
+ end Process_Action;
- Insert_After_And_Analyze (Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Temp_Id, Loc),
- Expression => Expr));
- end Process_Transient_Object;
+ procedure Process_Single_Action is new Traverse_Proc (Process_Action);
-- Local variables
- Decl : Node_Id;
+ Act : Node_Id;
-- Start of processing for Expand_N_Expression_With_Actions
begin
- Decl := First (Actions (N));
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration
- and then Is_Finalizable_Transient (Decl, N)
- then
- Process_Transient_Object (Decl);
- end if;
+ Act := First (Actions (N));
+ while Present (Act) loop
+ Process_Single_Action (Act);
- Next (Decl);
+ Next (Act);
end loop;
end Expand_N_Expression_With_Actions;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -4036,45 +4036,6 @@
-------------------------------
procedure Expand_Ctrl_Function_Call (N : Node_Id) is
- function Enclosing_Context return Node_Id;
- -- Find the enclosing context where the function call appears
-
- -----------------------
- -- Enclosing_Context --
- -----------------------
-
- function Enclosing_Context return Node_Id is
- Context : Node_Id;
-
- begin
- Context := Parent (N);
- while Present (Context) loop
-
- -- The following could use a comment (and why is N_Case_Expression
- -- not treated in a similar manner ???
-
- if Nkind (Context) = N_If_Expression then
- exit;
-
- -- Stop the search when reaching any statement because we have
- -- gone too far up the tree.
-
- elsif Nkind (Context) = N_Procedure_Call_Statement
- or else Nkind (Context) in N_Statement_Other_Than_Procedure_Call
- then
- exit;
- end if;
-
- Context := Parent (Context);
- end loop;
-
- return Context;
- end Enclosing_Context;
-
- -- Local variables
-
- Context : constant Node_Id := Enclosing_Context;
-
begin
-- Optimization, if the returned value (which is on the sec-stack) is
-- returned again, no need to copy/readjust/finalize, we can just pass
@@ -4096,15 +4057,12 @@
Remove_Side_Effects (N);
- -- The function call is part of an if expression dependent expression.
- -- The temporary result must live as long as the if expression itself,
- -- otherwise it will be finalized too early. Mark the transient as
- -- processed to avoid untimely finalization.
+ -- When the temporary function result appears inside a case or an if
+ -- expression, its lifetime must be extended to match that of the
+ -- context. If not, the function result would be finalized prematurely
+ -- and the evaluation of the expression could yield the wrong result.
- -- Why no special handling for case expressions here ???
-
- if Present (Context)
- and then Nkind (Context) = N_If_Expression
+ if Within_Case_Or_If_Expression (N)
and then Nkind (N) = N_Explicit_Dereference
then
Set_Is_Processed_Transient (Entity (Prefix (N)));
This patch adds machinery to properly finalize temporary controlled function results that appear in N_Expression_With_Actions nodes as well as case and if expressions. In general, such temporaries must be finalized after the related context is elaborated/evaluated. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl is new Controlled with record Data : Natural := 1234; end record; procedure Finalize (Obj : in out Ctrl); function Make_Ctrl (Val : Natural) return 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 Obj.Data := 0; Put_Line (" fin"); end Finalize; function Make_Ctrl (Val : Natural) return Ctrl is begin return (Controlled with Val); end Make_Ctrl; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is procedure Ensure_Value (Val : Natural; Exp : Natural; Act : Natural) is begin if Val /= Exp then Put_Line ("ERROR: transient finalized too early"); Put_Line (" Expected:" & Exp'Img); Put_Line (" Got :" & Act'Img); end if; end Ensure_Value; function Factorial (Val : Natural) return Natural is begin if Val > 1 then return Factorial (Val - 1) * Val; else return 1; end if; end Factorial; Exp : constant Natural := 9876; Junk : constant Natural := 5432; Flag : Boolean; Val : Natural; begin Put_Line ("Case expression"); Val := (case Factorial (3) is when 6 => Make_Ctrl (Exp).Data, when others => Junk); Ensure_Value (Val, Exp, Junk); Put_Line ("If expression"); Val := (if Factorial (3) = 6 then Make_Ctrl (Exp).Data else Junk); Ensure_Value (Val, Exp, Junk); Put_Line ("If statement"); if Val = Exp and then Make_Ctrl (Exp).Data = Exp then Put_Line (" then statements"); end if; Put_Line ("Assignment"); Flag := Val = Exp and then Make_Ctrl (Exp).Data = Exp; Put_Line ("End"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnat12 main.adb $ ./main Case expression fin fin If expression fin fin If statement fin fin then statements Assignment fin fin End Tested on x86_64-pc-linux-gnu, committed on trunk 2013-02-06 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This routine should be able to properly detect controlled transient objects in its actions and generate the appropriate finalization actions. * exp_ch6.adb (Enclosing_Context): Removed. (Expand_Ctrl_Function_Call): Remove local subprogram and constant. Use routine Within_Case_Or_If_Expression to determine whether the lifetime of the function result must be extended to match that of the context. * exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New routine.