This patch reimplements how finalization is carried out during an abort.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-03 Hristian Kirtchev <kirtc...@adacore.com>
* a-except-2005.adb (Raise_From_Controlled_Operation): Add new formal
From_Abort. When finalization was triggered by an abort, propagate
Standard'Abort_Signal rather than Program_Error.
* a-except-2005.ads (Raise_From_Controlled_Operation): Add new formal
From_Abort.
* a-except.adb (Raise_From_Controlled_Operation): Add new formal
From_Abort. When finalization was triggered by an abort, propagate
Standard'Abort_Signal rather than Program_Error.
* a-except.ads:(Raise_From_Controlled_Operation): Add new formal
From_Abort.
* exp_ch7.adb:(Build_Adjust_Or_Finalize_Statements): New local variable
Abort_Id. Update the calls to Build_Object_Declarations and
Build_Raise_Statement to include Abort_Id.
(Build_Adjust_Statements): New local variable Abort_Id. Update the
calls to Build_Object_Declarations and Build_Raise_Statement to include
Abort_Id.
(Build_Finalize_Statements): New local variable Abort_Id. Update the
calls to Build_Object_Declarations and Build_Raise_Statement to include
Abort_Id.
(Build_Components): Create an entity for Abort_Id when exceptions are
allowed on the target.
(Build_Finalizer): New local variable Abort_Id.
(Build_Initialize_Statements): New local variable Abort_Id. Update the
calls to Build_Object_Declarations and Build_Raise_Statement to include
Abort_Id.
(Build_Object_Declarations): Add new formal Abort_Id. Create the
declaration of flag Abort_Id to preserve the original abort status
before finalization code is executed.
(Build_Raise_Statement): Add new formal Abort_Id. Pass Abort_Id to
runtime routine Raise_From_Controlled_Operation.
(Create_Finalizer): Update the call to Build_Raise_Statement to include
Abort_Id. Update the call to Build_Object_Declarations to include
Abort_Id. Update the layout of the finalizer body.
(Make_Handler_For_Ctrl_Operation): Add an actual for From_Abort.
(Process_Transient_Objects): New local variable Abort_Id. Remove the
clunky code to create all flags and objects related to
exception propagation and replace it with a call to
Build_Object_Declarations. Update the call to Build_Raise_Statement to
include Abort_Id.
* exp_ch7.ads (Build_Object_Declarations): Moved from body to spec.
Add new formal Abort_Id and associated comment on its use.
(Build_Raise_Statement): Add new formal Abort_Id and associated comment
on its use.
* exp_intr.adb (Expand_Unc_Deallocation): New local variable Abort_Id.
Remove the clunky code to create all flags and objects related to
exception propagation and replace it with a call to
Build_Object_Declarations. Update the call to Build_Raise_Statement.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 177282)
+++ exp_ch7.adb (working copy)
@@ -359,17 +359,6 @@
-- an exception handler, the statements will be wrapped in a block to avoid
-- unwanted interaction with the new At_End handler.
- function Build_Object_Declarations
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- Raised_Id : Entity_Id) return List_Id;
- -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a
- -- list containing the object declarations of the exception occurrence E_Id
- -- and boolean flag Raised_Id.
- --
- -- E_Id : Exception_Occurrence;
- -- Raised_Id : Boolean := False;
-
procedure Build_Record_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Component_Component set and store them using the TSS mechanism.
@@ -1088,10 +1077,15 @@
-- 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
@@ -1237,6 +1231,7 @@
Counter_Typ := Make_Temporary (Loc, 'T');
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
@@ -1322,7 +1317,6 @@
procedure Create_Finalizer is
Conv_Name : Name_Id;
- E_Decl : Node_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
Jump_Block : Node_Id;
@@ -1514,14 +1508,14 @@
-- level finalizers. Generate:
--
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
if not For_Package
and then Exceptions_OK
then
Append_To (Finalizer_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- Create the jump block which controls the finalization flow
@@ -1587,11 +1581,18 @@
-- Generate:
-- procedure Fin_Id is
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence; -- All added if flag
-- Raised : Boolean := False; -- Has_Ctrl_Objs is set
-- L0 : label;
-- ...
-- Lnn : label;
+
-- begin
-- Abort_Defer; -- Added if abort is allowed
-- <call to Prev_At_End> -- Added if exists
@@ -1605,28 +1606,8 @@
if Has_Ctrl_Objs
and then Exceptions_OK
then
- -- Generate:
- -- Raised : Boolean := False;
-
- Prepend_To (Finalizer_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
-
- -- Generate:
- -- E : Exception_Occurrence;
-
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
-
- Prepend_To (Finalizer_Decls, E_Decl);
+ Prepend_List_To (Finalizer_Decls,
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- Create the body of the finalizer
@@ -2910,9 +2891,11 @@
function Build_Object_Declarations
(Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
E_Id : Entity_Id;
Raised_Id : Entity_Id) return List_Id
is
+ A_Expr : Node_Id;
E_Decl : Node_Id;
begin
@@ -2920,9 +2903,43 @@
return Empty_List;
end if;
+ pragma Assert (Present (Abort_Id));
pragma Assert (Present (E_Id));
pragma Assert (Present (Raised_Id));
+ -- Generate:
+ -- Exception_Identity (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+
+ if Abort_Allowed then
+ A_Expr :=
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Exception_Identity), Loc),
+ Parameter_Associations => New_List (
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Reference_To
+ (RTE (RE_Get_Current_Excep), Loc)))))),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Stand.Abort_Signal, Loc),
+ Attribute_Name => Name_Identity));
+ else
+ A_Expr := New_Reference_To (Standard_False, Loc);
+ end if;
+
+ -- Generate:
+ -- E_Id : Exception_Occurrence;
+
E_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => E_Id,
@@ -2930,13 +2947,30 @@
New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
Set_No_Initialization (E_Decl);
- return New_List (E_Decl,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
+ return
+ New_List (
+
+ -- Abort_Id
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Abort_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => A_Expr),
+
+ -- E_Id
+
+ E_Decl,
+
+ -- Raised_Id
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Id,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
end Build_Object_Declarations;
---------------------------
@@ -2944,44 +2978,53 @@
---------------------------
function Build_Raise_Statement
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- R_Id : Entity_Id) return Node_Id
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id) return Node_Id
is
- Raise_Id : Entity_Id;
+ Params : List_Id;
+ Proc_Id : Entity_Id;
begin
+ -- The default parameter is the local exception occurrence
+
+ Params := New_List (New_Reference_To (E_Id, Loc));
+
+ -- .NET/JVM
+
if VM_Target /= No_VM then
- Raise_Id := RTE (RE_Reraise_Occurrence);
+ Proc_Id := RTE (RE_Reraise_Occurrence);
- -- Standard run-time library
+ -- Standard run-time library, this case handles finalization exceptions
+ -- raised during an abort.
elsif RTE_Available (RE_Raise_From_Controlled_Operation) then
- Raise_Id := RTE (RE_Raise_From_Controlled_Operation);
+ Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
+ Append_To (Params, New_Reference_To (Abort_Id, Loc));
-- Restricted runtime: exception messages are not supported and hence
-- Raise_From_Controlled_Operation is not supported.
else
- Raise_Id := RTE (RE_Reraise_Occurrence);
+ Proc_Id := RTE (RE_Reraise_Occurrence);
end if;
-- Generate:
- -- if R_Id then
- -- <Raise_Id> (E_Id);
+ -- if Raised_Id then
+ -- <Proc_Id> (<Params>);
-- end if;
return
Make_If_Statement (Loc,
Condition =>
- New_Reference_To (R_Id, Loc),
+ New_Reference_To (Raised_Id, Loc),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (Raise_Id, Loc),
- Parameter_Associations => New_List (
- New_Reference_To (E_Id, Loc)))));
+ New_Reference_To (Proc_Id, Loc),
+ Parameter_Associations => Params)));
end Build_Raise_Statement;
-----------------------------
@@ -4158,9 +4201,9 @@
Last_Object : Node_Id;
Related_Node : Node_Id)
is
+ Abort_Id : Entity_Id;
Built : Boolean := False;
Desig : Entity_Id;
- E_Decl : Node_Id;
E_Id : Entity_Id;
Fin_Block : Node_Id;
Last_Fin : Node_Id := Empty;
@@ -4202,32 +4245,13 @@
-- time around.
if not Built then
-
- -- Generate:
- -- Enn : Exception_Occurrence;
-
- E_Id := Make_Temporary (Loc, 'E');
-
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
- Insert_Before_And_Analyze (First_Object, E_Decl);
-
- -- Generate:
- -- Rnn : Boolean := False;
-
+ Abort_Id := Make_Temporary (Loc, 'A');
+ E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
- Insert_Before_And_Analyze (First_Object,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
+ Insert_List_Before_And_Analyze (First_Object,
+ Build_Object_Declarations
+ (Loc, Abort_Id, E_Id, Raised_Id));
Built := True;
end if;
@@ -4292,14 +4316,14 @@
-- Generate:
-- if Rnn then
- -- Raise_From_Controlled_Operation (Enn);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
if Built
and then Present (Last_Fin)
then
Insert_After_And_Analyze (Last_Fin,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
end Process_Transient_Objects;
@@ -4576,6 +4600,12 @@
-- controlled elements. Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
@@ -4599,7 +4629,7 @@
-- end loop;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
@@ -4623,6 +4653,11 @@
-- exception
-- when others =>
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Raised : Boolean := False;
@@ -4657,7 +4692,7 @@
-- end;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- raise;
@@ -4683,6 +4718,7 @@
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;
@@ -4720,6 +4756,7 @@
Build_Indices;
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
@@ -4819,9 +4856,16 @@
end loop;
-- Generate the block which contains the core loop, the declarations
- -- of the flag and exception occurrence and the conditional raise:
+ -- of the abort flag, the exception occurrence, the raised flag and
+ -- the conditional raise:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
@@ -4829,21 +4873,22 @@
-- <core loop>
-- if Raised then -- Expection handlers allowed
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
Stmts := New_List (Core_Loop);
if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
@@ -4859,6 +4904,7 @@
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;
@@ -5024,6 +5070,7 @@
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');
end if;
@@ -5125,10 +5172,17 @@
Dim := Dim - 1;
end loop;
- -- Generate the block which houses the finalization failure flag,
- -- all the finalization loops and the exception raise.
+ -- Generate the block which contains the finalization loops, the
+ -- declarations of the abort flag, the exception occurrence, the
+ -- raised flag and the conditional raise.
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
@@ -5141,7 +5195,7 @@
-- <final loop>
-- if Raised then -- Exception handlers allowed
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- raise; -- Exception handlers allowed
@@ -5150,14 +5204,15 @@
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
Append_To (Stmts, Make_Raise_Statement (Loc));
end if;
Final_Block :=
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
@@ -5449,7 +5504,7 @@
-- end if;
-- if Raised then
- -- Raise_From_Controlled_Object (E);
+ -- Raise_From_Controlled_Object (E, Abort);
-- end if;
-- end;
@@ -5458,6 +5513,11 @@
-- may have discriminants and contain variant parts. Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Raised : Boolean := False;
@@ -5532,7 +5592,7 @@
-- Root_Controlled (V).Finalized := True;
-- if Raised then
- -- Raise_From_Controlled_Object (E);
+ -- Raise_From_Controlled_Object (E, Abort);
-- end if;
-- end;
@@ -5555,6 +5615,7 @@
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;
@@ -5765,6 +5826,7 @@
begin
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
@@ -5942,6 +6004,12 @@
-- Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurence;
-- Raised : Boolean := False;
@@ -5951,21 +6019,21 @@
-- <adjust statements>
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
else
if Exceptions_OK then
Append_To (Bod_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
@@ -5980,6 +6048,7 @@
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;
@@ -6358,6 +6427,7 @@
begin
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
@@ -6535,6 +6605,12 @@
-- Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurence;
-- Raised : Boolean := False;
@@ -6547,21 +6623,21 @@
-- V.Finalized := True;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
else
if Exceptions_OK then
Append_To (Bod_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
@@ -7110,7 +7186,7 @@
-- Generate:
-- when E : others =>
- -- Raise_From_Controlled_Operation (X => E);
+ -- Raise_From_Controlled_Operation (E, False);
-- or:
@@ -7150,10 +7226,11 @@
Raise_Node :=
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (
- RTE (RE_Raise_From_Controlled_Operation), Loc),
+ New_Reference_To
+ (RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
- New_Reference_To (E_Occ, Loc)));
+ New_Reference_To (E_Occ, Loc),
+ New_Reference_To (Standard_False, Loc)));
-- Restricted runtime: exception messages are not supported
Index: exp_ch7.ads
===================================================================
--- exp_ch7.ads (revision 177276)
+++ exp_ch7.ads (working copy)
@@ -57,19 +57,39 @@
-- 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) 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.
+ --
+ -- Abort_Id : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort_Id : constant Boolean := False; -- no abort
+ --
+ -- E_Id : Exception_Occurrence;
+ -- Raised_Id : Boolean := False;
+
function Build_Raise_Statement
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- R_Id : Entity_Id) return Node_Id;
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id) return Node_Id;
-- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
-- Deep_Record_Body. Generate the following conditional raise statement:
--
- -- if R_Id then
- -- Raise_From_Controlled_Operation (E_Id);
+ -- if Raised_Id then
+ -- Raise_From_Controlled_Operation (E_Id, Abort_Id);
-- end if;
--
- -- E_Id denotes the defining identifier of a local exception occurrence,
- -- R_Id is the entity of a local boolean flag.
+ -- Abort_Id is a local boolean flag which is set when the finalization was
+ -- triggered by an abort, E_Id denotes the defining identifier of a local
+ -- exception occurrence, Raised_Id is the entity of a local boolean flag.
function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
-- True if T is a class-wide type, or if it has controlled parts ("part"
Index: a-except.adb
===================================================================
--- a-except.adb (revision 177275)
+++ a-except.adb (working copy)
@@ -850,21 +850,15 @@
-------------------------------------
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence)
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean)
is
- Prev_Exc : constant EOA := Get_Current_Excep.all;
-
begin
- -- We're raising an exception during finalization. If the finalization
- -- was triggered by an abort, as indicated by Not_Handled_By_Others,
- -- then we don't want to raise Program_Error; we want to continue with
- -- the Abort_Signal exception. Note that the original exception
- -- occurrence that triggered the finalization is saved before calling
- -- the Finalize procedures, and then restored afterward, so in the case
- -- of abort, the original Abort_Signal will be the current one.
+ -- When finalization was triggered by an abort, keep propagating the
+ -- abort signal rather than raising Program_Error.
- if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then
- Raise_Current_Excep (Prev_Exc.Id);
+ if From_Abort then
+ raise Standard'Abort_Signal;
-- Otherwise, raise Program_Error
@@ -873,9 +867,11 @@
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
- Integer'Min (Prefix'Length, Orig_Msg'Length);
+ Integer'Min
+ (Prefix'Length, Orig_Msg'Length);
Orig_Prefix : String renames Orig_Msg
- (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
+ (Orig_Msg'First ..
+ Orig_Msg'First + Orig_Prefix_Length - 1);
begin
-- Message already has proper prefix, just re-reraise
Index: a-except.ads
===================================================================
--- a-except.ads (revision 177275)
+++ a-except.ads (working copy)
@@ -199,7 +199,8 @@
-- system to return here rather than to the original location.
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean);
pragma No_Return (Raise_From_Controlled_Operation);
pragma Export
(Ada, Raise_From_Controlled_Operation,
Index: a-except-2005.adb
===================================================================
--- a-except-2005.adb (revision 177278)
+++ a-except-2005.adb (working copy)
@@ -878,21 +878,15 @@
-------------------------------------
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence)
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean)
is
- Prev_Exc : constant EOA := Get_Current_Excep.all;
-
begin
- -- We're raising an exception during finalization. If the finalization
- -- was triggered by an abort, as indicated by Not_Handled_By_Others,
- -- then we don't want to raise Program_Error; we want to continue with
- -- the Abort_Signal exception. Note that the original exception
- -- occurrence that triggered the finalization is saved before calling
- -- the Finalize procedures, and then restored afterward, so in the case
- -- of abort, the original Abort_Signal will be the current one.
+ -- When finalization was triggered by an abort, keep propagating the
+ -- abort signal rather than raising Program_Error.
- if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then
- Raise_Current_Excep (Prev_Exc.Id);
+ if From_Abort then
+ raise Standard'Abort_Signal;
-- Otherwise, raise Program_Error
Index: a-except-2005.ads
===================================================================
--- a-except-2005.ads (revision 177275)
+++ a-except-2005.ads (working copy)
@@ -230,7 +230,8 @@
-- system to return here rather than to the original location.
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean);
pragma No_Return (Raise_From_Controlled_Operation);
pragma Export
(Ada, Raise_From_Controlled_Operation,
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 177280)
+++ exp_intr.adb (working copy)
@@ -884,16 +884,15 @@
Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
Stmts : constant List_Id := New_List;
- Blk : Node_Id := Empty;
- Deref : Node_Id;
- Exc_Occ_Decl : Node_Id;
- Exc_Occ_Id : Entity_Id := Empty;
- Final_Code : List_Id;
- Free_Arg : Node_Id;
- Free_Node : Node_Id;
- Gen_Code : Node_Id;
- Raised_Decl : Node_Id;
- Raised_Id : Entity_Id := Empty;
+ Abort_Id : Entity_Id := Empty;
+ 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
@@ -942,39 +941,30 @@
-- the later raise.
--
-- Generate:
- -- Raised : Boolean := False;
- -- Exc_Occ : Exception_Occurrence;
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
--
-- begin
-- [Deep_]Finalize (Obj);
-- exception
-- when others =>
-- Raised := True;
- -- Save_Occurrence (Exc_Occ, Get_Current_Excep.all.all);
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
-- end;
- Exc_Occ_Id := Make_Temporary (Loc, 'E');
- Raised_Id := Make_Temporary (Loc, 'R');
+ Abort_Id := Make_Temporary (Loc, 'A');
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
- Raised_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc));
+ Append_List_To (Stmts,
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
- Append_To (Stmts, Raised_Decl);
-
- Exc_Occ_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exc_Occ_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (Exc_Occ_Decl);
-
- Append_To (Stmts, Exc_Occ_Decl);
-
Final_Code := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -997,7 +987,7 @@
Name =>
New_Reference_To (RTE (RE_Save_Occurrence), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Exc_Occ_Id, Loc),
+ New_Reference_To (E_Id, Loc),
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
@@ -1243,14 +1233,15 @@
--
-- Generate:
-- if Raised then
- -- Reraise_Occurrence (Exc_Occ); -- for .NET and
- -- -- restricted RTS
+ -- Reraise_Occurrence (E); -- for .NET and
+ -- -- restricted RTS
-- <or>
- -- Raise_From_Controlled_Operation (Exc_Occ); -- all other cases
+ -- Raise_From_Controlled_Operation (E, Abort); -- all other cases
-- end if;
if Present (Raised_Id) then
- Append_To (Stmts, Build_Raise_Statement (Loc, Exc_Occ_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- If we know the argument is non-null, then make a block statement
