From 6e840989730297abbe1610c3b15ecb565e967f1f Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Fri, 23 Oct 2015 10:43:30 +0000 Subject: [PATCH] exp_ch7.adb (Process_Transient_Objects): Reimplement to properly handle restriction No_Exception_Propagation. 2015-10-23 Hristian Kirtchev * exp_ch7.adb (Process_Transient_Objects): Reimplement to properly handle restriction No_Exception_Propagation. * exp_ch11.adb (Expand_At_End_Handler): Update the parameter profile and all references to Block. * exp_ch11.ads (Expand_At_End_Handler): Update the parameter profile and comment on usage. * exp_intr.adb (Expand_Unc_Deallocation): Reimplement to properly handle restriction No_Exception_Propagation. * gnat1drv.adb, restrict.adb: Update comment. From-SVN: r229227 --- gcc/ada/ChangeLog | 12 ++ gcc/ada/exp_ch11.adb | 8 +- gcc/ada/exp_ch11.ads | 13 +-- gcc/ada/exp_ch7.adb | 324 ++++++++++++++++++++++++++++++++------------------- gcc/ada/exp_intr.adb | 305 +++++++++++++++++++++++++----------------------- gcc/ada/gnat1drv.adb | 5 +- gcc/ada/restrict.adb | 14 ++- 7 files changed, 395 insertions(+), 286 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 02301d5..03a8dd9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2015-10-23 Hristian Kirtchev + + * exp_ch7.adb (Process_Transient_Objects): Reimplement to properly + handle restriction No_Exception_Propagation. + * exp_ch11.adb (Expand_At_End_Handler): Update the parameter + profile and all references to Block. + * exp_ch11.ads (Expand_At_End_Handler): Update the parameter + profile and comment on usage. + * exp_intr.adb (Expand_Unc_Deallocation): Reimplement to properly + handle restriction No_Exception_Propagation. + * gnat1drv.adb, restrict.adb: Update comment. + 2015-10-23 Bob Duff * exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not call diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 7987045..9580d2d 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -99,7 +99,7 @@ package body Exp_Ch11 is -- and the code generator (e.g. gigi) must still handle proper generation -- of cleanup calls for the non-exceptional case. - procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is + procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); Ohandle : Node_Id; Stmnts : List_Id; @@ -138,8 +138,8 @@ package body Exp_Ch11 is return; end if; - if Present (Block) then - Push_Scope (Block); + if Present (Blk_Id) then + Push_Scope (Blk_Id); end if; Ohandle := @@ -175,7 +175,7 @@ package body Exp_Ch11 is Analyze_List (Stmnts, Suppress => All_Checks); Expand_Exception_Handlers (HSS); - if Present (Block) then + if Present (Blk_Id) then Pop_Scope; end if; end Expand_At_End_Handler; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index ab93d5d..cdd53de 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -40,12 +40,11 @@ package Exp_Ch11 is -- See runtime routine Ada.Exceptions for full details on the format and -- content of these tables. - procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id); - -- Given a handled statement sequence, HSS, for which the At_End_Proc - -- field is set, and which currently has no exception handlers, this - -- procedure expands the special exception handler required. - -- This procedure also create a new scope for the given Block, if - -- Block is not Empty. + procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id); + -- Given handled statement sequence HSS for which the At_End_Proc field + -- is set, and which currently has no exception handlers, this procedure + -- expands the special exception handler required. This procedure also + -- create a new scope for the given block, if Blk_Id is not Empty. procedure Expand_Exception_Handlers (HSS : Node_Id); -- This procedure expands exception handlers, and is called as part diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5a241b2..58a3322 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4683,28 +4683,97 @@ package body Exp_Ch7 is -- Local variables + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Built : Boolean := False; + Blk_Decl : Node_Id := Empty; + Blk_Decls : List_Id := No_List; + Blk_Ins : Node_Id; + Blk_Stmts : List_Id; Desig_Typ : Entity_Id; - Expr : Node_Id; - Fin_Block : Node_Id; + Fin_Call : Node_Id; Fin_Data : Finalization_Exception_Data; - Fin_Decls : List_Id; - Fin_Insrt : Node_Id; - Last_Fin : Node_Id := Empty; + Fin_Stmts : List_Id; + Hook_Clr : Node_Id := Empty; + Hook_Id : Entity_Id; + Hook_Ins : Node_Id; + Init_Expr : Node_Id; Loc : Source_Ptr; + Obj_Decl : Node_Id; Obj_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; - Prev_Fin : Node_Id := Empty; - Ptr_Id : Entity_Id; - Stmt : Node_Id; - Stmts : List_Id; - Temp_Id : Entity_Id; - Temp_Ins : Node_Id; + Ptr_Typ : Entity_Id; -- Start of processing for Process_Transient_Objects begin + -- The expansion performed by this routine is as follows: + + -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; + -- Hook_1 : Ptr_Typ_1 := null; + -- Ctrl_Trans_Obj_1 : ...; + -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; + -- . . . + -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; + -- Hook_N : Ptr_Typ_N := null; + -- Ctrl_Trans_Obj_N : ...; + -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; + + -- declare + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + -- begin + -- begin + -- Hook_N := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_N); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + -- . . . + -- begin + -- Hook_1 := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_1); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + + -- if Raised and not Abrt then + -- Raise_From_Controlled_Operation (Ex); + -- end if; + -- end; + + -- When restriction No_Exception_Propagation is active, the expansion + -- is as follows: + + -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; + -- Hook_1 : Ptr_Typ_1 := null; + -- Ctrl_Trans_Obj_1 : ...; + -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; + -- . . . + -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; + -- Hook_N : Ptr_Typ_N := null; + -- Ctrl_Trans_Obj_N : ...; + -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; + + -- begin + -- Hook_N := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_N); + -- Hook_1 := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_1); + -- end; + -- Recognize a scenario where the transient context is an object -- declaration initialized by a build-in-place function call: @@ -4723,7 +4792,7 @@ package body Exp_Ch7 is and then Present (BIP_Initialization_Call (Defining_Identifier (N))) then Must_Hook := True; - Fin_Insrt := BIP_Initialization_Call (Defining_Identifier (N)); + Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); -- Search the context for at least one subprogram call. If found, the -- machinery exports all transient objects to the enclosing finalizer @@ -4731,24 +4800,28 @@ package body Exp_Ch7 is else Detect_Subprogram_Call (N); - Fin_Insrt := Last_Object; + Blk_Ins := Last_Object; + end if; + + if Clean then + Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); end if; -- Examine all objects in the list First_Object .. Last_Object - Stmt := First_Object; - while Present (Stmt) loop - if Nkind (Stmt) = N_Object_Declaration - and then Analyzed (Stmt) - and then Is_Finalizable_Transient (Stmt, N) + Obj_Decl := First_Object; + while Present (Obj_Decl) loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Analyzed (Obj_Decl) + and then Is_Finalizable_Transient (Obj_Decl, N) -- Do not process the node to be wrapped since it will be -- handled by the enclosing finalizer. - and then Stmt /= Related_Node + and then Obj_Decl /= Related_Node then - Loc := Sloc (Stmt); - Obj_Id := Defining_Identifier (Stmt); + Loc := Sloc (Obj_Decl); + Obj_Id := Defining_Identifier (Obj_Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); Desig_Typ := Obj_Typ; @@ -4760,18 +4833,8 @@ package body Exp_Ch7 is Desig_Typ := Available_View (Designated_Type (Desig_Typ)); end if; - -- Create the necessary entities and declarations the first - -- time around. - - if not Built then - Built := True; - Fin_Decls := New_List; - - Build_Object_Declarations (Fin_Data, Fin_Decls, Loc); - end if; - - -- Transient variables associated with subprogram calls need - -- extra processing. These variables are usually created right + -- Transient objects associated with subprogram calls need + -- extra processing. These objects are usually created right -- before the call and finalized immediately after the call. -- If an exception occurs during the call, the clean up code -- is skipped due to the sudden change in control and the @@ -4783,16 +4846,15 @@ package body Exp_Ch7 is if Must_Hook then - -- Step 1: Create an access type which provides a reference - -- to the transient object. Generate: - - -- Ann : access [all] ; + -- Create an access type which provides a reference to the + -- transient object. Generate: + -- type Ptr_Typ is access [all] Desig_Typ; - Ptr_Id := Make_Temporary (Loc, 'A'); + Ptr_Typ := Make_Temporary (Loc, 'A'); - Insert_Action (Stmt, + Insert_Action (Obj_Decl, Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Id, + Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => @@ -4800,42 +4862,39 @@ package body Exp_Ch7 is Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)))); - -- Step 2: Create a temporary which acts as a hook to the - -- transient object. Generate: - - -- Temp : Ptr_Id := null; + -- Create a temporary which acts as a hook to the transient + -- object. Generate: + -- Hook : Ptr_Typ := null; - Temp_Id := Make_Temporary (Loc, 'T'); + Hook_Id := Make_Temporary (Loc, 'T'); - Insert_Action (Stmt, + Insert_Action (Obj_Decl, Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, + Defining_Identifier => Hook_Id, Object_Definition => - New_Occurrence_Of (Ptr_Id, Loc))); + New_Occurrence_Of (Ptr_Typ, Loc))); - -- Mark the temporary as a transient hook. This signals the - -- machinery in Build_Finalizer to recognize this special - -- case. + -- Mark the temporary as a hook. This signals the machinery + -- in Build_Finalizer to recognize this special case. - Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt); + Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); - -- Step 3: Hook the transient object to the temporary + -- Hook the transient object to the temporary. Generate: + -- Hook := Ptr_Typ (Obj_Id); + -- + -- Hook := Obj_Id'Unrestricted_Access; if Is_Access_Type (Obj_Typ) then - Expr := - Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc)); + Init_Expr := + Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); + else - Expr := + Init_Expr := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Obj_Id, Loc), Attribute_Name => Name_Unrestricted_Access); end if; - -- Generate: - -- Temp := Ptr_Id (Obj_Id); - -- - -- Temp := Obj_Id'Unrestricted_Access; - -- When the transient object is initialized by an aggregate, -- the hook must capture the object after the last component -- assignment takes place. Only then is the object fully @@ -4844,55 +4903,88 @@ package body Exp_Ch7 is if Ekind (Obj_Id) = E_Variable and then Present (Last_Aggregate_Assignment (Obj_Id)) then - Temp_Ins := Last_Aggregate_Assignment (Obj_Id); + Hook_Ins := Last_Aggregate_Assignment (Obj_Id); -- Otherwise the hook seizes the related object immediately else - Temp_Ins := Stmt; + Hook_Ins := Obj_Decl; end if; - Insert_After_And_Analyze (Temp_Ins, + Insert_After_And_Analyze (Hook_Ins, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Expr)); + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Init_Expr)); + + -- The transient object is about to be finalized by the + -- clean up code following the subprogram call. In order + -- to avoid double finalization, clear the hook. + + -- Generate: + -- Hook := null; + + Hook_Clr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Make_Null (Loc)); end if; - Stmts := New_List; + -- Before generating the clean up code for the first transient + -- object, create a wrapper block which houses all hook clear + -- statements and finalization calls. This wrapper is needed by + -- the back-end. - -- The transient object is about to be finalized by the clean - -- up code following the subprogram call. In order to avoid - -- double finalization, clear the hook. + if not Built then + Built := True; + Blk_Stmts := New_List; - -- Generate: - -- Temp := null; + -- Create the declarations of all entities that participate + -- in exception detection and propagation. - if Must_Hook then - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Make_Null (Loc))); + if Exceptions_OK then + Blk_Decls := New_List; + + -- Generate: + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); + + -- Generate: + -- if Raised and then not Abrt then + -- Raise_From_Controlled_Operation (Ex); + -- end if; + + Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); + end if; + + Blk_Decl := + Make_Block_Statement (Loc, + Declarations => Blk_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Blk_Stmts)); end if; -- Generate: -- [Deep_]Finalize (Obj_Ref); - -- Set type of dereference, so that proper conversion are - -- generated when operation is inherited. - Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); if Is_Access_Type (Obj_Typ) then Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Set_Etype (Obj_Ref, Directly_Designated_Type (Obj_Typ)); + Set_Etype (Obj_Ref, Desig_Typ); end if; - Append_To (Stmts, - Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ)); + Fin_Call := + Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); - -- Generate: - -- [Temp := null;] + -- When exception propagation is enabled wrap the hook clear + -- statement and the finalization call into a block to catch + -- potential exceptions raised during finalization. Generate: -- begin + -- [Temp := null;] -- [Deep_]Finalize (Obj_Ref); -- exception @@ -4904,60 +4996,48 @@ package body Exp_Ch7 is -- end if; -- end; - Fin_Block := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Fin_Data)))); + if Exceptions_OK then + Fin_Stmts := New_List; - -- 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. + if Present (Hook_Clr) then + Append_To (Fin_Stmts, Hook_Clr); + end if; - if Present (Prev_Fin) then - Insert_Before_And_Analyze (Prev_Fin, Fin_Block); - else - Insert_After_And_Analyze (Fin_Insrt, + Append_To (Fin_Stmts, Fin_Call); + + Prepend_To (Blk_Stmts, Make_Block_Statement (Loc, - Declarations => Fin_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Fin_Block)))); + Statements => Fin_Stmts, + Exception_Handlers => New_List ( + Build_Exception_Handler (Fin_Data))))); - Last_Fin := Fin_Block; - end if; + -- Otherwise generate: + -- [Temp := null;] + -- [Deep_]Finalize (Obj_Ref); + + else + Prepend_To (Blk_Stmts, Fin_Call); - Prev_Fin := Fin_Block; + if Present (Hook_Clr) then + Prepend_To (Blk_Stmts, Hook_Clr); + end if; + end if; end if; -- Terminate the scan after the last object has been processed to -- avoid touching unrelated code. - if Stmt = Last_Object then + if Obj_Decl = Last_Object then exit; end if; - Next (Stmt); + Next (Obj_Decl); end loop; - if Clean then - if Present (Prev_Fin) then - Insert_List_Before_And_Analyze (Prev_Fin, Act_Cleanup); - else - Insert_List_After_And_Analyze (Fin_Insrt, Act_Cleanup); - end if; - end if; - - -- Generate: - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; - - if Built and then Present (Last_Fin) then - Insert_After_And_Analyze (Last_Fin, - Build_Raise_Statement (Fin_Data)); + if Present (Blk_Decl) then + Insert_After_And_Analyze (Blk_Ins, Blk_Decl); end if; end Process_Transient_Objects; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 606f6a5..bbdcf77 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -959,39 +959,15 @@ package body Exp_Intr is -- Expand_Unc_Deallocation -- ----------------------------- - -- Generate the following Code : - - -- if Arg /= null then - -- (.., T'Class(Arg.all), ..); -- for controlled types - -- Free (Arg); - -- Arg := Null; - -- end if; - - -- For a task, we also generate a call to Free_Task to ensure that the - -- task itself is freed if it is terminated, ditto for a simple protected - -- object, with a call to Finalize_Protection. For composite types that - -- have tasks or simple protected objects as components, we traverse the - -- 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); + Desig_Typ : constant Entity_Id := Designated_Type (Typ); + Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ); + Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ); Stmts : constant List_Id := New_List; - Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); - - Finalizer_Data : Finalization_Exception_Data; - - Blk : Node_Id := Empty; - Blk_Id : Entity_Id; - Deref : Node_Id; - Final_Code : List_Id; - Free_Arg : Node_Id; - Free_Node : Node_Id; - Gen_Code : Node_Id; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -999,6 +975,20 @@ package body Exp_Intr is -- that we analyze some generated statements before properly attaching -- them to the tree, and that can disturb current value settings. + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + Abrt_Blk : Node_Id := Empty; + Abrt_Blk_Id : Entity_Id; + AUD : Entity_Id; + Fin_Blk : Node_Id; + Fin_Call : Node_Id; + Fin_Data : Finalization_Exception_Data; + Free_Arg : Node_Id; + Free_Nod : Node_Id; + Gen_Code : Node_Id; + Obj_Ref : Node_Id; + Dummy : Entity_Id; -- This variable captures an unused dummy internal entity, see the -- comment associated with its use. @@ -1010,141 +1000,166 @@ package body Exp_Intr is return; end if; - -- Processing for pointer to controlled type + -- Processing for pointer to controlled types. Generate: + + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + -- begin -- aborts allowed + -- Abort_Defer; + + -- begin -- exception propagation allowed + -- [Deep_]Finalize (Obj_Ref); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + -- at end + -- Abort_Undefer_Direct; + -- end; + + -- Depending on whether exception propagation is enabled and/or aborts + -- are allowed, the generated code may lack block statements. if Needs_Fin then - Deref := + Obj_Ref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); - -- If the type is tagged, then we must force dispatching on the - -- finalization call because the designated type may not be the - -- actual type of the object. + -- If the designated type is tagged, the finalization call must + -- dispatch because the designated type may not be the actual type + -- of the object. - if Is_Tagged_Type (Desig_T) - and then not Is_Class_Wide_Type (Desig_T) - then - Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); - - elsif not Is_Tagged_Type (Desig_T) then + if Is_Tagged_Type (Desig_Typ) then + if not Is_Class_Wide_Type (Desig_Typ) then + Obj_Ref := + Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref); + end if; - -- Set type of result, to force a conversion when needed (see - -- exp_ch7, Convert_View), given that Deep_Finalize may be - -- inherited from the parent type, and we need the type of the - -- expression to see whether the conversion is in fact needed. + -- Otherwise the designated type is untagged. Set the type of the + -- dereference explicitly to force a conversion when needed given + -- that [Deep_]Finalize may be inherited from a parent type. - Set_Etype (Deref, Desig_T); + else + Set_Etype (Obj_Ref, Desig_Typ); end if; - -- The finalization call is expanded wrapped in a block to catch any - -- possible exception. If an exception does occur, then Program_Error - -- must be raised following the freeing of the object and its removal - -- from the finalization collection's list. We set a flag to record - -- that an exception was raised, and save its occurrence for use in - -- the later raise. - -- -- Generate: - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; - -- - -- Abort : constant Boolean := False; -- no abort + -- [Deep_]Finalize (Obj_Ref); + + Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); - -- E : Exception_Occurrence; + -- Generate: + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; -- Raised : Boolean := False; - -- + -- begin - -- [Deep_]Finalize (Obj); + -- + -- exception -- when others => - -- Raised := True; - -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); -- end; - Build_Object_Declarations (Finalizer_Data, Stmts, Loc); + if Exceptions_OK then + Build_Object_Declarations (Fin_Data, Stmts, Loc); - Final_Code := New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data))))); + Fin_Blk := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Fin_Data)))); - -- If aborts are allowed, then the finalization code must be - -- protected by an abort defer/undefer pair. + -- The finalization action must be protected by an abort defer + -- undefer pair when aborts are allowed. Generate: - if Abort_Allowed then - Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer)); + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; - declare - AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); + if Abort_Allowed then + AUD := RTE (RE_Abort_Undefer_Direct); - begin - Blk := + Abrt_Blk := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Final_Code, + Statements => New_List ( + Build_Runtime_Call (Loc, RE_Abort_Defer), + Fin_Blk), At_End_Proc => New_Occurrence_Of (AUD, Loc))); + Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); + -- Present the Abort_Undefer_Direct function to the backend so -- that it can inline the call to the function. Add_Inlined_Body (AUD, N); - end; + Append_To (Stmts, Abrt_Blk); - Add_Block_Identifier (Blk, Blk_Id); + -- Otherwise aborts are not allowed. Generate a dummy entity to + -- ensure that the internal symbols are in sync when a unit is + -- compiled with and without aborts. - Append (Blk, Stmts); + else + Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Append_To (Stmts, Fin_Blk); + end if; - else - -- Generate a dummy entity to ensure that the internal symbols are - -- in sync when a unit is compiled with and without aborts. + -- Otherwise exception propagation is not allowed - Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Append_List_To (Stmts, Final_Code); + else + Append_To (Stmts, Fin_Call); end if; end if; - -- For a task type, call Free_Task before freeing the ATCB - - if Is_Task_Type (Desig_T) then - - -- We used to detect the case of Abort followed by a Free here, - -- because the Free wouldn't actually free if it happens before - -- the aborted task actually terminates. The warning was removed, - -- because Free now works properly (the task will be freed once - -- it terminates). + -- For a task type, call Free_Task before freeing the ATCB. We used to + -- detect the case of Abort followed by a Free here, because the Free + -- wouldn't actually free if it happens before the aborted task actually + -- terminates. The warning was removed, because Free now works properly + -- (the task will be freed once it terminates). + if Is_Task_Type (Desig_Typ) then Append_To (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); -- For composite types that contain tasks, recurse over the structure -- to build the selectors for the task subcomponents. - elsif Has_Task (Desig_T) then - if Is_Record_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); + elsif Has_Task (Desig_Typ) then + if Is_Array_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); - elsif Is_Array_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + elsif Is_Record_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); end if; end if; -- Same for simple protected types. Eventually call Finalize_Protection -- before freeing the PO for each protected component. - if Is_Simple_Protected_Type (Desig_T) then + if Is_Simple_Protected_Type (Desig_Typ) then Append_To (Stmts, Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); - elsif Has_Simple_Protected_Object (Desig_T) then - if Is_Record_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); - elsif Is_Array_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + elsif Has_Simple_Protected_Object (Desig_Typ) then + if Is_Array_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); + + elsif Is_Record_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); end if; end if; @@ -1152,10 +1167,10 @@ package body Exp_Intr is -- a renaming rather than a constant to ensure that the original context -- is always set to null after the deallocation takes place. - Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); - Free_Node := Make_Free_Statement (Loc, Empty); - Append_To (Stmts, Free_Node); - Set_Storage_Pool (Free_Node, Pool); + Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); + Free_Nod := Make_Free_Statement (Loc, Empty); + Append_To (Stmts, Free_Nod); + Set_Storage_Pool (Free_Nod, Pool); -- Attach to tree before analysis of generated subtypes below @@ -1176,23 +1191,24 @@ package body Exp_Intr is -- Deallocate (which is allowed), then the actual will simply be set -- to null. - elsif Present (Get_Rep_Pragma - (Etype (Pool), Name_Simple_Storage_Pool_Type)) + elsif Present + (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type)) then declare - Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); - Dealloc_Op : Entity_Id; + Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool)); + Dealloc : Entity_Id; + begin - Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate); - while Present (Dealloc_Op) loop - if Scope (Dealloc_Op) = Scope (Pool_Type) - and then Present (First_Formal (Dealloc_Op)) - and then Etype (First_Formal (Dealloc_Op)) = Pool_Type + Dealloc := Get_Name_Entity_Id (Name_Deallocate); + while Present (Dealloc) loop + if Scope (Dealloc) = Scope (Pool_Typ) + and then Present (First_Formal (Dealloc)) + and then Etype (First_Formal (Dealloc)) = Pool_Typ then - Set_Procedure_To_Call (Free_Node, Dealloc_Op); + Set_Procedure_To_Call (Free_Nod, Dealloc); exit; else - Dealloc_Op := Homonym (Dealloc_Op); + Dealloc := Homonym (Dealloc); end if; end loop; end; @@ -1201,17 +1217,17 @@ package body Exp_Intr is -- Deallocate through the class-wide Deallocate_Any. elsif Is_Class_Wide_Type (Etype (Pool)) then - Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any)); + Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any)); -- Case of a specific pool type: make a statically bound call else - Set_Procedure_To_Call (Free_Node, - Find_Prim_Op (Etype (Pool), Name_Deallocate)); + Set_Procedure_To_Call + (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); end if; end if; - if Present (Procedure_To_Call (Free_Node)) then + if Present (Procedure_To_Call (Free_Nod)) then -- For all cases of a Deallocate call, the back-end needs to be able -- to compute the size of the object being freed. This may require @@ -1222,11 +1238,11 @@ package body Exp_Intr is -- size parameter computed by GIGI. Same for an access to -- unconstrained packed array. - if Is_Class_Wide_Type (Desig_T) + if Is_Class_Wide_Type (Desig_Typ) or else - (Is_Array_Type (Desig_T) - and then not Is_Constrained (Desig_T) - and then Is_Packed (Desig_T)) + (Is_Array_Type (Desig_Typ) + and then not Is_Constrained (Desig_Typ) + and then Is_Packed (Desig_Typ)) then declare Deref : constant Node_Id := @@ -1239,9 +1255,9 @@ package body Exp_Intr is -- Perform minor decoration as it is needed by the side effect -- removal mechanism. - Set_Etype (Deref, Desig_T); - Set_Parent (Deref, Free_Node); - D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); + Set_Etype (Deref, Desig_Typ); + Set_Parent (Deref, Free_Nod); + D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ); if Nkind (D_Subtyp) in N_Has_Entity then D_Type := Entity (D_Subtyp); @@ -1260,9 +1276,8 @@ package body Exp_Intr is Freeze_Itype (D_Type, Deref); - Set_Actual_Designated_Subtype (Free_Node, D_Type); + Set_Actual_Designated_Subtype (Free_Nod, D_Type); end; - end if; end if; @@ -1277,10 +1292,11 @@ package body Exp_Intr is if Is_Interface (Directly_Designated_Type (Typ)) and then Tagged_Type_Expansion then - Set_Expression (Free_Node, + Set_Expression (Free_Nod, Unchecked_Convert_To (Typ, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); @@ -1288,7 +1304,7 @@ package body Exp_Intr is -- free (Obj_Ptr) else - Set_Expression (Free_Node, Free_Arg); + Set_Expression (Free_Nod, Free_Arg); end if; -- Only remaining step is to set result to null, or generate a raise of @@ -1316,14 +1332,14 @@ package body Exp_Intr is -- exception occurrence. -- Generate: - -- if Raised and then not Abort then + -- if Raised and then not Abrt then -- raise Program_Error; -- for restricted RTS -- -- Raise_From_Controlled_Operation (E); -- all other cases -- end if; - if Needs_Fin then - Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); + if Needs_Fin and then Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Fin_Data)); end if; -- If we know the argument is non-null, then make a block statement @@ -1342,7 +1358,7 @@ package body Exp_Intr is else Gen_Code := Make_Implicit_If_Statement (N, - Condition => + Condition => Make_Op_Ne (Loc, Left_Opnd => Duplicate_Subexpr (Arg), Right_Opnd => Make_Null (Loc)), @@ -1357,9 +1373,10 @@ package body Exp_Intr is -- If we generated a block with an At_End_Proc, expand the exception -- handler. We need to wait until after everything else is analyzed. - if Present (Blk) then + if Present (Abrt_Blk) then Expand_At_End_Handler - (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + (HSS => Handled_Statement_Sequence (Abrt_Blk), + Blk_Id => Entity (Identifier (Abrt_Blk))); end if; end Expand_Unc_Deallocation; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 2284caf..bd3af2e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -378,10 +378,7 @@ procedure Gnat1drv is Optimization_Level := 0; -- Enable some restrictions systematically to simplify the generated - -- code (and ease analysis). Note that restriction checks are also - -- disabled in SPARK mode, see Restrict.Check_Restriction, and user - -- specified Restrictions pragmas are ignored, see - -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. + -- code (and ease analysis). Restrict.Restrictions.Set (No_Initialize_Scalars) := True; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index fb0e968..37f579b 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -498,14 +498,18 @@ package body Restrict is begin Msg_Issued := False; - -- In CodePeer and SPARK mode, we do not want to check for any - -- restriction, or set additional restrictions other than those already - -- set in gnat1drv.adb so that we have consistency between each - -- compilation. + -- In CodePeer mode, we do not want to check for any restriction, or set + -- additional restrictions other than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. + + -- In GNATprove mode restrictions are checked, except for + -- No_Initialize_Scalars, which is implicitely set in gnat1drv.adb. -- Just checking, SPARK does not allow restrictions to be set ??? - if CodePeer_Mode then + if CodePeer_Mode + or else (GNATprove_Mode and then R = No_Initialize_Scalars) + then return; end if; -- 2.7.4