pragma Polling (Off);
with Ada.Unchecked_Deallocation;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with System; use System;
with System.Exception_Table; use System.Exception_Table;
with System.Exceptions; use System.Exceptions;
with System.Standard_Library; use System.Standard_Library;
with System.Storage_Elements; use System.Storage_Elements;
with System.Soft_Links; use System.Soft_Links;
with System.Machine_State_Operations; use System.Machine_State_Operations;
with System.Traceback;
with Unchecked_Conversion;
package body Ada.Exceptions is
procedure builtin_longjmp (buffer : Address; Flag : Integer);
pragma No_Return (builtin_longjmp);
pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
pragma Suppress (All_Checks);
type Subprogram_Descriptor_List_Ptr is
access all Subprogram_Descriptor_List;
Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
Num_Subprogram_Descriptors : Natural;
Exception_Tracebacks : Integer;
pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
Zero_Cost_Exceptions : Integer;
pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
Nline : constant String := String' (1 => ASCII.LF);
type Unwind_Reason_Code is
(URC_NO_REASON,
URC_FOREIGN_EXCEPTION_CAUGHT,
URC_PHASE2_ERROR,
URC_PHASE1_ERROR,
URC_NORMAL_STOP,
URC_END_OF_STACK,
URC_HANDLER_FOUND,
URC_INSTALL_CONTEXT,
URC_CONTINUE_UNWIND);
pragma Warnings (Off);
pragma Unreferenced
(URC_NO_REASON,
URC_FOREIGN_EXCEPTION_CAUGHT,
URC_PHASE2_ERROR,
URC_PHASE1_ERROR,
URC_NORMAL_STOP,
URC_END_OF_STACK,
URC_HANDLER_FOUND,
URC_INSTALL_CONTEXT,
URC_CONTINUE_UNWIND);
pragma Warnings (On);
pragma Convention (C, Unwind_Reason_Code);
subtype Exception_Class is String (1 .. 8);
GNAT_Exception_Class : constant Exception_Class
:= "GNU" & ASCII.NUL & "Ada" & ASCII.NUL;
type Unwind_Exception is record
Class : Exception_Class := GNAT_Exception_Class;
Cleanup : System.Address := System.Null_Address;
Private1 : Integer;
Private2 : Integer;
end record;
pragma Convention (C, Unwind_Exception);
for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
type GNAT_GCC_Exception is record
Header : Unwind_Exception;
Id : Exception_Id;
Handled_By_Others : Boolean;
Has_Cleanup : Boolean;
Select_Cleanups : Boolean;
end record;
pragma Convention (C, GNAT_GCC_Exception);
function Unwind_RaiseException
(E : access GNAT_GCC_Exception)
return Unwind_Reason_Code;
pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
procedure AAA;
procedure ZZZ;
function Address_Image (A : System.Address) return String;
procedure Call_Chain (Excep : EOA);
procedure Free
is new Ada.Unchecked_Deallocation
(Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);
procedure Process_Raise_Exception
(E : Exception_Id;
From_Signal_Handler : Boolean);
pragma Inline (Process_Raise_Exception);
pragma No_Return (Process_Raise_Exception);
procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State);
pragma No_Return (Propagate_Exception_With_FE_Support);
procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State);
pragma No_Return (Propagate_Exception_With_GCC_Support);
procedure Raise_Current_Excep (E : Exception_Id);
pragma No_Return (Raise_Current_Excep);
pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
procedure Raise_Exception_No_Defer
(E : Exception_Id; Message : String := "");
pragma Export (Ada, Raise_Exception_No_Defer,
"ada__exceptions__raise_exception_no_defer");
pragma No_Return (Raise_Exception_No_Defer);
procedure Raise_With_Msg (E : Exception_Id);
pragma No_Return (Raise_With_Msg);
pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
procedure Raise_With_Location
(E : Exception_Id;
F : Big_String_Ptr;
L : Integer);
pragma No_Return (Raise_With_Location);
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
L : Integer;
M : Big_String_Ptr);
pragma No_Return (Raise_With_Location_And_Msg);
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
Line : Integer);
pragma No_Return (Raise_Constraint_Error);
pragma Export
(C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
procedure Raise_Constraint_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr);
pragma No_Return (Raise_Constraint_Error_Msg);
pragma Export
(C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
procedure Raise_Program_Error
(File : Big_String_Ptr;
Line : Integer);
pragma No_Return (Raise_Program_Error);
pragma Export
(C, Raise_Program_Error, "__gnat_raise_program_error");
procedure Raise_Program_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr);
pragma No_Return (Raise_Program_Error_Msg);
pragma Export
(C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
procedure Raise_Storage_Error
(File : Big_String_Ptr;
Line : Integer);
pragma No_Return (Raise_Storage_Error);
pragma Export
(C, Raise_Storage_Error, "__gnat_raise_storage_error");
procedure Raise_Storage_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr);
pragma No_Return (Raise_Storage_Error_Msg);
pragma Export
(C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
procedure Reraise;
pragma No_Return (Reraise);
pragma Export (C, Reraise, "__gnat_reraise");
function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean;
procedure SDP_Table_Sort_Move (From : Natural; To : Natural);
procedure Set_Exception_C_Msg
(Id : Exception_Id;
Msg1 : Big_String_Ptr;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null);
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
procedure Unhandled_Exception_Terminate;
pragma No_Return (Unhandled_Exception_Terminate);
procedure Notify_Exception
(Id : Exception_Id;
Handler : Code_Loc;
Is_Others : Boolean);
pragma Export (C, Notify_Exception, "__gnat_notify_exception");
procedure Unhandled_Exception;
pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
use ASCII;
Rmsg_00 : constant String := "access check failed" & NUL;
Rmsg_01 : constant String := "access parameter is null" & NUL;
Rmsg_02 : constant String := "discriminant check failed" & NUL;
Rmsg_03 : constant String := "divide by zero" & NUL;
Rmsg_04 : constant String := "explicit raise" & NUL;
Rmsg_05 : constant String := "index check failed" & NUL;
Rmsg_06 : constant String := "invalid data" & NUL;
Rmsg_07 : constant String := "length check failed" & NUL;
Rmsg_08 : constant String := "overflow check failed" & NUL;
Rmsg_09 : constant String := "partition check failed" & NUL;
Rmsg_10 : constant String := "range check failed" & NUL;
Rmsg_11 : constant String := "tag check failed" & NUL;
Rmsg_12 : constant String := "access before elaboration" & NUL;
Rmsg_13 : constant String := "accessibility check failed" & NUL;
Rmsg_14 : constant String := "all guards closed" & NUL;
Rmsg_15 : constant String := "duplicated entry address" & NUL;
Rmsg_16 : constant String := "explicit raise" & NUL;
Rmsg_17 : constant String := "finalize raised exception" & NUL;
Rmsg_18 : constant String := "invalid data" & NUL;
Rmsg_19 : constant String := "misaligned address value" & NUL;
Rmsg_20 : constant String := "missing return" & NUL;
Rmsg_21 : constant String := "potentially blocking operation" & NUL;
Rmsg_22 : constant String := "stubbed subprogram called" & NUL;
Rmsg_23 : constant String := "unchecked union restriction" & NUL;
Rmsg_24 : constant String := "empty storage pool" & NUL;
Rmsg_25 : constant String := "explicit raise" & NUL;
Rmsg_26 : constant String := "infinite recursion" & NUL;
Rmsg_27 : constant String := "object too large" & NUL;
Rmsg_28 : constant String := "restriction violation" & NUL;
procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address));
end Rcheck_00;
procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address));
end Rcheck_01;
procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address));
end Rcheck_02;
procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address));
end Rcheck_03;
procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address));
end Rcheck_04;
procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address));
end Rcheck_05;
procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address));
end Rcheck_06;
procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address));
end Rcheck_07;
procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address));
end Rcheck_08;
procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address));
end Rcheck_09;
procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address));
end Rcheck_10;
procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address));
end Rcheck_11;
procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address));
end Rcheck_12;
procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address));
end Rcheck_13;
procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address));
end Rcheck_14;
procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address));
end Rcheck_15;
procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address));
end Rcheck_16;
procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address));
end Rcheck_17;
procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address));
end Rcheck_18;
procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address));
end Rcheck_19;
procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address));
end Rcheck_20;
procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address));
end Rcheck_21;
procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address));
end Rcheck_22;
procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address));
end Rcheck_23;
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
end Rcheck_24;
procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address));
end Rcheck_25;
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address));
end Rcheck_26;
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address));
end Rcheck_27;
procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address));
end Rcheck_28;
function Tailored_Exception_Information
(X : Exception_Occurrence)
return String;
pragma Export
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
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);
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural);
function Basic_Exception_Information
(X : Exception_Occurrence)
return String;
function Basic_Exception_Traceback
(X : Exception_Occurrence)
return String;
function Tailored_Exception_Traceback
(X : Exception_Occurrence)
return String;
procedure Notify_Handled_Exception
(Handler : Code_Loc;
Is_Others : Boolean;
Low_Notify : Boolean);
pragma Export (C, Notify_Handled_Exception,
"__gnat_notify_handled_exception");
procedure Notify_Unhandled_Exception (Id : Exception_Id);
pragma Export (C, Notify_Unhandled_Exception,
"__gnat_notify_unhandled_exception");
pragma Warnings (Off); pragma Propagate_Exceptions;
procedure Unhandled_Terminate;
pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
type Unsigned is mod 2 ** 32;
Counter : Unsigned := 0;
procedure Poll is separate;
procedure AAA is
begin
null;
end AAA;
function Address_Image (A : Address) return String 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);
while N /= 0 loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
end loop;
S (P - 1) := '0';
S (P) := 'x';
return S (P - 1 .. S'Last);
end Address_Image;
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;
Ptr := Ptr + 1;
Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
end Append_Info_Nat;
procedure Append_Info_NL
(Info : in out String;
Ptr : in out Natural)
is
begin
Ptr := Ptr + 1;
Info (Ptr) := ASCII.LF;
end Append_Info_NL;
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural)
is
begin
Info (Ptr + 1 .. Ptr + S'Length) := S;
Ptr := Ptr + S'Length;
end Append_Info_String;
function Basic_Exception_Information
(X : Exception_Occurrence)
return String
is
Name : constant String := Exception_Name (X);
Msg : constant String := Exception_Message (X);
Name_Len : constant Natural := Name'Length;
Msg_Len : constant Natural := Msg'Length;
Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
Info : String (1 .. Info_Maxlen);
Ptr : Natural := 0;
begin
if Name (1) /= '_' then
Append_Info_String ("Exception name: ", Info, Ptr);
Append_Info_String (Name, Info, Ptr);
Append_Info_NL (Info, Ptr);
if Msg_Len /= 0 then
Append_Info_String ("Message: ", Info, Ptr);
Append_Info_String (Msg, Info, Ptr);
Append_Info_NL (Info, Ptr);
end if;
end if;
if X.Pid /= 0 then
Append_Info_String ("PID: ", Info, Ptr);
Append_Info_Nat (X.Pid, Info, Ptr);
Append_Info_NL (Info, Ptr);
end if;
return Info (1 .. Ptr);
end Basic_Exception_Information;
function Basic_Exception_Traceback
(X : Exception_Occurrence)
return String
is
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
Info : String (1 .. Info_Maxlen);
Ptr : Natural := 0;
begin
if X.Num_Tracebacks > 0 then
Append_Info_String ("Call stack traceback locations:", Info, Ptr);
Append_Info_NL (Info, Ptr);
for J in 1 .. X.Num_Tracebacks loop
Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr);
exit when J = X.Num_Tracebacks;
Append_Info_String (" ", Info, Ptr);
end loop;
Append_Info_NL (Info, Ptr);
end if;
return Info (1 .. Ptr);
end Basic_Exception_Traceback;
procedure Break_Start is
begin
null;
end Break_Start;
procedure Call_Chain (Excep : EOA) is
begin
if Excep.Num_Tracebacks /= 0 then
return;
end if;
System.Traceback.Call_Chain
(Excep.Tracebacks'Address,
Max_Tracebacks,
Excep.Num_Tracebacks,
AAA'Address,
ZZZ'Address);
end Call_Chain;
function Current_Target_Exception return Exception_Occurrence is
begin
return Null_Occurrence;
end Current_Target_Exception;
function EId_To_String (X : Exception_Id) return String is
begin
if X = Null_Id then
return "";
else
return Exception_Name (X);
end if;
end EId_To_String;
function EO_To_String (X : Exception_Occurrence) return String is
begin
if X.Id = Null_Id then
return "";
else
return Exception_Information (X);
end if;
end EO_To_String;
function Exception_Identity
(X : Exception_Occurrence)
return Exception_Id
is
begin
if X.Id = Null_Id then
raise Constraint_Error;
else
return X.Id;
end if;
end Exception_Identity;
function Exception_Information (X : Exception_Occurrence) return String is
Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Basic_Exception_Traceback (X);
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
Info : String (1 .. Basic_Len + Tback_Len);
Ptr : Natural := 0;
begin
Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info;
end Exception_Information;
function Exception_Message (X : Exception_Occurrence) return String is
begin
if X.Id = Null_Id then
raise Constraint_Error;
end if;
return X.Msg (1 .. X.Msg_Length);
end Exception_Message;
function Exception_Name (Id : Exception_Id) return String is
begin
if Id = null then
raise Constraint_Error;
end if;
return Id.Full_Name.all (1 .. Id.Name_Length - 1);
end Exception_Name;
function Exception_Name (X : Exception_Occurrence) return String is
begin
return Exception_Name (X.Id);
end Exception_Name;
function Exception_Name_Simple (X : Exception_Occurrence) return String is
Name : constant String := Exception_Name (X);
P : Natural;
begin
P := Name'Length;
while P > 1 loop
exit when Name (P - 1) = '.';
P := P - 1;
end loop;
return Name (P .. Name'Length);
end Exception_Name_Simple;
procedure Process_Raise_Exception
(E : Exception_Id;
From_Signal_Handler : Boolean)
is
pragma Inspection_Point (E);
Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
Mstate_Ptr : constant Machine_State :=
Machine_State (Get_Machine_State_Addr.all);
Excep : EOA := Get_Current_Excep.all;
begin
if Zero_Cost_Exceptions /= 0 then
if not From_Signal_Handler then
Set_Machine_State (Mstate_Ptr);
end if;
if Subprogram_Descriptors /= null then
Propagate_Exception_With_FE_Support (Mstate_Ptr);
else
Propagate_Exception_With_GCC_Support (Mstate_Ptr);
end if;
else
if not From_Signal_Handler
and then Exception_Tracebacks /= 0
then
Call_Chain (Excep);
end if;
if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
Notify_Handled_Exception (Null_Loc, False, False);
end if;
builtin_longjmp (Jumpbuf_Ptr, 1);
else
Notify_Unhandled_Exception (E);
Unhandled_Exception_Terminate;
end if;
end if;
end Process_Raise_Exception;
procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is
Excep : constant EOA := Get_Current_Excep.all;
Loc : Code_Loc;
Lo, Hi : Natural;
Pdesc : Natural;
Hrec : Handler_Record_Ptr;
Info : Subprogram_Info_Type;
type Machine_State_Record is
new Storage_Array (1 .. Machine_State_Length);
for Machine_State_Record'Alignment use Standard'Maximum_Alignment;
procedure Duplicate_Machine_State (Dest, Src : Machine_State);
procedure Duplicate_Machine_State (Dest, Src : Machine_State) is
type Machine_State_Record_Access is access Machine_State_Record;
function To_MSR is new Unchecked_Conversion
(Machine_State, Machine_State_Record_Access);
begin
To_MSR (Dest).all := To_MSR (Src).all;
end Duplicate_Machine_State;
FH_Found : Boolean := False;
FH_Mstate : aliased Machine_State_Record;
FH_Handler : Code_Loc := Null_Address;
FH_Num_Trb : Natural := 0;
begin
Main_Loop : loop
Loc := Get_Code_Loc (Mstate);
exit Main_Loop when Loc = Null_Loc;
if Loc < AAA'Address or else Loc > ZZZ'Address then
if Excep.Num_Tracebacks /= Max_Tracebacks then
if not Excep.Cleanup_Flag then
Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1;
Excep.Tracebacks (Excep.Num_Tracebacks) := Loc;
else
Excep.Cleanup_Flag := False;
end if;
end if;
end if;
Lo := 1;
Hi := Num_Subprogram_Descriptors;
loop
Pdesc := (Lo + Hi) / 2;
if Loc < Subprogram_Descriptors (Pdesc).Code then
Hi := Pdesc - 1;
elsif Pdesc < Num_Subprogram_Descriptors
and then Loc > Subprogram_Descriptors (Pdesc + 1).Code
then
Lo := Pdesc + 1;
else
exit;
end if;
exit Main_Loop when Hi < Lo;
end loop;
for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop
Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J);
if Loc >= Hrec.Lo and then Loc < Hrec.Hi then
if Hrec.Id = All_Others_Id then
if not FH_Found then
FH_Found := True;
Duplicate_Machine_State
(Machine_State (FH_Mstate'Address), Mstate);
FH_Handler := Hrec.Handler;
FH_Num_Trb := Excep.Num_Tracebacks;
end if;
elsif Excep.Id = Hrec.Id
or else (Hrec.Id = Others_Id
and not Excep.Id.Not_Handled_By_Others)
then
Notify_Handled_Exception
(Hrec.Handler, Hrec.Id = Others_Id, True);
if FH_Found then
Excep.Num_Tracebacks := FH_Num_Trb;
Excep.Cleanup_Flag := True;
Enter_Handler
(Machine_State (FH_Mstate'Address), FH_Handler);
else
Enter_Handler (Mstate, Hrec.Handler);
end if;
end if;
end if;
end loop;
Info := Subprogram_Descriptors (Pdesc).Subprogram_Info;
exit Main_Loop when Info = No_Info;
Pop_Frame (Mstate, Info);
end loop Main_Loop;
Notify_Unhandled_Exception (Excep.Id);
if FH_Found then
Excep.Num_Tracebacks := FH_Num_Trb;
Excep.Cleanup_Flag := True;
Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler);
end if;
Unhandled_Exception_Terminate;
end Propagate_Exception_With_FE_Support;
procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is
Excep : EOA := Get_Current_Excep.all;
This_Exception : aliased GNAT_GCC_Exception;
Status : Unwind_Reason_Code;
begin
This_Exception.Id := Excep.Id;
This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
This_Exception.Has_Cleanup := False;
This_Exception.Select_Cleanups := False;
Status := Unwind_RaiseException (This_Exception'Access);
if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
Notify_Unhandled_Exception (Excep.Id);
end if;
if This_Exception.Has_Cleanup then
This_Exception.Select_Cleanups := True;
Status := Unwind_RaiseException (This_Exception'Access);
end if;
Unhandled_Exception_Terminate;
end Propagate_Exception_With_GCC_Support;
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
Line : Integer)
is
begin
Raise_With_Location (Constraint_Error_Def'Access, File, Line);
end Raise_Constraint_Error;
procedure Raise_Constraint_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
begin
Raise_With_Location_And_Msg
(Constraint_Error_Def'Access, File, Line, Msg);
end Raise_Constraint_Error_Msg;
procedure Raise_Current_Excep (E : Exception_Id) is
begin
Process_Raise_Exception (E => E, From_Signal_Handler => False);
end Raise_Current_Excep;
procedure Raise_Exception
(E : Exception_Id;
Message : String := "")
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
Excep : constant EOA := Get_Current_Excep.all;
begin
if E /= null then
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (1 .. Len);
Raise_With_Msg (E);
end if;
end Raise_Exception;
procedure Raise_Exception_Always
(E : Exception_Id;
Message : String := "")
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (1 .. Len);
Raise_With_Msg (E);
end Raise_Exception_Always;
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : Big_String_Ptr)
is
begin
Set_Exception_C_Msg (E, M);
Abort_Defer.all;
Process_Raise_Exception (E => E, From_Signal_Handler => True);
end Raise_From_Signal_Handler;
procedure Raise_No_Msg (E : Exception_Id) is
Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Msg_Length := 0;
Raise_With_Msg (E);
end Raise_No_Msg;
procedure Raise_Program_Error
(File : Big_String_Ptr;
Line : Integer)
is
begin
Raise_With_Location (Program_Error_Def'Access, File, Line);
end Raise_Program_Error;
procedure Raise_Program_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
begin
Raise_With_Location_And_Msg
(Program_Error_Def'Access, File, Line, Msg);
end Raise_Program_Error_Msg;
procedure Raise_Storage_Error
(File : Big_String_Ptr;
Line : Integer)
is
begin
Raise_With_Location (Storage_Error_Def'Access, File, Line);
end Raise_Storage_Error;
procedure Raise_Storage_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
begin
Raise_With_Location_And_Msg
(Storage_Error_Def'Access, File, Line, Msg);
end Raise_Storage_Error_Msg;
procedure Raise_With_C_Msg
(E : Exception_Id;
M : Big_String_Ptr)
is
begin
Set_Exception_C_Msg (E, M);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_C_Msg;
procedure Raise_With_Location
(E : Exception_Id;
F : Big_String_Ptr;
L : Integer)
is
begin
Set_Exception_C_Msg (E, F, L);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Location;
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
L : Integer;
M : Big_String_Ptr)
is
begin
Set_Exception_C_Msg (E, F, L, M);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Location_And_Msg;
procedure Raise_With_Msg (E : Exception_Id) is
Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Id := E;
Excep.Num_Tracebacks := 0;
Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Msg;
procedure Reraise is
Excep : constant EOA := Get_Current_Excep.all;
begin
Abort_Defer.all;
Raise_Current_Excep (Excep.Id);
end Reraise;
procedure Reraise_Occurrence (X : Exception_Occurrence) is
begin
if X.Id /= null then
Abort_Defer.all;
Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end if;
end Reraise_Occurrence;
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
Abort_Defer.all;
Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_Always;
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
begin
Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_No_Defer;
procedure Save_Occurrence
(Target : out Exception_Occurrence;
Source : Exception_Occurrence)
is
begin
Target.Id := Source.Id;
Target.Msg_Length := Source.Msg_Length;
Target.Num_Tracebacks := Source.Num_Tracebacks;
Target.Pid := Source.Pid;
Target.Cleanup_Flag := Source.Cleanup_Flag;
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
Source.Tracebacks (1 .. Target.Num_Tracebacks);
end Save_Occurrence;
function Save_Occurrence
(Source : Exception_Occurrence)
return EOA
is
Target : EOA := new Exception_Occurrence;
begin
Save_Occurrence (Target.all, Source);
return Target;
end Save_Occurrence;
procedure SDP_Table_Build
(SDP_Addresses : System.Address;
SDP_Count : Natural;
Elab_Addresses : System.Address;
Elab_Addr_Count : Natural)
is
type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr;
type SDLP_Array_Ptr is access all SDLP_Array;
function To_SDLP_Array_Ptr is new Unchecked_Conversion
(System.Address, SDLP_Array_Ptr);
T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses);
type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc;
type Elab_Array_Ptr is access all Elab_Array;
function To_Elab_Array_Ptr is new Unchecked_Conversion
(System.Address, Elab_Array_Ptr);
EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses);
Ndes : Natural;
Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
begin
if Subprogram_Descriptors = null then
Num_Subprogram_Descriptors := 0;
end if;
Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count;
for J in T'Range loop
Ndes := Ndes + T (J).Count;
end loop;
Previous_Subprogram_Descriptors := Subprogram_Descriptors;
Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes);
for J in 1 .. Num_Subprogram_Descriptors loop
Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J);
end loop;
Free (Previous_Subprogram_Descriptors);
Ndes := Num_Subprogram_Descriptors;
for J in EA'Range loop
Ndes := Ndes + 1;
Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0;
Subprogram_Descriptors (Ndes).all :=
Subprogram_Descriptor'
(Num_Handlers => 0,
Code => Fetch_Code (EA (J)),
Subprogram_Info => EA (J),
Handler_Records => (1 .. 0 => null));
end loop;
for J in T'Range loop
for K in 1 .. T (J).Count loop
Ndes := Ndes + 1;
Subprogram_Descriptors (Ndes) := T (J).SDesc (K);
Subprogram_Descriptors (Ndes).Code :=
Fetch_Code (T (J).SDesc (K).Code);
end loop;
end loop;
Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access);
Num_Subprogram_Descriptors := 1;
for J in 2 .. Ndes loop
if Subprogram_Descriptors (J).Code /=
Subprogram_Descriptors (Num_Subprogram_Descriptors).Code
then
Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1;
Subprogram_Descriptors (Num_Subprogram_Descriptors) :=
Subprogram_Descriptors (J);
end if;
end loop;
end SDP_Table_Build;
function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is
SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code;
SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code;
begin
if SDC1 < SDC2 then
return True;
elsif SDC1 > SDC2 then
return False;
else
return Subprogram_Descriptors (Op1).Num_Handlers /= 0
and then Subprogram_Descriptors (Op2).Num_Handlers = 0;
end if;
end SDP_Table_Sort_Lt;
procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is
begin
Subprogram_Descriptors (To) := Subprogram_Descriptors (From);
end SDP_Table_Sort_Move;
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
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;
function String_To_EId (S : String) return Exception_Id is
begin
if S = "" then
return Null_Id;
else
return Exception_Id (Internal_Exception (S));
end if;
end String_To_EId;
function String_To_EO (S : String) return Exception_Occurrence is
From : Natural;
To : Integer;
X : Exception_Occurrence;
procedure Bad_EO;
pragma No_Return (Bad_EO);
procedure Next_String;
procedure Bad_EO is
begin
Raise_Exception
(Program_Error'Identity,
"bad exception occurrence in stream input");
end Bad_EO;
procedure Next_String is
begin
From := To + 2;
if From < S'Last then
To := From + 1;
while To < S'Last - 1 loop
if To >= S'Last then
Bad_EO;
elsif S (To + 1) = ASCII.LF then
exit;
else
To := To + 1;
end if;
end loop;
end if;
end Next_String;
begin
if S = "" then
return Null_Occurrence;
else
X.Cleanup_Flag := False;
To := S'First - 2;
Next_String;
if S (From .. From + 15) /= "Exception name: " then
Bad_EO;
end if;
X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
Next_String;
if From <= To and then S (From) = 'M' then
if S (From .. From + 8) /= "Message: " then
Bad_EO;
end if;
X.Msg_Length := To - From - 8;
X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
Next_String;
else
X.Msg_Length := 0;
end if;
X.Pid := 0;
if From <= To and then S (From) = 'P' then
if S (From .. From + 3) /= "PID:" then
Bad_EO;
end if;
From := From + 5;
while From <= To loop
X.Pid := X.Pid * 10 +
(Character'Pos (S (From)) - Character'Pos ('0'));
From := From + 1;
end loop;
Next_String;
end if;
X.Num_Tracebacks := 0;
if From <= To then
if S (From .. To) /= "Call stack traceback locations:" then
Bad_EO;
end if;
Next_String;
loop
exit when From > To;
declare
Ch : Character;
C : Integer_Address;
N : Integer_Address;
begin
if S (From) /= '0'
or else S (From + 1) /= 'x'
then
Bad_EO;
else
From := From + 2;
end if;
C := 0;
while From <= To loop
Ch := S (From);
if Ch in '0' .. '9' then
N :=
Character'Pos (S (From)) - Character'Pos ('0');
elsif Ch in 'a' .. 'f' then
N :=
Character'Pos (S (From)) - Character'Pos ('a') + 10;
elsif Ch = ' ' then
From := From + 1;
exit;
else
Bad_EO;
end if;
C := C * 16 + N;
From := From + 1;
end loop;
if X.Num_Tracebacks = Max_Tracebacks then
Bad_EO;
end if;
X.Num_Tracebacks := X.Num_Tracebacks + 1;
X.Tracebacks (X.Num_Tracebacks) := To_Address (C);
end;
end loop;
end if;
X.Exception_Raised := True;
return X;
end if;
end String_To_EO;
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
Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Tailored_Exception_Traceback (X);
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
Info : String (1 .. Basic_Len + Tback_Len);
Ptr : Natural := 0;
begin
Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info;
end Tailored_Exception_Information;
procedure Unhandled_Exception is
begin
null;
end Unhandled_Exception;
procedure Notify_Exception
(Id : Exception_Id;
Handler : Code_Loc;
Is_Others : Boolean)
is
begin
null;
end Notify_Exception;
procedure Notify_Handled_Exception
(Handler : Code_Loc;
Is_Others : Boolean;
Low_Notify : Boolean)
is
Excep : constant EOA := Get_Current_Excep.all;
begin
if Low_Notify then
Notify_Exception (Excep.Id, Handler, Is_Others);
end if;
if Exception_Trace = Every_Raise
and then not Excep.Id.Not_Handled_By_Others
then
To_Stderr (Nline);
To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end if;
end Notify_Handled_Exception;
procedure Notify_Unhandled_Exception (Id : Exception_Id) is
begin
Unhandled_Exception;
Notify_Exception (Id, Null_Loc, False);
end Notify_Unhandled_Exception;
adafinal_Called : Boolean := False;
type FILEs is new System.Address;
type int is new Integer;
procedure Unhandled_Exception_Terminate is
Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
Msg : constant String := Exception_Message (Excep.all);
begin
if not adafinal_Called then
adafinal_Called := True;
System.Soft_Links.Adafinal.all;
end if;
if Exception_Name (Excep.all) (1) = '_' then
To_Stderr (Nline);
To_Stderr ("Execution terminated by abort of environment task");
To_Stderr (Nline);
elsif Excep.Num_Tracebacks = 0 then
To_Stderr (Nline);
To_Stderr ("raised ");
To_Stderr (Exception_Name (Excep.all));
if Msg'Length /= 0 then
To_Stderr (" : ");
To_Stderr (Msg);
end if;
To_Stderr (Nline);
else
To_Stderr (Nline);
To_Stderr ("Execution terminated by unhandled exception");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end if;
declare
procedure Unhandled_Terminate;
pragma No_Return (Unhandled_Terminate);
pragma Import
(C, Unhandled_Terminate, "__gnat_unhandled_terminate");
begin
Unhandled_Terminate;
end;
end Unhandled_Exception_Terminate;
procedure Raise_Exception_No_Defer
(E : Exception_Id;
Message : String := "")
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (1 .. Len);
Excep.Id := E;
Excep.Num_Tracebacks := 0;
Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
Raise_Current_Excep (E);
end Raise_Exception_No_Defer;
procedure To_Stderr (S : String) is
procedure put_char_stderr (C : int);
pragma Import (C, put_char_stderr, "put_char_stderr");
begin
for J in 1 .. S'Length loop
if S (J) /= ASCII.CR then
put_char_stderr (Character'Pos (S (J)));
end if;
end loop;
end To_Stderr;
procedure ZZZ is
begin
null;
end ZZZ;
begin
Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
end Ada.Exceptions;