+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * checks.adb, a-cihase.adb, a-cihase.ads, a-chtgop.adb, a-chtgop.ads,
+ a-except.adb, a-except-2005.adb, a-cborse.adb, a-cborse.ads,
+ a-exexda.adb, a-elchha.adb, exp_aggr.adb, a-cohase.adb: Minor
+ reformatting.
+
2014-07-30 Ed Schonberg <schonberg@adacore.com>
* a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New
L : Natural renames Container.Lock;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
- Control =>
- (Controlled with
- Container => Container'Access,
- Pos => Position,
- Old_Key => new Key_Type'(Key (Position))))
+ (Element => N.Element'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Pos => Position,
+ Old_Key => new Key_Type'(Key (Position))))
do
B := B + 1;
L := L + 1;
end return;
end;
-
end Reference_Preserving_Key;
function Reference_Preserving_Key
L : Natural renames Container.Lock;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
- Control =>
- (Controlled with
- Container => Container'Access,
- Pos => Find (Container, Key),
- Old_Key => new Key_Type'(Key)))
+ (Element => N.Element'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Pos => Find (Container, Key),
+ Old_Key => new Key_Type'(Key)))
do
B := B + 1;
L := L + 1;
end return;
-
end;
end Reference_Preserving_Key;
Old_Key : Key_Access;
end record;
- overriding procedure
- Adjust (Control : in out Reference_Control_Type);
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
- overriding procedure
- Finalize (Control : in out Reference_Control_Type);
+ overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Reference_Type (Element : not null access Element_Type) is record
begin
Prev := HT.Buckets (Indx);
+
if Prev = X then
HT.Buckets (Indx) := Next (Prev);
HT.Length := HT.Length - 1;
Free (X);
return;
end if;
+
Prev := Curr;
end loop;
+ end Delete_Node_At_Index;
- end Delete_Node_At_Index
-;
---------------------------
-- Delete_Node_Sans_Free --
---------------------------
-- deallocated. Program_Error is raised if the hash table is busy.
procedure Delete_Node_At_Index
- (HT : in out Hash_Table_Type;
- Indx : Hash_Type;
- X : in out Node_Access);
-
+ (HT : in out Hash_Table_Type;
+ Indx : Hash_Type;
+ X : in out Node_Access);
-- Delete a node whose bucket position is known. Used to remove a node
-- whose element has been modified through a key_preserving reference.
-- We cannot use the value of the element precisely because the current
generic
use Ada.Streams;
- with function New_Node (Stream : not null access Root_Stream_Type'Class)
- return Node_Access;
+ with function New_Node
+ (Stream : not null access Root_Stream_Type'Class)
+ return Node_Access;
procedure Generic_Read
(Stream : not null access Root_Stream_Type'Class;
HT : out Hash_Table_Type);
function New_Buckets (Length : Hash_Type) return Buckets_Access;
pragma Inline (New_Buckets);
- -- Allocate a new Buckets_Type array with bounds 0..Length-1
+ -- Allocate a new Buckets_Type array with bounds 0 .. Length - 1
procedure Free_Buckets (Buckets : in out Buckets_Access);
pragma Inline (Free_Buckets);
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
begin
if Control.Container /= null then
declare
- HT : Hash_Table_Type renames Control.Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ HT : Hash_Table_Type renames Control.Container.HT;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
HT_Ops.Delete_Node_At_Index
- (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
+ (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
raise Program_Error;
end if;
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
- (Element => Position.Node.Element.all'Access,
- Control =>
- (Controlled with
- Container => Container'Access,
- Index => HT_Ops.Index (HT, Position.Node),
- Old_Pos => Position,
- Old_Hash => Hash (Key (Position))))
- do
+ (Element => Position.Node.Element.all'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Index => HT_Ops.Index (HT, Position.Node),
+ Old_Pos => Position,
+ Old_Hash => Hash (Key (Position))))
+ do
B := B + 1;
L := L + 1;
end return;
(Container : aliased in out Set;
Key : Key_Type) return Reference_Type
is
- Node : constant Node_Access :=
- Key_Keys.Find (Container.HT, Key);
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
if Node = null then
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- P : constant Cursor := Find (Container, Key);
-
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+ P : constant Cursor := Find (Container, Key);
begin
return R : constant Reference_Type :=
- (Element => Node.Element.all'Access,
- Control =>
- (Controlled with
- Container => Container'Access,
- Index => HT_Ops.Index (HT, P.Node),
- Old_Pos => P,
- Old_Hash => Hash (Key)))
+ (Element => Node.Element.all'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Index => HT_Ops.Index (HT, P.Node),
+ Old_Pos => P,
+ Old_Hash => Hash (Key)))
do
B := B + 1;
L := L + 1;
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Node_Access :=
- Key_Keys.Find (Container.HT, Key);
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
if Node = null then
Old_Hash : Hash_Type;
end record;
- overriding procedure
- Adjust (Control : in out Reference_Control_Type);
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
- overriding procedure
- Finalize (Control : in out Reference_Control_Type);
+ overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Reference_Type (Element : not null access Element_Type) is record
- Control : Reference_Control_Type;
+ Control : Reference_Control_Type;
end record;
use Ada.Streams;
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
then
HT_Ops.Delete_Node_At_Index
- (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
+ (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
raise Program_Error with "key not preserved in reference";
end if;
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
Node : constant Node_Access := Key_Keys.Find (HT, 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 Find;
---------
declare
HT : Hash_Table_Type renames Position.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
- (Element => Position.Node.Element'Access,
- Control =>
- (Controlled with
- Container'Unrestricted_Access,
- Index => HT_Ops.Index (HT, Position.Node),
- Old_Pos => Position,
- Old_Hash => Hash (Key (Position))))
+ (Element => Position.Node.Element'Access,
+ Control =>
+ (Controlled with
+ Container'Unrestricted_Access,
+ Index => HT_Ops.Index (HT, Position.Node),
+ Old_Pos => Position,
+ Old_Hash => Hash (Key (Position))))
do
B := B + 1;
L := L + 1;
P : constant Cursor := Find (Container, Key);
begin
return R : constant Reference_Type :=
- (Element => Node.Element'Access,
- Control =>
- (Controlled with
- Container'Unrestricted_Access,
- Index => HT_Ops.Index (HT, P.Node),
- Old_Pos => P,
- Old_Hash => Hash (Key)))
+ (Element => Node.Element'Access,
+ Control =>
+ (Controlled with
+ Container'Unrestricted_Access,
+ Index => HT_Ops.Index (HT, P.Node),
+ Old_Pos => P,
+ Old_Hash => Hash (Key)))
do
B := B + 1;
L := L + 1;
pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
procedure Append_Info_Exception_Message
- (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
+ (X : Exception_Occurrence;
+ Info : in out String;
+ Ptr : in out Natural);
pragma Import
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
procedure Append_Info_Untailored_Exception_Information
- (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
+ (X : Exception_Occurrence;
+ Info : in out String;
+ Ptr : in out Natural);
pragma Import
(Ada, Append_Info_Untailored_Exception_Information,
"__gnat_append_info_u_e_info");
-- These procedures are used to provide exclusion bounds in
-- calls to Call_Chain at exception raise points from this unit. The
-- purpose is to arrange for the exception tracebacks not to include
- -- frames from routines involved in the raise process, as these are
+ -- frames from subprograms involved in the raise process, as these are
-- meaningless from the user's standpoint.
--
-- For these bounds to be meaningful, we need to ensure that the object
- -- code for the routines involved in processing a raise is located after
- -- the object code Code_Address_For_AAA and before the object code
- -- Code_Address_For_ZZZ. This will indeed be the case as long as the
- -- following rules are respected:
+ -- code for the subprograms involved in processing a raise is located
+ -- after the object code Code_Address_For_AAA and before the object
+ -- code Code_Address_For_ZZZ. This will indeed be the case as long as
+ -- the following rules are respected:
--
-- 1) The bodies of the subprograms involved in processing a raise
-- are located after the body of Code_Address_For_AAA and before the
package Exception_Data is
- ---------------------------------
- -- Exception messages routines --
- ---------------------------------
+ -----------------------------------
+ -- Exception Message Subprograms --
+ -----------------------------------
procedure Set_Exception_C_Msg
(Excep : EOA;
-- which is generated as the exception message.
---------------------------------------
- -- Exception information subprograms --
+ -- Exception Information Subprograms --
---------------------------------------
function Untailored_Exception_Information
--
-- The Exception_Name and Message lines are omitted in the abort
-- signal case, since this is not really an exception.
-
+ --
-- Note: If the format of the generated string is changed, please note
-- that an equivalent modification to the routine String_To_EO must be
-- made to preserve proper functioning of the stream attributes.
-
+ --
-- What is automatically output when exception tracing is on is the
-- usual exception information with the call chain backtrace possibly
-- tailored by a backtrace decorator. Modifying Exception_Information
-- itself is not a good idea because the decorated output is completely
-- out of control and would break all our code related to the streaming
- -- of exceptions. We then provide an alternative function to compute
+ -- of exceptions. We then provide an alternative function to compute
-- the possibly tailored output, which is equivalent if no decorator is
-- currently set:
package Exception_Traces is
- ----------------------------------------------
- -- Run-Time Exception Notification Routines --
- ----------------------------------------------
+ -------------------------------------------------
+ -- Run-Time Exception Notification Subprograms --
+ -------------------------------------------------
-- These subprograms provide a common run-time interface to trigger the
-- actions required when an exception is about to be propagated (e.g.
package Exception_Propagation is
- ------------------------------------
- -- Exception propagation routines --
- ------------------------------------
+ ---------------------------------------
+ -- Exception Propagation Subprograms --
+ ---------------------------------------
function Allocate_Occurrence return EOA;
-- Allocate an exception occurence (as well as the machine occurence)
package Stream_Attributes is
- --------------------------------
- -- Stream attributes routines --
- --------------------------------
+ ----------------------------------
+ -- Stream Attribute Subprograms --
+ ----------------------------------
function EId_To_String (X : Exception_Id) return String;
function String_To_EId (S : String) return Exception_Id;
-- Source as an exception to be propagated in the caller task. Target is
-- expected to be a pointer to the fixed TSD occurrence for this task.
- -----------------------------
- -- Run-Time Check Routines --
- -----------------------------
+ --------------------------------
+ -- Run-Time Check Subprograms --
+ --------------------------------
- -- These routines raise a specific exception with a reason message
+ -- These subprograms raise a specific exception with a reason message
-- attached. The parameters are the file name and line number in each
-- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
-- This routine is separated out because it has quite different behavior
-- from the others. This is the "finalize/adjust raised exception". This
-- subprogram is always called with abort deferred, unlike all other
- -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer.
+ -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
pragma Export (C, Rcheck_CE_Access_Check,
"__gnat_rcheck_CE_Access_Check");
Complete_And_Propagate_Occurrence (Excep);
end Raise_With_Msg;
- --------------------------------------
- -- Calls to Run-Time Check Routines --
- --------------------------------------
+ -----------------------------------------
+ -- Calls to Run-Time Check Subprograms --
+ -----------------------------------------
procedure Rcheck_CE_Access_Check
(File : System.Address; Line : Integer)
(File : System.Address; Line, Column, Index, First, Last : Integer)
is
Msg : constant String :=
- Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF &
- "index " & Image (Index) & " not in " & Image (First) &
- ".." & Image (Last) & ASCII.NUL;
+ Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF
+ & "index " & Image (Index) & " not in " & Image (First)
+ & ".." & Image (Last) & ASCII.NUL;
begin
Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
end Rcheck_CE_Index_Check_Ext;
(File : System.Address; Line, Column, Index, First, Last : Integer)
is
Msg : constant String :=
- Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF &
- "value " & Image (Index) & " not in " & Image (First) &
- ".." & Image (Last) & ASCII.NUL;
+ Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF
+ & "value " & Image (Index) & " not in " & Image (First)
+ & ".." & Image (Last) & ASCII.NUL;
begin
Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
end Rcheck_CE_Invalid_Data_Ext;
(File : System.Address; Line, Column, Index, First, Last : Integer)
is
Msg : constant String :=
- Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF &
- "value " & Image (Index) & " not in " & Image (First) &
- ".." & Image (Last) & ASCII.NUL;
+ Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF
+ & "value " & Image (Index) & " not in " & Image (First)
+ & ".." & Image (Last) & ASCII.NUL;
begin
Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
end Rcheck_CE_Range_Check_Ext;
begin
-- This is "finalize/adjust raised exception". This subprogram is always
- -- called with abort deferred, unlike all other Rcheck_* routines, it
+ -- called with abort deferred, unlike all other Rcheck_* subprograms, it
-- needs to call Raise_Exception_No_Defer.
-- This is consistent with Raise_From_Controlled_Operation
package Exception_Data is
- ---------------------------------
- -- Exception messages routines --
- ---------------------------------
+ -----------------------------------
+ -- Exception Message Subprograms --
+ -----------------------------------
procedure Set_Exception_C_Msg
(Excep : EOA;
-- message.
---------------------------------------
- -- Exception information subprograms --
+ -- Exception Information Subprograms --
---------------------------------------
function Untailored_Exception_Information
--
-- The Exception_Name and Message lines are omitted in the abort
-- signal case, since this is not really an exception.
-
+ --
-- Note: If the format of the generated string is changed, please note
-- that an equivalent modification to the routine String_To_EO must be
-- made to preserve proper functioning of the stream attributes.
-
+ --
-- What is automatically output when exception tracing is on is the
-- usual exception information with the call chain backtrace possibly
-- tailored by a backtrace decorator. Modifying Exception_Information
-- itself is not a good idea because the decorated output is completely
-- out of control and would break all our code related to the streaming
- -- of exceptions. We then provide an alternative function to compute
+ -- of exceptions. We then provide an alternative function to compute
-- the possibly tailored output, which is equivalent if no decorator is
-- currently set:
package Exception_Traces is
- ----------------------------------------------
- -- Run-Time Exception Notification Routines --
- ----------------------------------------------
+ -------------------------------------------------
+ -- Run-Time Exception Notification Subprograms --
+ -------------------------------------------------
-- These subprograms provide a common run-time interface to trigger the
-- actions required when an exception is about to be propagated (e.g.
package Stream_Attributes is
- --------------------------------
- -- Stream attributes routines --
- --------------------------------
+ ----------------------------------
+ -- Stream Attribute Subprograms --
+ ----------------------------------
function EId_To_String (X : Exception_Id) return String;
function String_To_EId (S : String) return Exception_Id;
-- about it.
procedure Raise_Exception_No_Defer
- (E : Exception_Id; Message : String := "");
+ (E : Exception_Id;
+ Message : String := "");
pragma Export
(Ada, Raise_Exception_No_Defer,
"ada__exceptions__raise_exception_no_defer");
-- caller task. Target is expected to be a pointer to the fixed TSD
-- occurrence for this task.
- -----------------------------
- -- Run-Time Check Routines --
- -----------------------------
+ --------------------------------
+ -- Run-Time Check Subprograms --
+ --------------------------------
- -- These routines raise a specific exception with a reason message
+ -- These subprograms raise a specific exception with a reason message
-- attached. The parameters are the file name and line number in each
-- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
- -- Note on ordering of these routines. Normally in the Ada.Exceptions units
- -- we don't care about the ordering of entries for Rcheck routines, and
- -- the normal approach is to keep them in the same order as declarations
- -- in Types.
+ -- Note on ordering of these subprograms. Normally in the Ada.Exceptions
+ -- units we do not care about the ordering of entries for Rcheck
+ -- subprograms, and the normal approach is to keep them in the same
+ -- order as declarations in Types.
-- This section is an IMPORTANT EXCEPTION. It is required by the .Net
-- runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the
-- This routine is separated out because it has quite different behavior
-- from the others. This is the "finalize/adjust raised exception". This
-- subprogram is always called with abort deferred, unlike all other
- -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer.
+ -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
pragma Export (C, Rcheck_CE_Access_Check,
"__gnat_rcheck_CE_Access_Check");
Raise_Current_Excep (E);
end Raise_With_Msg;
- --------------------------------------
- -- Calls to Run-Time Check Routines --
- --------------------------------------
+ -----------------------------------------
+ -- Calls to Run-Time Check Subprograms --
+ -----------------------------------------
procedure Rcheck_CE_Access_Check
(File : System.Address; Line : Integer)
is
E : constant Exception_Id := Program_Error_Def'Access;
Excep : constant EOA := Get_Current_Excep.all;
+
begin
-- This is "finalize/adjust raised exception". This subprogram is always
- -- called with abort deferred, unlike all other Rcheck_* routines, it
- -- needs to call Raise_Exception_No_Defer.
+ -- called with abort deferred, unlike all other Rcheck_* subprograms,
+ -- itneeds to call Raise_Exception_No_Defer.
-- This is consistent with Raise_From_Controlled_Operation
Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
end Append_Info_Address;
+ ---------------------------------------------
+ -- Append_Info_Basic_Exception_Information --
+ ---------------------------------------------
+
+ -- To ease the maximum length computation, we define and pull out a couple
+ -- of string constants:
+
+ BEI_Name_Header : constant String := "Exception name: ";
+ BEI_Msg_Header : constant String := "Message: ";
+ BEI_PID_Header : constant String := "PID: ";
+
+ procedure Append_Info_Basic_Exception_Information
+ (X : Exception_Occurrence;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ Name : String (1 .. Exception_Name_Length (X));
+ -- Buffer in which to fetch the exception name, in order to check
+ -- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
+
+ Name_Ptr : Natural := Name'First - 1;
+
+ begin
+ -- Output exception name and message except for _ABORT_SIGNAL, where
+ -- these two lines are omitted.
+
+ Append_Info_Exception_Name (X, Name, Name_Ptr);
+
+ if Name (Name'First) /= '_' then
+ Append_Info_String (BEI_Name_Header, Info, Ptr);
+ Append_Info_String (Name, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+
+ if Exception_Message_Length (X) /= 0 then
+ Append_Info_String (BEI_Msg_Header, Info, Ptr);
+ Append_Info_Exception_Message (X, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+ end if;
+ end if;
+
+ -- Output PID line if non-zero
+
+ if X.Pid /= 0 then
+ Append_Info_String (BEI_PID_Header, Info, Ptr);
+ Append_Info_Nat (X.Pid, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+ end if;
+ end Append_Info_Basic_Exception_Information;
+
---------------------------
-- Append_Info_Character --
---------------------------
end if;
end Append_Info_Character;
+ -----------------------------------
+ -- Append_Info_Exception_Message --
+ -----------------------------------
+
+ procedure Append_Info_Exception_Message
+ (X : Exception_Occurrence;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ if X.Id = Null_Id then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ Len : constant Natural := Exception_Message_Length (X);
+ Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
+ begin
+ Append_Info_String (Msg, Info, Ptr);
+ end;
+ end Append_Info_Exception_Message;
+
+ --------------------------------
+ -- Append_Info_Exception_Name --
+ --------------------------------
+
+ procedure Append_Info_Exception_Name
+ (Id : Exception_Id;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ if Id = Null_Id then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ Len : constant Natural := Exception_Name_Length (Id);
+ Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
+ begin
+ Append_Info_String (Name, Info, Ptr);
+ end;
+ end Append_Info_Exception_Name;
+
+ procedure Append_Info_Exception_Name
+ (X : Exception_Occurrence;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ Append_Info_Exception_Name (X.Id, Info, Ptr);
+ end Append_Info_Exception_Name;
+
+ ------------------------------
+ -- Exception_Info_Maxlength --
+ ------------------------------
+
+ function Exception_Info_Maxlength
+ (X : Exception_Occurrence) return Natural
+ is
+ begin
+ return
+ Basic_Exception_Info_Maxlength (X)
+ + Untailored_Exception_Traceback_Maxlength (X);
+ end Exception_Info_Maxlength;
+
---------------------
-- Append_Info_Nat --
---------------------
end if;
end Append_Info_String;
- ---------------------------------------------
- -- Append_Info_Basic_Exception_Information --
- ---------------------------------------------
-
- -- To ease the maximum length computation, we define and pull out a couple
- -- of string constants:
-
- BEI_Name_Header : constant String := "Exception name: ";
- BEI_Msg_Header : constant String := "Message: ";
- BEI_PID_Header : constant String := "PID: ";
+ --------------------------------------------------
+ -- Append_Info_Untailored_Exception_Information --
+ --------------------------------------------------
- procedure Append_Info_Basic_Exception_Information
+ procedure Append_Info_Untailored_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
- Name : String (1 .. Exception_Name_Length (X));
- -- Buffer in which to fetch the exception name, in order to check
- -- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
-
- Name_Ptr : Natural := Name'First - 1;
-
- begin
- -- Output exception name and message except for _ABORT_SIGNAL, where
- -- these two lines are omitted.
-
- Append_Info_Exception_Name (X, Name, Name_Ptr);
-
- if Name (Name'First) /= '_' then
- Append_Info_String (BEI_Name_Header, Info, Ptr);
- Append_Info_String (Name, Info, Ptr);
- Append_Info_NL (Info, Ptr);
-
- if Exception_Message_Length (X) /= 0 then
- Append_Info_String (BEI_Msg_Header, Info, Ptr);
- Append_Info_Exception_Message (X, Info, Ptr);
- Append_Info_NL (Info, Ptr);
- end if;
- end if;
-
- -- Output PID line if non-zero
-
- if X.Pid /= 0 then
- Append_Info_String (BEI_PID_Header, Info, Ptr);
- Append_Info_Nat (X.Pid, Info, Ptr);
- Append_Info_NL (Info, Ptr);
- end if;
- end Append_Info_Basic_Exception_Information;
-
- -------------------------------------------
- -- Basic_Exception_Information_Maxlength --
- -------------------------------------------
-
- function Basic_Exception_Info_Maxlength
- (X : Exception_Occurrence) return Natural is
begin
- return
- BEI_Name_Header'Length + Exception_Name_Length (X) + 1
- + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
- + BEI_PID_Header'Length + 15;
- end Basic_Exception_Info_Maxlength;
+ Append_Info_Basic_Exception_Information (X, Info, Ptr);
+ Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
+ end Append_Info_Untailored_Exception_Information;
------------------------------------------------
-- Append_Info_Untailored_Exception_Traceback --
end if;
-- The traceback lines
+
Append_Info_String (BETB_Header, Info, Ptr);
Append_Info_NL (Info, Ptr);
Append_Info_NL (Info, Ptr);
end Append_Info_Untailored_Exception_Traceback;
- ----------------------------------------------
- -- Untailored_Exception_Traceback_Maxlength --
- ----------------------------------------------
+ -------------------------------------------
+ -- Basic_Exception_Information_Maxlength --
+ -------------------------------------------
- function Untailored_Exception_Traceback_Maxlength
+ function Basic_Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural
is
- Space_Per_Address : constant := 2 + 16 + 1;
- -- Space for "0x" + HHHHHHHHHHHHHHHH + " "
begin
return
- LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
- X.Num_Tracebacks * Space_Per_Address + 1;
- end Untailored_Exception_Traceback_Maxlength;
+ BEI_Name_Header'Length + Exception_Name_Length (X) + 1
+ + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
+ + BEI_PID_Header'Length + 15;
+ end Basic_Exception_Info_Maxlength;
- --------------------------------------------------
- -- Append_Info_Untailored_Exception_Information --
- --------------------------------------------------
+ ---------------------------
+ -- Exception_Information --
+ ---------------------------
+
+ function Exception_Information (X : Exception_Occurrence) return String is
+ -- The tailored exception information is the basic information
+ -- associated with the tailored call chain backtrace.
+
+ Tback_Info : constant String := Tailored_Exception_Traceback (X);
+ Tback_Len : constant Natural := Tback_Info'Length;
+
+ Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
+ Ptr : Natural := Info'First - 1;
- procedure Append_Info_Untailored_Exception_Information
- (X : Exception_Occurrence;
- Info : in out String;
- Ptr : in out Natural)
- is
begin
Append_Info_Basic_Exception_Information (X, Info, Ptr);
- Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
- end Append_Info_Untailored_Exception_Information;
+ Append_Info_String (Tback_Info, Info, Ptr);
+ return Info (Info'First .. Ptr);
+ end Exception_Information;
------------------------------
- -- Exception_Info_Maxlength --
+ -- Exception_Message_Length --
------------------------------
- function Exception_Info_Maxlength
+ function Exception_Message_Length
(X : Exception_Occurrence) return Natural
is
begin
- return
- Basic_Exception_Info_Maxlength (X)
- + Untailored_Exception_Traceback_Maxlength (X);
- end Exception_Info_Maxlength;
-
- -----------------------------------
- -- Append_Info_Exception_Message --
- -----------------------------------
-
- procedure Append_Info_Exception_Message
- (X : Exception_Occurrence;
- Info : in out String;
- Ptr : in out Natural)
- is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- declare
- Len : constant Natural := Exception_Message_Length (X);
- Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
- begin
- Append_Info_String (Msg, Info, Ptr);
- end;
- end Append_Info_Exception_Message;
-
- --------------------------------
- -- Append_Info_Exception_Name --
- --------------------------------
-
- procedure Append_Info_Exception_Name
- (Id : Exception_Id;
- Info : in out String;
- Ptr : in out Natural)
- is
- begin
- if Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- declare
- Len : constant Natural := Exception_Name_Length (Id);
- Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
- begin
- Append_Info_String (Name, Info, Ptr);
- end;
- end Append_Info_Exception_Name;
-
- procedure Append_Info_Exception_Name
- (X : Exception_Occurrence;
- Info : in out String;
- Ptr : in out Natural)
- is
- begin
- Append_Info_Exception_Name (X.Id, Info, Ptr);
- end Append_Info_Exception_Name;
+ return X.Msg_Length;
+ end Exception_Message_Length;
---------------------------
-- Exception_Name_Length --
---------------------------
- function Exception_Name_Length
- (Id : Exception_Id) return Natural
- is
+ function Exception_Name_Length (Id : Exception_Id) return Natural is
begin
-- What is stored in the internal Name buffer includes a terminating
-- null character that we never care about.
return Id.Name_Length - 1;
end Exception_Name_Length;
- function Exception_Name_Length
- (X : Exception_Occurrence) return Natural is
+ function Exception_Name_Length (X : Exception_Occurrence) return Natural is
begin
return Exception_Name_Length (X.Id);
end Exception_Name_Length;
- ------------------------------
- -- Exception_Message_Length --
- ------------------------------
-
- function Exception_Message_Length
- (X : Exception_Occurrence) return Natural
- is
- begin
- return X.Msg_Length;
- end Exception_Message_Length;
-
-------------------------------
-- Untailored_Exception_Traceback --
-------------------------------
Id : Exception_Id;
Message : String)
is
- Len : constant Natural :=
- Natural'Min (Message'Length, Exception_Msg_Max_Length);
+ Len : constant Natural :=
+ Natural'Min (Message'Length, Exception_Msg_Max_Length);
First : constant Integer := Message'First;
begin
Excep.Exception_Raised := False;
-- call become inoffensive.
Wrapper : constant Traceback_Decorator_Wrapper_Call :=
- Traceback_Decorator_Wrapper;
+ Traceback_Decorator_Wrapper;
begin
if Wrapper = null then
end if;
end Tailored_Exception_Traceback;
- ---------------------------
- -- Exception_Information --
- ---------------------------
+ ----------------------------------------------
+ -- Untailored_Exception_Traceback_Maxlength --
+ ----------------------------------------------
- function Exception_Information
- (X : Exception_Occurrence) return String
+ function Untailored_Exception_Traceback_Maxlength
+ (X : Exception_Occurrence) return Natural
is
- -- The tailored exception information is the basic information
- -- associated with the tailored call chain backtrace.
-
- Tback_Info : constant String := Tailored_Exception_Traceback (X);
- Tback_Len : constant Natural := Tback_Info'Length;
-
- Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
- Ptr : Natural := Info'First - 1;
-
+ Space_Per_Address : constant := 2 + 16 + 1;
+ -- Space for "0x" + HHHHHHHHHHHHHHHH + " "
begin
- Append_Info_Basic_Exception_Information (X, Info, Ptr);
- Append_Info_String (Tback_Info, Info, Ptr);
- return Info (Info'First .. Ptr);
- end Exception_Information;
+ return
+ LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
+ X.Num_Tracebacks * Space_Per_Address + 1;
+ end Untailored_Exception_Traceback_Maxlength;
end Exception_Data;
else
OK := False;
end if;
+
return;
end if;
---------------------------
procedure Enable_Overflow_Check (N : Node_Id) is
- Typ : constant Entity_Id := Base_Type (Etype (N));
+ Typ : constant Entity_Id := Base_Type (Etype (N));
Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
Chk : Nat;
OK : Boolean;
Make_Assignment_Statement (Loc,
Name => Target,
Expression => New_Copy (N)));
- else
+ else
Aggr_Code :=
Build_Array_Aggr_Code (N,
Ctype => Ctyp,
git://gcc.gnu.org / gcc.git / commitdiff