OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch7.adb (Process_Transient_Objects): Reimplement to properly handle restriction No_Exception_Propagation. 

2015-10-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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
This commit is contained in:
Hristian Kirtchev 2015-10-23 10:43:30 +00:00 committed by Arnaud Charlet
parent c79f6efda3
commit 6e84098973
7 changed files with 395 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/ChangeLog
View File

@ -1,3 +1,15 @@
2015-10-23 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <duff@adacore.com>
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not call

8
gcc/ada/exp_ch11.adb
View File

@ -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;

13
gcc/ada/exp_ch11.ads
View File

@ -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

324
gcc/ada/exp_ch7.adb
View File

@ -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:
-- Create an access type which provides a reference to the
-- transient object. Generate:
-- type Ptr_Typ is access [all] Desig_Typ;
-- Ann : access [all] <Desig_Typ>;
Ptr_Typ := Make_Temporary (Loc, 'A');
Ptr_Id := 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:
-- Create a temporary which acts as a hook to the transient
-- object. Generate:
-- Hook : Ptr_Typ := null;
-- Temp : Ptr_Id := null;
Hook_Id := Make_Temporary (Loc, 'T');
Temp_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);
-- <or>
-- 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);
-- <or>
-- 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;
-- Otherwise generate:
-- [Temp := null;]
-- [Deep_]Finalize (Obj_Ref);
else
Prepend_To (Blk_Stmts, Fin_Call);
if Present (Hook_Clr) then
Prepend_To (Blk_Stmts, Hook_Clr);
end if;
end if;
Prev_Fin := Fin_Block;
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;

305
gcc/ada/exp_intr.adb
View File

@ -959,39 +959,15 @@ package body Exp_Intr is
-- Expand_Unc_Deallocation --
-----------------------------
-- Generate the following Code :
-- if Arg /= null then
-- <Finalize_Call> (.., 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);
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;
elsif not Is_Tagged_Type (Desig_T) then
-- 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 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.
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;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- [Deep_]Finalize (Obj_Ref);
-- E : Exception_Occurrence;
Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
-- Generate:
-- Abrt : constant Boolean := ...;
-- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
--
-- begin
-- [Deep_]Finalize (Obj);
-- <Fin_Call>
-- 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;
-- <Fin_Blk>
-- 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;
-- Otherwise exception propagation is not allowed
else
-- Generate a dummy entity to ensure that the internal symbols are
-- in sync when a unit is compiled with and without aborts.
Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Append_List_To (Stmts, Final_Code);
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
-- <or>
-- 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;

5
gcc/ada/gnat1drv.adb
View File

@ -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;

14
gcc/ada/restrict.adb
View File

@ -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;