-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- 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- --
-- Set the field Node_To_Be_Wrapped of the current scope
-- ??? The entire comment needs to be rewritten
+ -- ??? which entire comment?
-----------------------------
-- Finalization Management --
Defer_Abort : Boolean;
Fin_Id : out Entity_Id);
-- N may denote an accept statement, block, entry body, package body,
- -- package spec, protected body, subprogram body, and a task body. Create
+ -- package spec, protected body, subprogram body, or a task body. Create
-- a procedure which contains finalization calls for all controlled objects
-- declared in the declarative or statement region of N. The calls are
-- built in reverse order relative to the original declarations. In the
- -- case of a tack body, the routine delays the creation of the finalizer
+ -- case of a task body, the routine delays the creation of the finalizer
-- until all statements have been moved to the task body procedure.
-- Clean_Stmts may contain additional context-dependent code used to abort
-- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
-- Given an arbitrary entity, traverse the scope chain looking for the
-- first enclosing function. Return Empty if no function was found.
+ procedure Expand_Pragma_Initial_Condition (N : Node_Id);
+ -- Subsidiary to the expansion of package specs and bodies. Generate a
+ -- runtime check needed to verify the assumption introduced by pragma
+ -- Initial_Condition. N denotes the package spec or body.
+
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
Typ => Typ,
Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
- if not Is_Immutably_Limited_Type (Typ) then
+ if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
is
Actuals : List_Id;
Proc_To_Call : Entity_Id;
+ Except : Node_Id;
+ Stmts : List_Id;
begin
- pragma Assert (Present (Data.E_Id));
pragma Assert (Present (Data.Raised_Id));
- -- Generate:
- -- Get_Current_Excep.all.all
+ if Exception_Extra_Info
+ or else (For_Library and not Restricted_Profile)
+ then
+ if Exception_Extra_Info then
+
+ -- Generate:
+
+ -- Get_Current_Excep.all
+
+ Except :=
+ Make_Function_Call (Data.Loc,
+ Name =>
+ Make_Explicit_Dereference (Data.Loc,
+ Prefix =>
+ New_Reference_To
+ (RTE (RE_Get_Current_Excep), Data.Loc)));
+
+ else
+ -- Generate:
+
+ -- null
+
+ Except := Make_Null (Data.Loc);
+ end if;
+
+ if For_Library and then not Restricted_Profile then
+ Proc_To_Call := RTE (RE_Save_Library_Occurrence);
+ Actuals := New_List (Except);
- Actuals := New_List (
- Make_Explicit_Dereference (Data.Loc,
- Prefix =>
- Make_Function_Call (Data.Loc,
- Name =>
- Make_Explicit_Dereference (Data.Loc,
- Prefix =>
- New_Reference_To (RTE (RE_Get_Current_Excep),
- Data.Loc)))));
+ else
+ Proc_To_Call := RTE (RE_Save_Occurrence);
+
+ -- The dereference occurs only when Exception_Extra_Info is true,
+ -- and therefore Except is not null.
+
+ Actuals :=
+ New_List (
+ New_Reference_To (Data.E_Id, Data.Loc),
+ Make_Explicit_Dereference (Data.Loc, Except));
+ end if;
+
+ -- Generate:
- if For_Library and then not Restricted_Profile then
- Proc_To_Call := RTE (RE_Save_Library_Occurrence);
+ -- when others =>
+ -- if not Raised_Id then
+ -- Raised_Id := True;
+
+ -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
+ -- or
+ -- Save_Library_Occurrence (Get_Current_Excep.all);
+ -- end if;
+
+ Stmts :=
+ New_List (
+ Make_If_Statement (Data.Loc,
+ Condition =>
+ Make_Op_Not (Data.Loc,
+ Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Data.Loc,
+ Name => New_Reference_To (Data.Raised_Id, Data.Loc),
+ Expression => New_Reference_To (Standard_True, Data.Loc)),
+
+ Make_Procedure_Call_Statement (Data.Loc,
+ Name =>
+ New_Reference_To (Proc_To_Call, Data.Loc),
+ Parameter_Associations => Actuals))));
else
- Proc_To_Call := RTE (RE_Save_Occurrence);
- Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc));
+ -- Generate:
+
+ -- Raised_Id := True;
+
+ Stmts := New_List (
+ Make_Assignment_Statement (Data.Loc,
+ Name => New_Reference_To (Data.Raised_Id, Data.Loc),
+ Expression => New_Reference_To (Standard_True, Data.Loc)));
end if;
-- Generate:
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
- -- or
- -- Save_Library_Occurrence (Get_Current_Excep.all.all);
- -- end if;
+ -- when others =>
return
Make_Exception_Handler (Data.Loc,
- Exception_Choices =>
- New_List (Make_Others_Choice (Data.Loc)),
- Statements => New_List (
- Make_If_Statement (Data.Loc,
- Condition =>
- Make_Op_Not (Data.Loc,
- Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Data.Loc,
- Name => New_Reference_To (Data.Raised_Id, Data.Loc),
- Expression => New_Reference_To (Standard_True, Data.Loc)),
-
- Make_Procedure_Call_Statement (Data.Loc,
- Name =>
- New_Reference_To (Proc_To_Call, Data.Loc),
- Parameter_Associations => Actuals)))));
+ Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
+ Statements => Stmts);
end Build_Exception_Handler;
-------------------------------
then
return;
- -- Do not create finalization masters in Alfa mode because they result
+ -- Do not create finalization masters in SPARK mode because they result
-- in unwanted expansion.
- elsif Alfa_Mode then
+ -- More detail would be useful here ???
+
+ elsif GNATprove_Mode then
return;
end if;
Append_To (Finalizer_Stmts, Label);
- -- The local exception does not need to be reraised for library-
- -- level finalizers. Generate:
- --
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
-
- if not For_Package
- and then Exceptions_OK
- then
- Append_To (Finalizer_Stmts,
- Build_Raise_Statement (Finalizer_Data));
- end if;
-
-- Create the jump block which controls the finalization flow
-- depending on the value of the state counter.
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
end if;
+ -- The local exception does not need to be reraised for library-level
+ -- finalizers. Note that this action must be carried out after object
+ -- clean up, secondary stack release and abort undeferral. Generate:
+
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+
+ if Has_Ctrl_Objs
+ and then Exceptions_OK
+ and then not For_Package
+ then
+ Append_To (Finalizer_Stmts,
+ Build_Raise_Statement (Finalizer_Data));
+ end if;
+
-- Generate:
-- procedure Fin_Id is
-- Abort : constant Boolean := Triggered_By_Abort;
-- <finalization statements> -- Added if Has_Ctrl_Objs
-- <stack release> -- Added if Mark_Id exists
-- Abort_Undefer; -- Added if abort is allowed
+ -- <exception propagation> -- Added if Has_Ctrl_Objs
-- end Fin_Id;
-- Create the body of the finalizer
-- 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);
+
+ -- Process intermediate results of an if expression with one
+ -- of the alternatives using 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);
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);
then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
+
+ -- Handle the case where the original context has been wrapped in
+ -- a block to avoid interference between exception handlers and
+ -- At_End handlers. Treat the block as transparent and process its
+ -- contents.
+
+ elsif Nkind (Decl) = N_Block_Statement
+ and then Is_Finalization_Wrapper (Decl)
+ then
+ if Present (Handled_Statement_Sequence (Decl)) then
+ Process_Declarations
+ (Statements (Handled_Statement_Sequence (Decl)),
+ Preprocess);
+ end if;
+
+ Process_Declarations (Declarations (Decl), Preprocess);
end if;
Prev_Non_Pragma (Decl);
Obj_Ref => Obj_Ref,
Typ => Obj_Typ);
- if Exceptions_OK then
+ -- For CodePeer, the exception handlers normally generated here
+ -- generate complex flowgraphs which result in capacity problems.
+ -- Omitting these handlers for CodePeer is justified as follows:
+
+ -- If a handler is dead, then omitting it is surely ok
+
+ -- If a handler is live, then CodePeer should flag the
+ -- potentially-exception-raising construct that causes it
+ -- to be live. That is what we are interested in, not what
+ -- happens after the exception is raised.
+
+ if Exceptions_OK and not CodePeer_Mode then
Fin_Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
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
-- <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 =>
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Obj_Id, Loc),
Right_Opnd => Make_Null (Loc)),
-
Then_Statements => Fin_Stmts));
+
+ -- Return objects use a flag to aid in processing 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;
begin
Fin_Id := Empty;
- -- Do not perform this expansion in Alfa mode because it is not
+ -- Do not perform this expansion in SPARK mode because it is not
-- necessary.
- if Alfa_Mode then
+ if GNATprove_Mode then
return;
end if;
HSS : Node_Id;
begin
- -- Do not perform this expansion in Alfa mode because we do not create
+ -- Do not perform this expansion in SPARK mode because we do not create
-- finalizers in the first place.
- if Alfa_Mode then
+ if GNATprove_Mode then
return;
end if;
return;
end if;
- Data.Abort_Id := Make_Temporary (Loc, 'A');
- Data.E_Id := Make_Temporary (Loc, 'E');
Data.Raised_Id := Make_Temporary (Loc, 'R');
-- In certain scenarios, finalization can be triggered by an abort. If
and then VM_Target = No_VM
and then not For_Package
then
+ Data.Abort_Id := Make_Temporary (Loc, 'A');
+
A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
- -- No abort, .NET/JVM or library-level finalizers
+ -- Generate:
+
+ -- Abort_Id : constant Boolean := <A_Expr>;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data.Abort_Id,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_Boolean, Loc),
+ Expression => A_Expr));
else
- A_Expr := New_Reference_To (Standard_False, Loc);
+ -- No abort, .NET/JVM or library-level finalizers
+
+ Data.Abort_Id := Empty;
end if;
- -- Generate:
- -- Abort_Id : constant Boolean := <A_Expr>;
+ if Exception_Extra_Info then
+ Data.E_Id := Make_Temporary (Loc, 'E');
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Data.Abort_Id,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_Boolean, Loc),
- Expression => A_Expr));
+ -- Generate:
- -- Generate:
- -- E_Id : Exception_Occurrence;
+ -- E_Id : Exception_Occurrence;
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Data.E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
+ E_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data.E_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
+ Set_No_Initialization (E_Decl);
- Append_To (Decls, E_Decl);
+ Append_To (Decls, E_Decl);
+
+ else
+ Data.E_Id := Empty;
+ end if;
-- Generate:
+
-- Raised_Id : Boolean := False;
Append_To (Decls,
(Data : Finalization_Exception_Data) return Node_Id
is
Stmt : Node_Id;
+ Expr : Node_Id;
begin
-- Standard run-time and .NET/JVM targets use the specialized routine
-- Raise_From_Controlled_Operation.
- if RTE_Available (RE_Raise_From_Controlled_Operation) then
+ if Exception_Extra_Info
+ and then RTE_Available (RE_Raise_From_Controlled_Operation)
+ then
Stmt :=
Make_Procedure_Call_Statement (Data.Loc,
Name =>
end if;
-- Generate:
+
+ -- Raised_Id and then not Abort_Id
+ -- <or>
+ -- Raised_Id
+
+ Expr := New_Reference_To (Data.Raised_Id, Data.Loc);
+
+ if Present (Data.Abort_Id) then
+ Expr := Make_And_Then (Data.Loc,
+ Left_Opnd => Expr,
+ Right_Opnd =>
+ Make_Op_Not (Data.Loc,
+ Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc)));
+ end if;
+
+ -- Generate:
+
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
-- <or>
return
Make_If_Statement (Data.Loc,
- Condition =>
- Make_And_Then (Data.Loc,
- Left_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc),
- Right_Opnd =>
- Make_Op_Not (Data.Loc,
- Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),
-
+ Condition => Expr,
Then_Statements => New_List (Stmt));
end Build_Raise_Statement;
Typ => Typ,
Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
- if not Is_Immutably_Limited_Type (Typ) then
+ if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
-- with the array case and non-discriminated record cases.
Error_Msg_N
- ("task/protected object in variant record will not be freed?", N);
+ ("task/protected object in variant record will not be freed??", N);
return New_List (Make_Null_Statement (Loc));
end if;
-- If the node to wrap is an iteration_scheme, the expression is
-- one of the bounds, and the expansion will make an explicit
-- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
- -- so do not apply any transformations here.
+ -- so do not apply any transformations here. Same for an Ada 2012
+ -- iterator specification, where a block is created for the expression
+ -- that build the container.
- elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
+ elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
+ N_Iterator_Specification)
+ then
null;
-- In formal verification mode, if the node to wrap is a pragma check,
-- this node and enclosed expression are not expanded, so do not apply
-- any transformations here.
- elsif Alfa_Mode
+ elsif GNATprove_Mode
and then Nkind (Wrap_Node) = N_Pragma
and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
then
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
- Requires_Cleanup_Actions (N)
+ Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
Make_Block_Statement (Loc,
Handled_Statement_Sequence => HSS);
+ -- Signal the finalization machinery that this particular block
+ -- contains the original context.
+
+ Set_Is_Finalization_Wrapper (Block);
+
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
HSS := Handled_Statement_Sequence (N);
end if;
Build_Task_Activation_Call (N);
+
+ -- When the package is subject to pragma Initial_Condition, the
+ -- assertion expression must be verified at the end of the body
+ -- statements.
+
+ if Present (Get_Pragma (Spec_Ent, Pragma_Initial_Condition)) then
+ Expand_Pragma_Initial_Condition (N);
+ end if;
+
Pop_Scope;
end if;
if No_Body then
Push_Scope (Id);
- if Has_RACW (Id) then
-
- -- Generate RACW subprogram bodies
+ -- Generate RACW subprogram bodies
+ if Has_RACW (Id) then
Decls := Private_Declarations (Spec);
if No (Decls) then
Analyze_List (Decls);
end if;
+ -- Generate task activation call as last step of elaboration
+
if Present (Activation_Chain_Entity (N)) then
+ Build_Task_Activation_Call (N);
+ end if;
- -- Generate task activation call as last step of elaboration
+ -- When the package is subject to pragma Initial_Condition and lacks
+ -- a body, the assertion expression must be verified at the end of
+ -- the visible declarations. Otherwise the check is performed at the
+ -- end of the body statements (see Expand_N_Package_Body).
- Build_Task_Activation_Call (N);
+ if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
+ Expand_Pragma_Initial_Condition (N);
end if;
Pop_Scope;
end if;
end Expand_N_Package_Declaration;
+ -------------------------------------
+ -- Expand_Pragma_Initial_Condition --
+ -------------------------------------
+
+ procedure Expand_Pragma_Initial_Condition (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Check : Node_Id;
+ Expr : Node_Id;
+ Init_Cond : Node_Id;
+ List : List_Id;
+ Pack_Id : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Package_Body then
+ Pack_Id := Corresponding_Spec (N);
+
+ if Present (Handled_Statement_Sequence (N)) then
+ List := Statements (Handled_Statement_Sequence (N));
+
+ -- The package body lacks statements, create an empty list
+
+ else
+ List := New_List;
+
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
+ end if;
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Pack_Id := Defining_Entity (N);
+
+ if Present (Visible_Declarations (Specification (N))) then
+ List := Visible_Declarations (Specification (N));
+
+ -- The package lacks visible declarations, create an empty list
+
+ else
+ List := New_List;
+
+ Set_Visible_Declarations (Specification (N), List);
+ end if;
+
+ -- This routine should not be used on anything other than packages
+
+ else
+ raise Program_Error;
+ end if;
+
+ Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
+
+ -- The caller should check whether the package is subject to pragma
+ -- Initial_Condition.
+
+ pragma Assert (Present (Init_Cond));
+
+ Expr :=
+ Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
+
+ -- The assertion expression was found to be illegal, do not generate the
+ -- runtime check as it will repeat the illegality.
+
+ if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
+ return;
+ end if;
+
+ -- Generate:
+ -- pragma Check (Initial_Condition, <Expr>);
+
+ Check :=
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Initial_Condition)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression => New_Copy_Tree (Expr))));
+
+ Append_To (List, Check);
+ Analyze (Check);
+ end Expand_Pragma_Initial_Condition;
+
-----------------------------
-- Find_Node_To_Be_Wrapped --
-----------------------------
------------------------------------
procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
- SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
- After : List_Id renames SE.Actions_To_Be_Wrapped_After;
- Before : List_Id renames SE.Actions_To_Be_Wrapped_Before;
+ After : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After;
+ Before : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before;
+ -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
+ -- Last), but this was incorrect as Process_Transient_Object may
+ -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
procedure Process_Transient_Objects
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id)
is
- Requires_Hooking : constant Boolean :=
- Nkind_In (N, N_Function_Call,
- N_Procedure_Call_Statement);
+ Must_Hook : Boolean := False;
+ -- Flag denoting whether the context requires transient variable
+ -- export to the outer finalizer.
+
+ function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
+ -- Determine whether an arbitrary node denotes a subprogram call
+
+ ------------------------
+ -- Is_Subprogram_Call --
+ ------------------------
+
+ function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
+ begin
+ -- A regular procedure or function call
+
+ if Nkind (N) in N_Subprogram_Call then
+ Must_Hook := True;
+ return Abandon;
+
+ -- Detect a call to a function that returns on the secondary stack
+
+ elsif Nkind (N) = N_Object_Declaration
+ and then Nkind (Original_Node (Expression (N))) = N_Function_Call
+ then
+ Must_Hook := True;
+ return Abandon;
+
+ -- Keep searching
+
+ else
+ return OK;
+ end if;
+ end Is_Subprogram_Call;
+
+ procedure Detect_Subprogram_Call is
+ new Traverse_Proc (Is_Subprogram_Call);
+
+ -- Local variables
Built : Boolean := False;
Desig_Typ : Entity_Id;
Obj_Id : Entity_Id;
Obj_Ref : Node_Id;
Obj_Typ : Entity_Id;
+ Prev_Fin : Node_Id := Empty;
Stmt : Node_Id;
Stmts : List_Id;
Temp_Id : Entity_Id;
+ -- Start of processing for Process_Transient_Objects
+
begin
+ -- Search the context for at least one subprogram call. If found, the
+ -- machinery exports all transient objects to the enclosing finalizer
+ -- due to the possibility of abnormal call termination.
+
+ Detect_Subprogram_Call (N);
+
-- Examine all objects in the list First_Object .. Last_Object
Stmt := First_Object;
Fin_Decls := New_List;
Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
- Insert_List_Before_And_Analyze (First_Object, Fin_Decls);
Built := True;
end if;
-- enclosing sequence of statements where their corresponding
-- "hooks" are picked up by the finalization machinery.
- if Requires_Hooking then
+ if Must_Hook then
declare
Expr : Node_Id;
Ptr_Id : Entity_Id;
-- 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
-- Generate:
-- Temp := null;
- if Requires_Hooking then
+ if Must_Hook then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
Exception_Handlers => New_List (
Build_Exception_Handler (Fin_Data))));
- Insert_After_And_Analyze (Last_Object, Fin_Block);
+ -- The single raise statement must be inserted after all the
+ -- finalization blocks, and we put everything into a wrapper
+ -- block to clearly expose the construct to the back-end.
- -- The raise statement must be inserted after all the
- -- finalization blocks.
+ if Present (Prev_Fin) then
+ Insert_Before_And_Analyze (Prev_Fin, Fin_Block);
+ else
+ Insert_After_And_Analyze (Last_Object,
+ Make_Block_Statement (Loc,
+ Declarations => Fin_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Block))));
- if No (Last_Fin) then
Last_Fin := Fin_Block;
end if;
- -- When the associated node is an array object, the expander may
- -- sometimes generate a loop and create transient objects inside
- -- the loop.
-
- elsif Nkind (Related_Node) = N_Object_Declaration
- and then Is_Array_Type
- (Base_Type
- (Etype (Defining_Identifier (Related_Node))))
- and then Nkind (Stmt) = N_Loop_Statement
- then
- declare
- Block_HSS : Node_Id := First (Statements (Stmt));
-
- begin
- -- The loop statements may have been wrapped in a block by
- -- Process_Statements_For_Controlled_Objects, inspect the
- -- handled sequence of statements.
-
- if Nkind (Block_HSS) = N_Block_Statement
- and then No (Next (Block_HSS))
- then
- Block_HSS := Handled_Statement_Sequence (Block_HSS);
-
- Process_Transient_Objects
- (First_Object => First (Statements (Block_HSS)),
- Last_Object => Last (Statements (Block_HSS)),
- Related_Node => Related_Node);
-
- -- Inspect the statements of the loop
-
- else
- Process_Transient_Objects
- (First_Object => First (Statements (Stmt)),
- Last_Object => Last (Statements (Stmt)),
- Related_Node => Related_Node);
- end if;
- end;
+ Prev_Fin := Fin_Block;
+ end if;
- -- Terminate the scan after the last object has been processed
+ -- Terminate the scan after the last object has been processed to
+ -- avoid touching unrelated code.
- elsif Stmt = Last_Object then
+ if Stmt = Last_Object then
exit;
end if;
end if;
declare
- Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
- First_Obj : Node_Id;
- Last_Obj : Node_Id;
- Target : Node_Id;
+ Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
+ First_Obj : Node_Id;
+ Last_Obj : Node_Id;
+ Target : Node_Id;
begin
-- If the node to be wrapped is the trigger of an asynchronous
-- Reset the action lists
if Present (Before) then
- Before := No_List;
+ Scope_Stack.Table (Scope_Stack.Last).
+ Actions_To_Be_Wrapped_Before := No_List;
end if;
if Present (After) then
- After := No_List;
+ Scope_Stack.Table (Scope_Stack.Last).
+ Actions_To_Be_Wrapped_After := No_List;
end if;
end;
end Insert_Actions_In_Scope_Around;
begin
return
Is_Protected_Type (T)
+ and then not Uses_Lock_Free (T)
and then not Has_Entries (T)
and then Is_RTE (Find_Protection_Type (T), RE_Protection);
end Is_Simple_Protected_Type;
-------------------------------
procedure Wrap_Transient_Expression (N : Node_Id) is
- Expr : constant Node_Id := Relocate_Node (N);
Loc : constant Source_Ptr := Sloc (N);
+ Expr : Node_Id := Relocate_Node (N);
Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
Typ : constant Entity_Id := Etype (N);
-- declare
-- M : constant Mark_Id := SS_Mark;
-- procedure Finalizer is ... (See Build_Finalizer)
-
+ --
-- begin
- -- Temp := <Expr>;
+ -- Temp := <Expr>; -- general case
+ -- Temp := (if <Expr> then True else False); -- boolean case
--
-- at end
-- Finalizer;
-- end;
+ -- A special case is made for Boolean expressions so that the back-end
+ -- knows to generate a conditional branch instruction, if running with
+ -- -fpreserve-control-flow. This ensures that a control flow change
+ -- signalling the decision outcome occurs before the cleanup actions.
+
+ if Opt.Suppress_Control_Flow_Optimizations
+ and then Is_Boolean_Type (Typ)
+ then
+ Expr :=
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ Expr,
+ New_Occurrence_Of (Standard_True, Loc),
+ New_Occurrence_Of (Standard_False, Loc)));
+ end if;
+
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
projects / platform / upstream / gcc.git / blobdiff