with System.Storage_Elements; use System.Storage_Elements;
separate (Ada.Exceptions)
package body Exception_Data is
procedure Append_Info_Address
(A : Address;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Character
(C : Character;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Nat
(N : Natural;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_NL
(Info : in out String;
Ptr : in out Natural);
pragma Inline (Append_Info_NL);
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Name
(Id : Exception_Id;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Name
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Message
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Basic_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Basic_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
function Basic_Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural;
function Basic_Exception_Tback_Maxlength
(X : Exception_Occurrence) return Natural;
function Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural;
function Exception_Name_Length
(Id : Exception_Id) return Natural;
function Exception_Name_Length
(X : Exception_Occurrence) return Natural;
function Exception_Message_Length
(X : Exception_Occurrence) return Natural;
function Basic_Exception_Traceback
(X : Exception_Occurrence) return String;
function Tailored_Exception_Traceback
(X : Exception_Occurrence) return String;
pragma Export
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
pragma Export
(Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
pragma Export
(Ada, Exception_Message_Length, "__gnat_exception_msg_len");
procedure Append_Info_Address
(A : Address;
Info : in out String;
Ptr : in out Natural)
is
S : String (1 .. 18);
P : Natural;
N : Integer_Address;
H : constant array (Integer range 0 .. 15) of Character :=
"0123456789abcdef";
begin
P := S'Last;
N := To_Integer (A);
loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
exit when N = 0;
end loop;
S (P - 1) := '0';
S (P) := 'x';
Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
end Append_Info_Address;
procedure Append_Info_Character
(C : Character;
Info : in out String;
Ptr : in out Natural)
is
begin
if Info'Length = 0 then
To_Stderr (C);
elsif Ptr < Info'Last then
Ptr := Ptr + 1;
Info (Ptr) := C;
end if;
end Append_Info_Character;
procedure Append_Info_Nat
(N : Natural;
Info : in out String;
Ptr : in out Natural)
is
begin
if N > 9 then
Append_Info_Nat (N / 10, Info, Ptr);
end if;
Append_Info_Character
(Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
end Append_Info_Nat;
procedure Append_Info_NL
(Info : in out String;
Ptr : in out Natural)
is
begin
Append_Info_Character (ASCII.LF, Info, Ptr);
end Append_Info_NL;
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural)
is
begin
if Info'Length = 0 then
To_Stderr (S);
else
declare
Last : constant Natural :=
Integer'Min (Ptr + S'Length, Info'Last);
begin
Info (Ptr + 1 .. Last) := S;
Ptr := Last;
end;
end if;
end Append_Info_String;
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));
Name_Ptr : Natural := Name'First - 1;
begin
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;
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;
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;
BETB_Header : constant String := "Call stack traceback locations:";
procedure Append_Info_Basic_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
begin
if X.Num_Tracebacks <= 0 then
return;
end if;
Append_Info_String (BETB_Header, Info, Ptr);
Append_Info_NL (Info, Ptr);
for J in 1 .. X.Num_Tracebacks loop
Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
exit when J = X.Num_Tracebacks;
Append_Info_Character (' ', Info, Ptr);
end loop;
Append_Info_NL (Info, Ptr);
end Append_Info_Basic_Exception_Traceback;
function Basic_Exception_Tback_Maxlength
(X : Exception_Occurrence) return Natural is
begin
return BETB_Header'Length + 1 + X.Num_Tracebacks * 19 + 1;
end Basic_Exception_Tback_Maxlength;
procedure Append_Info_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_Basic_Exception_Traceback (X, Info, Ptr);
end Append_Info_Exception_Information;
function Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural is
begin
return
Basic_Exception_Info_Maxlength (X)
+ Basic_Exception_Tback_Maxlength (X);
end Exception_Info_Maxlength;
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;
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) := 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;
function Exception_Name_Length
(Id : Exception_Id) return Natural is
begin
return Id.Name_Length - 1;
end Exception_Name_Length;
function Exception_Name_Length
(X : Exception_Occurrence) return Natural is
begin
return Exception_Name_Length (X.Id);
end Exception_Name_Length;
function Exception_Message_Length
(X : Exception_Occurrence) return Natural is
begin
return X.Msg_Length;
end Exception_Message_Length;
function Basic_Exception_Traceback
(X : Exception_Occurrence) return String
is
Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
return Info (Info'First .. Ptr);
end Basic_Exception_Traceback;
function Exception_Information
(X : Exception_Occurrence) return String
is
Info : String (1 .. Exception_Info_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
Append_Info_Exception_Information (X, Info, Ptr);
return Info (Info'First .. Ptr);
end Exception_Information;
procedure Set_Exception_C_Msg
(Id : Exception_Id;
Msg1 : Big_String_Ptr;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null)
is
Excep : constant EOA := Get_Current_Excep.all;
Val : Integer := Line;
Remind : Integer;
Size : Integer := 1;
Ptr : Natural;
begin
Exception_Propagation.Setup_Exception (Excep, Excep);
Excep.Exception_Raised := False;
Excep.Id := Id;
Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
Excep.Msg_Length := 0;
Excep.Cleanup_Flag := False;
while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
end loop;
if Line > 0 then
while Val > 0 loop
Val := Val / 10;
Size := Size + 1;
end loop;
if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
Excep.Msg (Excep.Msg_Length + 1) := ':';
Excep.Msg_Length := Excep.Msg_Length + Size;
Val := Line;
Size := 0;
while Val > 0 loop
Remind := Val rem 10;
Val := Val / 10;
Excep.Msg (Excep.Msg_Length - Size) :=
Character'Val (Remind + Character'Pos ('0'));
Size := Size + 1;
end loop;
end if;
end if;
if Msg2 /= null
and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
then
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := ' ';
Ptr := 1;
while Msg2 (Ptr) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
Ptr := Ptr + 1;
end loop;
end if;
end Set_Exception_C_Msg;
procedure Set_Exception_Msg
(Id : Exception_Id;
Message : String)
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
First : constant Integer := Message'First;
Excep : constant EOA := Get_Current_Excep.all;
begin
Exception_Propagation.Setup_Exception (Excep, Excep);
Excep.Exception_Raised := False;
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (First .. First + Len - 1);
Excep.Id := Id;
Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
Excep.Cleanup_Flag := False;
end Set_Exception_Msg;
function Tailored_Exception_Traceback
(X : Exception_Occurrence) return String
is
Wrapper : constant Traceback_Decorator_Wrapper_Call :=
Traceback_Decorator_Wrapper;
begin
if Wrapper = null then
return Basic_Exception_Traceback (X);
else
return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
end if;
end Tailored_Exception_Traceback;
function Tailored_Exception_Information
(X : Exception_Occurrence) return String
is
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;
begin
Append_Info_Basic_Exception_Information (X, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info (Info'First .. Ptr);
end Tailored_Exception_Information;
end Exception_Data;