2011-08-29 Robert Dewar <dewar@adacore.com>
+ * a-cdlili.ads, a-coinve.ads, a-coorma.adb, a-coorma.ads, s-tassta.adb,
+ a-cborma.adb, a-cborma.ads, a-cohama.ads, a-coorse.ads, a-cbhama.ads,
+ a-cborse.ads, a-cobove.adb, a-cobove.ads, a-cbhase.ads: Minor
+ reformatting.
+
+2011-08-29 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch7.adb, exp_ch7.ads (Build_Exception_Handler): Move its spec to
+ package spec.
+ * exp_intr.adb (Expand_Unc_Deallocation): Use Build_Exception_Handler.
+ * a-except.adb, a-except-2005.adb (Rcheck_22): Do not defer aborts
+ while raising PE.
+
+2011-08-29 Robert Dewar <dewar@adacore.com>
+
* a-cbhama.adb, a-cbhama.ads: Minor reformatting.
2011-08-29 Javier Miranda <miranda@adacore.com>
private with Ada.Containers.Hash_Tables;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic
for Reference_Type'Read use Read;
function Constant_Reference
- (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
- return Constant_Reference_Type;
+ (Container : Map;
+ Key : Key_Type) -- SHOULD BE ALIASED???
+ return Constant_Reference_Type;
- function Reference (Container : Map; Key : Key_Type)
- return Reference_Type;
+ function Reference (Container : Map; Key : Key_Type) return Reference_Type;
private
pragma Inline (Length);
type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
+ -- Note: If a Cursor object has no explicit initialization expression,
+ -- it must default initialize to the same value as constant No_Element.
+ -- The Node component of type Cursor has scalar type Count_Type, so it
+ -- requires an explicit initialization expression of its own declaration,
+ -- in order for objects of record type Cursor to properly initialize.
+
type Cursor is record
Container : Map_Access;
Node : Count_Type := 0;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
+ -- Note: If a Cursor object has no explicit initialization expression,
+ -- it must default initialize to the same value as constant No_Element.
+ -- The Node component of type Cursor has scalar type Count_Type, so it
+ -- requires an explicit initialization expression of its own declaration,
+ -- in order for objects of record type Cursor to properly initialize.
+
type Cursor is record
Container : Set_Access;
Node : Count_Type := 0;
end record;
overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
declare
LN : Node_Type renames Left.Container.Nodes (Left.Node);
-
begin
return Right < LN.Key;
end;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
-
begin
if Node = 0 then
raise Constraint_Error with "key not in map";
+ else
+ return Container.Nodes (Node).Element;
end if;
-
- return Container.Nodes (Node).Element;
end Element;
---------------------
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
-
begin
if Node = 0 then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
begin
if Container.First = 0 then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Container.First);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Container.First);
end First;
function First (Object : Iterator) return Cursor is
begin
if F = 0 then
return No_Element;
+ else
+ return Cursor'(Object.Container.all'Unchecked_Access, F);
end if;
-
- return
- Cursor'(Object.Container.all'Unchecked_Access, F);
end First;
-------------------
begin
if Container.First = 0 then
raise Constraint_Error with "map is empty";
+ else
+ return Container.Nodes (Container.First).Element;
end if;
-
- return Container.Nodes (Container.First).Element;
end First_Element;
---------------
begin
if Container.First = 0 then
raise Constraint_Error with "map is empty";
+ else
+ return Container.Nodes (Container.First).Key;
end if;
-
- return Container.Nodes (Container.First).Key;
end First_Key;
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type := Key_Ops.Floor (Container, Key);
-
begin
if Node = 0 then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-----------------
declare
N : Node_Type renames Container.Nodes (Position.Node);
-
begin
N.Key := Key;
N.Element := New_Item;
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Container, Result);
return Result;
procedure Assign (Node : in out Node_Type) is
begin
Node.Key := Key;
+
+ -- Why is the following commented out ???
-- Node.Element := New_Item;
end Assign;
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Container, Result);
return Result;
Right : Node_Type) return Boolean
is
begin
- -- k > node same as node < k
+ -- Left > Right same as Right < Left
return Right.Key < Left;
end Is_Greater_Key_Node;
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class
is
It : constant Iterator :=
- (Container'Unrestricted_Access, Container.First);
+ (Container'Unrestricted_Access, Container.First);
begin
return It;
end Iterate;
- function Iterate (Container : Map; Start : Cursor)
+ function Iterate
+ (Container : Map;
+ Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unrestricted_Access, Start.Node);
begin
if Container.Last = 0 then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if F = 0 then
return No_Element;
+ else
+ return Cursor'(Object.Container.all'Unchecked_Access, F);
end if;
-
- return
- Cursor'(Object.Container.all'Unchecked_Access, F);
end Last;
------------------
begin
if Container.Last = 0 then
raise Constraint_Error with "map is empty";
+ else
+ return Container.Nodes (Container.Last).Element;
end if;
-
- return Container.Nodes (Container.Last).Element;
end Last_Element;
--------------
begin
if Container.Last = 0 then
raise Constraint_Error with "map is empty";
+ else
+ return Container.Nodes (Container.Last).Key;
end if;
-
- return Container.Nodes (Container.Last).Key;
end Last_Key;
----------
-- Reference --
---------------
- function Constant_Reference (Container : Map; Key : Key_Type)
- return Constant_Reference_Type
+ function Constant_Reference
+ (Container : Map;
+ Key : Key_Type) return Constant_Reference_Type
is
begin
return (Element => Container.Element (Key)'Unrestricted_Access);
end Constant_Reference;
- function Reference (Container : Map; Key : Key_Type)
- return Reference_Type
+ function Reference
+ (Container : Map;
+ Key : Key_Type) return Reference_Type
is
begin
return (Element => Container.Element (Key)'Unrestricted_Access);
B : Natural renames Container'Unrestricted_Access.all.Busy;
- -- Start of processing for Reverse_Iterate
+ -- Start of processing for Reverse_Iterate
begin
B := B + 1;
------------------------------------------------------------------------------
private with Ada.Containers.Red_Black_Trees;
+
with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
- type Map (Capacity : Count_Type) is tagged private
- with
+ type Map (Capacity : Count_Type) is tagged private with
constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
Empty_Map : constant Map;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package Map_Iterator_Interfaces is new
(Container : in out Map;
Position : Cursor;
Process : not null access
- procedure (Key : Key_Type; Element : in out Element_Type));
+ procedure (Key : Key_Type; Element : in out Element_Type));
procedure Assign (Target : in out Map; Source : Map);
for Reference_Type'Write use Write;
function Constant_Reference
- (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
- return Constant_Reference_Type;
+ (Container : Map;
+ Key : Key_Type) -- SHOULD BE ALIASED ???
+ return Constant_Reference_Type;
- function Reference (Container : Map; Key : Key_Type)
- return Reference_Type;
+ function Reference (Container : Map; Key : Key_Type) return Reference_Type;
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
- function Iterate (Container : Map)
- return Map_Iterator_Interfaces.Forward_Iterator'class;
+ function Iterate
+ (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class;
- function Iterate (Container : Map; Start : Cursor)
+ function Iterate
+ (Container : Map;
+ Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'class;
procedure Reverse_Iterate
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
+ -- Note: If a Cursor object has no explicit initialization expression,
+ -- it must default initialize to the same value as constant No_Element.
+ -- The Node component of type Cursor has scalar type Count_Type, so it
+ -- requires an explicit initialization expression of its own declaration,
+ -- in order for objects of record type Cursor to properly initialize.
+
type Cursor is record
Container : Set_Access;
Node : Count_Type := 0;
private with Ada.Finalization;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic
------------------------------------------------------------------------------
with Ada.Containers.Generic_Array_Sort;
+
with System; use type System.Address;
package body Ada.Containers.Bounded_Vectors is
type Iterator is new
Vector_Iterator_Interfaces.Reversible_Iterator with record
- Container : Vector_Access;
- Index : Index_Type;
- end record;
+ Container : Vector_Access;
+ Index : Index_Type;
+ end record;
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return Container.Elements (To_Array_Index (Index));
end if;
-
- return Container.Elements (To_Array_Index (Index));
end Element;
function Element (Position : Cursor) return Element_Type is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ return Position.Container.Element (Position.Index);
end if;
-
- return Position.Container.Element (Position.Index);
end Element;
----------
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unrestricted_Access, Index_Type'First);
end if;
-
- return (Container'Unrestricted_Access, Index_Type'First);
end First;
function First (Object : Iterator) return Cursor is
begin
if Is_Empty (Object.Container.all) then
return No_Element;
+ else
+ return Cursor'(Object.Container, Index_Type'First);
end if;
-
- return Cursor'(Object.Container, Index_Type'First);
end First;
-------------------
begin
if Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
+ else
+ return Container.Elements (To_Array_Index (Index_Type'First));
end if;
-
- return Container.Elements (To_Array_Index (Index_Type'First));
end First_Element;
-----------------
B := B - 1;
end Iterate;
- function Iterate (Container : Vector)
+ function Iterate
+ (Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
begin
return Iterator'(Container'Unrestricted_Access, Index_Type'First);
end Iterate;
- function Iterate (Container : Vector; Start : Cursor)
+ function Iterate
+ (Container : Vector;
+ Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
begin
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Last);
end if;
-
- return (Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if Is_Empty (Object.Container.all) then
return No_Element;
+ else
+ return Cursor'(Object.Container, Object.Container.Last);
end if;
-
- return Cursor'(Object.Container, Object.Container.Last);
end Last;
------------------
begin
if Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
+ else
+ return Container.Elements (Container.Length);
end if;
-
- return Container.Elements (Container.Length);
end Last_Element;
----------------
end if;
return (Element =>
- Container.Elements (To_Array_Index (Position))'Access);
+ Container.Elements (To_Array_Index (Position))'Access);
end Constant_Reference;
function Reference (Container : Vector; Position : Cursor)
return
(Element =>
- Position.Container.Elements
+ Position.Container.Elements
(To_Array_Index (Position.Index))'Access);
end Reference;
begin
if Position > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return (Element =>
+ Container.Elements (To_Array_Index (Position))'Unrestricted_Access);
end if;
-
- return (Element =>
- Container.Elements (To_Array_Index (Position))'Unrestricted_Access);
end Reference;
---------------------
-- Index >= Index_Type'First
-- hence we also know that
-- Index - Index_Type'First >= 0
- --
+
-- The issue is that even though 0 is guaranteed to be a value
-- in the type Index_Type'Base, there's no guarantee that the
-- difference is a value in that type. To prevent overflow we
end if;
elsif Index_Type'First <= 0 then
+
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Length.
-- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
end if;
elsif Index_Type'First <= 0 then
+
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Length.
No_Index : constant Extended_Index := Extended_Index'First;
- type Vector (Capacity : Count_Type) is tagged private
- with
+ type Vector (Capacity : Count_Type) is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
(Container : Vector;
Process : not null access procedure (Position : Cursor));
- function Iterate (Container : Vector)
+ function Iterate
+ (Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class;
- function Iterate (Container : Vector; Start : Cursor)
+ function Iterate
+ (Container : Vector;
+ Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class;
type Constant_Reference_Type
private with Ada.Containers.Hash_Tables;
private with Ada.Finalization;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic
private with Ada.Finalization;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, 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- --
end record;
overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
-- Clear --
-----------
- procedure Clear is
- new Tree_Operations.Generic_Clear (Delete_Tree);
+ procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
procedure Clear (Container : in out Map) is
begin
return Node.Color;
end Color;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : Map;
+ Key : Key_Type) return Constant_Reference_Type
+ is
+ begin
+ return (Element => Container.Element (Key)'Unrestricted_Access);
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
function First (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
-
begin
if T.First = null then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, T.First);
end if;
-
- return Cursor'(Container'Unrestricted_Access, T.First);
end First;
function First (Object : Iterator) return Cursor is
M : constant Map_Access := Object.Container;
N : constant Node_Access := M.Tree.First;
-
begin
if N = null then
return No_Element;
+ else
+ return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
-
- return Cursor'(Object.Container.all'Unchecked_Access, N);
end First;
-------------------
begin
if T.First = null then
raise Constraint_Error with "map is empty";
+ else
+ return T.First.Element;
end if;
-
- return T.First.Element;
end First_Element;
---------------
function First_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
-
begin
if T.First = null then
raise Constraint_Error with "map is empty";
+ else
+ return T.First.Key;
end if;
-
- return T.First.Key;
end First_Key;
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
-
begin
if Node = null then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
------------------------
function Is_Equal_Node_Node
- (L, R : Node_Access) return Boolean is
+ (L, R : Node_Access) return Boolean
+ is
begin
if L.Key < R.Key then
return False;
Right : Node_Access) return Boolean
is
begin
- -- k > node same as node < k
+ -- Left > Right same as Right < Left
return Right.Key < Left;
end Is_Greater_Key_Node;
function Last (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
-
begin
if T.Last = null then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, T.Last);
end if;
-
- return Cursor'(Container'Unrestricted_Access, T.Last);
end Last;
function Last (Object : Iterator) return Cursor is
M : constant Map_Access := Object.Container;
N : constant Node_Access := M.Tree.Last;
-
begin
if N = null then
return No_Element;
+ else
+ return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
-
- return Cursor'(Object.Container.all'Unchecked_Access, N);
end Last;
------------------
function Last_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
-
begin
if T.Last = null then
raise Constraint_Error with "map is empty";
+ else
+ return T.Last.Element;
end if;
-
- return T.Last.Element;
end Last_Element;
--------------
function Last_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
-
begin
if T.Last = null then
raise Constraint_Error with "map is empty";
+ else
+ return T.Last.Key;
end if;
-
- return T.Last.Key;
end Last_Key;
----------
-- Reference --
---------------
- function Constant_Reference (Container : Map; Key : Key_Type)
- return Constant_Reference_Type is
- begin
- return (Element => Container.Element (Key)'Unrestricted_Access);
- end Constant_Reference;
-
- function Reference (Container : Map; Key : Key_Type)
- return Reference_Type is
+ function Reference
+ (Container : Map;
+ Key : Key_Type)
+ return Reference_Type
+ is
begin
return (Element => Container.Element (Key)'Unrestricted_Access);
end Reference;
B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
- -- Start of processing for Reverse_Iterate
+ -- Start of processing for Reverse_Iterate
begin
B := B + 1;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
+
with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
- type Map is tagged private
- with
+ type Map is tagged private with
constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
Empty_Map : constant Map;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package Map_Iterator_Interfaces is new
for Reference_Type'Write use Write;
function Constant_Reference
- (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
- return Constant_Reference_Type;
+ (Container : Map;
+ Key : Key_Type) -- SHOULD BE ALIASED???
+ return Constant_Reference_Type;
function Reference (Container : Map; Key : Key_Type)
return Reference_Type;
(Container : Map;
Process : not null access procedure (Position : Cursor));
- function Iterate (Container : Map)
+ function Iterate
+ (Container : Map)
return Map_Iterator_Interfaces.Forward_Iterator'class;
- function Iterate (Container : Map; Start : Cursor)
+ function Iterate
+ (Container : Map;
+ Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'class;
procedure Reverse_Iterate
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic
end Rcheck_21;
procedure Rcheck_22 (File : System.Address; Line : Integer) is
+ E : constant Exception_Id := Program_Error_Def'Access;
begin
- Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
+ -- This is "finalize/adjust raised exception".
+ -- As this exception is only raised with aborts defered, it must
+ -- call Raise_Exception_No_Defer, contrary to all other Rcheck
+ -- subprograms (which defer aborts).
+ -- This is coherent with Raise_From_Controlled_Operation.
+
+ Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
+ Raise_Current_Excep (E);
end Rcheck_22;
procedure Rcheck_23 (File : System.Address; Line : Integer) is
end Rcheck_21;
procedure Rcheck_22 (File : System.Address; Line : Integer) is
+ E : constant Exception_Id := Program_Error_Def'Access;
begin
- Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
+ -- This is "finalize/adjust raised exception".
+ -- As this exception is only raised with aborts defered, it must
+ -- call Raise_Exception_No_Defer, contrary to all other Rcheck
+ -- subprograms (which defer aborts).
+ -- This is coherent with Raise_From_Controlled_Operation.
+
+ Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
+ Raise_Current_Excep (E);
end Rcheck_22;
procedure Rcheck_23 (File : System.Address; Line : Integer) is
-- context does not contain the above constructs, the routine returns an
-- empty list.
- function Build_Exception_Handler
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- Raised_Id : Entity_Id;
- For_Library : Boolean := False) return Node_Id;
- -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record
- -- _Body. Create an exception handler of the following form:
- --
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
- -- end if;
- --
- -- If flag For_Library is set (and not in restricted profile):
- --
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Library_Occurrence (Get_Current_Excep.all.all);
- -- end if;
- --
- -- E_Id denotes the defining identifier of a local exception occurrence.
- -- Raised_Id is the entity of a local boolean flag. Flag For_Library is
- -- used when operating at the library level, when enabled the current
- -- exception will be saved to a global location.
-
procedure Build_Finalizer
(N : Node_Id;
Clean_Stmts : List_Id;
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
-- that take care of finalization management at run-time.
+ function Build_Exception_Handler
+ (Loc : Source_Ptr;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id;
+ For_Library : Boolean := False) return Node_Id;
+ -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record
+ -- _Body. Create an exception handler of the following form:
+ --
+ -- when others =>
+ -- if not Raised_Id then
+ -- Raised_Id := True;
+ -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
+ -- end if;
+ --
+ -- If flag For_Library is set (and not in restricted profile):
+ --
+ -- when others =>
+ -- if not Raised_Id then
+ -- Raised_Id := True;
+ -- Save_Library_Occurrence (Get_Current_Excep.all.all);
+ -- end if;
+ --
+ -- E_Id denotes the defining identifier of a local exception occurrence.
+ -- Raised_Id is the entity of a local boolean flag. Flag For_Library is
+ -- used when operating at the library level, when enabled the current
+ -- exception will be saved to a global location.
+
procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Obj_Ref => Deref,
Typ => Desig_T)),
Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Raised_Id, Loc),
- Expression =>
- New_Reference_To (Standard_True, Loc)),
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Save_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (E_Id, Loc),
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To
- (RTE (RE_Get_Current_Excep),
- Loc))))))))))));
+ Build_Exception_Handler (Loc, E_Id, Raised_Id)))));
-- For .NET/JVM, detach the object from the containing finalization
-- collection before finalizing it.
TH.all (Cause, Self_ID, EO);
exception
+
+ -- RM-C.7.3 requires all exceptions raised here to be ignored
+
when others =>
- -- RM-C.7.3 requires these exceptions to be ignored
null;
end;
end if;
OSDN Git Service
