+2012-07-16 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting.
+
+2012-07-16 Thomas Quinot <quinot@adacore.com>
+
+ * s-oscons-tmplt.c: Add definitions of E2BIG and EILSEQ.
+
+2012-07-16 Tristan Gingold <gingold@adacore.com>
+
+ * a-exexpr.adb (Propagate_Continue): New function replacing
+ Raise_Current_Excep.
+ (Allocate_Occurrence): New function.
+ (Propagate_Exception): Add Excep parameter, remove call to Call_Chain.
+ * a-exexpr-gcc.adb (GNAT_GCC_Exception): Occurrence component
+ is now aliased.
+ (To_GCC_Exception): Convert from Address.
+ (Allocate_Occurrence): Allocate an Unwind exception occurrence.
+ (Setup_Current_Excep): Fill the machine occurrence in case of
+ foreign exception.
+ (Propagate_Exception): Add Excep parameter, remove call to Call_Chain.
+ * a-except.adb (Set_Exception_C_Msg, Set_Exception_Msg): add
+ Excep parameter.
+ (Raise_Exception, Raise_Exception_Always,
+ Raise_Exception_No_Defer): Adjust calls to the above procedures.
+ (Raise_From_Signal_Handler, Raise_With_Location_And_Msg)
+ (Rcheck_PE_Finalize_Raised_Exception): Likewise.
+ * a-except-2005.adb (Set_Exception_C_Msg, Set_Exception_Msg):
+ add Excep parameter.
+ (Propagate_Exception): Likewise.
+ (Allocate_Occurrence): New function.
+ (Raise_Current_Excep): Removed.
+ (Complete_Occurrence): New function to save the call chain.
+ (Complete_And_Propagate_Occurrence): New procedure.
+ (Create_Occurrence_From_Signal_Handler): New function to build an
+ occurrence without propagating it.
+ (Create_Machine_Occurrence_From_Signal_Handler): Likewise, but
+ return the machine occurrence.
+ (Raise_From_Signal_Handler): Use Create_Occurrence_From_Signal_Handler.
+ (Raise_Exception, Raise_Exception_Always, Raise_Exception_No_Defer):
+ Adjust calls to the above procedures. Allocate the occurrence at
+ the beginning.
+ (Raise_With_Location_And_Msg, Raise_With_Msg)
+ (Rcheck_PE_Finalize_Raised_Exceptionm Reraise): Likewise.
+ (Reraise_Occurrence): Use Reraise_Occurrence_Always.
+ (Reraise_Occurrence_Always): Use Reraise_Occurrence_No_Defer.
+ (Reraise_Occurrence_No_Defer): Preserve machine occurrence.
+ (Save_Occurrence): Do not save machine occurrence.
+ * a-except-2005.ads (Exception_Occurrence): Add Machine_Occurrence
+ component.
+ (Null_Occurrence): Consider it.
+ * a-exexda.adb (Set_Exception_C_Msg, Set_Exception_Msg): add
+ Excep parameter.
+
+2012-07-16 Tristan Gingold <gingold@adacore.com>
+
+ * seh_init.c (__gnat_map_SEH): New function extracted from
+ __gnat_SEH_error_handler.
+ * raise-gcc.c: __gnat_personality_seh0: Directly transforms
+ Windows system exception into GCC one when possible, in order
+ to save stack room (particularly useful when Storage_Error will
+ be propagated).
+
2012-07-16 Robert Dewar <dewar@adacore.com>
* a-direct.adb, g-dirope.adb: Minor reformatting.
---------------------------------
procedure Set_Exception_C_Msg
- (Id : Exception_Id;
+ (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 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
- (Id : Exception_Id;
+ (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 subprogram --
package Exception_Propagation is
- use Exception_Traces;
- -- Imports Notify_Unhandled_Exception and
- -- Unhandled_Exception_Terminate
-
------------------------------------
-- Exception propagation routines --
------------------------------------
- procedure Propagate_Exception;
+ function Allocate_Occurrence return EOA;
+ -- Allocate an exception occurence (as well as the machine occurence)
+
+ procedure Propagate_Exception (Excep : EOA);
pragma No_Return (Propagate_Exception);
- -- This procedure propagates the exception represented by the occurrence
- -- referenced by Current_Excep in the TSD for the current task.
+ -- This procedure propagates the exception represented by Excep
end Exception_Propagation;
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 Exception_Propagation.Propagate_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 := "");
-- | | | |
-- | | | Set_E_C_Msg(i)
-- | | |
- -- Raise_Current_Excep
+ -- Complete_And_Propagate_Occurrence
procedure Reraise;
pragma No_Return (Reraise);
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.
+
+ -- ??? 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));
+ 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));
- Exception_Propagation.Propagate_Exception;
- end Raise_Current_Excep;
+ Complete_Occurrence (X);
+ Exception_Propagation.Propagate_Exception (X);
+ end Complete_And_Propagate_Occurrence;
---------------------
-- Raise_Exception --
Message : String := "")
is
EF : Exception_Id := E;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
-- Raise CE if E = Null_ID (AI-446)
-- Go ahead and raise appropriate exception
- Exception_Data.Set_Exception_Msg (EF, Message);
+ Exception_Data.Set_Exception_Msg (X, EF, Message);
if not ZCX_By_Default then
Abort_Defer.all;
end if;
- Raise_Current_Excep (EF);
+ Complete_Occurrence (X);
+ Exception_Propagation.Propagate_Exception (X);
end Raise_Exception;
----------------------------
(E : Exception_Id;
Message : String := "")
is
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
- Exception_Data.Set_Exception_Msg (E, Message);
+ Exception_Data.Set_Exception_Msg (X, E, Message);
if not ZCX_By_Default then
Abort_Defer.all;
end if;
- Raise_Current_Excep (E);
+ Complete_And_Propagate_Occurrence (X);
end Raise_Exception_Always;
------------------------------
(E : Exception_Id;
Message : String := "")
is
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
- Exception_Data.Set_Exception_Msg (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;
-------------------------------------
end if;
end Raise_From_Controlled_Operation;
- -------------------------------
- -- Raise_From_Signal_Handler --
- -------------------------------
+ -------------------------------------------
+ -- Create_Occurrence_From_Signal_Handler --
+ -------------------------------------------
- procedure Raise_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 (E, M);
+ Exception_Data.Set_Exception_C_Msg (X, E, M);
if not ZCX_By_Default then
Abort_Defer.all;
end if;
- Raise_Current_Excep (E);
+ 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;
-------------------------
C : Integer := 0;
M : System.Address := System.Null_Address)
is
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
- Exception_Data.Set_Exception_C_Msg (E, F, L, C, M);
+ Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
if not ZCX_By_Default then
Abort_Defer.all;
end if;
- Raise_Current_Excep (E);
+ Complete_And_Propagate_Occurrence (X);
end Raise_With_Location_And_Msg;
--------------------
--------------------
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;
+ -- 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 ???
Abort_Defer.all;
end if;
- Raise_Current_Excep (E);
+ Complete_And_Propagate_Occurrence (Excep);
end Raise_With_Msg;
--------------------------------------
procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer)
is
- E : constant Exception_Id := Program_Error_Def'Access;
+ X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin
-- This is "finalize/adjust raised exception". This subprogram is always
-- This is consistent with Raise_From_Controlled_Operation
- Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
- Raise_Current_Excep (E);
+ Exception_Data.Set_Exception_C_Msg
+ (X, Program_Error_Def'Access, File, Line, 0, Rmsg_22'Address);
+ Complete_And_Propagate_Occurrence (X);
end Rcheck_PE_Finalize_Raised_Exception;
-------------
-------------
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
if not ZCX_By_Default then
Abort_Defer.all;
end if;
- Raise_Current_Excep (Excep.Id);
+ Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
+ Excep.Machine_Occurrence := Saved_MO;
+ Complete_And_Propagate_Occurrence (Excep);
end Reraise;
--------------------------------------
procedure Reraise_Occurrence (X : Exception_Occurrence) is
begin
- if X.Id /= null then
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Save_Occurrence (Get_Current_Excep.all.all, X);
- Raise_Current_Excep (X.Id);
+ if X.Id = null then
+ return;
end if;
+
+ Reraise_Occurrence_Always (X);
end Reraise_Occurrence;
-------------------------------
Abort_Defer.all;
end if;
- Save_Occurrence (Get_Current_Excep.all.all, X);
- Raise_Current_Excep (X.Id);
+ Reraise_Occurrence_No_Defer (X);
end Reraise_Occurrence_Always;
---------------------------------
---------------------------------
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;
---------------------
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);
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)
-- 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;
---------------------------------
procedure Set_Exception_C_Msg
- (Id : Exception_Id;
+ (Excep : EOA;
+ Id : Exception_Id;
Msg1 : System.Address;
Line : Integer := 0;
Column : Integer := 0;
-- additional null terminated string is added to the message.
procedure Set_Exception_Msg
- (Id : Exception_Id;
+ (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
(E : Exception_Id;
Message : String := "")
is
- EF : Exception_Id := E;
-
+ EF : Exception_Id := E;
+ Excep : constant EOA := Get_Current_Excep.all;
begin
-- Raise CE if E = Null_ID (AI-446)
-- Go ahead and raise appropriate exception
- Exception_Data.Set_Exception_Msg (EF, Message);
+ Exception_Data.Set_Exception_Msg (Excep, EF, Message);
Abort_Defer.all;
Raise_Current_Excep (EF);
end Raise_Exception;
(E : Exception_Id;
Message : String := "")
is
+ Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Data.Set_Exception_Msg (E, Message);
+ Exception_Data.Set_Exception_Msg (Excep, E, Message);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_Exception_Always;
(E : Exception_Id;
Message : String := "")
is
+ Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Data.Set_Exception_Msg (E, Message);
+ Exception_Data.Set_Exception_Msg (Excep, E, Message);
-- Do not call Abort_Defer.all, as specified by the spec
(E : Exception_Id;
M : System.Address)
is
+ Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Data.Set_Exception_C_Msg (E, M);
+ Exception_Data.Set_Exception_C_Msg (Excep, E, M);
Abort_Defer.all;
Process_Raise_Exception (E);
end Raise_From_Signal_Handler;
L : Integer;
M : System.Address := System.Null_Address)
is
+ Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Data.Set_Exception_C_Msg (E, F, L, Msg2 => M);
+ Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Location_And_Msg;
procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer)
is
- E : constant Exception_Id := Program_Error_Def'Access;
-
+ E : constant Exception_Id := Program_Error_Def'Access;
+ Excep : constant EOA := Get_Current_Excep.all;
begin
-- This is "finalize/adjust raised exception". This subprogram is always
-- called with abort deferred, unlike all other Rcheck_* routines, it
-- This is consistent with Raise_From_Controlled_Operation
- Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
+ Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0,
+ Rmsg_22'Address);
Raise_Current_Excep (E);
end Rcheck_PE_Finalize_Raised_Exception;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-------------------------
procedure Set_Exception_C_Msg
- (Id : Exception_Id;
+ (Excep : EOA;
+ Id : Exception_Id;
Msg1 : System.Address;
Line : Integer := 0;
Column : Integer := 0;
Msg2 : System.Address := System.Null_Address)
is
- Excep : constant EOA := Get_Current_Excep.all;
Remind : Integer;
Ptr : Natural;
-----------------------
procedure Set_Exception_Msg
- (Id : Exception_Id;
+ (Excep : EOA;
+ Id : Exception_Id;
Message : String)
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
First : constant Integer := Message'First;
- Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Msg_Length := Len;
separate (Ada.Exceptions)
package body Exception_Propagation is
+ use Exception_Traces;
+
------------------------------------------------
-- Entities to interface with the GCC runtime --
------------------------------------------------
Private2 : Unwind_Word;
-- Usual exception structure has only two private fields, but the SEH
- -- one has six. To avoid makeing this file more complex, we use six
+ -- one has six. To avoid making this file more complex, we use six
-- fields on all platforms, wasting a few bytes on some.
Private3 : Unwind_Word;
Header : Unwind_Exception;
-- ABI Exception header first
- Occurrence : Exception_Occurrence;
+ Occurrence : aliased Exception_Occurrence;
-- The Ada occurrence
end record;
type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
function To_GCC_Exception is new
- Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access);
+ Unchecked_Conversion (System.Address, GCC_Exception_Access);
function To_GNAT_GCC_Exception is new
Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
-- 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 GNAT_GCC_Exception'
+ (Header => (Class => GNAT_Exception_Class,
+ Cleanup => GNAT_GCC_Exception_Cleanup'Address,
+ others => 0),
+ Occurrence => (others => <>));
+ Res.Occurrence.Machine_Occurrence := Res.all'Address;
+
+ return Res.Occurrence'Access;
+ end Allocate_Occurrence;
+
--------------------------------
-- GNAT_GCC_Exception_Cleanup --
--------------------------------
-- A default one
Excep.Id := Foreign_Exception'Access;
+ Excep.Machine_Occurrence := GCC_Exception.all'Address;
Excep.Msg_Length := 0;
Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID;
-- Propagate_Exception --
-------------------------
- -- Build an object suitable for the libgcc processing and call
- -- Unwind_RaiseException to actually do the raise, taking care of
- -- handling the two phase scheme it implements.
-
- procedure Propagate_Exception is
- Excep : constant EOA := Get_Current_Excep.all;
- GCC_Exception : GNAT_GCC_Exception_Access;
-
+ procedure Propagate_Exception (Excep : 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 (Excep);
-
- -- Allocate the GCC exception
-
- GCC_Exception :=
- new GNAT_GCC_Exception'
- (Header => (Class => GNAT_Exception_Class,
- Cleanup => GNAT_GCC_Exception_Cleanup'Address,
- others => 0),
- Occurrence => Excep.all);
-
- -- Propagate it
-
- Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
+ Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
end Propagate_Exception;
------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
pragma No_Return (builtin_longjmp);
pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp");
+ procedure Propagate_Continue (Excep : EOA);
+ 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.
+
-------------------------
- -- Propagate_Exception --
+ -- Allocate_Occurrence --
-------------------------
- procedure Propagate_Exception
- is
- Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
- Excep : constant EOA := Get_Current_Excep.all;
+ function Allocate_Occurrence return EOA is
begin
- -- Compute the backtrace for this occurrence if corresponding binder
- -- option has been set. Call_Chain takes care of the reraise case.
-
- Call_Chain (Excep);
-
- -- Note on above call to Call_Chain:
-
- -- We used to only do this if From_Signal_Handler was not set,
- -- based on the assumption that backtracing from a signal handler
- -- would not work due to stack layout oddities. However, since
-
- -- 1. The flag is never set in tasking programs (Notify_Exception
- -- performs regular raise statements), and
-
- -- 2. No problem has shown up in tasking programs around here so
- -- far, this turned out to be too strong an assumption.
-
- -- As, in addition, the test was
-
- -- 1. preventing the production of backtraces in non-tasking
- -- programs, and
+ return Get_Current_Excep.all;
+ end Allocate_Occurrence;
- -- 2. introducing a behavior inconsistency between
- -- the tasking and non-tasking cases,
-
- -- we have simply removed it
+ -------------------------
+ -- Propagate_Exception --
+ -------------------------
+ procedure Propagate_Exception (Excep : EOA) is
+ Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
+ 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
end if;
end Propagate_Exception;
+ ------------------------
+ -- Propagate_Continue --
+ ------------------------
+
+ procedure Propagate_Continue (Excep : EOA) is
+ begin
+ Propagate_Exception (Excep);
+ end Propagate_Continue;
+
end Exception_Propagation;
--------------------------------
procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Nod);
- Object_Name : constant Name_Id := New_Internal_Name ('I');
+ Loc : constant Source_Ptr := Sloc (Nod);
+
+ Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument
- Body_Stmts : List_Id;
- Index_List : List_Id;
- Proc_Id : Entity_Id;
- Proc_Body : Node_Id;
+ Body_Stmts : List_Id;
+ Index_List : List_Id;
+ Proc_Id : Entity_Id;
+ Proc_Body : Node_Id;
function Build_Component_Invariant_Call return Node_Id;
-- Create one statement to verify invariant on one array component,
function Build_Component_Invariant_Call return Node_Id is
Comp : Node_Id;
-
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
- Expressions => Index_List);
+ Expressions => Index_List);
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(Invariant_Procedure (Component_Type (A_Type)), Loc),
Parameter_Associations => New_List (Comp));
-
end Build_Component_Invariant_Call;
-------------------------
Index : Entity_Id;
begin
- -- If all dimensions dealt with, we simply check invariant of
- -- the component
+ -- If all dimensions dealt with, we simply check invariant of the
+ -- component.
if N > Number_Dimensions (A_Type) then
return New_List (Build_Component_Invariant_Call);
return New_List (
Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
+ Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Index,
+ Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Object_Entity, Loc),
+ Prefix =>
+ New_Occurrence_Of (Object_Entity, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
- Statements => Check_One_Dimension (N + 1)));
+ Statements => Check_One_Dimension (N + 1)));
end if;
end Check_One_Dimension;
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
+ Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
- Declarations => New_List,
+ Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts));
end;
end if;
- -- For a record (sub)type, freeze all the component types (RM
- -- 13.14(15). We test for E_Record_(sub)Type here, rather than using
- -- Is_Record_Type, because we don't want to attempt the freeze for
- -- the case of a private type with record extension (we will do that
- -- later when the full type is frozen).
-
- elsif Ekind (E) = E_Record_Type
- or else Ekind (E) = E_Record_Subtype
- then
+ -- For a record type or record subtype, freeze all component types
+ -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than
+ -- using Is_Record_Type, because we don't want to attempt the freeze
+ -- for the case of a private type with record extension (we will do
+ -- that later when the full type is frozen).
+
+ elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then
Freeze_Record_Type (E);
-- For a concurrent type, freeze corresponding record type. This
-- Use standard (i.e. through malloc) allocations. This automatically
-- raises Storage_Error if needed. We also try once more to physically
-- release memory, so that even marked blocks, in the advanced scanning,
- -- are freed.
+ -- are freed. Note that we do not initialize the storage array since it
+ -- is not necessary to do so (however this will cause bogus valgrind
+ -- warnings, which should simply be ignored).
begin
P := new Local_Storage_Array;
#ifdef __SEH__
#define STATUS_USER_DEFINED (1U << 29)
+
+/* From unwind-seh.c. */
+#define GCC_MAGIC (('G' << 16) | ('C' << 8) | 'C')
+#define GCC_EXCEPTION(TYPE) \
+ (STATUS_USER_DEFINED | ((TYPE) << 24) | GCC_MAGIC)
+#define STATUS_GCC_THROW GCC_EXCEPTION (0)
+
EXCEPTION_DISPOSITION __gnat_SEH_error_handler
(struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
+struct Exception_Data *
+__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg);
+
+struct _Unwind_Exception *
+__gnat_create_machine_occurrence_from_signal_handler (Exception_Id,
+ const char *);
+
/* Unwind opcodes. */
#define UWOP_PUSH_NONVOL 0
#define UWOP_ALLOC_LARGE 1
exceptions. */
if (!(ms_exc->ExceptionCode & STATUS_USER_DEFINED))
{
+ struct Exception_Data *exception;
+ const char *msg;
ULONG64 excpip = (ULONG64) ms_exc->ExceptionAddress;
+
if (excpip != 0
&& excpip >= (ms_disp->ImageBase
+ ms_disp->FunctionEntry->BeginAddress)
__gnat_adjust_context
((unsigned char *)(mf_imagebase + mf_func->UnwindData), mf_rsp);
}
- __gnat_SEH_error_handler (ms_exc, this_frame, ms_orig_context, ms_disp);
+
+ exception = __gnat_map_SEH (ms_exc, &msg);
+ if (exception != NULL)
+ {
+ struct _Unwind_Exception *exc;
+
+ /* Directly convert the system exception to a GCC one.
+ This is really breaking the API, but is necessary for stack size
+ reasons: the normal way is to call Raise_From_Signal_Handler,
+ which build the exception and calls _Unwind_RaiseException, which
+ unwinds the stack and will call this personality routine. But
+ the Windows unwinder needs about 2KB of stack. */
+ exc = __gnat_create_machine_occurrence_from_signal_handler
+ (exception, msg);
+ memset (exc->private_, 0, sizeof (exc->private_));
+ ms_exc->ExceptionCode = STATUS_GCC_THROW;
+ ms_exc->NumberParameters = 1;
+ ms_exc->ExceptionInformation[0] = (ULONG_PTR)exc;
+ }
+
}
return _GCC_specific_handler (ms_exc, this_frame, ms_orig_context,
#endif
CND(EWOULDBLOCK, "Operation would block")
+#ifndef E2BIG
+# define E2BIG -1
+#endif
+CND(E2BIG, "Argument list too long")
+
+#ifndef EILSEQ
+# define EILSEQ -1
+#endif
+CND(EILSEQ, "Illegal byte sequence")
+
/**
** Terminal I/O constants
**/
#include <windows.h>
#include <excpt.h>
+/* Prototypes. */
extern void _global_unwind2 (void *);
EXCEPTION_DISPOSITION __gnat_SEH_error_handler
(struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
-EXCEPTION_DISPOSITION
-__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
- void *EstablisherFrame,
- struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED,
- void *DispatcherContext ATTRIBUTE_UNUSED)
-{
- struct Exception_Data *exception;
- const char *msg;
+struct Exception_Data *
+__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg);
+/* Convert an SEH exception to an Ada one. Return the exception ID
+ and set MSG with the corresponding message. */
+
+struct Exception_Data *
+__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg)
+{
switch (ExceptionRecord->ExceptionCode)
{
case EXCEPTION_ACCESS_VIOLATION:
|| IsBadCodePtr
((void *)(ExceptionRecord->ExceptionInformation[1] + 4096)))
{
- exception = &program_error;
- msg = "EXCEPTION_ACCESS_VIOLATION";
+ *msg = "EXCEPTION_ACCESS_VIOLATION";
+ return &program_error;
}
else
{
/* otherwise it is a stack overflow */
- exception = &storage_error;
- msg = "stack overflow or erroneous memory access";
+ *msg = "stack overflow or erroneous memory access";
+ return &storage_error;
}
- break;
case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
- exception = &constraint_error;
- msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED";
- break;
+ *msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED";
+ return &constraint_error;
case EXCEPTION_DATATYPE_MISALIGNMENT:
- exception = &constraint_error;
- msg = "EXCEPTION_DATATYPE_MISALIGNMENT";
- break;
+ *msg = "EXCEPTION_DATATYPE_MISALIGNMENT";
+ return &constraint_error;
case EXCEPTION_FLT_DENORMAL_OPERAND:
- exception = &constraint_error;
- msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
- break;
+ *msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
+ return &constraint_error;
case EXCEPTION_FLT_DIVIDE_BY_ZERO:
- exception = &constraint_error;
- msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
- break;
+ *msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
+ return &constraint_error;
case EXCEPTION_FLT_INVALID_OPERATION:
- exception = &constraint_error;
- msg = "EXCEPTION_FLT_INVALID_OPERATION";
- break;
+ *msg = "EXCEPTION_FLT_INVALID_OPERATION";
+ return &constraint_error;
case EXCEPTION_FLT_OVERFLOW:
- exception = &constraint_error;
- msg = "EXCEPTION_FLT_OVERFLOW";
- break;
+ *msg = "EXCEPTION_FLT_OVERFLOW";
+ return &constraint_error;
case EXCEPTION_FLT_STACK_CHECK:
- exception = &program_error;
- msg = "EXCEPTION_FLT_STACK_CHECK";
- break;
+ *msg = "EXCEPTION_FLT_STACK_CHECK";
+ return &program_error;
case EXCEPTION_FLT_UNDERFLOW:
- exception = &constraint_error;
- msg = "EXCEPTION_FLT_UNDERFLOW";
- break;
+ *msg = "EXCEPTION_FLT_UNDERFLOW";
+ return &constraint_error;
case EXCEPTION_INT_DIVIDE_BY_ZERO:
- exception = &constraint_error;
- msg = "EXCEPTION_INT_DIVIDE_BY_ZERO";
- break;
+ *msg = "EXCEPTION_INT_DIVIDE_BY_ZERO";
+ return &constraint_error;
case EXCEPTION_INT_OVERFLOW:
- exception = &constraint_error;
- msg = "EXCEPTION_INT_OVERFLOW";
- break;
+ *msg = "EXCEPTION_INT_OVERFLOW";
+ return &constraint_error;
case EXCEPTION_INVALID_DISPOSITION:
- exception = &program_error;
- msg = "EXCEPTION_INVALID_DISPOSITION";
- break;
+ *msg = "EXCEPTION_INVALID_DISPOSITION";
+ return &program_error;
case EXCEPTION_NONCONTINUABLE_EXCEPTION:
- exception = &program_error;
- msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION";
- break;
+ *msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION";
+ return &program_error;
case EXCEPTION_PRIV_INSTRUCTION:
- exception = &program_error;
- msg = "EXCEPTION_PRIV_INSTRUCTION";
- break;
+ *msg = "EXCEPTION_PRIV_INSTRUCTION";
+ return &program_error;
case EXCEPTION_SINGLE_STEP:
- exception = &program_error;
- msg = "EXCEPTION_SINGLE_STEP";
- break;
+ *msg = "EXCEPTION_SINGLE_STEP";
+ return &program_error;
case EXCEPTION_STACK_OVERFLOW:
- exception = &storage_error;
- msg = "EXCEPTION_STACK_OVERFLOW";
- break;
+ *msg = "EXCEPTION_STACK_OVERFLOW";
+ return &storage_error;
default:
+ *msg = NULL;
+ return NULL;
+ }
+}
+
+EXCEPTION_DISPOSITION
+__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED,
+ void *DispatcherContext ATTRIBUTE_UNUSED)
+{
+ struct Exception_Data *exception;
+ const char *msg;
+
+ exception = __gnat_map_SEH (ExceptionRecord, &msg);
+
+ if (exception == NULL)
+ {
#if defined (_WIN64) && defined (__SEH__)
/* On Windows x64, do not transform other exception as they could
be caught by user (when SEH is used to propagate exceptions). */
projects / platform / upstream / gcc.git / commitdiff