* [Ada] Funalization of controlled function results in conditional expression
@ 2012-06-14 10:46 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2012-06-14 10:46 UTC (permalink / raw)
To: gcc-patches; +Cc: Hristian Kirtchev
[-- Attachment #1: Type: text/plain, Size: 4488 bytes --]
This patch adds logic to postpone the finalization of temporary controlled
function results in the context of conditional expressions because the results
are finalized too early.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Controlled with record
Id : Natural;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
type Root is tagged null record;
type Ctrl_Rec is new Root with record
Comp : Ctrl;
end record;
function Make_Ctrl_Rec (Flag : Boolean) return Ctrl_Rec;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 0;
procedure Adjust (Obj : in out Ctrl) is
New_Id : constant Natural := Obj.Id * 100;
begin
Put_Line (" adj" & Obj.Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line (" fin" & Obj.Id'Img);
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Id_Gen := Id_Gen + 1;
Obj.Id := Id_Gen;
Put_Line (" ini" & Obj.Id'Img);
end Initialize;
function Make_Ctrl_Rec (Flag : Boolean) return Ctrl_Rec is
Result : Ctrl_Rec;
begin
return Result;
end Make_Ctrl_Rec;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
function Factorial (N : Natural) return Natural is
begin
if N = 0 then
return 0;
else
return N * Factorial (N - 1);
end if;
end Factorial;
Empty : Ctrl_Rec;
begin
Put_Line ("Main");
declare
Obj : Root'Class := Empty;
begin
Put_Line ("Function");
Obj := (if Factorial (3) > 2 then
Make_Ctrl_Rec (True)
else
Make_Ctrl_Rec (False));
Put_Line ("Function end");
end;
Put_Line ("Main end");
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q -gnat12 main.adb
$ ./main
$ ini 1
$ Main
$ adj 1 -> 100
$ Function
$ ini 2
$ adj 2 -> 200
$ fin 2
$ fin 100
$ adj 200 -> 20000
$ fin 200
$ Function end
$ fin 20000
$ Main end
$ fin 1
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-06-14 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Update the usage of Node15.
(Return_Flag_Or_Transient_Decl): Removed.
(Set_Return_Flag_Or_Transient_Decl): Removed.
(Set_Status_Flag_Or_Transient_Decl): New routine.
(Status_Flag_Or_Transient_Decl): New routine.
(Write_Field15_Name): Update the output for variables and constants.
* einfo.ads: Remove attribute
Return_Flag_Or_Transient_Decl along with occurrences in nodes.
(Return_Flag_Or_Transient_Decl): Removed along with pragma Inline.
(Set_Return_Flag_Or_Transient_Decl): Removed along with pragma Inline.
(Set_Status_Flag_Or_Transient_Decl): New routine along with pragma
Inline.
(Status_Flag_Or_Transient_Decl): New routine along with pragma Inline.
* exp_ch4.adb (Create_Alternative): New routine.
(Expand_N_Conditional_Expression): Handle the case
where at least one of the conditional expression
alternatives prodices a controlled temporary by means of a function
call.
(Is_Controlled_Function_Call): New routine.
(Process_Transient_Object): Update the call to
Set_Return_Flag_Or_Transient_Decl.
* exp_ch6.adb (Enclosing_Context): New routine.
(Expand_N_Extended_Return_Statement): Update all calls to
Set_Return_Flag_Or_Transient_Decl.
(Expand_Ctrl_Function_Call): Prohibit the finalization of a controlled
function result when the context is a conditional expression.
* exp_ch7.adb (Process_Declarations): Update all calls to
Return_Flag_Or_Transient_Decl. Add processing for intermediate
results of conditional expressions where one of the alternatives
uses a controlled function call.
(Process_Object_Declaration): Update all calls to
Return_Flag_Or_Transient_Decl and rearrange the logic to process
"hook" objects first.
(Process_Transient_Objects): Update the call to
Set_Return_Flag_Or_Transient_Decl.
* exp_util.adb (Requires_Cleanup_Actions (List_Id, Boolean,
Boolean)): Update all calls to Return_Flag_Or_Transient_Decl. Add
detection for intermediate results of conditional expressions
where one of the alternatives uses a controlled function call.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 26991 bytes --]
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 188605)
+++ exp_ch7.adb (working copy)
@@ -1884,14 +1884,27 @@
-- transients declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
- and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ 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
- (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
Processing_Actions (Has_No_Init => True);
+ -- Processing for intermediate results of conditional
+ -- expressions where one of the alternatives uses a controlled
+ -- function call.
+
+ 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_Defining_Identifier
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Null
+ then
+ Processing_Actions (Has_No_Init => True);
+
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should
-- be treated as controlled since they require manual cleanup.
@@ -1954,7 +1967,7 @@
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
Processing_Actions (Has_No_Init => True);
@@ -2685,27 +2698,8 @@
end if;
if Ekind_In (Obj_Id, E_Constant, E_Variable)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
- -- Return objects use a flag to aid their potential
- -- finalization when the enclosing function fails to return
- -- properly. Generate:
-
- -- if not Flag then
- -- <object finalization statements>
- -- end if;
-
- if Is_Return_Object (Obj_Id) then
- Fin_Stmts := New_List (
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- New_Reference_To
- (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
-
- Then_Statements => Fin_Stmts));
-
-- Temporaries created for the purpose of "exporting" a
-- controlled transient out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
@@ -2733,11 +2727,9 @@
-- <object finalization statements>
-- end if;
- else
- pragma Assert
- (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration);
-
+ if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
+ then
Fin_Stmts := New_List (
Make_If_Statement (Loc,
Condition =>
@@ -2746,6 +2738,25 @@
Right_Opnd => Make_Null (Loc)),
Then_Statements => Fin_Stmts));
+
+ -- Return objects use a flag to aid their potential
+ -- finalization when the enclosing function fails to return
+ -- properly. Generate:
+
+ -- if not Flag then
+ -- <object finalization statements>
+ -- end if;
+
+ else
+ Fin_Stmts := New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Reference_To
+ (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
+
+ Then_Statements => Fin_Stmts));
end if;
end if;
end if;
@@ -4475,7 +4486,7 @@
-- the machinery in Build_Finalizer to recognize this
-- special case.
- Set_Return_Flag_Or_Transient_Decl (Temp_Id, Stmt);
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
-- Step 3: Hook the transient object to the temporary
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 188605)
+++ exp_util.adb (working copy)
@@ -7179,14 +7179,26 @@
-- transients declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
- and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ 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
- (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
return True;
+ -- Processing for intermediate results of conditional expressions
+ -- where one of the alternatives uses a controlled function call.
+
+ 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_Defining_Identifier
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Null
+ then
+ return True;
+
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should be
-- treated as controlled since they require manual cleanup.
@@ -7218,7 +7230,7 @@
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
Index: einfo.adb
===================================================================
--- einfo.adb (revision 188605)
+++ einfo.adb (working copy)
@@ -124,7 +124,7 @@
-- Extra_Formal Node15
-- Lit_Indexes Node15
-- Related_Instance Node15
- -- Return_Flag_Or_Transient_Decl Node15
+ -- Status_Flag_Or_Transient_Decl Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- String_Literal_Low_Bound Node15
@@ -2579,12 +2579,6 @@
return Flag213 (Id);
end Requires_Overriding;
- function Return_Flag_Or_Transient_Decl (Id : E) return N is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
- return Node15 (Id);
- end Return_Flag_Or_Transient_Decl;
-
function Return_Present (Id : E) return B is
begin
return Flag54 (Id);
@@ -2684,6 +2678,12 @@
return List25 (Id);
end Static_Predicate;
+ function Status_Flag_Or_Transient_Decl (Id : E) return N is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ return Node15 (Id);
+ end Status_Flag_Or_Transient_Decl;
+
function Storage_Size_Variable (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
@@ -5138,12 +5138,6 @@
Set_Flag213 (Id, V);
end Set_Requires_Overriding;
- procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E) is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
- Set_Node15 (Id, V);
- end Set_Return_Flag_Or_Transient_Decl;
-
procedure Set_Return_Present (Id : E; V : B := True) is
begin
Set_Flag54 (Id, V);
@@ -5250,6 +5244,12 @@
Set_List25 (Id, V);
end Set_Static_Predicate;
+ procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+ Set_Node15 (Id, V);
+ end Set_Status_Flag_Or_Transient_Decl;
+
procedure Set_Storage_Size_Variable (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
@@ -8238,13 +8238,13 @@
E_Package_Body =>
Write_Str ("Related_Instance");
+ when Decimal_Fixed_Point_Kind =>
+ Write_Str ("Scale_Value");
+
when E_Constant |
E_Variable =>
- Write_Str ("Return_Flag_Or_Transient_Decl");
+ Write_Str ("Status_Flag_Or_Transient_Decl");
- when Decimal_Fixed_Point_Kind =>
- Write_Str ("Scale_Value");
-
when Access_Kind |
Task_Kind =>
Write_Str ("Storage_Size_Variable");
Index: einfo.ads
===================================================================
--- einfo.ads (revision 188605)
+++ einfo.ads (working copy)
@@ -3508,15 +3508,6 @@
-- is True only for implicitly declare subprograms; it is not set on the
-- parent type's subprogram. See also Is_Abstract_Subprogram.
--- Return_Flag_Or_Transient_Decl (Node15)
--- Applies to variables and constants. Set for objects which act as the
--- return value of an extended return statement. The node contains the
--- entity of a locally declared flag which controls the finalization of
--- the return object should the function fail. Also set for access-to-
--- controlled objects used to provide a hook to controlled transients
--- declared inside an Expression_With_Actions. The node contains the
--- object declaration of the controlled transient.
-
-- Return_Present (Flag54)
-- Present in function and generic function entities. Set if the
-- function contains a return statement (used for error checking).
@@ -3687,6 +3678,14 @@
-- type of the subtype. Note that all entries are static and have values
-- within the subtype range.
+-- Status_Flag_Or_Transient_Decl (Node15)
+-- Present in variables and constants. Applies to objects that require
+-- special treatment by the finalization machinery. Such examples are
+-- extended return results, conditional expression results and objects
+-- inside N_Expression_With_Actions nodes. The attribute contains the
+-- entity of a flag which specifies particular behavior over a region
+-- of code or the declaration of a "hook" object.
+
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
@@ -5086,7 +5085,7 @@
-- Esize (Uint12)
-- Extra_Accessibility (Node13) (constants only)
-- Alignment (Uint14)
- -- Return_Flag_Or_Transient_Decl (Node15) (constants only)
+ -- Status_Flag_Or_Transient_Decl (Node15) (constants only)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
@@ -5747,7 +5746,7 @@
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
- -- Return_Flag_Or_Transient_Decl (Node15) (transient object only)
+ -- Status_Flag_Or_Transient_Decl (Node15) (transient object only)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
@@ -6367,7 +6366,6 @@
function Renaming_Map (Id : E) return U;
function Requires_Overriding (Id : E) return B;
function Return_Applies_To (Id : E) return N;
- function Return_Flag_Or_Transient_Decl (Id : E) return E;
function Return_Present (Id : E) return B;
function Returns_By_Ref (Id : E) return B;
function Reverse_Bit_Order (Id : E) return B;
@@ -6386,6 +6384,7 @@
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
function Static_Predicate (Id : E) return S;
+ function Status_Flag_Or_Transient_Decl (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
function Stored_Constraint (Id : E) return L;
function Strict_Alignment (Id : E) return B;
@@ -6963,7 +6962,6 @@
procedure Set_Renaming_Map (Id : E; V : U);
procedure Set_Requires_Overriding (Id : E; V : B := True);
procedure Set_Return_Applies_To (Id : E; V : N);
- procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Return_Present (Id : E; V : B := True);
procedure Set_Returns_By_Ref (Id : E; V : B := True);
procedure Set_Reverse_Bit_Order (Id : E; V : B := True);
@@ -6982,6 +6980,7 @@
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
procedure Set_Static_Predicate (Id : E; V : S);
+ procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Stored_Constraint (Id : E; V : L);
procedure Set_Strict_Alignment (Id : E; V : B := True);
@@ -7740,7 +7739,6 @@
pragma Inline (Renaming_Map);
pragma Inline (Requires_Overriding);
pragma Inline (Return_Applies_To);
- pragma Inline (Return_Flag_Or_Transient_Decl);
pragma Inline (Return_Present);
pragma Inline (Returns_By_Ref);
pragma Inline (Reverse_Bit_Order);
@@ -7759,6 +7757,7 @@
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
pragma Inline (Static_Predicate);
+ pragma Inline (Status_Flag_Or_Transient_Decl);
pragma Inline (Storage_Size_Variable);
pragma Inline (Stored_Constraint);
pragma Inline (Strict_Alignment);
@@ -8142,7 +8141,6 @@
pragma Inline (Set_Renaming_Map);
pragma Inline (Set_Requires_Overriding);
pragma Inline (Set_Return_Applies_To);
- pragma Inline (Set_Return_Flag_Or_Transient_Decl);
pragma Inline (Set_Return_Present);
pragma Inline (Set_Returns_By_Ref);
pragma Inline (Set_Reverse_Bit_Order);
@@ -8161,6 +8159,7 @@
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);
pragma Inline (Set_Static_Predicate);
+ pragma Inline (Set_Status_Flag_Or_Transient_Decl);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Stored_Constraint);
pragma Inline (Set_Strict_Alignment);
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 188605)
+++ exp_ch4.adb (working copy)
@@ -4267,19 +4267,83 @@
-- Deal with limited types and condition actions
procedure Expand_N_Conditional_Expression (N : Node_Id) is
+ function Create_Alternative
+ (Loc : Source_Ptr;
+ Temp_Id : Entity_Id;
+ Flag_Id : Entity_Id;
+ Expr : Node_Id) return List_Id;
+ -- Build the statements of a "then" or "else" conditional expression
+ -- alternative. Temp_Id is the conditional expression result, Flag_Id
+ -- is a finalization flag created to service expression Expr.
+
+ function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean;
+ -- Determine whether an expression is a rewritten controlled function
+ -- call.
+
+ ------------------------
+ -- Create_Alternative --
+ ------------------------
+
+ function Create_Alternative
+ (Loc : Source_Ptr;
+ Temp_Id : Entity_Id;
+ Flag_Id : Entity_Id;
+ Expr : Node_Id) return List_Id
+ is
+ Result : constant List_Id := New_List;
+
+ begin
+ -- Generate:
+ -- Fnn := True;
+
+ if Present (Flag_Id)
+ and then not Is_Controlled_Function_Call (Expr)
+ then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Flag_Id, Loc),
+ Expression => New_Reference_To (Standard_True, Loc)));
+ end if;
+
+ -- Generate:
+ -- Cnn := <expr>'Unrestricted_Access;
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expr),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ return Result;
+ end Create_Alternative;
+
+ ---------------------------------
+ -- Is_Controlled_Function_Call --
+ ---------------------------------
+
+ function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (Original_Node (Expr)) = N_Function_Call
+ and then Needs_Finalization (Etype (Expr));
+ end Is_Controlled_Function_Call;
+
+ -- Local variables
+
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := First (Expressions (N));
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
+ Actions : List_Id;
Cnn : Entity_Id;
Decl : Node_Id;
+ Expr : Node_Id;
New_If : Node_Id;
New_N : Node_Id;
- P_Decl : Node_Id;
- Expr : Node_Id;
- Actions : List_Id;
begin
-- Fold at compile time if condition known. We have already folded
@@ -4354,49 +4418,70 @@
if Is_By_Reference_Type (Typ)
and then not Back_End_Handles_Limited_Types
then
- Cnn := Make_Temporary (Loc, 'C', N);
+ declare
+ Flag_Id : Entity_Id;
+ Ptr_Typ : Entity_Id;
- P_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'A'),
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication => New_Reference_To (Typ, Loc)));
+ begin
+ Flag_Id := Empty;
- Insert_Action (N, P_Decl);
+ -- At least one of the conditional expression alternatives uses a
+ -- controlled function to provide the result. Create a status flag
+ -- to signal the finalization machinery that Cnn needs special
+ -- handling.
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cnn,
- Object_Definition =>
- New_Occurrence_Of (Defining_Identifier (P_Decl), Loc));
+ if Is_Controlled_Function_Call (Thenx)
+ or else Is_Controlled_Function_Call (Elsex)
+ then
+ Flag_Id := Make_Temporary (Loc, 'F');
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
+ end if;
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Thenx)))),
+ -- Generate:
+ -- type Ann is access all Typ;
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Elsex)))));
+ Ptr_Typ := Make_Temporary (Loc, 'A');
- New_N :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Cnn, Loc));
+ Insert_Action (N,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Reference_To (Typ, Loc))));
+ -- Generate:
+ -- Cnn : Ann;
+
+ Cnn := Make_Temporary (Loc, 'C', N);
+ Set_Ekind (Cnn, E_Variable);
+ Set_Status_Flag_Or_Transient_Decl (Cnn, Flag_Id);
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements =>
+ Create_Alternative (Sloc (Thenx), Cnn, Flag_Id, Thenx),
+ Else_Statements =>
+ Create_Alternative (Sloc (Elsex), Cnn, Flag_Id, Elsex));
+
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Cnn, Loc));
+ end;
+
-- For other types, we only need to expand if there are other actions
-- associated with either branch.
@@ -4632,7 +4717,7 @@
-- transient declaration out of the Actions list. This signals the
-- machinery in Build_Finalizer to recognize this special case.
- Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl);
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
-- Step 3: Hook the transient object to the temporary
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 188605)
+++ exp_ch6.adb (working copy)
@@ -4031,6 +4031,42 @@
-------------------------------
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
+
+ if Nkind (Context) = N_Conditional_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
@@ -4051,6 +4087,18 @@
-- the function using 'reference.
Remove_Side_Effects (N);
+
+ -- The function call is part of a conditional expression alternative.
+ -- The temporary result must live as long as the conditional expression
+ -- itself, otherwise it will be finalized too early. Mark the transient
+ -- as processed to avoid untimely finalization.
+
+ if Present (Context)
+ and then Nkind (Context) = N_Conditional_Expression
+ and then Nkind (N) = N_Explicit_Dereference
+ then
+ Set_Is_Processed_Transient (Entity (Prefix (N)));
+ end if;
end Expand_Ctrl_Function_Call;
-------------------------
@@ -5503,7 +5551,7 @@
-- Create a flag to track the function state
Flag_Id := Make_Temporary (Loc, 'F');
- Set_Return_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
+ Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
-- Insert the flag at the beginning of the function declarations,
-- generate:
@@ -5582,7 +5630,7 @@
then
declare
Flag_Id : constant Entity_Id :=
- Return_Flag_Or_Transient_Decl (Ret_Obj_Id);
+ Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
begin
-- Generate:
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2012-06-14 10:40 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-06-14 10:46 [Ada] Funalization of controlled function results in conditional expression Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).