Result : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Body_Decl);
+ Last_Decl : Node_Id;
Params : List_Id := No_List;
Proc_Bod : Node_Id;
Proc_Decl : Node_Id;
Proc_Id : Entity_Id;
Proc_Spec : Node_Id;
+ -- Extra declarations needed to handle interactions between
+ -- postconditions and finalization.
+
+ Postcond_Enabled_Decl : Node_Id;
+ Return_Success_Decl : Node_Id;
+ Result_Obj_Decl : Node_Id;
+ Result_Obj_Type_Decl : Node_Id;
+ Result_Obj_Type : Entity_Id;
+
+ -- Start of processing for Build_Postconditions_Procedure
+
begin
-- Nothing to do if there are no actions to check on exit
return;
end if;
+ -- Otherwise, we generate the postcondition procedure and add
+ -- associated objects and conditions used to coordinate postcondition
+ -- evaluation with finalization.
+
+ -- Generate:
+ --
+ -- procedure _postconditions (Return_Exp : Result_Typ);
+ --
+ -- -- Result_Obj_Type created when Result_Type is non-elementary
+ -- [type Result_Obj_Type is access all Result_Typ;]
+ --
+ -- Result_Obj : Result_Obj_Type;
+ --
+ -- Postcond_Enabled : Boolean := True;
+ -- Return_Success_For_Postcond : Boolean := False;
+ --
+ -- procedure _postconditions (Return_Exp : Result_Typ) is
+ -- begin
+ -- if Postcond_Enabled and then Return_Success_For_Postcond then
+ -- [stmts];
+ -- end if;
+ -- end;
+
Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions);
Set_Debug_Info_Needed (Proc_Id);
Set_Postconditions_Proc (Subp_Id, Proc_Id);
-- body. This ensures that the body will not cause any premature
-- freezing, as it may mention types:
+ -- Generate:
+ --
-- procedure Proc (Obj : Array_Typ) is
-- procedure _postconditions is
-- begin
-- ... Obj ...
-- end _postconditions;
-
+ --
-- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1));
-- begin
Insert_Before_First_Source_Declaration
(Proc_Decl, Declarations (Body_Decl));
Analyze (Proc_Decl);
+ Last_Decl := Proc_Decl;
+
+ -- When Result is present (e.g. the postcondition checks apply to a
+ -- function) we make a local object to capture the result, so, if
+ -- needed, we can call the generated postconditions procedure during
+ -- finalization instead of at the point of return.
+
+ -- Note: The placement of the following declarations before the
+ -- declaration of the body of the postconditions, but after the
+ -- declaration of the postconditions spec is deliberate and required
+ -- since other code within the expander expects them to be located
+ -- here. Perhaps when more space is available in the tree this will
+ -- no longer be necessary ???
+
+ if Present (Result) then
+ -- Elementary result types mean a copy is cheap and preferred over
+ -- using pointers.
+
+ if Is_Elementary_Type (Etype (Result)) then
+ Result_Obj_Type := Etype (Result);
+
+ -- Otherwise, we create a named access type to capture the result
+
+ -- Generate:
+ --
+ -- type Result_Obj_Type is access all [Result_Type];
+
+ else
+ Result_Obj_Type := Make_Temporary (Loc, 'R');
+
+ Result_Obj_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Result_Obj_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of
+ (Etype (Result), Loc)));
+ Insert_After_And_Analyze (Proc_Decl, Result_Obj_Type_Decl);
+ Last_Decl := Result_Obj_Type_Decl;
+ end if;
+
+ -- Create the result obj declaration
+
+ -- Generate:
+ --
+ -- Result_Object_For_Postcond : Result_Obj_Type;
+
+ Result_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uResult_Object_For_Postcond),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Result_Obj_Type, Loc));
+ Set_No_Initialization (Result_Obj_Decl);
+ Insert_After_And_Analyze (Last_Decl, Result_Obj_Decl);
+ Last_Decl := Result_Obj_Decl;
+ end if;
+
+ -- Build the Postcond_Enabled flag used to delay evaluation of
+ -- postconditions until finalization has been performed when cleanup
+ -- actions are present.
+
+ -- Generate:
+ --
+ -- Postcond_Enabled : Boolean := True;
+
+ Postcond_Enabled_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uPostcond_Enabled),
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc));
+ Insert_After_And_Analyze (Last_Decl, Postcond_Enabled_Decl);
+ Last_Decl := Postcond_Enabled_Decl;
+
+ -- Create a flag to indicate that return has been reached
+
+ -- This is necessary for deciding whether to execute _postconditions
+ -- during finalization.
+
+ -- Generate:
+ --
+ -- Return_Success_For_Postcond : Boolean := False;
+
+ Return_Success_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc, Name_uReturn_Success_For_Postcond),
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc));
+ Insert_After_And_Analyze (Last_Decl, Return_Success_Decl);
+ Last_Decl := Return_Success_Decl;
-- Set an explicit End_Label to override the sloc of the implicit
-- RETURN statement, and prevent it from inheriting the sloc of one
-- the postconditions: this would cause confusing debug info to be
-- produced, interfering with coverage-analysis tools.
+ -- Also, wrap the postcondition checks in a conditional which can be
+ -- used to delay their evaluation when clean-up actions are present.
+
+ -- Generate:
+ --
+ -- procedure _postconditions is
+ -- begin
+ -- if Postcond_Enabled and then Return_Success_For_Postcond then
+ -- [Stmts];
+ -- end if;
+ -- end;
+
Proc_Bod :=
Make_Subprogram_Body (Loc,
Specification =>
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts,
- End_Label => Make_Identifier (Loc, Chars (Proc_Id))));
+ End_Label => Make_Identifier (Loc, Chars (Proc_Id)),
+ Statements => New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of
+ (Defining_Identifier
+ (Postcond_Enabled_Decl), Loc),
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Defining_Identifier
+ (Return_Success_Decl), Loc)),
+ Then_Statements => Stmts))));
+ Insert_After_And_Analyze (Last_Decl, Proc_Bod);
- Insert_After_And_Analyze (Proc_Decl, Proc_Bod);
end Build_Postconditions_Procedure;
----------------------------
Freeze_Contracts;
end Freeze_Previous_Contracts;
+ --------------------------
+ -- Get_Postcond_Enabled --
+ --------------------------
+
+ function Get_Postcond_Enabled (Subp : Entity_Id) return Node_Id is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uPostcond_Enabled
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Postcond_Enabled;
+
+ ------------------------------------
+ -- Get_Result_Object_For_Postcond --
+ ------------------------------------
+
+ function Get_Result_Object_For_Postcond
+ (Subp : Entity_Id) return Node_Id
+ is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uResult_Object_For_Postcond
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Result_Object_For_Postcond;
+
+ -------------------------------------
+ -- Get_Return_Success_For_Postcond --
+ -------------------------------------
+
+ function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Node_Id
+ is
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Next (Unit_Declaration_Node (Postconditions_Proc (Subp)));
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Name_uReturn_Success_For_Postcond
+ then
+ return Defining_Identifier (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Get_Return_Success_For_Postcond;
+
---------------------------------
-- Inherit_Subprogram_Contract --
---------------------------------
-- - controlled types
-- - transient scopes
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Dist; use Exp_Dist;
-with Exp_Disp; use Exp_Disp;
-with Exp_Prag; use Exp_Prag;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Dist; use Exp_Dist;
+with Exp_Disp; use Exp_Disp;
+with Exp_Prag; use Exp_Prag;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Exp_Ch7 is
-- such as for task termination. Fin_Id is the finalizer declaration
-- entity.
+ procedure Build_Finalizer_Helper
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id;
+ Finalize_Old_Only : Boolean);
+ -- An internal routine which does all of the heavy lifting on behalf of
+ -- Build_Finalizer.
+
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-- N is a construct which contains a handled sequence of statements, Fin_Id
-- is the entity of a finalizer. Create an At_End handler which covers the
else
Append_Freeze_Actions (Ptr_Typ, Actions);
end if;
+
+ Analyze_List (Actions);
+
+ -- When the type the finalization master is being generated for was
+ -- created to store a 'Old object, then mark it as such so its
+ -- finalization can be delayed until after postconditions have been
+ -- checked.
+
+ if Stores_Attribute_Old_Prefix (Ptr_Typ) then
+ Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
+ end if;
end;
end Build_Finalization_Master;
- ---------------------
- -- Build_Finalizer --
- ---------------------
+ ----------------------------
+ -- Build_Finalizer_Helper --
+ ----------------------------
- procedure Build_Finalizer
+ procedure Build_Finalizer_Helper
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
- Fin_Id : out Entity_Id)
+ Fin_Id : out Entity_Id;
+ Finalize_Old_Only : Boolean)
is
Acts_As_Clean : constant Boolean :=
Present (Mark_Id)
-- The default name is _finalizer
else
- Fin_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Name_uFinalizer));
+ -- Generation of a finalization procedure exclusively for 'Old
+ -- interally generated constants requires different name since
+ -- there will need to be multiple finalization routines in the
+ -- same scope. See Build_Finalizer for details.
+
+ if Finalize_Old_Only then
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer_Old));
+ else
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer));
+ end if;
-- The visibility semantics of AT_END handlers force a strange
-- separation of spec and body for stack-related finalizers:
pragma Assert (Present (Spec_Decls));
- Append_To (Spec_Decls, Fin_Spec);
- Analyze (Fin_Spec);
+ -- It maybe possible that we are finalizing 'Old objects which
+ -- exist in the spec declarations. When this is the case the
+ -- Finalizer_Insert_Node will come before the end of the
+ -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
+ -- earlier at the Finalizer_Insert_Nod instead of appending to the
+ -- end of Spec_Decls to prevent its body appearing before its
+ -- corresponding spec.
+
+ if Present (Finalizer_Insert_Nod)
+ and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
+ then
+ Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
+ Finalizer_Insert_Nod := Fin_Spec;
+
+ -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
+
+ else
+ Append_To (Spec_Decls, Fin_Spec);
+ Analyze (Fin_Spec);
+ end if;
-- When the finalizer acts solely as a cleanup routine, the body
-- is inserted right after the spec.
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
+ -- Depending on the value of flag Finalize_Old_Only we determine
+ -- which objects get finalized as part of the current finalizer
+ -- being built.
+
+ -- When True, only temporaries capturing the value of attribute
+ -- 'Old are finalized and all other cases are ignored.
+
+ -- When False, temporary objects used to capture the value of 'Old
+ -- are ignored and all others are considered.
+
+ if Finalize_Old_Only
+ xor (Nkind (Decl) = N_Object_Declaration
+ and then Stores_Attribute_Old_Prefix
+ (Defining_Identifier (Decl)))
+ then
+ null;
+
-- Library-level tagged types
- if Nkind (Decl) = N_Full_Type_Declaration then
+ elsif Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
-- Ignored Ghost types do not need any cleanup actions because
New_Occurrence_Of (DT_Ptr, Loc))));
end Process_Tagged_Type_Declaration;
- -- Start of processing for Build_Finalizer
+ -- Start of processing for Build_Finalizer_Helper
begin
Fin_Id := Empty;
if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
Create_Finalizer;
end if;
- end Build_Finalizer;
+ end Build_Finalizer_Helper;
--------------------------
-- Build_Finalizer_Call --
Expand_At_End_Handler (HSS, Empty);
end Build_Finalizer_Call;
+ ---------------------
+ -- Build_Finalizer --
+ ---------------------
+
+ procedure Build_Finalizer
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id)
+ is
+ Def_Ent : constant Entity_Id := Unique_Defining_Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ -- Declarations used for the creation of _finalization_controller
+
+ Fin_Old_Id : Entity_Id := Empty;
+ Fin_Controller_Id : Entity_Id := Empty;
+ Fin_Controller_Decls : List_Id;
+ Fin_Controller_Stmts : List_Id;
+ Fin_Controller_Body : Node_Id := Empty;
+ Fin_Controller_Spec : Node_Id := Empty;
+ Postconditions_Call : Node_Id := Empty;
+
+ -- Defining identifiers for local objects used to store exception info
+
+ Raised_Post_Exception_Id : Entity_Id := Empty;
+ Raised_Finalization_Exception_Id : Entity_Id := Empty;
+ Saved_Exception_Id : Entity_Id := Empty;
+
+ -- Start of processing for Build_Finalizer
+
+ begin
+ -- Create the general finalization routine
+
+ Build_Finalizer_Helper
+ (N => N,
+ Clean_Stmts => Clean_Stmts,
+ Mark_Id => Mark_Id,
+ Top_Decls => Top_Decls,
+ Defer_Abort => Defer_Abort,
+ Fin_Id => Fin_Id,
+ Finalize_Old_Only => False);
+
+ -- When postconditions are present, expansion gets much more complicated
+ -- due to both the fact that they must be called after finalization and
+ -- that finalization of 'Old objects must occur after the postconditions
+ -- get checked.
+
+ -- Additionally, exceptions between general finalization and 'Old
+ -- finalization must be propagated correctly and exceptions which happen
+ -- during _postconditions need to be saved and reraised after
+ -- finalization of 'Old objects.
+
+ -- Generate:
+ --
+ -- Postcond_Enabled := False;
+ --
+ -- procedure _finalization_controller is
+ --
+ -- -- Exception capturing and tracking
+ --
+ -- Saved_Exception : Exception_Occurrence;
+ -- Raised_Post_Exception : Boolean := False;
+ -- Raised_Finalization_Exception : Boolean := False;
+ --
+ -- -- Start of processing for _finalization_controller
+ --
+ -- begin
+ -- -- Perform general finalization
+ --
+ -- begin
+ -- _finalizer;
+ -- exception
+ -- when others =>
+ -- -- Save the exception
+ --
+ -- Raised_Finalization_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ --
+ -- -- Perform postcondition checks after general finalization, but
+ -- -- before finalization of 'Old related objects.
+ --
+ -- if not Raised_Finalization_Exception then
+ -- begin
+ -- -- Re-enable postconditions and check them
+ --
+ -- Postcond_Enabled := True;
+ -- _postconditions [(Result_Obj_For_Postcond[.all])];
+ -- exception
+ -- when others =>
+ -- -- Save the exception
+ --
+ -- Raised_Post_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ -- end if;
+ --
+ -- -- Finally finalize 'Old related objects
+ --
+ -- begin
+ -- _finalizer_old;
+ -- exception
+ -- when others =>
+ -- -- Reraise the previous finalization error if there is
+ -- -- one.
+ --
+ -- if Raised_Finalization_Exception then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ --
+ -- -- Otherwise, reraise the current one
+ --
+ -- raise;
+ -- end;
+ --
+ -- -- Reraise any saved exception
+ --
+ -- if Raised_Finalization_Exception
+ -- or else Raised_Post_Exception
+ -- then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ -- end _finalization_controller;
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Present (Postconditions_Proc (Def_Ent))
+ then
+ Fin_Controller_Stmts := New_List;
+ Fin_Controller_Decls := New_List;
+
+ -- Build the 'Old finalizer
+
+ Build_Finalizer_Helper
+ (N => N,
+ Clean_Stmts => Empty_List,
+ Mark_Id => Mark_Id,
+ Top_Decls => Top_Decls,
+ Defer_Abort => Defer_Abort,
+ Fin_Id => Fin_Old_Id,
+ Finalize_Old_Only => True);
+
+ -- Create local declarations for _finalization_controller needed for
+ -- saving exceptions.
+ --
+ -- Generate:
+ --
+ -- Saved_Exception : Exception_Occurrence;
+ -- Raised_Post_Exception : Boolean := False;
+ -- Raised_Finalization_Exception : Boolean := False;
+
+ Saved_Exception_Id := Make_Temporary (Loc, 'S');
+ Raised_Post_Exception_Id := Make_Temporary (Loc, 'P');
+ Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F');
+
+ Append_List_To (Fin_Controller_Decls, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Saved_Exception_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Post_Exception_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Finalization_Exception_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
+
+ -- Call _finalizer and save any exceptions which occur
+
+ -- Generate:
+ --
+ -- begin
+ -- _finalizer;
+ -- exception
+ -- when others =>
+ -- Raised_Finalization_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+
+ if Present (Fin_Id) then
+ Append_To (Fin_Controller_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Fin_Id, Loc))),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc)),
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Save_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc),
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ Loc))))))))))));
+ end if;
+
+ -- Create the call to postconditions based on the kind of the current
+ -- subprogram, and the type of the Result_Obj_For_Postcond.
+
+ -- Generate:
+ --
+ -- _postconditions (Result_Obj_For_Postcond[.all]);
+ --
+ -- or
+ --
+ -- _postconditions;
+
+ if Ekind (Def_Ent) = E_Procedure then
+ Postconditions_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Def_Ent), Loc));
+ else
+ Postconditions_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Def_Ent), Loc),
+ Parameter_Associations => New_List (
+ (if Is_Elementary_Type (Etype (Def_Ent)) then
+ New_Occurrence_Of
+ (Get_Result_Object_For_Postcond
+ (Def_Ent), Loc)
+ else
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Get_Result_Object_For_Postcond
+ (Def_Ent), Loc)))));
+ end if;
+
+ -- Call _postconditions when no general finalization exceptions have
+ -- occured taking care to enable the postconditions and save any
+ -- exception occurrences.
+
+ -- Generate:
+ --
+ -- if not Raised_Finalization_Exception then
+ -- begin
+ -- Postcond_Enabled := True;
+ -- _postconditions [(Result_Obj_For_Postcond[.all])];
+ -- exception
+ -- when others =>
+ -- Raised_Post_Exception := True;
+ -- Save_Occurrence
+ -- (Saved_Exception, Get_Current_Excep.all);
+ -- end;
+ -- end if;
+
+ Append_To (Fin_Controller_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc)),
+ Then_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Postcond_Enabled (Def_Ent), Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Standard_True, Loc)),
+ Postconditions_Call),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Raised_Post_Exception_Id, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc)),
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Save_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc),
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ Loc))))))))))))));
+
+ -- Call _finalizer_old and reraise any exception that occurred during
+ -- initial finalization within the exception handler. Otherwise,
+ -- propagate the current exception.
+
+ -- Generate:
+ --
+ -- begin
+ -- _finalizer_old;
+ -- exception
+ -- when others =>
+ -- if Raised_Finalization_Exception then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+ -- raise;
+ -- end;
+
+ if Present (Fin_Old_Id) then
+ Append_To (Fin_Controller_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Fin_Old_Id, Loc))),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Reraise_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc))))),
+ Make_Raise_Statement (Loc)))))));
+ end if;
+
+ -- Once finalization is complete reraise any pending exceptions
+
+ -- Generate:
+ --
+ -- if Raised_Post_Exception
+ -- or else Raised_Finalization_Exception
+ -- then
+ -- Reraise_Occurrence (Saved_Exception);
+ -- end if;
+
+ Append_To (Fin_Controller_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of
+ (Raised_Post_Exception_Id, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc)),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of
+ (Saved_Exception_Id, Loc))))));
+
+ -- Make the finalization controller subprogram body and declaration.
+
+ -- Generate:
+ -- procedure _finalization_controller;
+ --
+ -- procedure _finalization_controller is
+ -- begin
+ -- [Fin_Controller_Stmts];
+ -- end;
+
+ Fin_Controller_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalization_Controller));
+
+ Fin_Controller_Spec :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Fin_Controller_Id));
+
+ Fin_Controller_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))),
+ Declarations => Fin_Controller_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Controller_Stmts));
+
+ -- Disable _postconditions calls which get generated before return
+ -- statements to delay their evaluation until after finalization.
+
+ -- This is done by way of the local Postcond_Enabled object which is
+ -- initially assigned to True - we then create an assignment within
+ -- the subprogram's declaration to make it False and assign it back
+ -- to True before _postconditions is called within
+ -- _finalization_controller.
+
+ -- Generate:
+ --
+ -- Postcond_Enable := False;
+
+ Append_To (Top_Decls,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Get_Postcond_Enabled (Def_Ent), Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Standard_False, Loc)));
+
+ -- Add the subprogram to the list of declarations an analyze it
+
+ Append_To (Top_Decls, Fin_Controller_Spec);
+ Analyze (Fin_Controller_Spec);
+ Insert_After (Fin_Controller_Spec, Fin_Controller_Body);
+ Analyze (Fin_Controller_Body, Suppress => All_Checks);
+
+ -- Return the finalization controller as the result Fin_Id
+
+ Fin_Id := Fin_Controller_Id;
+ end if;
+ end Build_Finalizer;
+
---------------------
-- Build_Late_Proc --
---------------------
Nkind (N) = N_Block_Statement
and then Present (Cleanup_Actions (N));
+ Has_Postcondition : constant Boolean :=
+ Nkind (N) = N_Subprogram_Body
+ and then Present
+ (Postconditions_Proc
+ (Unique_Defining_Entity (N)));
+
Actions_Required : constant Boolean :=
Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
end;
end if;
+ -- Move the _postconditions subprogram declaration and its associated
+ -- objects into the declarations section so that it is callable
+ -- within _postconditions.
+
+ if Has_Postcondition then
+ declare
+ Decl : Node_Id;
+ Prev_Decl : Node_Id;
+
+ begin
+ Decl :=
+ Prev (Subprogram_Body
+ (Postconditions_Proc (Current_Subprogram)));
+ while Present (Decl) loop
+ Prev_Decl := Prev (Decl);
+
+ Remove (Decl);
+ Prepend_To (New_Decls, Decl);
+
+ exit when Nkind (Decl) = N_Subprogram_Declaration
+ and then Chars (Corresponding_Body (Decl))
+ = Name_uPostconditions;
+
+ Decl := Prev_Decl;
+ end loop;
+ end;
+ end if;
+
-- Ensure the presence of a declaration list in order to successfully
-- append all original statements to it.
projects / gcc.git / commitdiff