===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2016, 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- --
@@ -29,71 +29,411 @@
-- --
------------------------------------------------------------------------------
+-- This is the version using the GCC EH mechanism
with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; use System.Storage_Elements;
+with System.Exceptions.Machine; use System.Exceptions.Machine;
+
separate (Ada.Exceptions)
package body Exception_Propagation is
- -- Common binding to __builtin_longjmp for sjlj variants.
+ use Exception_Traces;
- procedure builtin_longjmp (buffer : System.Address; Flag : Integer);
- pragma No_Return (builtin_longjmp);
- pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp");
+ Foreign_Exception : aliased System.Standard_Library.Exception_Data;
+ pragma Import (Ada, Foreign_Exception,
+ "system__exceptions__foreign_exception");
+ -- Id for foreign exceptions
- procedure Propagate_Continue (E : Exception_Id);
- pragma No_Return (Propagate_Continue);
- pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg");
- -- A call to this procedure is inserted automatically by GIGI, in order
- -- to continue the propagation when the exception was not handled.
- -- The linkage name is historical.
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+ procedure GNAT_GCC_Exception_Cleanup
+ (Reason : Unwind_Reason_Code;
+ Excep : not null GNAT_GCC_Exception_Access);
+ pragma Convention (C, GNAT_GCC_Exception_Cleanup);
+ -- Procedure called when a GNAT GCC exception is free.
+
+ procedure Propagate_GCC_Exception
+ (GCC_Exception : not null GCC_Exception_Access);
+ pragma No_Return (Propagate_GCC_Exception);
+ -- Propagate a GCC exception
+
+ procedure Reraise_GCC_Exception
+ (GCC_Exception : not null GCC_Exception_Access);
+ pragma No_Return (Reraise_GCC_Exception);
+ pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
+ -- Called to implement raise without exception, ie reraise. Called
+ -- directly from gigi.
+
+ function Setup_Current_Excep
+ (GCC_Exception : not null GCC_Exception_Access) return EOA;
+ pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
+ -- Write Get_Current_Excep.all from GCC_Exception. Called by the
+ -- personality routine.
+
+ procedure Unhandled_Except_Handler
+ (GCC_Exception : not null GCC_Exception_Access);
+ pragma No_Return (Unhandled_Except_Handler);
+ pragma Export (C, Unhandled_Except_Handler,
+ "__gnat_unhandled_except_handler");
+ -- Called for handle unhandled exceptions, ie the last chance handler
+ -- on platforms (such as SEH) that never returns after throwing an
+ -- exception. Called directly by gigi.
+
+ function CleanupUnwind_Handler
+ (UW_Version : Integer;
+ UW_Phases : Unwind_Action;
+ UW_Eclass : Exception_Class;
+ UW_Exception : not null GCC_Exception_Access;
+ UW_Context : System.Address;
+ UW_Argument : System.Address) return Unwind_Reason_Code;
+ pragma Import (C, CleanupUnwind_Handler,
+ "__gnat_cleanupunwind_handler");
+ -- Hook called at each step of the forced unwinding we perform to trigger
+ -- cleanups found during the propagation of an unhandled exception.
+
+ -- GCC runtime functions used. These are C non-void functions, actually,
+ -- but we ignore the return values. See raise.c as to why we are using
+ -- __gnat stubs for these.
+
+ procedure Unwind_RaiseException
+ (UW_Exception : not null GCC_Exception_Access);
+ pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
+
+ procedure Unwind_ForcedUnwind
+ (UW_Exception : not null GCC_Exception_Access;
+ UW_Handler : System.Address;
+ UW_Argument : System.Address);
+ pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
+
+ procedure Set_Exception_Parameter
+ (Excep : EOA;
+ GCC_Exception : not null GCC_Exception_Access);
+ pragma Export
+ (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
+ -- Called inserted by gigi to set the exception choice parameter from the
+ -- gcc occurrence.
+
+ procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
+ -- Utility routine to initialize occurrence Excep from a foreign exception
+ -- whose machine occurrence is Mo. The message is empty, the backtrace
+ -- is empty too and the exception identity is Foreign_Exception.
+
+ -- Hooks called when entering/leaving an exception handler for a given
+ -- occurrence, aimed at handling the stack of active occurrences. The
+ -- calls are generated by gigi in tree_transform/N_Exception_Handler.
+
+ procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
+ pragma Export (C, Begin_Handler, "__gnat_begin_handler");
+
+ procedure End_Handler (GCC_Exception : GCC_Exception_Access);
+ pragma Export (C, End_Handler, "__gnat_end_handler");
+
+ --------------------------------------------------------------------
+ -- Accessors to Basic Components of a GNAT Exception Data Pointer --
+ --------------------------------------------------------------------
+
+ -- As of today, these are only used by the C implementation of the GCC
+ -- propagation personality routine to avoid having to rely on a C
+ -- counterpart of the whole exception_data structure, which is both
+ -- painful and error prone. These subprograms could be moved to a more
+ -- widely visible location if need be.
+
+ function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
+ pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
+ pragma Warnings (Off, Is_Handled_By_Others);
+
+ function Language_For (E : Exception_Data_Ptr) return Character;
+ pragma Export (C, Language_For, "__gnat_language_for");
+
+ function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
+ pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
+
+ function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
+ return Exception_Id;
+ pragma Export (C, EID_For, "__gnat_eid_for");
+
+ ---------------------------------------------------------------------------
+ -- Objects to materialize "others" and "all others" in the GCC EH tables --
+ ---------------------------------------------------------------------------
+
+ -- Currently, these only have their address taken and compared so there is
+ -- no real point having whole exception data blocks allocated. Note that
+ -- there are corresponding declarations in gigi (trans.c) which must be
+ -- kept properly synchronized.
+
+ Others_Value : constant Character := 'O';
+ pragma Export (C, Others_Value, "__gnat_others_value");
+
+ All_Others_Value : constant Character := 'A';
+ pragma Export (C, All_Others_Value, "__gnat_all_others_value");
+
+ Unhandled_Others_Value : constant Character := 'U';
+ pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
+ -- Special choice (emitted by gigi) to catch and notify unhandled
+ -- exceptions on targets which always handle exceptions (such as SEH).
+ -- The handler will simply call Unhandled_Except_Handler.
+
-------------------------
-- Allocate_Occurrence --
-------------------------
function Allocate_Occurrence return EOA is
+ Res : GNAT_GCC_Exception_Access;
+
begin
- return Get_Current_Excep.all;
+ Res := New_Occurrence;
+ Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
+ Res.Occurrence.Machine_Occurrence := Res.all'Address;
+
+ return Res.Occurrence'Access;
end Allocate_Occurrence;
+ --------------------------------
+ -- GNAT_GCC_Exception_Cleanup --
+ --------------------------------
+
+ procedure GNAT_GCC_Exception_Cleanup
+ (Reason : Unwind_Reason_Code;
+ Excep : not null GNAT_GCC_Exception_Access)
+ is
+ pragma Unreferenced (Reason);
+
+ procedure Free is new Unchecked_Deallocation
+ (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
+
+ Copy : GNAT_GCC_Exception_Access := Excep;
+
+ begin
+ -- Simply free the memory
+
+ Free (Copy);
+ end GNAT_GCC_Exception_Cleanup;
+
+ ----------------------------
+ -- Set_Foreign_Occurrence --
+ ----------------------------
+
+ procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
+ begin
+ Excep.all := (
+ Id => Foreign_Exception'Access,
+ Machine_Occurrence => Mo,
+ Msg => <>,
+ Msg_Length => 0,
+ Exception_Raised => True,
+ Pid => Local_Partition_ID,
+ Num_Tracebacks => 0,
+ Tracebacks => <>);
+ end Set_Foreign_Occurrence;
+
-------------------------
+ -- Setup_Current_Excep --
+ -------------------------
+
+ function Setup_Current_Excep
+ (GCC_Exception : not null GCC_Exception_Access) return EOA
+ is
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ -- Setup the exception occurrence
+
+ if GCC_Exception.Class = GNAT_Exception_Class then
+
+ -- From the GCC exception
+
+ declare
+ GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (GCC_Exception);
+ begin
+ Excep.all := GNAT_Occurrence.Occurrence;
+ return GNAT_Occurrence.Occurrence'Access;
+ end;
+
+ else
+ -- A default one
+
+ Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
+
+ return Excep;
+ end if;
+ end Setup_Current_Excep;
+
+ -------------------
+ -- Begin_Handler --
+ -------------------
+
+ procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
+ pragma Unreferenced (GCC_Exception);
+ begin
+ null;
+ end Begin_Handler;
+
+ -----------------
+ -- End_Handler --
+ -----------------
+
+ procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
+ begin
+ if GCC_Exception /= null then
+
+ -- The exception might have been reraised, in this case the cleanup
+ -- mustn't be called.
+
+ Unwind_DeleteException (GCC_Exception);
+ end if;
+ end End_Handler;
+
+ -----------------------------
+ -- Reraise_GCC_Exception --
+ -----------------------------
+
+ procedure Reraise_GCC_Exception
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
+ begin
+ -- Simply propagate it
+
+ Propagate_GCC_Exception (GCC_Exception);
+ end Reraise_GCC_Exception;
+
+ -----------------------------
+ -- Propagate_GCC_Exception --
+ -----------------------------
+
+ -- Call Unwind_RaiseException to actually throw, taking care of handling
+ -- the two phase scheme it implements.
+
+ procedure Propagate_GCC_Exception
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
+ Excep : EOA;
+
+ begin
+ -- Perform a standard raise first. If a regular handler is found, it
+ -- will be entered after all the intermediate cleanups have run. If
+ -- there is no regular handler, it will return.
+
+ Unwind_RaiseException (GCC_Exception);
+
+ -- If we get here we know the exception is not handled, as otherwise
+ -- Unwind_RaiseException arranges for the handler to be entered. Take
+ -- the necessary steps to enable the debugger to gain control while the
+ -- stack is still intact.
+
+ Excep := Setup_Current_Excep (GCC_Exception);
+ Notify_Unhandled_Exception (Excep);
+
+ -- Now, un a forced unwind to trigger cleanups. Control should not
+ -- resume there, if there are cleanups and in any cases as the
+ -- unwinding hook calls Unhandled_Exception_Terminate when end of
+ -- stack is reached.
+
+ Unwind_ForcedUnwind
+ (GCC_Exception,
+ CleanupUnwind_Handler'Address,
+ System.Null_Address);
+
+ -- We get here in case of error. The debugger has been notified before
+ -- the second step above.
+
+ Unhandled_Except_Handler (GCC_Exception);
+ end Propagate_GCC_Exception;
+
+ -------------------------
-- Propagate_Exception --
-------------------------
procedure Propagate_Exception (Excep : EOA) is
- Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
+ begin
+ Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
+ end Propagate_Exception;
+ -----------------------------
+ -- Set_Exception_Parameter --
+ -----------------------------
+
+ procedure Set_Exception_Parameter
+ (Excep : EOA;
+ GCC_Exception : not null GCC_Exception_Access)
+ is
begin
- -- If the jump buffer pointer is non-null, transfer control using
- -- it. Otherwise announce an unhandled exception (note that this
- -- means that we have no finalizations to do other than at the outer
- -- level). Perform the necessary notification tasks in both cases.
+ -- Setup the exception occurrence
- if Jumpbuf_Ptr /= Null_Address then
- if not Excep.Exception_Raised then
- Excep.Exception_Raised := True;
- Exception_Traces.Notify_Handled_Exception (Excep);
- end if;
+ if GCC_Exception.Class = GNAT_Exception_Class then
- builtin_longjmp (Jumpbuf_Ptr, 1);
+ -- From the GCC exception
+ declare
+ GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (GCC_Exception);
+ begin
+ Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
+ end;
+
else
- Exception_Traces.Notify_Unhandled_Exception (Excep);
- Exception_Traces.Unhandled_Exception_Terminate (Excep);
+ -- A default one
+
+ Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
end if;
- end Propagate_Exception;
+ end Set_Exception_Parameter;
- ------------------------
- -- Propagate_Continue --
- ------------------------
+ ------------------------------
+ -- Unhandled_Except_Handler --
+ ------------------------------
- procedure Propagate_Continue (E : Exception_Id) is
- pragma Unreferenced (E);
+ procedure Unhandled_Except_Handler
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
+ Excep : EOA;
begin
- Propagate_Exception (Get_Current_Excep.all);
- end Propagate_Continue;
+ Excep := Setup_Current_Excep (GCC_Exception);
+ Unhandled_Exception_Terminate (Excep);
+ end Unhandled_Except_Handler;
+ -------------
+ -- EID_For --
+ -------------
+
+ function EID_For
+ (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
+ is
+ begin
+ return GNAT_Exception.Occurrence.Id;
+ end EID_For;
+
+ ----------------------
+ -- Foreign_Data_For --
+ ----------------------
+
+ function Foreign_Data_For
+ (E : SSL.Exception_Data_Ptr) return Address
+ is
+ begin
+ return E.Foreign_Data;
+ end Foreign_Data_For;
+
+ --------------------------
+ -- Is_Handled_By_Others --
+ --------------------------
+
+ function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
+ begin
+ return not E.all.Not_Handled_By_Others;
+ end Is_Handled_By_Others;
+
+ ------------------
+ -- Language_For --
+ ------------------
+
+ function Language_For (E : SSL.Exception_Data_Ptr) return Character is
+ begin
+ return E.all.Lang;
+ end Language_For;
+
end Exception_Propagation;
===================================================================
@@ -1,439 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
-
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Exceptions.Machine; use System.Exceptions.Machine;
-
-separate (Ada.Exceptions)
-package body Exception_Propagation is
-
- use Exception_Traces;
-
- Foreign_Exception : aliased System.Standard_Library.Exception_Data;
- pragma Import (Ada, Foreign_Exception,
- "system__exceptions__foreign_exception");
- -- Id for foreign exceptions
-
- --------------------------------------------------------------
- -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
- --------------------------------------------------------------
-
- procedure GNAT_GCC_Exception_Cleanup
- (Reason : Unwind_Reason_Code;
- Excep : not null GNAT_GCC_Exception_Access);
- pragma Convention (C, GNAT_GCC_Exception_Cleanup);
- -- Procedure called when a GNAT GCC exception is free.
-
- procedure Propagate_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access);
- pragma No_Return (Propagate_GCC_Exception);
- -- Propagate a GCC exception
-
- procedure Reraise_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access);
- pragma No_Return (Reraise_GCC_Exception);
- pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
- -- Called to implement raise without exception, ie reraise. Called
- -- directly from gigi.
-
- function Setup_Current_Excep
- (GCC_Exception : not null GCC_Exception_Access) return EOA;
- pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
- -- Write Get_Current_Excep.all from GCC_Exception. Called by the
- -- personality routine.
-
- procedure Unhandled_Except_Handler
- (GCC_Exception : not null GCC_Exception_Access);
- pragma No_Return (Unhandled_Except_Handler);
- pragma Export (C, Unhandled_Except_Handler,
- "__gnat_unhandled_except_handler");
- -- Called for handle unhandled exceptions, ie the last chance handler
- -- on platforms (such as SEH) that never returns after throwing an
- -- exception. Called directly by gigi.
-
- function CleanupUnwind_Handler
- (UW_Version : Integer;
- UW_Phases : Unwind_Action;
- UW_Eclass : Exception_Class;
- UW_Exception : not null GCC_Exception_Access;
- UW_Context : System.Address;
- UW_Argument : System.Address) return Unwind_Reason_Code;
- pragma Import (C, CleanupUnwind_Handler,
- "__gnat_cleanupunwind_handler");
- -- Hook called at each step of the forced unwinding we perform to trigger
- -- cleanups found during the propagation of an unhandled exception.
-
- -- GCC runtime functions used. These are C non-void functions, actually,
- -- but we ignore the return values. See raise.c as to why we are using
- -- __gnat stubs for these.
-
- procedure Unwind_RaiseException
- (UW_Exception : not null GCC_Exception_Access);
- pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
-
- procedure Unwind_ForcedUnwind
- (UW_Exception : not null GCC_Exception_Access;
- UW_Handler : System.Address;
- UW_Argument : System.Address);
- pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
-
- procedure Set_Exception_Parameter
- (Excep : EOA;
- GCC_Exception : not null GCC_Exception_Access);
- pragma Export
- (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
- -- Called inserted by gigi to set the exception choice parameter from the
- -- gcc occurrence.
-
- procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
- -- Utility routine to initialize occurrence Excep from a foreign exception
- -- whose machine occurrence is Mo. The message is empty, the backtrace
- -- is empty too and the exception identity is Foreign_Exception.
-
- -- Hooks called when entering/leaving an exception handler for a given
- -- occurrence, aimed at handling the stack of active occurrences. The
- -- calls are generated by gigi in tree_transform/N_Exception_Handler.
-
- procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
- pragma Export (C, Begin_Handler, "__gnat_begin_handler");
-
- procedure End_Handler (GCC_Exception : GCC_Exception_Access);
- pragma Export (C, End_Handler, "__gnat_end_handler");
-
- --------------------------------------------------------------------
- -- Accessors to Basic Components of a GNAT Exception Data Pointer --
- --------------------------------------------------------------------
-
- -- As of today, these are only used by the C implementation of the GCC
- -- propagation personality routine to avoid having to rely on a C
- -- counterpart of the whole exception_data structure, which is both
- -- painful and error prone. These subprograms could be moved to a more
- -- widely visible location if need be.
-
- function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
- pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
- pragma Warnings (Off, Is_Handled_By_Others);
-
- function Language_For (E : Exception_Data_Ptr) return Character;
- pragma Export (C, Language_For, "__gnat_language_for");
-
- function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
- pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
-
- function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
- return Exception_Id;
- pragma Export (C, EID_For, "__gnat_eid_for");
-
- ---------------------------------------------------------------------------
- -- Objects to materialize "others" and "all others" in the GCC EH tables --
- ---------------------------------------------------------------------------
-
- -- Currently, these only have their address taken and compared so there is
- -- no real point having whole exception data blocks allocated. Note that
- -- there are corresponding declarations in gigi (trans.c) which must be
- -- kept properly synchronized.
-
- Others_Value : constant Character := 'O';
- pragma Export (C, Others_Value, "__gnat_others_value");
-
- All_Others_Value : constant Character := 'A';
- pragma Export (C, All_Others_Value, "__gnat_all_others_value");
-
- Unhandled_Others_Value : constant Character := 'U';
- pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
- -- Special choice (emitted by gigi) to catch and notify unhandled
- -- exceptions on targets which always handle exceptions (such as SEH).
- -- The handler will simply call Unhandled_Except_Handler.
-
- -------------------------
- -- Allocate_Occurrence --
- -------------------------
-
- function Allocate_Occurrence return EOA is
- Res : GNAT_GCC_Exception_Access;
-
- begin
- Res := New_Occurrence;
- Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
- Res.Occurrence.Machine_Occurrence := Res.all'Address;
-
- return Res.Occurrence'Access;
- end Allocate_Occurrence;
-
- --------------------------------
- -- GNAT_GCC_Exception_Cleanup --
- --------------------------------
-
- procedure GNAT_GCC_Exception_Cleanup
- (Reason : Unwind_Reason_Code;
- Excep : not null GNAT_GCC_Exception_Access)
- is
- pragma Unreferenced (Reason);
-
- procedure Free is new Unchecked_Deallocation
- (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
-
- Copy : GNAT_GCC_Exception_Access := Excep;
-
- begin
- -- Simply free the memory
-
- Free (Copy);
- end GNAT_GCC_Exception_Cleanup;
-
- ----------------------------
- -- Set_Foreign_Occurrence --
- ----------------------------
-
- procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
- begin
- Excep.all := (
- Id => Foreign_Exception'Access,
- Machine_Occurrence => Mo,
- Msg => <>,
- Msg_Length => 0,
- Exception_Raised => True,
- Pid => Local_Partition_ID,
- Num_Tracebacks => 0,
- Tracebacks => <>);
- end Set_Foreign_Occurrence;
-
- -------------------------
- -- Setup_Current_Excep --
- -------------------------
-
- function Setup_Current_Excep
- (GCC_Exception : not null GCC_Exception_Access) return EOA
- is
- Excep : constant EOA := Get_Current_Excep.all;
-
- begin
- -- Setup the exception occurrence
-
- if GCC_Exception.Class = GNAT_Exception_Class then
-
- -- From the GCC exception
-
- declare
- GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (GCC_Exception);
- begin
- Excep.all := GNAT_Occurrence.Occurrence;
- return GNAT_Occurrence.Occurrence'Access;
- end;
-
- else
- -- A default one
-
- Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
-
- return Excep;
- end if;
- end Setup_Current_Excep;
-
- -------------------
- -- Begin_Handler --
- -------------------
-
- procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
- pragma Unreferenced (GCC_Exception);
- begin
- null;
- end Begin_Handler;
-
- -----------------
- -- End_Handler --
- -----------------
-
- procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
- begin
- if GCC_Exception /= null then
-
- -- The exception might have been reraised, in this case the cleanup
- -- mustn't be called.
-
- Unwind_DeleteException (GCC_Exception);
- end if;
- end End_Handler;
-
- -----------------------------
- -- Reraise_GCC_Exception --
- -----------------------------
-
- procedure Reraise_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access)
- is
- begin
- -- Simply propagate it
-
- Propagate_GCC_Exception (GCC_Exception);
- end Reraise_GCC_Exception;
-
- -----------------------------
- -- Propagate_GCC_Exception --
- -----------------------------
-
- -- Call Unwind_RaiseException to actually throw, taking care of handling
- -- the two phase scheme it implements.
-
- procedure Propagate_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access)
- is
- Excep : EOA;
-
- begin
- -- Perform a standard raise first. If a regular handler is found, it
- -- will be entered after all the intermediate cleanups have run. If
- -- there is no regular handler, it will return.
-
- Unwind_RaiseException (GCC_Exception);
-
- -- If we get here we know the exception is not handled, as otherwise
- -- Unwind_RaiseException arranges for the handler to be entered. Take
- -- the necessary steps to enable the debugger to gain control while the
- -- stack is still intact.
-
- Excep := Setup_Current_Excep (GCC_Exception);
- Notify_Unhandled_Exception (Excep);
-
- -- Now, un a forced unwind to trigger cleanups. Control should not
- -- resume there, if there are cleanups and in any cases as the
- -- unwinding hook calls Unhandled_Exception_Terminate when end of
- -- stack is reached.
-
- Unwind_ForcedUnwind
- (GCC_Exception,
- CleanupUnwind_Handler'Address,
- System.Null_Address);
-
- -- We get here in case of error. The debugger has been notified before
- -- the second step above.
-
- Unhandled_Except_Handler (GCC_Exception);
- end Propagate_GCC_Exception;
-
- -------------------------
- -- Propagate_Exception --
- -------------------------
-
- procedure Propagate_Exception (Excep : EOA) is
- begin
- Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
- end Propagate_Exception;
-
- -----------------------------
- -- Set_Exception_Parameter --
- -----------------------------
-
- procedure Set_Exception_Parameter
- (Excep : EOA;
- GCC_Exception : not null GCC_Exception_Access)
- is
- begin
- -- Setup the exception occurrence
-
- if GCC_Exception.Class = GNAT_Exception_Class then
-
- -- From the GCC exception
-
- declare
- GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (GCC_Exception);
- begin
- Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
- end;
-
- else
- -- A default one
-
- Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
- end if;
- end Set_Exception_Parameter;
-
- ------------------------------
- -- Unhandled_Except_Handler --
- ------------------------------
-
- procedure Unhandled_Except_Handler
- (GCC_Exception : not null GCC_Exception_Access)
- is
- Excep : EOA;
- begin
- Excep := Setup_Current_Excep (GCC_Exception);
- Unhandled_Exception_Terminate (Excep);
- end Unhandled_Except_Handler;
-
- -------------
- -- EID_For --
- -------------
-
- function EID_For
- (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
- is
- begin
- return GNAT_Exception.Occurrence.Id;
- end EID_For;
-
- ----------------------
- -- Foreign_Data_For --
- ----------------------
-
- function Foreign_Data_For
- (E : SSL.Exception_Data_Ptr) return Address
- is
- begin
- return E.Foreign_Data;
- end Foreign_Data_For;
-
- --------------------------
- -- Is_Handled_By_Others --
- --------------------------
-
- function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
- begin
- return not E.all.Not_Handled_By_Others;
- end Is_Handled_By_Others;
-
- ------------------
- -- Language_For --
- ------------------
-
- function Language_For (E : SSL.Exception_Data_Ptr) return Character is
- begin
- return E.all.Lang;
- end Language_For;
-
-end Exception_Propagation;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2017, 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- --
@@ -29,8 +29,6 @@
-- --
------------------------------------------------------------------------------
-pragma Compiler_Unit_Warning;
-
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
@@ -39,16 +37,29 @@
-- elaboration circularities with System.Exception_Tables.
with System; use System;
+with System.Exceptions; use System.Exceptions;
with System.Exceptions_Debug; use System.Exceptions_Debug;
with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_StW; use System.WCh_StW;
+pragma Warnings (Off);
+-- Suppress complaints about Symbolic not being referenced, and about it not
+-- having pragma Preelaborate.
+with System.Traceback.Symbolic;
+-- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version,
+-- it will install symbolic tracebacks as the default decorator. Otherwise,
+-- symbolic tracebacks are not supported, and we fall back to hexadecimal
+-- addresses.
+pragma Warnings (On);
+
package body Ada.Exceptions is
pragma Suppress (All_Checks);
- -- We definitely do not want exceptions occurring within this unit, or we
- -- are in big trouble. If an exceptional situation does occur, better that
- -- it not be raised, since raising it can cause confusing chaos.
+ -- We definitely do not want exceptions occurring within this unit, or
+ -- we are in big trouble. If an exceptional situation does occur, better
+ -- that it not be raised, since raising it can cause confusing chaos.
-----------------------
-- Local Subprograms --
@@ -58,22 +69,47 @@
-- from C clients using the given external name, even though they are not
-- technically visible in the Ada sense.
- procedure Process_Raise_Exception (E : Exception_Id);
- pragma No_Return (Process_Raise_Exception);
- -- This is the lowest level raise routine. It raises the exception
- -- referenced by Current_Excep.all in the TSD, without deferring abort
- -- (the caller must ensure that abort is deferred on entry).
+ function Code_Address_For_AAA return System.Address;
+ function Code_Address_For_ZZZ return System.Address;
+ -- Return start and end of procedures in this package
+ --
+ -- 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 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 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
+ -- body of Code_Address_For_ZZZ.
+ --
+ -- 2) No pragma Inline applies to any of these subprograms, as this
+ -- could delay the corresponding assembly output until the end of
+ -- the unit.
+ procedure Call_Chain (Excep : EOA);
+ -- Store up to Max_Tracebacks in Excep, corresponding to the current
+ -- call chain.
+
+ function Image (Index : Integer) return String;
+ -- Return string image corresponding to Index
+
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
- -- Little routine to output string to stderr that is also used in the
- -- tasking run time.
+ -- Little routine to output string to stderr that is also used
+ -- in the tasking run time.
procedure To_Stderr (C : Character);
pragma Inline (To_Stderr);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
- -- Little routine to output a character to stderr, used by some of the
- -- separate units below.
+ -- Little routine to output a character to stderr, used by some of
+ -- the separate units below.
package Exception_Data is
@@ -88,22 +124,21 @@
Line : Integer := 0;
Column : Integer := 0;
Msg2 : System.Address := System.Null_Address);
- -- This routine is called to setup the exception referenced by the
- -- Current_Excep field in the TSD to contain the indicated Id value
- -- and message. Msg1 is a null terminated string which is generated
- -- as the exception message. If line is non-zero, then a colon and
- -- the decimal representation of this integer is appended to the
- -- message. Ditto for Column. When Msg2 is non-null, a space and this
- -- additional null terminated string is added to the message.
+ -- This routine is called to setup the exception referenced by X
+ -- to contain the indicated Id value and message. Msg1 is a null
+ -- terminated string which is generated as the exception message. If
+ -- line is non-zero, then a colon and the decimal representation of
+ -- this integer is appended to the message. Ditto for Column. When Msg2
+ -- is non-null, a space and this additional null terminated string is
+ -- added to the message.
procedure Set_Exception_Msg
(Excep : EOA;
Id : Exception_Id;
Message : String);
- -- This routine is called to setup the exception referenced by the
- -- Current_Excep field in the TSD to contain the indicated Id value and
- -- message. Message is a string which is generated as the exception
- -- message.
+ -- This routine is called to setup the exception referenced by X
+ -- to contain the indicated Id value and message. Message is a string
+ -- which is generated as the exception message.
---------------------------------------
-- Exception Information Subprograms --
@@ -176,14 +211,29 @@
procedure Unhandled_Exception_Terminate (Excep : EOA);
pragma No_Return (Unhandled_Exception_Terminate);
- -- This procedure is called to terminate program execution following an
- -- unhandled exception. The exception information, including traceback
- -- if available is output, and execution is then terminated. Note that
- -- at the point where this routine is called, the stack has typically
- -- been destroyed.
+ -- This procedure is called to terminate execution following an
+ -- unhandled exception. The exception information, including
+ -- traceback if available is output, and execution is then
+ -- terminated. Note that at the point where this routine is
+ -- called, the stack has typically been destroyed.
end Exception_Traces;
+ package Exception_Propagation is
+
+ ---------------------------------------
+ -- Exception Propagation Subprograms --
+ ---------------------------------------
+
+ function Allocate_Occurrence return EOA;
+ -- Allocate an exception occurrence (as well as the machine occurrence)
+
+ procedure Propagate_Exception (Excep : EOA);
+ pragma No_Return (Propagate_Exception);
+ -- This procedure propagates the exception represented by Excep
+
+ end Exception_Propagation;
+
package Stream_Attributes is
----------------------------------
@@ -201,18 +251,32 @@
end Stream_Attributes;
- procedure Raise_Current_Excep (E : Exception_Id);
- pragma No_Return (Raise_Current_Excep);
- pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
- -- This is a simple wrapper to Process_Raise_Exception.
- --
- -- This external name for Raise_Current_Excep is historical, and probably
- -- should be changed but for now we keep it, because gdb and gigi know
- -- about it.
+ procedure Complete_Occurrence (X : EOA);
+ -- Finish building the occurrence: save the call chain and notify the
+ -- debugger.
+ procedure Complete_And_Propagate_Occurrence (X : EOA);
+ pragma No_Return (Complete_And_Propagate_Occurrence);
+ -- This is a simple wrapper to Complete_Occurrence and
+ -- Exception_Propagation.Propagate_Exception.
+
+ function Create_Occurrence_From_Signal_Handler
+ (E : Exception_Id;
+ M : System.Address) return EOA;
+ -- Create and build an exception occurrence using exception id E and
+ -- nul-terminated message M.
+
+ function Create_Machine_Occurrence_From_Signal_Handler
+ (E : Exception_Id;
+ M : System.Address) return System.Address;
+ pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler,
+ "__gnat_create_machine_occurrence_from_signal_handler");
+ -- Create and build an exception occurrence using exception id E and
+ -- nul-terminated message M. Return the machine occurrence.
+
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");
@@ -222,45 +286,41 @@
procedure Raise_With_Msg (E : Exception_Id);
pragma No_Return (Raise_With_Msg);
pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
- -- Raises an exception with given exception id value. A message is
- -- associated with the raise, and has already been stored in the exception
- -- occurrence referenced by the Current_Excep in the TSD. Abort is deferred
- -- before the raise call.
+ -- Raises an exception with given exception id value. A message
+ -- is associated with the raise, and has already been stored in the
+ -- exception occurrence referenced by the Current_Excep in the TSD.
+ -- Abort is deferred before the raise call.
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : System.Address;
L : Integer;
+ C : Integer := 0;
M : System.Address := System.Null_Address);
pragma No_Return (Raise_With_Location_And_Msg);
-- Raise an exception with given exception id value. A filename and line
-- number is associated with the raise and is stored in the exception
- -- occurrence and in addition a string message M is appended to this
- -- if M is not null.
+ -- occurrence and in addition a column and a string message M may be
+ -- appended to this (if not null/0).
- procedure Raise_Constraint_Error
- (File : System.Address;
- Line : Integer);
+ procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
pragma No_Return (Raise_Constraint_Error);
- pragma Export
- (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
+ pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
-- Raise constraint error with file:line information
procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address);
+ (File : System.Address;
+ Line : Integer;
+ Column : Integer;
+ Msg : System.Address);
pragma No_Return (Raise_Constraint_Error_Msg);
pragma Export
(C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
- -- Raise constraint error with file:line + msg information
+ -- Raise constraint error with file:line:col + msg information
- procedure Raise_Program_Error
- (File : System.Address;
- Line : Integer);
+ procedure Raise_Program_Error (File : System.Address; Line : Integer);
pragma No_Return (Raise_Program_Error);
- pragma Export
- (C, Raise_Program_Error, "__gnat_raise_program_error");
+ pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
-- Raise program error with file:line information
procedure Raise_Program_Error_Msg
@@ -272,12 +332,9 @@
(C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
-- Raise program error with file:line + msg information
- procedure Raise_Storage_Error
- (File : System.Address;
- Line : Integer);
+ procedure Raise_Storage_Error (File : System.Address; Line : Integer);
pragma No_Return (Raise_Storage_Error);
- pragma Export
- (C, Raise_Storage_Error, "__gnat_raise_storage_error");
+ pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
-- Raise storage error with file:line information
procedure Raise_Storage_Error_Msg
@@ -294,10 +351,10 @@
-- graph below illustrates the relations between the Raise_ subprograms
-- and identifies the points where basic flags such as Exception_Raised
-- are initialized.
- --
+
-- (i) signs indicate the flags initialization points. R stands for Raise,
-- W for With, and E for Exception.
- --
+
-- R_No_Msg R_E R_Pe R_Ce R_Se
-- | | | | |
-- +--+ +--+ +---+ | +---+
@@ -308,23 +365,24 @@
-- | | | |
-- | | | Set_E_C_Msg(i)
-- | | |
- -- Raise_Current_Excep
+ -- Complete_And_Propagate_Occurrence
procedure Reraise;
pragma No_Return (Reraise);
pragma Export (C, Reraise, "__gnat_reraise");
- -- Reraises the exception referenced by the Current_Excep field of the TSD
- -- (all fields of this exception occurrence are set). Abort is deferred
- -- before the reraise operation.
+ -- Reraises the exception referenced by the Current_Excep field
+ -- of the TSD (all fields of this exception occurrence are set).
+ -- Abort is deferred before the reraise operation. Called from
+ -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous
procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access;
Source : Exception_Occurrence);
pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
- -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
- -- to setup Target from 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.
+ -- Called from s-tasren.adb:Local_Complete_RendezVous and
+ -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
+ -- 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 Subprograms --
@@ -334,91 +392,88 @@
-- 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 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
- -- end of the list (for reasons that are documented in the exceptmsg.awk
- -- script which takes care of generating the required exception data).
-
- procedure Rcheck_CE_Access_Check -- 00
+ procedure Rcheck_CE_Access_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Access_Parameter -- 01
+ procedure Rcheck_CE_Null_Access_Parameter
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Discriminant_Check -- 02
+ procedure Rcheck_CE_Discriminant_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Divide_By_Zero -- 03
+ procedure Rcheck_CE_Divide_By_Zero
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Explicit_Raise -- 04
+ procedure Rcheck_CE_Explicit_Raise
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Index_Check -- 05
+ procedure Rcheck_CE_Index_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Invalid_Data -- 06
+ procedure Rcheck_CE_Invalid_Data
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Length_Check -- 07
+ procedure Rcheck_CE_Length_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Exception_Id -- 08
+ procedure Rcheck_CE_Null_Exception_Id
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Not_Allowed -- 09
+ procedure Rcheck_CE_Null_Not_Allowed
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Overflow_Check -- 10
+ procedure Rcheck_CE_Overflow_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Partition_Check -- 11
+ procedure Rcheck_CE_Partition_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Range_Check -- 12
+ procedure Rcheck_CE_Range_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_CE_Tag_Check -- 13
+ procedure Rcheck_CE_Tag_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Access_Before_Elaboration -- 14
+ procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Accessibility_Check -- 15
+ procedure Rcheck_PE_Accessibility_Check
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Address_Of_Intrinsic -- 16
+ procedure Rcheck_PE_Address_Of_Intrinsic
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Aliased_Parameters -- 17
+ procedure Rcheck_PE_Aliased_Parameters
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_All_Guards_Closed -- 18
+ procedure Rcheck_PE_All_Guards_Closed
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Bad_Predicated_Generic_Type -- 19
+ procedure Rcheck_PE_Bad_Predicated_Generic_Type
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Current_Task_In_Entry_Body -- 20
+ procedure Rcheck_PE_Current_Task_In_Entry_Body
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Duplicated_Entry_Address -- 21
+ procedure Rcheck_PE_Duplicated_Entry_Address
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Explicit_Raise -- 22
+ procedure Rcheck_PE_Explicit_Raise
(File : System.Address; Line : Integer);
-
- procedure Rcheck_PE_Implicit_Return -- 24
+ procedure Rcheck_PE_Implicit_Return
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Misaligned_Address_Value -- 25
+ procedure Rcheck_PE_Misaligned_Address_Value
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Missing_Return -- 26
+ procedure Rcheck_PE_Missing_Return
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Overlaid_Controlled_Object -- 27
+ procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Potentially_Blocking_Operation -- 28
+ procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Stubbed_Subprogram_Called -- 29
+ procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Unchecked_Union_Restriction -- 30
+ procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Non_Transportable_Actual -- 31
+ procedure Rcheck_PE_Unchecked_Union_Restriction
(File : System.Address; Line : Integer);
- procedure Rcheck_SE_Empty_Storage_Pool -- 32
+ procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer);
- procedure Rcheck_SE_Explicit_Raise -- 33
+ procedure Rcheck_SE_Explicit_Raise
(File : System.Address; Line : Integer);
- procedure Rcheck_SE_Infinite_Recursion -- 34
+ procedure Rcheck_SE_Infinite_Recursion
(File : System.Address; Line : Integer);
- procedure Rcheck_SE_Object_Too_Large -- 35
+ procedure Rcheck_SE_Object_Too_Large
(File : System.Address; Line : Integer);
- procedure Rcheck_PE_Stream_Operation_Not_Allowed -- 36
+ procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer);
+ procedure Rcheck_CE_Access_Check_Ext
+ (File : System.Address; Line, Column : Integer);
+ procedure Rcheck_CE_Index_Check_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
+ procedure Rcheck_CE_Invalid_Data_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
+ procedure Rcheck_CE_Range_Check_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
- procedure Rcheck_PE_Finalize_Raised_Exception -- 23
+ procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer);
-- This routine is separated out because it has quite different behavior
-- from the others. This is the "finalize/adjust raised exception". This
@@ -500,6 +555,15 @@
pragma Export (C, Rcheck_SE_Object_Too_Large,
"__gnat_rcheck_SE_Object_Too_Large");
+ pragma Export (C, Rcheck_CE_Access_Check_Ext,
+ "__gnat_rcheck_CE_Access_Check_ext");
+ pragma Export (C, Rcheck_CE_Index_Check_Ext,
+ "__gnat_rcheck_CE_Index_Check_ext");
+ pragma Export (C, Rcheck_CE_Invalid_Data_Ext,
+ "__gnat_rcheck_CE_Invalid_Data_ext");
+ pragma Export (C, Rcheck_CE_Range_Check_Ext,
+ "__gnat_rcheck_CE_Range_Check_ext");
+
-- None of these procedures ever returns (they raise an exception). By
-- using pragma No_Return, we ensure that any junk code after the call,
-- such as normal return epilogue stuff, can be eliminated).
@@ -530,8 +594,8 @@
pragma No_Return (Rcheck_PE_Implicit_Return);
pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
pragma No_Return (Rcheck_PE_Missing_Return);
+ pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
- pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
@@ -542,125 +606,11 @@
pragma No_Return (Rcheck_SE_Infinite_Recursion);
pragma No_Return (Rcheck_SE_Object_Too_Large);
- -- For compatibility with previous version of GNAT, to preserve bootstrap
+ pragma No_Return (Rcheck_CE_Access_Check_Ext);
+ pragma No_Return (Rcheck_CE_Index_Check_Ext);
+ pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
+ pragma No_Return (Rcheck_CE_Range_Check_Ext);
- procedure Rcheck_00 (File : System.Address; Line : Integer);
- procedure Rcheck_01 (File : System.Address; Line : Integer);
- procedure Rcheck_02 (File : System.Address; Line : Integer);
- procedure Rcheck_03 (File : System.Address; Line : Integer);
- procedure Rcheck_04 (File : System.Address; Line : Integer);
- procedure Rcheck_05 (File : System.Address; Line : Integer);
- procedure Rcheck_06 (File : System.Address; Line : Integer);
- procedure Rcheck_07 (File : System.Address; Line : Integer);
- procedure Rcheck_08 (File : System.Address; Line : Integer);
- procedure Rcheck_09 (File : System.Address; Line : Integer);
- procedure Rcheck_10 (File : System.Address; Line : Integer);
- procedure Rcheck_11 (File : System.Address; Line : Integer);
- procedure Rcheck_12 (File : System.Address; Line : Integer);
- procedure Rcheck_13 (File : System.Address; Line : Integer);
- procedure Rcheck_14 (File : System.Address; Line : Integer);
- procedure Rcheck_15 (File : System.Address; Line : Integer);
- procedure Rcheck_16 (File : System.Address; Line : Integer);
- procedure Rcheck_17 (File : System.Address; Line : Integer);
- procedure Rcheck_18 (File : System.Address; Line : Integer);
- procedure Rcheck_19 (File : System.Address; Line : Integer);
- procedure Rcheck_20 (File : System.Address; Line : Integer);
- procedure Rcheck_21 (File : System.Address; Line : Integer);
- procedure Rcheck_22 (File : System.Address; Line : Integer);
- procedure Rcheck_23 (File : System.Address; Line : Integer);
- procedure Rcheck_24 (File : System.Address; Line : Integer);
- procedure Rcheck_25 (File : System.Address; Line : Integer);
- procedure Rcheck_26 (File : System.Address; Line : Integer);
- procedure Rcheck_27 (File : System.Address; Line : Integer);
- procedure Rcheck_28 (File : System.Address; Line : Integer);
- procedure Rcheck_29 (File : System.Address; Line : Integer);
- procedure Rcheck_30 (File : System.Address; Line : Integer);
- procedure Rcheck_31 (File : System.Address; Line : Integer);
- procedure Rcheck_32 (File : System.Address; Line : Integer);
- procedure Rcheck_33 (File : System.Address; Line : Integer);
- procedure Rcheck_34 (File : System.Address; Line : Integer);
- procedure Rcheck_35 (File : System.Address; Line : Integer);
- procedure Rcheck_36 (File : System.Address; 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");
- pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
- pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
- pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
- pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
- pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
- pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
- pragma Export (C, Rcheck_35, "__gnat_rcheck_35");
- pragma Export (C, Rcheck_36, "__gnat_rcheck_36");
-
- -- None of these procedures ever returns (they raise an exception). By
- -- using pragma No_Return, we ensure that any junk code after the call,
- -- such as normal return epilogue stuff, can be eliminated).
-
- pragma No_Return (Rcheck_00);
- pragma No_Return (Rcheck_01);
- pragma No_Return (Rcheck_02);
- pragma No_Return (Rcheck_03);
- pragma No_Return (Rcheck_04);
- pragma No_Return (Rcheck_05);
- pragma No_Return (Rcheck_06);
- pragma No_Return (Rcheck_07);
- pragma No_Return (Rcheck_08);
- pragma No_Return (Rcheck_09);
- pragma No_Return (Rcheck_10);
- pragma No_Return (Rcheck_11);
- pragma No_Return (Rcheck_12);
- pragma No_Return (Rcheck_13);
- pragma No_Return (Rcheck_14);
- pragma No_Return (Rcheck_15);
- pragma No_Return (Rcheck_16);
- pragma No_Return (Rcheck_17);
- pragma No_Return (Rcheck_18);
- pragma No_Return (Rcheck_19);
- pragma No_Return (Rcheck_20);
- pragma No_Return (Rcheck_21);
- pragma No_Return (Rcheck_22);
- pragma No_Return (Rcheck_23);
- pragma No_Return (Rcheck_24);
- pragma No_Return (Rcheck_25);
- pragma No_Return (Rcheck_26);
- pragma No_Return (Rcheck_27);
- pragma No_Return (Rcheck_28);
- pragma No_Return (Rcheck_29);
- pragma No_Return (Rcheck_30);
- pragma No_Return (Rcheck_32);
- pragma No_Return (Rcheck_33);
- pragma No_Return (Rcheck_34);
- pragma No_Return (Rcheck_35);
- pragma No_Return (Rcheck_36);
-
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
---------------------------------------------
@@ -727,6 +677,33 @@
-- The actual polling routine is separate, so that it can easily be
-- replaced with a target dependent version.
+ --------------------------
+ -- Code_Address_For_AAA --
+ --------------------------
+
+ -- This function gives us the start of the PC range for addresses within
+ -- the exception unit itself. We hope that gigi/gcc keep all the procedures
+ -- in their original order.
+
+ function Code_Address_For_AAA return System.Address is
+ begin
+ -- We are using a label instead of Code_Address_For_AAA'Address because
+ -- on some platforms the latter does not yield the address we want, but
+ -- the address of a stub or of a descriptor instead. This is the case at
+ -- least on PA-HPUX.
+
+ <<Start_Of_AAA>>
+ return Start_Of_AAA'Address;
+ end Code_Address_For_AAA;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain (Excep : EOA) is separate;
+ -- The actual Call_Chain routine is separate, so that it can easily
+ -- be dummied out when no exception traceback information is needed.
+
-------------------
-- EId_To_String --
-------------------
@@ -752,9 +729,9 @@
(X : Exception_Occurrence) return Exception_Id
is
begin
- -- Note that the following test used to be here for the original Ada 95
- -- semantics, but these were modified by AI-241 to require returning
- -- Null_Id instead of raising Constraint_Error.
+ -- Note that the following test used to be here for the original
+ -- Ada 95 semantics, but these were modified by AI-241 to require
+ -- returning Null_Id instead of raising Constraint_Error.
-- if X.Id = Null_Id then
-- raise Constraint_Error;
@@ -784,9 +761,9 @@
begin
if X.Id = Null_Id then
raise Constraint_Error;
+ else
+ return X.Msg (1 .. X.Msg_Length);
end if;
-
- return X.Msg (1 .. X.Msg_Length);
end Exception_Message;
--------------------
@@ -797,9 +774,9 @@
begin
if Id = null then
raise Constraint_Error;
+ else
+ return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
end if;
-
- return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
end Exception_Name;
function Exception_Name (X : Exception_Occurrence) return String is
@@ -839,16 +816,50 @@
-- This package can be easily dummied out if we do not want the basic
-- support for exception messages (such as in Ada 83).
+ ---------------------------
+ -- Exception_Propagation --
+ ---------------------------
+
+ package body Exception_Propagation is separate;
+ -- Depending on the actual exception mechanism used (front-end or
+ -- back-end based), the implementation will differ, which is why this
+ -- package is separated.
+
----------------------
-- Exception_Traces --
----------------------
package body Exception_Traces is separate;
-- Depending on the underlying support for IO the implementation will
- -- differ. Moreover we would like to dummy out this package in case we do
- -- not want any exception tracing support. This is why this package is
- -- separated.
+ -- differ. Moreover we would like to dummy out this package in case we
+ -- do not want any exception tracing support. This is why this package
+ -- is separated.
+ --------------------------------------
+ -- Get_Exception_Machine_Occurrence --
+ --------------------------------------
+
+ function Get_Exception_Machine_Occurrence
+ (X : Exception_Occurrence) return System.Address
+ is
+ begin
+ return X.Machine_Occurrence;
+ end Get_Exception_Machine_Occurrence;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Index : Integer) return String is
+ Result : constant String := Integer'Image (Index);
+ begin
+ if Result (1) = ' ' then
+ return Result (2 .. Result'Last);
+ else
+ return Result;
+ end if;
+ end Image;
+
-----------------------
-- Stream Attributes --
-----------------------
@@ -857,59 +868,13 @@
-- This package can be easily dummied out if we do not want the
-- support for streaming Exception_Ids and Exception_Occurrences.
- -----------------------------
- -- Process_Raise_Exception --
- -----------------------------
-
- procedure Process_Raise_Exception (E : Exception_Id) is
- pragma Inspection_Point (E);
- -- This is so the debugger can reliably inspect the parameter
-
- Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
- Excep : constant EOA := Get_Current_Excep.all;
-
- procedure builtin_longjmp (buffer : Address; Flag : Integer);
- pragma No_Return (builtin_longjmp);
- pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
-
- begin
- -- WARNING: There should be no exception handler for this body because
- -- this would cause gigi to prepend a setup for a new jmpbuf to the
- -- sequence of statements in case of built-in sjljl. We would then
- -- always get this new buf in Jumpbuf_Ptr instead of the one for the
- -- exception we are handling, which would completely break the whole
- -- design of this procedure.
-
- -- If the jump buffer pointer is non-null, transfer control using it.
- -- Otherwise announce an unhandled exception (note that this means that
- -- we have no finalizations to do other than at the outer level).
- -- Perform the necessary notification tasks in both cases.
-
- if Jumpbuf_Ptr /= Null_Address then
- if not Excep.Exception_Raised then
- Excep.Exception_Raised := True;
- Exception_Traces.Notify_Handled_Exception (Excep);
- end if;
-
- builtin_longjmp (Jumpbuf_Ptr, 1);
-
- else
- Exception_Traces.Notify_Unhandled_Exception (Excep);
- Exception_Traces.Unhandled_Exception_Terminate (Excep);
- end if;
- end Process_Raise_Exception;
-
----------------------------
-- Raise_Constraint_Error --
----------------------------
- procedure Raise_Constraint_Error
- (File : System.Address;
- Line : Integer)
- is
+ procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
begin
- Raise_With_Location_And_Msg
- (Constraint_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
end Raise_Constraint_Error;
--------------------------------
@@ -917,41 +882,60 @@
--------------------------------
procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address)
+ (File : System.Address;
+ Line : Integer;
+ Column : Integer;
+ Msg : System.Address)
is
begin
Raise_With_Location_And_Msg
- (Constraint_Error_Def'Access, File, Line, Msg);
+ (Constraint_Error_Def'Access, File, Line, Column, Msg);
end Raise_Constraint_Error_Msg;
-------------------------
- -- Raise_Current_Excep --
+ -- Complete_Occurrence --
-------------------------
- procedure Raise_Current_Excep (E : Exception_Id) is
+ procedure Complete_Occurrence (X : EOA) is
+ begin
+ -- Compute the backtrace for this occurrence if the corresponding
+ -- binder option has been set. Call_Chain takes care of the reraise
+ -- case.
- pragma Inspection_Point (E);
- -- This is so the debugger can reliably inspect the parameter when
- -- inserting a breakpoint at the start of this procedure.
+ -- ??? Using Call_Chain here means we are going to walk up the stack
+ -- once only for backtracing purposes before doing it again for the
+ -- propagation per se.
- Id : Exception_Id := E;
- pragma Volatile (Id);
- pragma Warnings (Off, Id);
- -- In order to provide support for breakpoints on unhandled exceptions,
- -- the debugger will also need to be able to inspect the value of E from
- -- another (inner) frame. So we need to make sure that if E is passed in
- -- a register, its value is also spilled on stack. For this, we store
- -- the parameter value in a local variable, and add a pragma Volatile to
- -- make sure it is spilled. The pragma Warnings (Off) is needed because
- -- the compiler knows that Id is not referenced and that this use of
- -- pragma Volatile is peculiar.
+ -- The first inspection is much lighter, though, as it only requires
+ -- partial unwinding of each frame. Additionally, although we could use
+ -- the personality routine to record the addresses while propagating,
+ -- this method has two drawbacks:
+ -- 1) the trace is incomplete if the exception is handled since we
+ -- don't walk past the frame with the handler,
+
+ -- and
+
+ -- 2) we would miss the frames for which our personality routine is not
+ -- called, e.g. if C or C++ calls are on the way.
+
+ Call_Chain (X);
+
+ -- Notify the debugger
+ Debug_Raise_Exception
+ (E => SSL.Exception_Data_Ptr (X.Id),
+ Message => X.Msg (1 .. X.Msg_Length));
+ end Complete_Occurrence;
+
+ ---------------------------------------
+ -- Complete_And_Propagate_Occurrence --
+ ---------------------------------------
+
+ procedure Complete_And_Propagate_Occurrence (X : EOA) is
begin
- Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E), Message => "");
- Process_Raise_Exception (E);
- end Raise_Current_Excep;
+ Complete_Occurrence (X);
+ Exception_Propagation.Propagate_Exception (X);
+ end Complete_And_Propagate_Occurrence;
---------------------
-- Raise_Exception --
@@ -961,8 +945,7 @@
(E : Exception_Id;
Message : String := "")
is
- EF : Exception_Id := E;
- Excep : constant EOA := Get_Current_Excep.all;
+ EF : Exception_Id := E;
begin
-- Raise CE if E = Null_ID (AI-446)
@@ -972,9 +955,7 @@
-- Go ahead and raise appropriate exception
- Exception_Data.Set_Exception_Msg (Excep, EF, Message);
- Abort_Defer.all;
- Raise_Current_Excep (EF);
+ Raise_Exception_Always (EF, Message);
end Raise_Exception;
----------------------------
@@ -985,11 +966,16 @@
(E : Exception_Id;
Message : String := "")
is
- Excep : constant EOA := Get_Current_Excep.all;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
+
begin
- Exception_Data.Set_Exception_Msg (Excep, E, Message);
- Abort_Defer.all;
- Raise_Current_Excep (E);
+ Exception_Data.Set_Exception_Msg (X, E, Message);
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Complete_And_Propagate_Occurrence (X);
end Raise_Exception_Always;
------------------------------
@@ -1000,13 +986,14 @@
(E : Exception_Id;
Message : String := "")
is
- Excep : constant EOA := Get_Current_Excep.all;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
+
begin
- Exception_Data.Set_Exception_Msg (Excep, E, Message);
+ Exception_Data.Set_Exception_Msg (X, E, Message);
-- Do not call Abort_Defer.all, as specified by the spec
- Raise_Current_Excep (E);
+ Complete_And_Propagate_Occurrence (X);
end Raise_Exception_No_Defer;
-------------------------------------
@@ -1019,11 +1006,13 @@
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
- Integer'Min (Prefix'Length, Orig_Msg'Length);
- Orig_Prefix : String renames Orig_Msg
- (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
+ Integer'Min (Prefix'Length, Orig_Msg'Length);
+
+ Orig_Prefix : String renames
+ Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
+
begin
- -- Message already has proper prefix, just re-reraise
+ -- Message already has the proper prefix, just re-raise
if Orig_Prefix = Prefix then
Raise_Exception_No_Defer
@@ -1053,6 +1042,39 @@
end if;
end Raise_From_Controlled_Operation;
+ -------------------------------------------
+ -- Create_Occurrence_From_Signal_Handler --
+ -------------------------------------------
+
+ function Create_Occurrence_From_Signal_Handler
+ (E : Exception_Id;
+ M : System.Address) return EOA
+ is
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
+
+ begin
+ Exception_Data.Set_Exception_C_Msg (X, E, M);
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Complete_Occurrence (X);
+ return X;
+ end Create_Occurrence_From_Signal_Handler;
+
+ ---------------------------------------------------
+ -- Create_Machine_Occurrence_From_Signal_Handler --
+ ---------------------------------------------------
+
+ function Create_Machine_Occurrence_From_Signal_Handler
+ (E : Exception_Id;
+ M : System.Address) return System.Address
+ is
+ begin
+ return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence;
+ end Create_Machine_Occurrence_From_Signal_Handler;
+
-------------------------------
-- Raise_From_Signal_Handler --
-------------------------------
@@ -1061,11 +1083,9 @@
(E : Exception_Id;
M : System.Address)
is
- Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Data.Set_Exception_C_Msg (Excep, E, M);
- Abort_Defer.all;
- Process_Raise_Exception (E);
+ Exception_Propagation.Propagate_Exception
+ (Create_Occurrence_From_Signal_Handler (E, M));
end Raise_From_Signal_Handler;
-------------------------
@@ -1077,8 +1097,7 @@
Line : Integer)
is
begin
- Raise_With_Location_And_Msg
- (Program_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
end Raise_Program_Error;
-----------------------------
@@ -1092,7 +1111,7 @@
is
begin
Raise_With_Location_And_Msg
- (Program_Error_Def'Access, File, Line, Msg);
+ (Program_Error_Def'Access, File, Line, M => Msg);
end Raise_Program_Error_Msg;
-------------------------
@@ -1104,8 +1123,7 @@
Line : Integer)
is
begin
- Raise_With_Location_And_Msg
- (Storage_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
end Raise_Storage_Error;
-----------------------------
@@ -1119,7 +1137,7 @@
is
begin
Raise_With_Location_And_Msg
- (Storage_Error_Def'Access, File, Line, Msg);
+ (Storage_Error_Def'Access, File, Line, M => Msg);
end Raise_Storage_Error_Msg;
---------------------------------
@@ -1130,13 +1148,18 @@
(E : Exception_Id;
F : System.Address;
L : Integer;
+ C : Integer := 0;
M : System.Address := System.Null_Address)
is
- Excep : constant EOA := Get_Current_Excep.all;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
- Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M);
- Abort_Defer.all;
- Raise_Current_Excep (E);
+ Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Complete_And_Propagate_Occurrence (X);
end Raise_With_Location_And_Msg;
--------------------
@@ -1144,15 +1167,28 @@
--------------------
procedure Raise_With_Msg (E : Exception_Id) is
- Excep : constant EOA := Get_Current_Excep.all;
-
+ Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
+ Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Id := E;
Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
- Abort_Defer.all;
- Raise_Current_Excep (E);
+
+ -- Copy the message from the current exception
+ -- Change the interface to be called with an occurrence ???
+
+ Excep.Msg_Length := Ex.Msg_Length;
+ Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
+
+ -- The following is a common pattern, should be abstracted
+ -- into a procedure call ???
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Complete_And_Propagate_Occurrence (Excep);
end Raise_With_Msg;
-----------------------------------------
@@ -1163,98 +1199,98 @@
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
end Rcheck_CE_Access_Check;
procedure Rcheck_CE_Null_Access_Parameter
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
end Rcheck_CE_Null_Access_Parameter;
procedure Rcheck_CE_Discriminant_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
end Rcheck_CE_Discriminant_Check;
procedure Rcheck_CE_Divide_By_Zero
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
end Rcheck_CE_Divide_By_Zero;
procedure Rcheck_CE_Explicit_Raise
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
end Rcheck_CE_Explicit_Raise;
procedure Rcheck_CE_Index_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
end Rcheck_CE_Index_Check;
procedure Rcheck_CE_Invalid_Data
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
end Rcheck_CE_Invalid_Data;
procedure Rcheck_CE_Length_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
end Rcheck_CE_Length_Check;
procedure Rcheck_CE_Null_Exception_Id
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
end Rcheck_CE_Null_Exception_Id;
procedure Rcheck_CE_Null_Not_Allowed
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
end Rcheck_CE_Null_Not_Allowed;
procedure Rcheck_CE_Overflow_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
end Rcheck_CE_Overflow_Check;
procedure Rcheck_CE_Partition_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
end Rcheck_CE_Partition_Check;
procedure Rcheck_CE_Range_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
end Rcheck_CE_Range_Check;
procedure Rcheck_CE_Tag_Check
(File : System.Address; Line : Integer)
is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
end Rcheck_CE_Tag_Check;
procedure Rcheck_PE_Access_Before_Elaboration
@@ -1341,6 +1377,13 @@
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_PE_Missing_Return;
+ procedure Rcheck_PE_Non_Transportable_Actual
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
+ end Rcheck_PE_Non_Transportable_Actual;
+
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer)
is
@@ -1355,6 +1398,13 @@
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_PE_Potentially_Blocking_Operation;
+ procedure Rcheck_PE_Stream_Operation_Not_Allowed
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
+ end Rcheck_PE_Stream_Operation_Not_Allowed;
+
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer)
is
@@ -1369,13 +1419,6 @@
Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_PE_Unchecked_Union_Restriction;
- procedure Rcheck_PE_Non_Transportable_Actual
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
- end Rcheck_PE_Non_Transportable_Actual;
-
procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer)
is
@@ -1404,116 +1447,79 @@
Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
end Rcheck_SE_Object_Too_Large;
- procedure Rcheck_PE_Stream_Operation_Not_Allowed
- (File : System.Address; Line : Integer)
+ procedure Rcheck_CE_Access_Check_Ext
+ (File : System.Address; Line, Column : Integer)
is
begin
- Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
- end Rcheck_PE_Stream_Operation_Not_Allowed;
+ Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
+ end Rcheck_CE_Access_Check_Ext;
+ procedure Rcheck_CE_Index_Check_Ext
+ (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;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_CE_Index_Check_Ext;
+
+ procedure Rcheck_CE_Invalid_Data_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;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_CE_Invalid_Data_Ext;
+
+ procedure Rcheck_CE_Range_Check_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;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_CE_Range_Check_Ext;
+
procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer)
is
- E : constant Exception_Id := Program_Error_Def'Access;
- Excep : constant EOA := Get_Current_Excep.all;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
-- This is "finalize/adjust raised exception". This subprogram is always
- -- called with abort deferred, unlike all other Rcheck_* subprograms,
- -- itneeds to call Raise_Exception_No_Defer.
+ -- 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
- Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0,
- Rmsg_23'Address);
- Raise_Current_Excep (E);
+ Exception_Data.Set_Exception_C_Msg
+ (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
+ Complete_And_Propagate_Occurrence (X);
end Rcheck_PE_Finalize_Raised_Exception;
- procedure Rcheck_00 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Access_Check;
- procedure Rcheck_01 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Null_Access_Parameter;
- procedure Rcheck_02 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Discriminant_Check;
- procedure Rcheck_03 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Divide_By_Zero;
- procedure Rcheck_04 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Explicit_Raise;
- procedure Rcheck_05 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Index_Check;
- procedure Rcheck_06 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Invalid_Data;
- procedure Rcheck_07 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Length_Check;
- procedure Rcheck_08 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Null_Exception_Id;
- procedure Rcheck_09 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Null_Not_Allowed;
- procedure Rcheck_10 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Overflow_Check;
- procedure Rcheck_11 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Partition_Check;
- procedure Rcheck_12 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Range_Check;
- procedure Rcheck_13 (File : System.Address; Line : Integer)
- renames Rcheck_CE_Tag_Check;
- procedure Rcheck_14 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Access_Before_Elaboration;
- procedure Rcheck_15 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Accessibility_Check;
- procedure Rcheck_16 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Address_Of_Intrinsic;
- procedure Rcheck_17 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Aliased_Parameters;
- procedure Rcheck_18 (File : System.Address; Line : Integer)
- renames Rcheck_PE_All_Guards_Closed;
- procedure Rcheck_19 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Bad_Predicated_Generic_Type;
- procedure Rcheck_20 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Current_Task_In_Entry_Body;
- procedure Rcheck_21 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Duplicated_Entry_Address;
- procedure Rcheck_22 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Explicit_Raise;
- procedure Rcheck_23 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Finalize_Raised_Exception;
- procedure Rcheck_24 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Implicit_Return;
- procedure Rcheck_25 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Misaligned_Address_Value;
- procedure Rcheck_26 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Missing_Return;
- procedure Rcheck_27 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Overlaid_Controlled_Object;
- procedure Rcheck_28 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Potentially_Blocking_Operation;
- procedure Rcheck_29 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Stubbed_Subprogram_Called;
- procedure Rcheck_30 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Unchecked_Union_Restriction;
- procedure Rcheck_31 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Non_Transportable_Actual;
- procedure Rcheck_32 (File : System.Address; Line : Integer)
- renames Rcheck_SE_Empty_Storage_Pool;
- procedure Rcheck_33 (File : System.Address; Line : Integer)
- renames Rcheck_SE_Explicit_Raise;
- procedure Rcheck_34 (File : System.Address; Line : Integer)
- renames Rcheck_SE_Infinite_Recursion;
- procedure Rcheck_35 (File : System.Address; Line : Integer)
- renames Rcheck_SE_Object_Too_Large;
- procedure Rcheck_36 (File : System.Address; Line : Integer)
- renames Rcheck_PE_Stream_Operation_Not_Allowed;
-
-------------
-- Reraise --
-------------
procedure Reraise is
- Excep : constant EOA := Get_Current_Excep.all;
+ Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
+ Saved_MO : constant System.Address := Excep.Machine_Occurrence;
begin
- Abort_Defer.all;
- Raise_Current_Excep (Excep.Id);
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
+ Excep.Machine_Occurrence := Saved_MO;
+ Complete_And_Propagate_Occurrence (Excep);
end Reraise;
--------------------------------------
@@ -1522,10 +1528,18 @@
procedure Reraise_Library_Exception_If_Any is
LE : Exception_Occurrence;
+
begin
if Library_Exception_Set then
LE := Library_Exception;
- Raise_From_Controlled_Operation (LE);
+
+ if LE.Id = Null_Id then
+ Raise_Exception_No_Defer
+ (E => Program_Error'Identity,
+ Message => "finalize/adjust raised exception");
+ else
+ Raise_From_Controlled_Operation (LE);
+ end if;
end if;
end Reraise_Library_Exception_If_Any;
@@ -1535,10 +1549,10 @@
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);
+ if X.Id = null then
+ return;
+ else
+ Reraise_Occurrence_Always (X);
end if;
end Reraise_Occurrence;
@@ -1548,9 +1562,11 @@
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);
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Reraise_Occurrence_No_Defer (X);
end Reraise_Occurrence_Always;
---------------------------------
@@ -1558,9 +1574,12 @@
---------------------------------
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
+ Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
+ Saved_MO : constant System.Address := Excep.Machine_Occurrence;
begin
- Save_Occurrence (Get_Current_Excep.all.all, X);
- Raise_Current_Excep (X.Id);
+ Save_Occurrence (Excep.all, X);
+ Excep.Machine_Occurrence := Saved_MO;
+ Complete_And_Propagate_Occurrence (Excep);
end Reraise_Occurrence_No_Defer;
---------------------
@@ -1572,11 +1591,15 @@
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;
+ -- As the machine occurrence might be a data that must be finalized
+ -- (outside any Ada mechanism), do not copy it
+ Target.Id := Source.Id;
+ Target.Machine_Occurrence := System.Null_Address;
+ Target.Msg_Length := Source.Msg_Length;
+ Target.Num_Tracebacks := Source.Num_Tracebacks;
+ Target.Pid := Source.Pid;
+
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
@@ -1610,13 +1633,10 @@
---------------
procedure To_Stderr (C : Character) is
- type int is new Integer;
-
- procedure put_char_stderr (C : int);
- pragma Import (C, put_char_stderr, "put_char_stderr");
-
+ procedure Put_Char_Stderr (C : Character);
+ pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
- put_char_stderr (Character'Pos (C));
+ Put_Char_Stderr (C);
end To_Stderr;
procedure To_Stderr (S : String) is
@@ -1651,4 +1671,78 @@
and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
end Triggered_By_Abort;
+ -------------------------
+ -- Wide_Exception_Name --
+ -------------------------
+
+ WC_Encoding : Character;
+ pragma Import (C, WC_Encoding, "__gl_wc_encoding");
+ -- Encoding method for source, as exported by binder
+
+ function Wide_Exception_Name
+ (Id : Exception_Id) return Wide_String
+ is
+ S : constant String := Exception_Name (Id);
+ W : Wide_String (1 .. S'Length);
+ L : Natural;
+ begin
+ String_To_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
+ end Wide_Exception_Name;
+
+ function Wide_Exception_Name
+ (X : Exception_Occurrence) return Wide_String
+ is
+ S : constant String := Exception_Name (X);
+ W : Wide_String (1 .. S'Length);
+ L : Natural;
+ begin
+ String_To_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
+ end Wide_Exception_Name;
+
+ ----------------------------
+ -- Wide_Wide_Exception_Name --
+ -----------------------------
+
+ function Wide_Wide_Exception_Name
+ (Id : Exception_Id) return Wide_Wide_String
+ is
+ S : constant String := Exception_Name (Id);
+ W : Wide_Wide_String (1 .. S'Length);
+ L : Natural;
+ begin
+ String_To_Wide_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
+ end Wide_Wide_Exception_Name;
+
+ function Wide_Wide_Exception_Name
+ (X : Exception_Occurrence) return Wide_Wide_String
+ is
+ S : constant String := Exception_Name (X);
+ W : Wide_Wide_String (1 .. S'Length);
+ L : Natural;
+ begin
+ String_To_Wide_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
+ end Wide_Wide_Exception_Name;
+
+ --------------------------
+ -- Code_Address_For_ZZZ --
+ --------------------------
+
+ -- This function gives us the end of the PC range for addresses
+ -- within the exception unit itself. We hope that gigi/gcc keeps all the
+ -- procedures in their original order.
+
+ function Code_Address_For_ZZZ return System.Address is
+ begin
+ <<Start_Of_ZZZ>>
+ return Start_Of_ZZZ'Address;
+ end Code_Address_For_ZZZ;
+
end Ada.Exceptions;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2017, 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 --
@@ -33,24 +33,15 @@
-- --
------------------------------------------------------------------------------
+-- This version of Ada.Exceptions fully supports Ada 95 and later language
+-- versions. It is used in all situations except for the build of the
+-- compiler and other basic tools. For these latter builds, we use an
+-- Ada 95-only version.
-
-- The reason for this splitting off of a separate version is to support
-- older bootstrap compilers that do not support Ada 2005 features, and
-- Ada.Exceptions is part of the compiler sources.
-pragma Compiler_Unit_Warning;
-
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with ourself.
@@ -62,26 +53,40 @@
package Ada.Exceptions is
pragma Preelaborate;
- -- We make this preelaborable. If we did not do this, then run time units
- -- used by the compiler (e.g. s-soflin.ads) would run into trouble.
- -- Conformance with Ada 95 is not an issue, since this version is used
- -- only by the compiler.
+ -- In accordance with Ada 2005 AI-362.
type Exception_Id is private;
+ pragma Preelaborable_Initialization (Exception_Id);
Null_Id : constant Exception_Id;
type Exception_Occurrence is limited private;
+ pragma Preelaborable_Initialization (Exception_Occurrence);
type Exception_Occurrence_Access is access all Exception_Occurrence;
Null_Occurrence : constant Exception_Occurrence;
+ function Exception_Name (Id : Exception_Id) return String;
+
function Exception_Name (X : Exception_Occurrence) return String;
- -- Same as Exception_Name (Exception_Identity (X))
- function Exception_Name (Id : Exception_Id) return String;
+ function Wide_Exception_Name
+ (Id : Exception_Id) return Wide_String;
+ pragma Ada_05 (Wide_Exception_Name);
+ function Wide_Exception_Name
+ (X : Exception_Occurrence) return Wide_String;
+ pragma Ada_05 (Wide_Exception_Name);
+
+ function Wide_Wide_Exception_Name
+ (Id : Exception_Id) return Wide_Wide_String;
+ pragma Ada_05 (Wide_Wide_Exception_Name);
+
+ function Wide_Wide_Exception_Name
+ (X : Exception_Occurrence) return Wide_Wide_String;
+ pragma Ada_05 (Wide_Wide_Exception_Name);
+
procedure Raise_Exception (E : Exception_Id; Message : String := "");
pragma No_Return (Raise_Exception);
-- Note: In accordance with AI-466, CE is raised if E = Null_Id
@@ -105,7 +110,9 @@
-- 0xyyyyyyyy 0xyyyyyyyy ...
--
-- The lines are separated by a ASCII.LF character
- -- The nnnn is the partition Id given as decimal digits.
+ --
+ -- The nnnn is the partition Id given as decimal digits
+ --
-- The 0x... line represents traceback program counter locations,
-- in order with the first one being the exception location.
@@ -121,6 +128,22 @@
(Source : Exception_Occurrence)
return Exception_Occurrence_Access;
+ -- Ada 2005 (AI-438): The language revision introduces the following
+ -- subprograms and attribute definitions. We do not provide them
+ -- explicitly. instead, the corresponding stream attributes are made
+ -- available through a pragma Stream_Convert in the private part.
+
+ -- procedure Read_Exception_Occurrence
+ -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ -- Item : out Exception_Occurrence);
+
+ -- procedure Write_Exception_Occurrence
+ -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ -- Item : Exception_Occurrence);
+
+ -- for Exception_Occurrence'Read use Read_Exception_Occurrence;
+ -- for Exception_Occurrence'Write use Write_Exception_Occurrence;
+
private
package SSL renames System.Standard_Library;
package SP renames System.Parameters;
@@ -216,8 +239,8 @@
pragma No_Return (Reraise_Occurrence_No_Defer);
-- Exactly like Reraise_Occurrence, except that abort is not deferred
-- before the call and the parameter X is known not to be the null
- -- occurrence. This is used in generated code when it is known that
- -- abort is already deferred.
+ -- occurrence. This is used in generated code when it is known that abort
+ -- is already deferred.
function Triggered_By_Abort return Boolean;
-- Determine whether the current exception (if it exists) is an instance of
@@ -264,6 +287,10 @@
Id : Exception_Id;
-- Exception_Identity for this exception occurrence
+ Machine_Occurrence : System.Address;
+ -- The underlying machine occurrence. For GCC, this corresponds to the
+ -- _Unwind_Exception structure address.
+
Msg_Length : Natural := 0;
-- Length of message (zero = no message)
@@ -295,18 +322,28 @@
-- this, and it would not work right, because of the Msg and Tracebacks
-- fields which have unused entries not copied by Save_Occurrence.
+ function Get_Exception_Machine_Occurrence
+ (X : Exception_Occurrence) return System.Address;
+ pragma Export (Ada, Get_Exception_Machine_Occurrence,
+ "__gnat_get_exception_machine_occurrence");
+ -- Get the machine occurrence corresponding to an exception occurrence.
+ -- It is Null_Address if there is no machine occurrence (in runtimes that
+ -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence
+ -- doesn't save the machine occurrence).
+
function EO_To_String (X : Exception_Occurrence) return String;
function String_To_EO (S : String) return Exception_Occurrence;
pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String);
-- Functions for implementing Exception_Occurrence stream attributes
Null_Occurrence : constant Exception_Occurrence := (
- Id => null,
- Msg_Length => 0,
- Msg => (others => ' '),
- Exception_Raised => False,
- Pid => 0,
- Num_Tracebacks => 0,
- Tracebacks => (others => TBE.Null_TB_Entry));
+ Id => null,
+ Machine_Occurrence => System.Null_Address,
+ Msg_Length => 0,
+ Msg => (others => ' '),
+ Exception_Raised => False,
+ Pid => 0,
+ Num_Tracebacks => 0,
+ Tracebacks => (others => TBE.Null_TB_Entry));
end Ada.Exceptions;
===================================================================
@@ -1,349 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-
-pragma Polling (Off);
-
-with System;
-with System.Parameters;
-with System.Standard_Library;
-with System.Traceback_Entries;
-
-package Ada.Exceptions is
- pragma Preelaborate;
- -- In accordance with Ada 2005 AI-362.
-
- type Exception_Id is private;
- pragma Preelaborable_Initialization (Exception_Id);
-
- Null_Id : constant Exception_Id;
-
- type Exception_Occurrence is limited private;
- pragma Preelaborable_Initialization (Exception_Occurrence);
-
- type Exception_Occurrence_Access is access all Exception_Occurrence;
-
- Null_Occurrence : constant Exception_Occurrence;
-
- function Exception_Name (Id : Exception_Id) return String;
-
- function Exception_Name (X : Exception_Occurrence) return String;
-
- function Wide_Exception_Name
- (Id : Exception_Id) return Wide_String;
- pragma Ada_05 (Wide_Exception_Name);
-
- function Wide_Exception_Name
- (X : Exception_Occurrence) return Wide_String;
- pragma Ada_05 (Wide_Exception_Name);
-
- function Wide_Wide_Exception_Name
- (Id : Exception_Id) return Wide_Wide_String;
- pragma Ada_05 (Wide_Wide_Exception_Name);
-
- function Wide_Wide_Exception_Name
- (X : Exception_Occurrence) return Wide_Wide_String;
- pragma Ada_05 (Wide_Wide_Exception_Name);
-
- procedure Raise_Exception (E : Exception_Id; Message : String := "");
- pragma No_Return (Raise_Exception);
- -- Note: In accordance with AI-466, CE is raised if E = Null_Id
-
- function Exception_Message (X : Exception_Occurrence) return String;
-
- procedure Reraise_Occurrence (X : Exception_Occurrence);
- -- Note: it would be really nice to give a pragma No_Return for this
- -- procedure, but it would be wrong, since Reraise_Occurrence does return
- -- if the argument is the null exception occurrence. See also procedure
- -- Reraise_Occurrence_Always in the private part of this package.
-
- function Exception_Identity (X : Exception_Occurrence) return Exception_Id;
-
- function Exception_Information (X : Exception_Occurrence) return String;
- -- The format of the exception information is as follows:
- --
- -- exception name (as in Exception_Name)
- -- message (or a null line if no message)
- -- PID=nnnn
- -- 0xyyyyyyyy 0xyyyyyyyy ...
- --
- -- The lines are separated by a ASCII.LF character
- --
- -- The nnnn is the partition Id given as decimal digits
- --
- -- The 0x... line represents traceback program counter locations,
- -- in order with the first one being the exception location.
-
- -- Note on ordering: the compiler uses the Save_Occurrence procedure, but
- -- not the function from Rtsfind, so it is important that the procedure
- -- come first, since Rtsfind finds the first matching entity.
-
- procedure Save_Occurrence
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence);
-
- function Save_Occurrence
- (Source : Exception_Occurrence)
- return Exception_Occurrence_Access;
-
- -- Ada 2005 (AI-438): The language revision introduces the following
- -- subprograms and attribute definitions. We do not provide them
- -- explicitly. instead, the corresponding stream attributes are made
- -- available through a pragma Stream_Convert in the private part.
-
- -- procedure Read_Exception_Occurrence
- -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- -- Item : out Exception_Occurrence);
-
- -- procedure Write_Exception_Occurrence
- -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- -- Item : Exception_Occurrence);
-
- -- for Exception_Occurrence'Read use Read_Exception_Occurrence;
- -- for Exception_Occurrence'Write use Write_Exception_Occurrence;
-
-private
- package SSL renames System.Standard_Library;
- package SP renames System.Parameters;
-
- subtype EOA is Exception_Occurrence_Access;
-
- Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length;
-
- ------------------
- -- Exception_Id --
- ------------------
-
- subtype Code_Loc is System.Address;
- -- Code location used in building exception tables and for call addresses
- -- when propagating an exception. Values of this type are created by using
- -- Label'Address or extracted from machine states using Get_Code_Loc.
-
- Null_Loc : constant Code_Loc := System.Null_Address;
- -- Null code location, used to flag outer level frame
-
- type Exception_Id is new SSL.Exception_Data_Ptr;
-
- function EId_To_String (X : Exception_Id) return String;
- function String_To_EId (S : String) return Exception_Id;
- pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String);
- -- Functions for implementing Exception_Id stream attributes
-
- Null_Id : constant Exception_Id := null;
-
- -------------------------
- -- Private Subprograms --
- -------------------------
-
- function Exception_Name_Simple (X : Exception_Occurrence) return String;
- -- Like Exception_Name, but returns the simple non-qualified name of the
- -- exception. This is used to implement the Exception_Name function in
- -- Current_Exceptions (the DEC compatible unit). It is called from the
- -- compiler generated code (using Rtsfind, which does not respect the
- -- private barrier, so we can place this function in the private part
- -- where the compiler can find it, but the spec is unchanged.)
-
- procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
- pragma No_Return (Raise_Exception_Always);
- pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception");
- -- This differs from Raise_Exception only in that the caller has determined
- -- that for sure the parameter E is not null, and that therefore no check
- -- for Null_Id is required. The expander converts Raise_Exception calls to
- -- Raise_Exception_Always if it can determine this is the case. The Export
- -- allows this routine to be accessed from Pure units.
-
- procedure Raise_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address);
- pragma Export
- (Ada, Raise_From_Signal_Handler,
- "ada__exceptions__raise_from_signal_handler");
- pragma No_Return (Raise_From_Signal_Handler);
- -- This routine is used to raise an exception from a signal handler. The
- -- signal handler has already stored the machine state (i.e. the state that
- -- corresponds to the location at which the signal was raised). E is the
- -- Exception_Id specifying what exception is being raised, and M is a
- -- pointer to a null-terminated string which is the message to be raised.
- -- Note that this routine never returns, so it is permissible to simply
- -- jump to this routine, rather than call it. This may be appropriate for
- -- systems where the right way to get out of signal handler is to alter the
- -- PC value in the machine state or in some other way ask the operating
- -- system to return here rather than to the original location.
-
- procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
- pragma No_Return (Raise_From_Controlled_Operation);
- pragma Export
- (Ada, Raise_From_Controlled_Operation,
- "__gnat_raise_from_controlled_operation");
- -- Raise Program_Error, providing information about X (an exception raised
- -- during a controlled operation) in the exception message.
-
- procedure Reraise_Library_Exception_If_Any;
- pragma Export
- (Ada, Reraise_Library_Exception_If_Any,
- "__gnat_reraise_library_exception_if_any");
- -- If there was an exception raised during library-level finalization,
- -- reraise the exception.
-
- procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
- pragma No_Return (Reraise_Occurrence_Always);
- -- This differs from Raise_Occurrence only in that the caller guarantees
- -- that for sure the parameter X is not the null occurrence, and that
- -- therefore this procedure cannot return. The expander uses this routine
- -- in the translation of a raise statement with no parameter (reraise).
-
- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence);
- pragma No_Return (Reraise_Occurrence_No_Defer);
- -- Exactly like Reraise_Occurrence, except that abort is not deferred
- -- before the call and the parameter X is known not to be the null
- -- occurrence. This is used in generated code when it is known that abort
- -- is already deferred.
-
- function Triggered_By_Abort return Boolean;
- -- Determine whether the current exception (if it exists) is an instance of
- -- Standard'Abort_Signal.
-
- -----------------------
- -- Polling Interface --
- -----------------------
-
- -- The GNAT compiler has an option to generate polling calls to the Poll
- -- routine in this package. Specifying the -gnatP option for a compilation
- -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram
- -- entry and on every iteration of a loop, thus avoiding the possibility of
- -- a case of unbounded time between calls.
-
- -- This polling interface may be used for instrumentation or debugging
- -- purposes (e.g. implementing watchpoints in software or in the debugger).
-
- -- In the GNAT technology itself, this interface is used to implement
- -- immediate asynchronous transfer of control and immediate abort on
- -- targets which do not provide for one thread interrupting another.
-
- -- Note: this used to be in a separate unit called System.Poll, but that
- -- caused horrible circular elaboration problems between System.Poll and
- -- Ada.Exceptions.
-
- procedure Poll;
- -- Check for asynchronous abort. Note that we do not inline the body.
- -- This makes the interface more useful for debugging purposes.
-
- --------------------------
- -- Exception_Occurrence --
- --------------------------
-
- package TBE renames System.Traceback_Entries;
-
- Max_Tracebacks : constant := 50;
- -- Maximum number of trace backs stored in exception occurrence
-
- subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks);
- -- Traceback array stored in exception occurrence
-
- type Exception_Occurrence is record
- Id : Exception_Id;
- -- Exception_Identity for this exception occurrence
-
- Machine_Occurrence : System.Address;
- -- The underlying machine occurrence. For GCC, this corresponds to the
- -- _Unwind_Exception structure address.
-
- Msg_Length : Natural := 0;
- -- Length of message (zero = no message)
-
- Msg : String (1 .. Exception_Msg_Max_Length);
- -- Characters of message
-
- Exception_Raised : Boolean := False;
- -- Set to true to indicate that this exception occurrence has actually
- -- been raised. When an exception occurrence is first created, this is
- -- set to False, then when it is processed by Raise_Current_Exception,
- -- it is set to True. If Raise_Current_Exception is used to raise an
- -- exception for which this flag is already True, then it knows that
- -- it is dealing with the reraise case (which is useful to distinguish
- -- for exception tracing purposes).
-
- Pid : Natural := 0;
- -- Partition_Id for partition raising exception
-
- Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0;
- -- Number of traceback entries stored
-
- Tracebacks : Tracebacks_Array;
- -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks))
- end record;
-
- function "=" (Left, Right : Exception_Occurrence) return Boolean
- is abstract;
- -- Don't allow comparison on exception occurrences, we should not need
- -- this, and it would not work right, because of the Msg and Tracebacks
- -- fields which have unused entries not copied by Save_Occurrence.
-
- function Get_Exception_Machine_Occurrence
- (X : Exception_Occurrence) return System.Address;
- pragma Export (Ada, Get_Exception_Machine_Occurrence,
- "__gnat_get_exception_machine_occurrence");
- -- Get the machine occurrence corresponding to an exception occurrence.
- -- It is Null_Address if there is no machine occurrence (in runtimes that
- -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence
- -- doesn't save the machine occurrence).
-
- function EO_To_String (X : Exception_Occurrence) return String;
- function String_To_EO (S : String) return Exception_Occurrence;
- pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String);
- -- Functions for implementing Exception_Occurrence stream attributes
-
- Null_Occurrence : constant Exception_Occurrence := (
- Id => null,
- Machine_Occurrence => System.Null_Address,
- Msg_Length => 0,
- Msg => (others => ' '),
- Exception_Raised => False,
- Pid => 0,
- Num_Tracebacks => 0,
- Tracebacks => (others => TBE.Null_TB_Entry));
-
-end Ada.Exceptions;
===================================================================
@@ -1,1748 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-pragma Style_Checks (All_Checks);
-
-pragma Polling (Off);
-
-with System; use System;
-with System.Exceptions; use System.Exceptions;
-with System.Exceptions_Debug; use System.Exceptions_Debug;
-with System.Standard_Library; use System.Standard_Library;
-with System.Soft_Links; use System.Soft_Links;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_StW; use System.WCh_StW;
-
-pragma Warnings (Off);
-with System.Traceback.Symbolic;
-pragma Warnings (On);
-
-package body Ada.Exceptions is
-
- pragma Suppress (All_Checks);
- -- We definitely do not want exceptions occurring within this unit, or
- -- we are in big trouble. If an exceptional situation does occur, better
- -- that it not be raised, since raising it can cause confusing chaos.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- Note: the exported subprograms in this package body are called directly
- -- from C clients using the given external name, even though they are not
- -- technically visible in the Ada sense.
-
- function Code_Address_For_AAA return System.Address;
- function Code_Address_For_ZZZ return System.Address;
- -- Return start and end of procedures in this package
- --
- -- 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 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 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
- -- body of Code_Address_For_ZZZ.
- --
- -- 2) No pragma Inline applies to any of these subprograms, as this
- -- could delay the corresponding assembly output until the end of
- -- the unit.
-
- procedure Call_Chain (Excep : EOA);
- -- Store up to Max_Tracebacks in Excep, corresponding to the current
- -- call chain.
-
- function Image (Index : Integer) return String;
- -- Return string image corresponding to Index
-
- procedure To_Stderr (S : String);
- pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
- -- Little routine to output string to stderr that is also used
- -- in the tasking run time.
-
- procedure To_Stderr (C : Character);
- pragma Inline (To_Stderr);
- pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
- -- Little routine to output a character to stderr, used by some of
- -- the separate units below.
-
- package Exception_Data is
-
- -----------------------------------
- -- Exception Message Subprograms --
- -----------------------------------
-
- procedure Set_Exception_C_Msg
- (Excep : EOA;
- Id : Exception_Id;
- Msg1 : System.Address;
- Line : Integer := 0;
- Column : Integer := 0;
- Msg2 : System.Address := System.Null_Address);
- -- This routine is called to setup the exception referenced by X
- -- to contain the indicated Id value and message. Msg1 is a null
- -- terminated string which is generated as the exception message. If
- -- line is non-zero, then a colon and the decimal representation of
- -- this integer is appended to the message. Ditto for Column. When Msg2
- -- is non-null, a space and this additional null terminated string is
- -- added to the message.
-
- procedure Set_Exception_Msg
- (Excep : EOA;
- Id : Exception_Id;
- Message : String);
- -- This routine is called to setup the exception referenced by X
- -- to contain the indicated Id value and message. Message is a string
- -- which is generated as the exception message.
-
- ---------------------------------------
- -- Exception Information Subprograms --
- ---------------------------------------
-
- function Untailored_Exception_Information
- (X : Exception_Occurrence) return String;
- -- This is used by Stream_Attributes.EO_To_String to convert an
- -- Exception_Occurrence to a String for the stream attributes.
- -- String_To_EO understands the format, as documented here.
- --
- -- The format of the string is as follows:
- --
- -- raised <exception name> : <message>
- -- (" : <message>" is present only if Exception_Message is not empty)
- -- PID=nnnn (only if nonzero)
- -- Call stack traceback locations: (only if at least one location)
- -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
- --
- -- The lines are separated by a ASCII.LF character.
- -- The nnnn is the partition Id given as decimal digits.
- -- The 0x... line represents traceback program counter locations, in
- -- execution order with the first one being the exception location.
- --
- -- 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.
-
- function Exception_Information (X : Exception_Occurrence) return String;
- -- This is the implementation of Ada.Exceptions.Exception_Information,
- -- as defined in the Ada RM.
- --
- -- If no traceback decorator (see GNAT.Exception_Traces) is currently
- -- in place, this is the same as Untailored_Exception_Information.
- -- Otherwise, the decorator is used to produce a symbolic traceback
- -- instead of hexadecimal addresses.
- --
- -- Note that unlike Untailored_Exception_Information, there is no need
- -- to keep the output of Exception_Information stable for streaming
- -- purposes, and in fact the output differs across platforms.
-
- end Exception_Data;
-
- package Exception_Traces is
-
- -------------------------------------------------
- -- 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.
- -- user specified actions or output of exception information). They are
- -- exported to be usable by the Ada exception handling personality
- -- routine when the GCC 3 mechanism is used.
-
- procedure Notify_Handled_Exception (Excep : EOA);
- pragma Export
- (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
- -- This routine is called for a handled occurrence is about to be
- -- propagated.
-
- procedure Notify_Unhandled_Exception (Excep : EOA);
- pragma Export
- (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
- -- This routine is called when an unhandled occurrence is about to be
- -- propagated.
-
- procedure Unhandled_Exception_Terminate (Excep : EOA);
- pragma No_Return (Unhandled_Exception_Terminate);
- -- This procedure is called to terminate execution following an
- -- unhandled exception. The exception information, including
- -- traceback if available is output, and execution is then
- -- terminated. Note that at the point where this routine is
- -- called, the stack has typically been destroyed.
-
- end Exception_Traces;
-
- package Exception_Propagation is
-
- ---------------------------------------
- -- Exception Propagation Subprograms --
- ---------------------------------------
-
- function Allocate_Occurrence return EOA;
- -- Allocate an exception occurrence (as well as the machine occurrence)
-
- procedure Propagate_Exception (Excep : EOA);
- pragma No_Return (Propagate_Exception);
- -- This procedure propagates the exception represented by Excep
-
- end Exception_Propagation;
-
- package Stream_Attributes is
-
- ----------------------------------
- -- Stream Attribute Subprograms --
- ----------------------------------
-
- function EId_To_String (X : Exception_Id) return String;
- function String_To_EId (S : String) return Exception_Id;
- -- Functions for implementing Exception_Id stream attributes
-
- function EO_To_String (X : Exception_Occurrence) return String;
- function String_To_EO (S : String) return Exception_Occurrence;
- -- Functions for implementing Exception_Occurrence stream
- -- attributes
-
- end Stream_Attributes;
-
- procedure Complete_Occurrence (X : EOA);
- -- Finish building the occurrence: save the call chain and notify the
- -- debugger.
-
- procedure Complete_And_Propagate_Occurrence (X : EOA);
- pragma No_Return (Complete_And_Propagate_Occurrence);
- -- This is a simple wrapper to Complete_Occurrence and
- -- Exception_Propagation.Propagate_Exception.
-
- function Create_Occurrence_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address) return EOA;
- -- Create and build an exception occurrence using exception id E and
- -- nul-terminated message M.
-
- function Create_Machine_Occurrence_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address) return System.Address;
- pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler,
- "__gnat_create_machine_occurrence_from_signal_handler");
- -- Create and build an exception occurrence using exception id E and
- -- nul-terminated message M. Return the machine occurrence.
-
- 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);
- -- Similar to Raise_Exception, but with no abort deferral
-
- procedure Raise_With_Msg (E : Exception_Id);
- pragma No_Return (Raise_With_Msg);
- pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
- -- Raises an exception with given exception id value. A message
- -- is associated with the raise, and has already been stored in the
- -- exception occurrence referenced by the Current_Excep in the TSD.
- -- Abort is deferred before the raise call.
-
- procedure Raise_With_Location_And_Msg
- (E : Exception_Id;
- F : System.Address;
- L : Integer;
- C : Integer := 0;
- M : System.Address := System.Null_Address);
- pragma No_Return (Raise_With_Location_And_Msg);
- -- Raise an exception with given exception id value. A filename and line
- -- number is associated with the raise and is stored in the exception
- -- occurrence and in addition a column and a string message M may be
- -- appended to this (if not null/0).
-
- procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
- pragma No_Return (Raise_Constraint_Error);
- pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
- -- Raise constraint error with file:line information
-
- procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Column : Integer;
- Msg : System.Address);
- pragma No_Return (Raise_Constraint_Error_Msg);
- pragma Export
- (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
- -- Raise constraint error with file:line:col + msg information
-
- procedure Raise_Program_Error (File : System.Address; Line : Integer);
- pragma No_Return (Raise_Program_Error);
- pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
- -- Raise program error with file:line information
-
- procedure Raise_Program_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address);
- pragma No_Return (Raise_Program_Error_Msg);
- pragma Export
- (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
- -- Raise program error with file:line + msg information
-
- procedure Raise_Storage_Error (File : System.Address; Line : Integer);
- pragma No_Return (Raise_Storage_Error);
- pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
- -- Raise storage error with file:line information
-
- procedure Raise_Storage_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address);
- pragma No_Return (Raise_Storage_Error_Msg);
- pragma Export
- (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
- -- Raise storage error with file:line + reason msg information
-
- -- The exception raising process and the automatic tracing mechanism rely
- -- on some careful use of flags attached to the exception occurrence. The
- -- graph below illustrates the relations between the Raise_ subprograms
- -- and identifies the points where basic flags such as Exception_Raised
- -- are initialized.
-
- -- (i) signs indicate the flags initialization points. R stands for Raise,
- -- W for With, and E for Exception.
-
- -- R_No_Msg R_E R_Pe R_Ce R_Se
- -- | | | | |
- -- +--+ +--+ +---+ | +---+
- -- | | | | |
- -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc
- -- | | | |
- -- +------------+ | +-----------+ +--+
- -- | | | |
- -- | | | Set_E_C_Msg(i)
- -- | | |
- -- Complete_And_Propagate_Occurrence
-
- procedure Reraise;
- pragma No_Return (Reraise);
- pragma Export (C, Reraise, "__gnat_reraise");
- -- Reraises the exception referenced by the Current_Excep field
- -- of the TSD (all fields of this exception occurrence are set).
- -- Abort is deferred before the reraise operation. Called from
- -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous
-
- procedure Transfer_Occurrence
- (Target : Exception_Occurrence_Access;
- Source : Exception_Occurrence);
- pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
- -- Called from s-tasren.adb:Local_Complete_RendezVous and
- -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
- -- 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 Subprograms --
- --------------------------------
-
- -- 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.
-
- procedure Rcheck_CE_Access_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Access_Parameter
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Discriminant_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Divide_By_Zero
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Explicit_Raise
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Index_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Invalid_Data
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Length_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Exception_Id
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Null_Not_Allowed
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Overflow_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Partition_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Range_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Tag_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Access_Before_Elaboration
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Accessibility_Check
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Address_Of_Intrinsic
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Aliased_Parameters
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_All_Guards_Closed
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Bad_Predicated_Generic_Type
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Current_Task_In_Entry_Body
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Duplicated_Entry_Address
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Explicit_Raise
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Implicit_Return
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Misaligned_Address_Value
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Missing_Return
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Non_Transportable_Actual
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Overlaid_Controlled_Object
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Potentially_Blocking_Operation
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Stubbed_Subprogram_Called
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Unchecked_Union_Restriction
- (File : System.Address; Line : Integer);
- procedure Rcheck_SE_Empty_Storage_Pool
- (File : System.Address; Line : Integer);
- procedure Rcheck_SE_Explicit_Raise
- (File : System.Address; Line : Integer);
- procedure Rcheck_SE_Infinite_Recursion
- (File : System.Address; Line : Integer);
- procedure Rcheck_SE_Object_Too_Large
- (File : System.Address; Line : Integer);
- procedure Rcheck_PE_Stream_Operation_Not_Allowed
- (File : System.Address; Line : Integer);
- procedure Rcheck_CE_Access_Check_Ext
- (File : System.Address; Line, Column : Integer);
- procedure Rcheck_CE_Index_Check_Ext
- (File : System.Address; Line, Column, Index, First, Last : Integer);
- procedure Rcheck_CE_Invalid_Data_Ext
- (File : System.Address; Line, Column, Index, First, Last : Integer);
- procedure Rcheck_CE_Range_Check_Ext
- (File : System.Address; Line, Column, Index, First, Last : Integer);
-
- procedure Rcheck_PE_Finalize_Raised_Exception
- (File : System.Address; Line : Integer);
- -- 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_* subprograms, it needs to call Raise_Exception_No_Defer.
-
- pragma Export (C, Rcheck_CE_Access_Check,
- "__gnat_rcheck_CE_Access_Check");
- pragma Export (C, Rcheck_CE_Null_Access_Parameter,
- "__gnat_rcheck_CE_Null_Access_Parameter");
- pragma Export (C, Rcheck_CE_Discriminant_Check,
- "__gnat_rcheck_CE_Discriminant_Check");
- pragma Export (C, Rcheck_CE_Divide_By_Zero,
- "__gnat_rcheck_CE_Divide_By_Zero");
- pragma Export (C, Rcheck_CE_Explicit_Raise,
- "__gnat_rcheck_CE_Explicit_Raise");
- pragma Export (C, Rcheck_CE_Index_Check,
- "__gnat_rcheck_CE_Index_Check");
- pragma Export (C, Rcheck_CE_Invalid_Data,
- "__gnat_rcheck_CE_Invalid_Data");
- pragma Export (C, Rcheck_CE_Length_Check,
- "__gnat_rcheck_CE_Length_Check");
- pragma Export (C, Rcheck_CE_Null_Exception_Id,
- "__gnat_rcheck_CE_Null_Exception_Id");
- pragma Export (C, Rcheck_CE_Null_Not_Allowed,
- "__gnat_rcheck_CE_Null_Not_Allowed");
- pragma Export (C, Rcheck_CE_Overflow_Check,
- "__gnat_rcheck_CE_Overflow_Check");
- pragma Export (C, Rcheck_CE_Partition_Check,
- "__gnat_rcheck_CE_Partition_Check");
- pragma Export (C, Rcheck_CE_Range_Check,
- "__gnat_rcheck_CE_Range_Check");
- pragma Export (C, Rcheck_CE_Tag_Check,
- "__gnat_rcheck_CE_Tag_Check");
- pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
- "__gnat_rcheck_PE_Access_Before_Elaboration");
- pragma Export (C, Rcheck_PE_Accessibility_Check,
- "__gnat_rcheck_PE_Accessibility_Check");
- pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
- "__gnat_rcheck_PE_Address_Of_Intrinsic");
- pragma Export (C, Rcheck_PE_Aliased_Parameters,
- "__gnat_rcheck_PE_Aliased_Parameters");
- pragma Export (C, Rcheck_PE_All_Guards_Closed,
- "__gnat_rcheck_PE_All_Guards_Closed");
- pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
- "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
- pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
- "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
- pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
- "__gnat_rcheck_PE_Duplicated_Entry_Address");
- pragma Export (C, Rcheck_PE_Explicit_Raise,
- "__gnat_rcheck_PE_Explicit_Raise");
- pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
- "__gnat_rcheck_PE_Finalize_Raised_Exception");
- pragma Export (C, Rcheck_PE_Implicit_Return,
- "__gnat_rcheck_PE_Implicit_Return");
- pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
- "__gnat_rcheck_PE_Misaligned_Address_Value");
- pragma Export (C, Rcheck_PE_Missing_Return,
- "__gnat_rcheck_PE_Missing_Return");
- pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
- "__gnat_rcheck_PE_Non_Transportable_Actual");
- pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
- "__gnat_rcheck_PE_Overlaid_Controlled_Object");
- pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
- "__gnat_rcheck_PE_Potentially_Blocking_Operation");
- pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
- "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
- pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
- "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
- pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
- "__gnat_rcheck_PE_Unchecked_Union_Restriction");
- pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
- "__gnat_rcheck_SE_Empty_Storage_Pool");
- pragma Export (C, Rcheck_SE_Explicit_Raise,
- "__gnat_rcheck_SE_Explicit_Raise");
- pragma Export (C, Rcheck_SE_Infinite_Recursion,
- "__gnat_rcheck_SE_Infinite_Recursion");
- pragma Export (C, Rcheck_SE_Object_Too_Large,
- "__gnat_rcheck_SE_Object_Too_Large");
-
- pragma Export (C, Rcheck_CE_Access_Check_Ext,
- "__gnat_rcheck_CE_Access_Check_ext");
- pragma Export (C, Rcheck_CE_Index_Check_Ext,
- "__gnat_rcheck_CE_Index_Check_ext");
- pragma Export (C, Rcheck_CE_Invalid_Data_Ext,
- "__gnat_rcheck_CE_Invalid_Data_ext");
- pragma Export (C, Rcheck_CE_Range_Check_Ext,
- "__gnat_rcheck_CE_Range_Check_ext");
-
- -- None of these procedures ever returns (they raise an exception). By
- -- using pragma No_Return, we ensure that any junk code after the call,
- -- such as normal return epilogue stuff, can be eliminated).
-
- pragma No_Return (Rcheck_CE_Access_Check);
- pragma No_Return (Rcheck_CE_Null_Access_Parameter);
- pragma No_Return (Rcheck_CE_Discriminant_Check);
- pragma No_Return (Rcheck_CE_Divide_By_Zero);
- pragma No_Return (Rcheck_CE_Explicit_Raise);
- pragma No_Return (Rcheck_CE_Index_Check);
- pragma No_Return (Rcheck_CE_Invalid_Data);
- pragma No_Return (Rcheck_CE_Length_Check);
- pragma No_Return (Rcheck_CE_Null_Exception_Id);
- pragma No_Return (Rcheck_CE_Null_Not_Allowed);
- pragma No_Return (Rcheck_CE_Overflow_Check);
- pragma No_Return (Rcheck_CE_Partition_Check);
- pragma No_Return (Rcheck_CE_Range_Check);
- pragma No_Return (Rcheck_CE_Tag_Check);
- pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
- pragma No_Return (Rcheck_PE_Accessibility_Check);
- pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
- pragma No_Return (Rcheck_PE_Aliased_Parameters);
- pragma No_Return (Rcheck_PE_All_Guards_Closed);
- pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
- pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
- pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
- pragma No_Return (Rcheck_PE_Explicit_Raise);
- pragma No_Return (Rcheck_PE_Implicit_Return);
- pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
- pragma No_Return (Rcheck_PE_Missing_Return);
- pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
- pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
- pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
- pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
- pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
- pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
- pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
- pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
- pragma No_Return (Rcheck_SE_Explicit_Raise);
- pragma No_Return (Rcheck_SE_Infinite_Recursion);
- pragma No_Return (Rcheck_SE_Object_Too_Large);
-
- pragma No_Return (Rcheck_CE_Access_Check_Ext);
- pragma No_Return (Rcheck_CE_Index_Check_Ext);
- pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
- pragma No_Return (Rcheck_CE_Range_Check_Ext);
-
- ---------------------------------------------
- -- Reason Strings for Run-Time Check Calls --
- ---------------------------------------------
-
- -- These strings are null-terminated and are used by Rcheck_nn. The
- -- strings correspond to the definitions for Types.RT_Exception_Code.
-
- 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 := "null Exception_Id" & NUL;
- Rmsg_09 : constant String := "null-exclusion check failed" & NUL;
- Rmsg_10 : constant String := "overflow check failed" & NUL;
- Rmsg_11 : constant String := "partition check failed" & NUL;
- Rmsg_12 : constant String := "range check failed" & NUL;
- Rmsg_13 : constant String := "tag check failed" & NUL;
- Rmsg_14 : constant String := "access before elaboration" & NUL;
- Rmsg_15 : constant String := "accessibility check failed" & NUL;
- Rmsg_16 : constant String := "attempt to take address of" &
- " intrinsic subprogram" & NUL;
- Rmsg_17 : constant String := "aliased parameters" & NUL;
- Rmsg_18 : constant String := "all guards closed" & NUL;
- Rmsg_19 : constant String := "improper use of generic subtype" &
- " with predicate" & NUL;
- Rmsg_20 : constant String := "Current_Task referenced in entry" &
- " body" & NUL;
- Rmsg_21 : constant String := "duplicated entry address" & NUL;
- Rmsg_22 : constant String := "explicit raise" & NUL;
- Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
- Rmsg_24 : constant String := "implicit return with No_Return" & NUL;
- Rmsg_25 : constant String := "misaligned address value" & NUL;
- Rmsg_26 : constant String := "missing return" & NUL;
- Rmsg_27 : constant String := "overlaid controlled object" & NUL;
- Rmsg_28 : constant String := "potentially blocking operation" & NUL;
- Rmsg_29 : constant String := "stubbed subprogram called" & NUL;
- Rmsg_30 : constant String := "unchecked union restriction" & NUL;
- Rmsg_31 : constant String := "actual/returned class-wide" &
- " value not transportable" & NUL;
- Rmsg_32 : constant String := "empty storage pool" & NUL;
- Rmsg_33 : constant String := "explicit raise" & NUL;
- Rmsg_34 : constant String := "infinite recursion" & NUL;
- Rmsg_35 : constant String := "object too large" & NUL;
- Rmsg_36 : constant String := "stream operation not allowed" & NUL;
-
- -----------------------
- -- Polling Interface --
- -----------------------
-
- type Unsigned is mod 2 ** 32;
-
- Counter : Unsigned := 0;
- pragma Warnings (Off, Counter);
- -- This counter is provided for convenience. It can be used in Poll to
- -- perform periodic but not systematic operations.
-
- procedure Poll is separate;
- -- The actual polling routine is separate, so that it can easily be
- -- replaced with a target dependent version.
-
- --------------------------
- -- Code_Address_For_AAA --
- --------------------------
-
- -- This function gives us the start of the PC range for addresses within
- -- the exception unit itself. We hope that gigi/gcc keep all the procedures
- -- in their original order.
-
- function Code_Address_For_AAA return System.Address is
- begin
- -- We are using a label instead of Code_Address_For_AAA'Address because
- -- on some platforms the latter does not yield the address we want, but
- -- the address of a stub or of a descriptor instead. This is the case at
- -- least on PA-HPUX.
-
- <<Start_Of_AAA>>
- return Start_Of_AAA'Address;
- end Code_Address_For_AAA;
-
- ----------------
- -- Call_Chain --
- ----------------
-
- procedure Call_Chain (Excep : EOA) is separate;
- -- The actual Call_Chain routine is separate, so that it can easily
- -- be dummied out when no exception traceback information is needed.
-
- -------------------
- -- EId_To_String --
- -------------------
-
- function EId_To_String (X : Exception_Id) return String
- renames Stream_Attributes.EId_To_String;
-
- ------------------
- -- EO_To_String --
- ------------------
-
- -- We use the null string to represent the null occurrence, otherwise we
- -- output the Untailored_Exception_Information string for the occurrence.
-
- function EO_To_String (X : Exception_Occurrence) return String
- renames Stream_Attributes.EO_To_String;
-
- ------------------------
- -- Exception_Identity --
- ------------------------
-
- function Exception_Identity
- (X : Exception_Occurrence) return Exception_Id
- is
- begin
- -- Note that the following test used to be here for the original
- -- Ada 95 semantics, but these were modified by AI-241 to require
- -- returning Null_Id instead of raising Constraint_Error.
-
- -- if X.Id = Null_Id then
- -- raise Constraint_Error;
- -- end if;
-
- return X.Id;
- end Exception_Identity;
-
- ---------------------------
- -- Exception_Information --
- ---------------------------
-
- function Exception_Information (X : Exception_Occurrence) return String is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- else
- return Exception_Data.Exception_Information (X);
- end if;
- end Exception_Information;
-
- -----------------------
- -- Exception_Message --
- -----------------------
-
- function Exception_Message (X : Exception_Occurrence) return String is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- else
- return X.Msg (1 .. X.Msg_Length);
- end if;
- end Exception_Message;
-
- --------------------
- -- Exception_Name --
- --------------------
-
- function Exception_Name (Id : Exception_Id) return String is
- begin
- if Id = null then
- raise Constraint_Error;
- else
- return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
- end if;
- end Exception_Name;
-
- function Exception_Name (X : Exception_Occurrence) return String is
- begin
- return Exception_Name (X.Id);
- end Exception_Name;
-
- ---------------------------
- -- Exception_Name_Simple --
- ---------------------------
-
- 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 result making sure lower bound is 1
-
- declare
- subtype Rname is String (1 .. Name'Length - P + 1);
- begin
- return Rname (Name (P .. Name'Length));
- end;
- end Exception_Name_Simple;
-
- --------------------
- -- Exception_Data --
- --------------------
-
- package body Exception_Data is separate;
- -- This package can be easily dummied out if we do not want the basic
- -- support for exception messages (such as in Ada 83).
-
- ---------------------------
- -- Exception_Propagation --
- ---------------------------
-
- package body Exception_Propagation is separate;
- -- Depending on the actual exception mechanism used (front-end or
- -- back-end based), the implementation will differ, which is why this
- -- package is separated.
-
- ----------------------
- -- Exception_Traces --
- ----------------------
-
- package body Exception_Traces is separate;
- -- Depending on the underlying support for IO the implementation will
- -- differ. Moreover we would like to dummy out this package in case we
- -- do not want any exception tracing support. This is why this package
- -- is separated.
-
- --------------------------------------
- -- Get_Exception_Machine_Occurrence --
- --------------------------------------
-
- function Get_Exception_Machine_Occurrence
- (X : Exception_Occurrence) return System.Address
- is
- begin
- return X.Machine_Occurrence;
- end Get_Exception_Machine_Occurrence;
-
- -----------
- -- Image --
- -----------
-
- function Image (Index : Integer) return String is
- Result : constant String := Integer'Image (Index);
- begin
- if Result (1) = ' ' then
- return Result (2 .. Result'Last);
- else
- return Result;
- end if;
- end Image;
-
- -----------------------
- -- Stream Attributes --
- -----------------------
-
- package body Stream_Attributes is separate;
- -- This package can be easily dummied out if we do not want the
- -- support for streaming Exception_Ids and Exception_Occurrences.
-
- ----------------------------
- -- Raise_Constraint_Error --
- ----------------------------
-
- procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
- begin
- Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
- end Raise_Constraint_Error;
-
- --------------------------------
- -- Raise_Constraint_Error_Msg --
- --------------------------------
-
- procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Column : Integer;
- Msg : System.Address)
- is
- begin
- Raise_With_Location_And_Msg
- (Constraint_Error_Def'Access, File, Line, Column, Msg);
- end Raise_Constraint_Error_Msg;
-
- -------------------------
- -- Complete_Occurrence --
- -------------------------
-
- procedure Complete_Occurrence (X : EOA) is
- begin
- -- Compute the backtrace for this occurrence if the corresponding
- -- binder option has been set. Call_Chain takes care of the reraise
- -- case.
-
- -- ??? Using Call_Chain here means we are going to walk up the stack
- -- once only for backtracing purposes before doing it again for the
- -- propagation per se.
-
- -- The first inspection is much lighter, though, as it only requires
- -- partial unwinding of each frame. Additionally, although we could use
- -- the personality routine to record the addresses while propagating,
- -- this method has two drawbacks:
-
- -- 1) the trace is incomplete if the exception is handled since we
- -- don't walk past the frame with the handler,
-
- -- and
-
- -- 2) we would miss the frames for which our personality routine is not
- -- called, e.g. if C or C++ calls are on the way.
-
- Call_Chain (X);
-
- -- Notify the debugger
- Debug_Raise_Exception
- (E => SSL.Exception_Data_Ptr (X.Id),
- Message => X.Msg (1 .. X.Msg_Length));
- end Complete_Occurrence;
-
- ---------------------------------------
- -- Complete_And_Propagate_Occurrence --
- ---------------------------------------
-
- procedure Complete_And_Propagate_Occurrence (X : EOA) is
- begin
- Complete_Occurrence (X);
- Exception_Propagation.Propagate_Exception (X);
- end Complete_And_Propagate_Occurrence;
-
- ---------------------
- -- Raise_Exception --
- ---------------------
-
- procedure Raise_Exception
- (E : Exception_Id;
- Message : String := "")
- is
- EF : Exception_Id := E;
- begin
- -- Raise CE if E = Null_ID (AI-446)
-
- if E = null then
- EF := Constraint_Error'Identity;
- end if;
-
- -- Go ahead and raise appropriate exception
-
- Raise_Exception_Always (EF, Message);
- end Raise_Exception;
-
- ----------------------------
- -- Raise_Exception_Always --
- ----------------------------
-
- procedure Raise_Exception_Always
- (E : Exception_Id;
- Message : String := "")
- is
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
-
- begin
- Exception_Data.Set_Exception_Msg (X, E, Message);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Complete_And_Propagate_Occurrence (X);
- end Raise_Exception_Always;
-
- ------------------------------
- -- Raise_Exception_No_Defer --
- ------------------------------
-
- procedure Raise_Exception_No_Defer
- (E : Exception_Id;
- Message : String := "")
- is
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
-
- begin
- Exception_Data.Set_Exception_Msg (X, E, Message);
-
- -- Do not call Abort_Defer.all, as specified by the spec
-
- Complete_And_Propagate_Occurrence (X);
- end Raise_Exception_No_Defer;
-
- -------------------------------------
- -- Raise_From_Controlled_Operation --
- -------------------------------------
-
- procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence)
- is
- Prefix : constant String := "adjust/finalize raised ";
- Orig_Msg : constant String := Exception_Message (X);
- Orig_Prefix_Length : constant Natural :=
- Integer'Min (Prefix'Length, Orig_Msg'Length);
-
- Orig_Prefix : String renames
- Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
-
- begin
- -- Message already has the proper prefix, just re-raise
-
- if Orig_Prefix = Prefix then
- Raise_Exception_No_Defer
- (E => Program_Error'Identity,
- Message => Orig_Msg);
-
- else
- declare
- New_Msg : constant String := Prefix & Exception_Name (X);
-
- begin
- -- No message present, just provide our own
-
- if Orig_Msg = "" then
- Raise_Exception_No_Defer
- (E => Program_Error'Identity,
- Message => New_Msg);
-
- -- Message present, add informational prefix
-
- else
- Raise_Exception_No_Defer
- (E => Program_Error'Identity,
- Message => New_Msg & ": " & Orig_Msg);
- end if;
- end;
- end if;
- end Raise_From_Controlled_Operation;
-
- -------------------------------------------
- -- Create_Occurrence_From_Signal_Handler --
- -------------------------------------------
-
- function Create_Occurrence_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address) return EOA
- is
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
-
- begin
- Exception_Data.Set_Exception_C_Msg (X, E, M);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Complete_Occurrence (X);
- return X;
- end Create_Occurrence_From_Signal_Handler;
-
- ---------------------------------------------------
- -- Create_Machine_Occurrence_From_Signal_Handler --
- ---------------------------------------------------
-
- function Create_Machine_Occurrence_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address) return System.Address
- is
- begin
- return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence;
- end Create_Machine_Occurrence_From_Signal_Handler;
-
- -------------------------------
- -- Raise_From_Signal_Handler --
- -------------------------------
-
- procedure Raise_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address)
- is
- begin
- Exception_Propagation.Propagate_Exception
- (Create_Occurrence_From_Signal_Handler (E, M));
- end Raise_From_Signal_Handler;
-
- -------------------------
- -- Raise_Program_Error --
- -------------------------
-
- procedure Raise_Program_Error
- (File : System.Address;
- Line : Integer)
- is
- begin
- Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
- end Raise_Program_Error;
-
- -----------------------------
- -- Raise_Program_Error_Msg --
- -----------------------------
-
- procedure Raise_Program_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address)
- is
- begin
- Raise_With_Location_And_Msg
- (Program_Error_Def'Access, File, Line, M => Msg);
- end Raise_Program_Error_Msg;
-
- -------------------------
- -- Raise_Storage_Error --
- -------------------------
-
- procedure Raise_Storage_Error
- (File : System.Address;
- Line : Integer)
- is
- begin
- Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
- end Raise_Storage_Error;
-
- -----------------------------
- -- Raise_Storage_Error_Msg --
- -----------------------------
-
- procedure Raise_Storage_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address)
- is
- begin
- Raise_With_Location_And_Msg
- (Storage_Error_Def'Access, File, Line, M => Msg);
- end Raise_Storage_Error_Msg;
-
- ---------------------------------
- -- Raise_With_Location_And_Msg --
- ---------------------------------
-
- procedure Raise_With_Location_And_Msg
- (E : Exception_Id;
- F : System.Address;
- L : Integer;
- C : Integer := 0;
- M : System.Address := System.Null_Address)
- is
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
- begin
- Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Complete_And_Propagate_Occurrence (X);
- end Raise_With_Location_And_Msg;
-
- --------------------
- -- Raise_With_Msg --
- --------------------
-
- procedure Raise_With_Msg (E : Exception_Id) is
- Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
- Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
- begin
- Excep.Exception_Raised := False;
- Excep.Id := E;
- Excep.Num_Tracebacks := 0;
- Excep.Pid := Local_Partition_ID;
-
- -- Copy the message from the current exception
- -- Change the interface to be called with an occurrence ???
-
- Excep.Msg_Length := Ex.Msg_Length;
- Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
-
- -- The following is a common pattern, should be abstracted
- -- into a procedure call ???
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Complete_And_Propagate_Occurrence (Excep);
- end Raise_With_Msg;
-
- -----------------------------------------
- -- Calls to Run-Time Check Subprograms --
- -----------------------------------------
-
- procedure Rcheck_CE_Access_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
- end Rcheck_CE_Access_Check;
-
- procedure Rcheck_CE_Null_Access_Parameter
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
- end Rcheck_CE_Null_Access_Parameter;
-
- procedure Rcheck_CE_Discriminant_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
- end Rcheck_CE_Discriminant_Check;
-
- procedure Rcheck_CE_Divide_By_Zero
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
- end Rcheck_CE_Divide_By_Zero;
-
- procedure Rcheck_CE_Explicit_Raise
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
- end Rcheck_CE_Explicit_Raise;
-
- procedure Rcheck_CE_Index_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
- end Rcheck_CE_Index_Check;
-
- procedure Rcheck_CE_Invalid_Data
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
- end Rcheck_CE_Invalid_Data;
-
- procedure Rcheck_CE_Length_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
- end Rcheck_CE_Length_Check;
-
- procedure Rcheck_CE_Null_Exception_Id
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
- end Rcheck_CE_Null_Exception_Id;
-
- procedure Rcheck_CE_Null_Not_Allowed
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
- end Rcheck_CE_Null_Not_Allowed;
-
- procedure Rcheck_CE_Overflow_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
- end Rcheck_CE_Overflow_Check;
-
- procedure Rcheck_CE_Partition_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
- end Rcheck_CE_Partition_Check;
-
- procedure Rcheck_CE_Range_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
- end Rcheck_CE_Range_Check;
-
- procedure Rcheck_CE_Tag_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
- end Rcheck_CE_Tag_Check;
-
- procedure Rcheck_PE_Access_Before_Elaboration
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
- end Rcheck_PE_Access_Before_Elaboration;
-
- procedure Rcheck_PE_Accessibility_Check
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
- end Rcheck_PE_Accessibility_Check;
-
- procedure Rcheck_PE_Address_Of_Intrinsic
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
- end Rcheck_PE_Address_Of_Intrinsic;
-
- procedure Rcheck_PE_Aliased_Parameters
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
- end Rcheck_PE_Aliased_Parameters;
-
- procedure Rcheck_PE_All_Guards_Closed
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
- end Rcheck_PE_All_Guards_Closed;
-
- procedure Rcheck_PE_Bad_Predicated_Generic_Type
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
- end Rcheck_PE_Bad_Predicated_Generic_Type;
-
- procedure Rcheck_PE_Current_Task_In_Entry_Body
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
- end Rcheck_PE_Current_Task_In_Entry_Body;
-
- procedure Rcheck_PE_Duplicated_Entry_Address
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
- end Rcheck_PE_Duplicated_Entry_Address;
-
- procedure Rcheck_PE_Explicit_Raise
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
- end Rcheck_PE_Explicit_Raise;
-
- procedure Rcheck_PE_Implicit_Return
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
- end Rcheck_PE_Implicit_Return;
-
- procedure Rcheck_PE_Misaligned_Address_Value
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
- end Rcheck_PE_Misaligned_Address_Value;
-
- procedure Rcheck_PE_Missing_Return
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
- end Rcheck_PE_Missing_Return;
-
- procedure Rcheck_PE_Non_Transportable_Actual
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
- end Rcheck_PE_Non_Transportable_Actual;
-
- procedure Rcheck_PE_Overlaid_Controlled_Object
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
- end Rcheck_PE_Overlaid_Controlled_Object;
-
- procedure Rcheck_PE_Potentially_Blocking_Operation
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
- end Rcheck_PE_Potentially_Blocking_Operation;
-
- procedure Rcheck_PE_Stream_Operation_Not_Allowed
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
- end Rcheck_PE_Stream_Operation_Not_Allowed;
-
- procedure Rcheck_PE_Stubbed_Subprogram_Called
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
- end Rcheck_PE_Stubbed_Subprogram_Called;
-
- procedure Rcheck_PE_Unchecked_Union_Restriction
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
- end Rcheck_PE_Unchecked_Union_Restriction;
-
- procedure Rcheck_SE_Empty_Storage_Pool
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
- end Rcheck_SE_Empty_Storage_Pool;
-
- procedure Rcheck_SE_Explicit_Raise
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
- end Rcheck_SE_Explicit_Raise;
-
- procedure Rcheck_SE_Infinite_Recursion
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
- end Rcheck_SE_Infinite_Recursion;
-
- procedure Rcheck_SE_Object_Too_Large
- (File : System.Address; Line : Integer)
- is
- begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
- end Rcheck_SE_Object_Too_Large;
-
- procedure Rcheck_CE_Access_Check_Ext
- (File : System.Address; Line, Column : Integer)
- is
- begin
- Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
- end Rcheck_CE_Access_Check_Ext;
-
- procedure Rcheck_CE_Index_Check_Ext
- (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;
- begin
- Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
- end Rcheck_CE_Index_Check_Ext;
-
- procedure Rcheck_CE_Invalid_Data_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;
- begin
- Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
- end Rcheck_CE_Invalid_Data_Ext;
-
- procedure Rcheck_CE_Range_Check_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;
- begin
- Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
- end Rcheck_CE_Range_Check_Ext;
-
- procedure Rcheck_PE_Finalize_Raised_Exception
- (File : System.Address; Line : Integer)
- is
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
-
- begin
- -- This is "finalize/adjust raised exception". This subprogram is always
- -- 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
-
- Exception_Data.Set_Exception_C_Msg
- (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
- Complete_And_Propagate_Occurrence (X);
- end Rcheck_PE_Finalize_Raised_Exception;
-
- -------------
- -- Reraise --
- -------------
-
- procedure Reraise is
- Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
- Saved_MO : constant System.Address := Excep.Machine_Occurrence;
-
- begin
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
- Excep.Machine_Occurrence := Saved_MO;
- Complete_And_Propagate_Occurrence (Excep);
- end Reraise;
-
- --------------------------------------
- -- Reraise_Library_Exception_If_Any --
- --------------------------------------
-
- procedure Reraise_Library_Exception_If_Any is
- LE : Exception_Occurrence;
-
- begin
- if Library_Exception_Set then
- LE := Library_Exception;
-
- if LE.Id = Null_Id then
- Raise_Exception_No_Defer
- (E => Program_Error'Identity,
- Message => "finalize/adjust raised exception");
- else
- Raise_From_Controlled_Operation (LE);
- end if;
- end if;
- end Reraise_Library_Exception_If_Any;
-
- ------------------------
- -- Reraise_Occurrence --
- ------------------------
-
- procedure Reraise_Occurrence (X : Exception_Occurrence) is
- begin
- if X.Id = null then
- return;
- else
- Reraise_Occurrence_Always (X);
- end if;
- end Reraise_Occurrence;
-
- -------------------------------
- -- Reraise_Occurrence_Always --
- -------------------------------
-
- procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
- begin
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Reraise_Occurrence_No_Defer (X);
- end Reraise_Occurrence_Always;
-
- ---------------------------------
- -- Reraise_Occurrence_No_Defer --
- ---------------------------------
-
- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
- Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
- Saved_MO : constant System.Address := Excep.Machine_Occurrence;
- begin
- Save_Occurrence (Excep.all, X);
- Excep.Machine_Occurrence := Saved_MO;
- Complete_And_Propagate_Occurrence (Excep);
- end Reraise_Occurrence_No_Defer;
-
- ---------------------
- -- Save_Occurrence --
- ---------------------
-
- procedure Save_Occurrence
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence)
- is
- begin
- -- As the machine occurrence might be a data that must be finalized
- -- (outside any Ada mechanism), do not copy it
-
- Target.Id := Source.Id;
- Target.Machine_Occurrence := System.Null_Address;
- Target.Msg_Length := Source.Msg_Length;
- Target.Num_Tracebacks := Source.Num_Tracebacks;
- Target.Pid := Source.Pid;
-
- 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 : constant EOA := new Exception_Occurrence;
- begin
- Save_Occurrence (Target.all, Source);
- return Target;
- end Save_Occurrence;
-
- -------------------
- -- String_To_EId --
- -------------------
-
- function String_To_EId (S : String) return Exception_Id
- renames Stream_Attributes.String_To_EId;
-
- ------------------
- -- String_To_EO --
- ------------------
-
- function String_To_EO (S : String) return Exception_Occurrence
- renames Stream_Attributes.String_To_EO;
-
- ---------------
- -- To_Stderr --
- ---------------
-
- procedure To_Stderr (C : Character) is
- procedure Put_Char_Stderr (C : Character);
- pragma Import (C, Put_Char_Stderr, "put_char_stderr");
- begin
- Put_Char_Stderr (C);
- end To_Stderr;
-
- procedure To_Stderr (S : String) is
- begin
- for J in S'Range loop
- if S (J) /= ASCII.CR then
- To_Stderr (S (J));
- end if;
- end loop;
- end To_Stderr;
-
- -------------------------
- -- Transfer_Occurrence --
- -------------------------
-
- procedure Transfer_Occurrence
- (Target : Exception_Occurrence_Access;
- Source : Exception_Occurrence)
- is
- begin
- Save_Occurrence (Target.all, Source);
- end Transfer_Occurrence;
-
- ------------------------
- -- Triggered_By_Abort --
- ------------------------
-
- function Triggered_By_Abort return Boolean is
- Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
- begin
- return Ex /= null
- and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
- end Triggered_By_Abort;
-
- -------------------------
- -- Wide_Exception_Name --
- -------------------------
-
- WC_Encoding : Character;
- pragma Import (C, WC_Encoding, "__gl_wc_encoding");
- -- Encoding method for source, as exported by binder
-
- function Wide_Exception_Name
- (Id : Exception_Id) return Wide_String
- is
- S : constant String := Exception_Name (Id);
- W : Wide_String (1 .. S'Length);
- L : Natural;
- begin
- String_To_Wide_String
- (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
- return W (1 .. L);
- end Wide_Exception_Name;
-
- function Wide_Exception_Name
- (X : Exception_Occurrence) return Wide_String
- is
- S : constant String := Exception_Name (X);
- W : Wide_String (1 .. S'Length);
- L : Natural;
- begin
- String_To_Wide_String
- (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
- return W (1 .. L);
- end Wide_Exception_Name;
-
- ----------------------------
- -- Wide_Wide_Exception_Name --
- -----------------------------
-
- function Wide_Wide_Exception_Name
- (Id : Exception_Id) return Wide_Wide_String
- is
- S : constant String := Exception_Name (Id);
- W : Wide_Wide_String (1 .. S'Length);
- L : Natural;
- begin
- String_To_Wide_Wide_String
- (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
- return W (1 .. L);
- end Wide_Wide_Exception_Name;
-
- function Wide_Wide_Exception_Name
- (X : Exception_Occurrence) return Wide_Wide_String
- is
- S : constant String := Exception_Name (X);
- W : Wide_Wide_String (1 .. S'Length);
- L : Natural;
- begin
- String_To_Wide_Wide_String
- (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
- return W (1 .. L);
- end Wide_Wide_Exception_Name;
-
- --------------------------
- -- Code_Address_For_ZZZ --
- --------------------------
-
- -- This function gives us the end of the PC range for addresses
- -- within the exception unit itself. We hope that gigi/gcc keeps all the
- -- procedures in their original order.
-
- function Code_Address_For_ZZZ return System.Address is
- begin
- <<Start_Of_ZZZ>>
- return Start_Of_ZZZ'Address;
- end Code_Address_For_ZZZ;
-
-end Ada.Exceptions;
===================================================================
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, 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- *
@@ -47,20 +47,6 @@
extern "C" {
#endif
-/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj
- runtime library interfaces directly to the intrinsic. We can't yet do
- this for the compiler itself, because this capability relies on changes
- made in April 2008 and we need to preserve the possibility to bootstrap
- with an older base version. */
-
-#if defined (IN_GCC) && !defined (IN_RTS)
-void
-_gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED)
-{
- __builtin_longjmp (ptr, 1);
-}
-#endif
-
/* When an exception is raised for which no handler exists, the procedure
Ada.Exceptions.Unhandled_Exception is called, which performs the call to
adafinal to complete finalization, and then prints out the error messages
@@ -84,6 +70,71 @@
__gnat_os_exit (1);
}
+#ifndef IN_RTS
+int
+__gnat_backtrace (void **array ATTRIBUTE_UNUSED,
+ int size ATTRIBUTE_UNUSED,
+ void *exclude_min ATTRIBUTE_UNUSED,
+ void *exclude_max ATTRIBUTE_UNUSED,
+ int skip_frames ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+void
+__gnat_eh_personality (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_04 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_10 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_19 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_20 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_21 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_30 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_31 (void)
+{
+ abort ();
+}
+
+void
+__gnat_rcheck_32 (void)
+{
+ abort ();
+}
+#endif
#ifdef __cplusplus
}
#endif
===================================================================
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, 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- *
@@ -32,10 +32,6 @@
/* Code related to the integration of the GCC mechanism for exception
handling. */
-#ifndef IN_RTS
-#error "RTS unit only"
-#endif
-
#ifndef CERT
#include "tconfig.h"
#include "tsystem.h"
@@ -45,9 +41,14 @@
#endif
#include <stdarg.h>
+
+#ifdef __cplusplus
+# include <cstdlib>
+#else
typedef char bool;
# define true 1
# define false 0
+#endif
#include "raise.h"
@@ -72,6 +73,10 @@
#include "unwind.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
typedef struct _Unwind_Context _Unwind_Context;
typedef struct _Unwind_Exception _Unwind_Exception;
@@ -79,7 +84,7 @@
__gnat_Unwind_RaiseException (_Unwind_Exception *);
_Unwind_Reason_Code
-__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
+__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *);
extern struct Exception_Occurrence *__gnat_setup_current_excep
(_Unwind_Exception *);
@@ -209,7 +214,7 @@
}
static void ATTRIBUTE_PRINTF_2
-db (int db_code, char * msg_format, ...)
+db (int db_code, const char * msg_format, ...)
{
if (db_accepted_codes () & db_code)
{
@@ -816,8 +821,8 @@
db (DB_CSITE,
"c_site @ %p (+%p), len = %p, lpad @ %p (+%p)\n",
- (void *)region->base + cs_start, (void *)cs_start, (void *)cs_len,
- (void *)region->lp_base + cs_lp, (void *)cs_lp);
+ (char *)region->base + cs_start, (void *)cs_start, (void *)cs_len,
+ (char *)region->lp_base + cs_lp, (void *)cs_lp);
/* The table is sorted, so if we've passed the IP, stop. */
if (ip < region->base + cs_start)
@@ -1399,7 +1404,7 @@
_Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED,
- void *handler ATTRIBUTE_UNUSED,
+ _Unwind_Stop_Fn handler ATTRIBUTE_UNUSED,
void *argument ATTRIBUTE_UNUSED)
{
#ifdef __USING_SJLJ_EXCEPTIONS__
@@ -1609,3 +1614,7 @@
const int __gnat_unwind_exception_size = sizeof (_Unwind_Exception);
#endif
+
+#ifdef __cplusplus
+}
+#endif
===================================================================
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Version) --
-- --
+-- Copyright (C) 1992-2017, 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 --
@@ -163,8 +163,8 @@
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := True;
- ZCX_By_Default : constant Boolean := False;
+ Frontend_Exceptions : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
-- Obsolete entries, to be removed eventually (bootstrap issues)
@@ -173,6 +173,6 @@
Long_Shifts_Inlined : constant Boolean := True;
Functions_Return_By_DSP : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True;
- GCC_ZCX_Support : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := True;
end System;
===================================================================
@@ -2427,32 +2427,20 @@
ifeq ($(EH_MECHANISM),-gcc)
LIBGNAT_TARGET_PAIRS += \
- a-exexpr.adb<a-exexpr-gcc.adb \
- s-excmac.ads<s-excmac-gcc.ads
+ s-excmac.ads<s-excmac-gcc.ads \
+ s-excmac.adb<s-excmac-gcc.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
ifeq ($(EH_MECHANISM),-arm)
LIBGNAT_TARGET_PAIRS += \
- a-exexpr.adb<a-exexpr-gcc.adb \
- s-excmac.ads<s-excmac-arm.ads
+ s-excmac.ads<s-excmac-arm.ads \
+ s-excmac.adb<s-excmac-arm.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
-# Use the Ada 2005 version of Ada.Exceptions by default, unless specified
-# explicitly already. The base files (a-except.ad?) are used only for building
-# the compiler and other basic tools.
-# These base versions lack Ada 2005 additions which would cause bootstrap
-# problems if included in the compiler and other basic tools.
-
-ifeq ($(filter a-except%,$(LIBGNAT_TARGET_PAIRS)),)
- LIBGNAT_TARGET_PAIRS += \
- a-except.ads<a-except-2005.ads \
- a-except.adb<a-except-2005.adb
-endif
-
# Configuration of host tools
# Under linux, host tools need to be linked with -ldl
===================================================================
@@ -99,6 +99,8 @@
ada-warn = $(ADA_CFLAGS) $(filter-out -pedantic, $(STRICT_WARN))
# Unresolved warnings in specific files.
ada/adaint.o-warn = -Wno-error
+# For unwind-pe.h
+CFLAGS-ada/raise-gcc.o += -I$(srcdir)/../libgcc -Iinclude
ada/%.o: ada/gcc-interface/%.c
$(COMPILE) $<
@@ -223,6 +225,7 @@
# Object files for gnat1 from C sources.
GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \
ada/cstreams.o ada/env.o ada/init.o ada/initialize.o ada/raise.o \
+ ada/raise-gcc.o \
ada/seh_init.o ada/targext.o ada/cuintp.o ada/decl.o ada/rtfinal.o \
ada/rtinit.o ada/misc.o ada/utils.o ada/utils2.o ada/trans.o ada/targtyps.o
@@ -232,6 +235,7 @@
ada/a-chlat1.o \
ada/a-elchha.o \
ada/a-except.o \
+ ada/a-exctra.o \
ada/a-ioexce.o \
ada/ada.o \
ada/spark_xrefs.o \
@@ -334,6 +338,7 @@
ada/rident.o \
ada/rtsfind.o \
ada/s-addope.o \
+ ada/s-addima.o \
ada/s-assert.o \
ada/s-bitops.o \
ada/s-carun8.o \
@@ -351,9 +356,11 @@
ada/s-excdeb.o \
ada/s-except.o \
ada/s-exctab.o \
+ ada/s-excmac.o \
ada/s-htable.o \
ada/s-imenne.o \
ada/s-imgenu.o \
+ ada/s-imgint.o \
ada/s-mastop.o \
ada/s-memory.o \
ada/s-os_lib.o \
@@ -372,7 +379,9 @@
ada/s-strhas.o \
ada/s-string.o \
ada/s-strops.o \
+ ada/s-traceb.o \
ada/s-traent.o \
+ ada/s-trasym.o \
ada/s-unstyp.o \
ada/s-utf_32.o \
ada/s-valint.o \
@@ -381,6 +390,7 @@
ada/s-wchcnv.o \
ada/s-wchcon.o \
ada/s-wchjis.o \
+ ada/s-wchstw.o \
ada/scans.o \
ada/scil_ll.o \
ada/scn.o \
@@ -514,6 +524,7 @@
ada/osint.o \
ada/output.o \
ada/raise.o \
+ ada/raise-gcc.o \
ada/restrict.o \
ada/rident.o \
ada/rtfinal.o \
@@ -534,10 +545,12 @@
ada/s-crtl.o \
ada/s-excdeb.o \
ada/s-except.o \
+ ada/s-excmac.o \
ada/s-exctab.o \
ada/s-htable.o \
ada/s-imenne.o \
ada/s-imgenu.o \
+ ada/s-imgint.o \
ada/s-mastop.o \
ada/s-memory.o \
ada/s-os_lib.o \
@@ -555,11 +568,13 @@
ada/s-string.o \
ada/s-strops.o \
ada/s-traent.o \
+ ada/s-traceb.o \
ada/s-unstyp.o \
ada/s-utf_32.o \
ada/s-wchcnv.o \
ada/s-wchcon.o \
ada/s-wchjis.o \
+ ada/s-wchstw.o \
ada/scans.o \
ada/scil_ll.o \
ada/scng.o \
@@ -594,6 +609,21 @@
# List of target dependent sources, overridden below as necessary
TARGET_ADA_SRCS =
+# Select the right s-excmac according to exception layout (Itanium or arm)
+host_cpu=$(word 1, $(subst -, ,$(host)))
+EH_MECHANISM=-gcc
+ifeq ($(strip $(filter-out arm%,$(host_cpu))),)
+EH_MECHANISM=-arm
+endif
+
+ada/s-excmac.o: ada/s-excmac.ads ada/s-excmac.adb
+
+ada/s-excmac.ads: $(srcdir)/ada/s-excmac$(EH_MECHANISM).ads
+ $(CP) $< $@
+
+ada/s-excmac.adb: $(srcdir)/ada/s-excmac$(EH_MECHANISM).adb
+ $(CP) $< $@
+
# Needs to be built with CC=gcc
# Since the RTL should be built with the latest compiler, remove the
# stamp target in the parent directory whenever gnat1 is rebuilt
@@ -976,12 +1006,12 @@
# Special flags - see gcc-interface/Makefile.in for the template.
-ada/a-except.o : ada/a-except.adb ada/a-except.ads
+ada/a-except.o : ada/a-except.adb ada/a-except.ads ada/s-excmac.ads ada/s-excmac.adb
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
@$(ADA_DEPS)
-ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads
+ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
@$(ADA_DEPS)