From patchwork Wed Aug 31 09:14:22 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112479 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 79CADB6F7F for ; Wed, 31 Aug 2011 19:14:55 +1000 (EST) Received: (qmail 31784 invoked by alias); 31 Aug 2011 09:14:50 -0000 Received: (qmail 31178 invoked by uid 22791); 31 Aug 2011 09:14:42 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00,TW_TM X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 31 Aug 2011 09:14:23 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 449402BADF8; Wed, 31 Aug 2011 05:14:22 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id YHHeEwZ9oDKG; Wed, 31 Aug 2011 05:14:22 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 288192BADF7; Wed, 31 Aug 2011 05:14:22 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 195C73FEE8; Wed, 31 Aug 2011 05:14:22 -0400 (EDT) Date: Wed, 31 Aug 2011 05:14:22 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Tristan Gingold Subject: [Ada] Isolate variables used to handle exceptions during finalization Message-ID: <20110831091422.GA11384@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This is a small refactoring that remove some duplicate code. No functional change. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-31 Tristan Gingold * exp_ch7.ads, exp_ch7.adb (Finalization_Exception_Data): New type to hold variables between these following subprograms. (Build_Exception_Handler, Build_Object_Declarations, Build_Raise_Statement): Use the above type as parameter. Make the above adjustments. * exp_intr.adb (Expand_Unc_Deallocation): Adjust. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 178360) +++ exp_ch7.adb (working copy) @@ -711,36 +711,35 @@ ----------------------------- function Build_Exception_Handler - (Loc : Source_Ptr; - E_Id : Entity_Id; - Raised_Id : Entity_Id; + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id is Actuals : List_Id; Proc_To_Call : Entity_Id; begin - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); + pragma Assert (Present (Data.E_Id)); + pragma Assert (Present (Data.Raised_Id)); -- Generate: -- Get_Current_Excep.all.all Actuals := New_List ( - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - Make_Function_Call (Loc, + Make_Function_Call (Data.Loc, Name => - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - New_Reference_To (RTE (RE_Get_Current_Excep), Loc))))); + New_Reference_To (RTE (RE_Get_Current_Excep), + Data.Loc))))); if For_Library and then not Restricted_Profile then Proc_To_Call := RTE (RE_Save_Library_Occurrence); else Proc_To_Call := RTE (RE_Save_Occurrence); - Prepend_To (Actuals, New_Reference_To (E_Id, Loc)); + Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc)); end if; -- Generate: @@ -754,23 +753,23 @@ -- end if; return - Make_Exception_Handler (Loc, + Make_Exception_Handler (Data.Loc, Exception_Choices => - New_List (Make_Others_Choice (Loc)), + New_List (Make_Others_Choice (Data.Loc)), Statements => New_List ( - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Raised_Id, Loc)), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)), Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Raised_Id, Loc), - Expression => New_Reference_To (Standard_True, Loc)), + 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 (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => - New_Reference_To (Proc_To_Call, Loc), + New_Reference_To (Proc_To_Call, Data.Loc), Parameter_Associations => Actuals))))); end Build_Exception_Handler; @@ -1052,21 +1051,14 @@ -- structures right from the start. Entities and lists are created once -- it has been established that N has at least one controlled object. - Abort_Id : Entity_Id := Empty; - -- Entity of local flag. The flag is set when finalization is triggered - -- by an abort. - Components_Built : Boolean := False; -- A flag used to avoid double initialization of entities and lists. If -- the flag is set then the following variables have been initialized: -- - -- Abort_Id -- Counter_Id - -- E_Id -- Finalizer_Decls -- Finalizer_Stmts -- Jump_Alts - -- Raised_Id Counter_Id : Entity_Id := Empty; Counter_Val : Int := 0; @@ -1076,9 +1068,8 @@ -- Declarative region of N (if available). If N is a package declaration -- Decls denotes the visible declarations. - E_Id : Entity_Id := Empty; - -- Entity of the local exception occurence. The first exception which - -- occurred during finalization is stored in E_Id and later reraised. + Finalizer_Data : Finalization_Exception_Data; + -- Data for the exception Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations @@ -1140,10 +1131,6 @@ Priv_Decls : List_Id := No_List; -- The private declarations of N if N is a package declaration - Raised_Id : Entity_Id := Empty; - -- Entity for the raised flag. Along with E_Id, the flag is used in the - -- propagation of exceptions which occur during finalization. - Spec_Id : Entity_Id := Empty; Spec_Decls : List_Id := Top_Decls; Stmts : List_Id := No_List; @@ -1217,10 +1204,11 @@ Counter_Id := Make_Temporary (Loc, 'C'); Counter_Typ := Make_Temporary (Loc, 'T'); + Finalizer_Decls := New_List; + if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc, For_Package); end if; -- Since the total number of controlled objects is always known, @@ -1280,7 +1268,6 @@ Analyze (Counter_Decl); end if; - Finalizer_Decls := New_List; Jump_Alts := New_List; end if; @@ -1442,7 +1429,7 @@ and then Exceptions_OK then Append_To (Finalizer_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; -- Create the jump block which controls the finalization flow @@ -1533,14 +1520,6 @@ -- Abort_Undefer; -- Added if abort is allowed -- end Fin_Id; - if Has_Ctrl_Objs - and then Exceptions_OK - then - Prepend_List_To (Finalizer_Decls, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id, For_Package)); - end if; - -- Create the body of the finalizer Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); @@ -2567,7 +2546,7 @@ Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id, For_Package))))); + (Finalizer_Data, For_Package))))); -- When exception handlers are prohibited, the finalization call -- appears unprotected. Any exception raised during finalization @@ -2940,28 +2919,30 @@ -- Build_Object_Declarations -- ------------------------------- - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False) is A_Expr : Node_Id; E_Decl : Node_Id; - Result : List_Id; begin + pragma Assert (Decls /= No_List); + if Restriction_Active (No_Exception_Propagation) then - return Empty_List; + Data.Abort_Id := Empty; + Data.E_Id := Empty; + Data.Raised_Id := Empty; + return; end if; - pragma Assert (Present (Abort_Id)); - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); + Data.Abort_Id := Make_Temporary (Loc, 'A'); + Data.E_Id := Make_Temporary (Loc, 'E'); + Data.Raised_Id := Make_Temporary (Loc, 'R'); + Data.Loc := Loc; - Result := New_List; - -- In certain scenarios, finalization can be triggered by an abort. If -- the finalization itself fails and raises an exception, the resulting -- Program_Error must be supressed and replaced by an abort signal. In @@ -2990,9 +2971,9 @@ -- Generate: -- Abort_Id : constant Boolean := ; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Abort_Id, + Defining_Identifier => Data.Abort_Id, Constant_Present => True, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => A_Expr)); @@ -3002,23 +2983,21 @@ E_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => E_Id, + Defining_Identifier => Data.E_Id, Object_Definition => New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); - Append_To (Result, E_Decl); + Append_To (Decls, E_Decl); -- Generate: -- Raised_Id : Boolean := False; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Id, + Defining_Identifier => Data.Raised_Id, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc))); - - return Result; end Build_Object_Declarations; --------------------------- @@ -3026,10 +3005,7 @@ --------------------------- function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id + (Data : Finalization_Exception_Data) return Node_Id is Stmt : Node_Id; @@ -3039,12 +3015,12 @@ if RTE_Available (RE_Raise_From_Controlled_Operation) then Stmt := - Make_Procedure_Call_Statement (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => New_Reference_To - (RTE (RE_Raise_From_Controlled_Operation), Loc), + (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), Parameter_Associations => - New_List (New_Reference_To (E_Id, Loc))); + New_List (New_Reference_To (Data.E_Id, Data.Loc))); -- Restricted runtime: exception messages are not supported and hence -- Raise_From_Controlled_Operation is not supported. Raise Program_Error @@ -3052,7 +3028,7 @@ else Stmt := - Make_Raise_Program_Error (Loc, + Make_Raise_Program_Error (Data.Loc, Reason => PE_Finalize_Raised_Exception); end if; @@ -3064,13 +3040,13 @@ -- end if; return - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_And_Then (Loc, - Left_Opnd => New_Reference_To (Raised_Id, Loc), + Make_And_Then (Data.Loc, + Left_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc), Right_Opnd => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Abort_Id, Loc))), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))), Then_Statements => New_List (Stmt)); end Build_Raise_Statement; @@ -4222,18 +4198,17 @@ Last_Object : Node_Id; Related_Node : Node_Id) is - Abort_Id : Entity_Id; - Built : Boolean := False; - Desig : Entity_Id; - E_Id : Entity_Id; - Fin_Block : Node_Id; - Last_Fin : Node_Id := Empty; - Loc : Source_Ptr; - Obj_Id : Entity_Id; - Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; - Raised_Id : Entity_Id; - Stmt : Node_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id; + Built : Boolean := False; + Desig : Entity_Id; + Fin_Block : Node_Id; + Last_Fin : Node_Id := Empty; + Loc : Source_Ptr; + Obj_Id : Entity_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + Stmt : Node_Id; begin -- Examine all objects in the list First_Object .. Last_Object @@ -4266,13 +4241,12 @@ -- time around. if not Built then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc); - Insert_List_Before_And_Analyze (First_Object, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id)); + Insert_List_Before_And_Analyze + (First_Object, Finalizer_Decls); Built := True; end if; @@ -4306,7 +4280,7 @@ Typ => Desig)), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); Insert_After_And_Analyze (Last_Object, Fin_Block); -- The raise statement must be inserted after all the @@ -4371,7 +4345,7 @@ and then Present (Last_Fin) then Insert_After_And_Analyze (Last_Fin, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; end Process_Transient_Objects; @@ -4760,20 +4734,19 @@ function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id := Empty; - Call : Node_Id; - Comp_Ref : Node_Id; - Core_Loop : Node_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - J : Entity_Id; - Loop_Id : Entity_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Finalizer_Decls : List_Id := No_List; + Finalizer_Data : Finalization_Exception_Data; + Call : Node_Id; + Comp_Ref : Node_Id; + Core_Loop : Node_Id; + Dim : Int; + J : Entity_Id; + Loop_Id : Entity_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -4802,9 +4775,8 @@ Build_Indices; if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; Comp_Ref := @@ -4848,7 +4820,7 @@ Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Core_Loop := Call; end if; @@ -4912,14 +4884,14 @@ if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); end Build_Adjust_Or_Finalize_Statements; @@ -4929,24 +4901,23 @@ --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id; - Counter_Id : Entity_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - F : Node_Id; - Fin_Stmt : Node_Id; - Final_Block : Node_Id; - Final_Loop : Node_Id; - Init_Loop : Node_Id; - J : Node_Id; - Loop_Id : Node_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Counter_Id : Entity_Id; + Dim : Int; + F : Node_Id; + Fin_Stmt : Node_Id; + Final_Block : Node_Id; + Final_Loop : Node_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Init_Loop : Node_Id; + J : Node_Id; + Loop_Id : Node_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5081,9 +5052,8 @@ Counter_Id := Make_Temporary (Loc, 'C'); if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; -- Generate the block which houses the finalization call, the index @@ -5112,7 +5082,7 @@ Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Build_Finalization_Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Fin_Stmt := Build_Finalization_Call; end if; @@ -5204,14 +5174,14 @@ if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); Append_To (Stmts, Make_Raise_Statement (Loc)); end if; Final_Block := Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); @@ -5583,14 +5553,13 @@ ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5654,7 +5623,7 @@ Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Adj_Stmt); @@ -5792,9 +5761,8 @@ begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -5891,7 +5859,7 @@ Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Adj_Stmt); @@ -5942,7 +5910,7 @@ Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, @@ -5981,14 +5949,14 @@ else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; @@ -5999,15 +5967,14 @@ ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - Counter : Int := 0; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Counter : Int := 0; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -6140,7 +6107,7 @@ Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Fin_Stmt); @@ -6372,9 +6339,8 @@ begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -6473,7 +6439,7 @@ Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, Fin_Stmt); @@ -6526,7 +6492,7 @@ Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, @@ -6563,14 +6529,14 @@ else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; Index: exp_ch7.ads =================================================================== --- exp_ch7.ads (revision 178358) +++ exp_ch7.ads (working copy) @@ -40,10 +40,39 @@ -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. - function Build_Exception_Handler - (Loc : Source_Ptr; + -- Support of exceptions from user finalization procedures + -- + -- There is a specific mechanism to handle these exceptions, continue + -- finalization and then raise PE. + -- This mechanism is used by this package but also by exp_intr for + -- Ada.Unchecked_Deallocation. + -- There are 3 subprograms to use this mechanism, and the type + -- Finalization_Exception_Data carries internal data between these + -- subprograms: + -- + -- 1. Build_Object_Declaration: create the variables for the next two + -- subprograms. + -- 2. Build_Exception_Handler: create the exception handler for a call to + -- a user finalization procedure. + -- 3. Build_Raise_Stmt: create the code to potentially raise a PE exception + -- if am exception was raise in a user finalization procedure. + type Finalization_Exception_Data is record + Loc : Source_Ptr; + -- Sloc for the added nodes + + Abort_Id : Entity_Id; + -- Boolean variable set to true if the finalization was triggered by + -- an abort. + E_Id : Entity_Id; + -- Variable containing the exception occurrence raised by user code + Raised_Id : Entity_Id; + -- Boolean variable set to true if an exception was raised in user code + end record; + + function Build_Exception_Handler + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id; -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record -- _Body. Create an exception handler of the following form: @@ -84,15 +113,14 @@ -- Build one controlling procedure when a late body overrides one of -- the controlling operations. - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id; - -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a - -- list containing the object declarations of boolean flag Abort_Id, the - -- exception occurrence E_Id and boolean flag Raised_Id. + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False); + -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the + -- list List containing the object declarations of boolean flag Abort_Id, + -- the exception occurrence E_Id and boolean flag Raised_Id. -- -- Abort_Id : constant Boolean := -- Exception_Identity (Get_Current_Excep.all) = @@ -104,10 +132,7 @@ -- Raised_Id : Boolean := False; function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id; + (Data : Finalization_Exception_Data) return Node_Id; -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ -- Deep_Record_Body. Generate the following conditional raise statement: -- Index: exp_intr.adb =================================================================== --- exp_intr.adb (revision 178358) +++ exp_intr.adb (working copy) @@ -876,23 +876,23 @@ -- structures to find and terminate those components. procedure Expand_Unc_Deallocation (N : Node_Id) is - Arg : constant Node_Id := First_Actual (N); - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (Arg); - Desig_T : constant Entity_Id := Designated_Type (Typ); - Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); - Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); - Stmts : constant List_Id := New_List; + Arg : constant Node_Id := First_Actual (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Arg); + Desig_T : constant Entity_Id := Designated_Type (Typ); + Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + Stmts : constant List_Id := New_List; + Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); - Abort_Id : Entity_Id := Empty; + Finalizer_Data : Finalization_Exception_Data; + Blk : Node_Id := Empty; Deref : Node_Id; - E_Id : Entity_Id := Empty; Final_Code : List_Id; Free_Arg : Node_Id; Free_Node : Node_Id; Gen_Code : Node_Id; - Raised_Id : Entity_Id := Empty; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -909,7 +909,7 @@ -- Processing for pointer to controlled type - if Needs_Finalization (Desig_T) then + if Needs_Fin then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); @@ -958,13 +958,8 @@ -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end; - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Build_Object_Declarations (Finalizer_Data, Stmts, Loc); - Append_List_To (Stmts, - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id)); - Final_Code := New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -974,7 +969,7 @@ Obj_Ref => Deref, Typ => Desig_T)), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id))))); + Build_Exception_Handler (Finalizer_Data))))); -- For .NET/JVM, detach the object from the containing finalization -- collection before finalizing it. @@ -1216,9 +1211,8 @@ -- Raise_From_Controlled_Operation (E); -- all other cases -- end if; - if Present (Raised_Id) then - Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + if Needs_Fin then + Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); end if; -- If we know the argument is non-null, then make a block statement