From e187fa72fb4806da5b93af1d346446b9fc7f0993 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 16 Jul 2012 14:51:41 +0200 Subject: [PATCH] [multiple changes] 2012-07-16 Robert Dewar * freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting. 2012-07-16 Thomas Quinot * s-oscons-tmplt.c: Add definitions of E2BIG and EILSEQ. 2012-07-16 Tristan Gingold * 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 * 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). From-SVN: r189530 --- gcc/ada/ChangeLog | 63 ++++++++++ gcc/ada/a-except-2005.adb | 237 ++++++++++++++++++++++++++------------ gcc/ada/a-except-2005.ads | 19 +-- gcc/ada/a-except.adb | 31 +++-- gcc/ada/a-exexda.adb | 10 +- gcc/ada/a-exexpr-gcc.adb | 72 +++++------- gcc/ada/a-exexpr.adb | 58 +++++----- gcc/ada/exp_ch3.adb | 34 +++--- gcc/ada/freeze.adb | 16 ++- gcc/ada/g-debpoo.adb | 4 +- gcc/ada/raise-gcc.c | 38 +++++- gcc/ada/s-oscons-tmplt.c | 10 ++ gcc/ada/seh_init.c | 119 +++++++++---------- 13 files changed, 453 insertions(+), 258 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 18126f43e75..a0724c0d4c5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,66 @@ +2012-07-16 Robert Dewar + + * freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting. + +2012-07-16 Thomas Quinot + + * s-oscons-tmplt.c: Add definitions of E2BIG and EILSEQ. + +2012-07-16 Tristan Gingold + + * 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 + + * 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 * a-direct.adb, g-dirope.adb: Minor reformatting. diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index a42c82efa09..b7dcb0adc1a 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -116,26 +116,27 @@ package body Ada.Exceptions is --------------------------------- 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 -- @@ -232,18 +233,16 @@ package body Ada.Exceptions is 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; @@ -264,14 +263,30 @@ package body Ada.Exceptions is 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 := ""); @@ -372,7 +387,7 @@ package body Ada.Exceptions is -- | | | | -- | | | Set_E_C_Msg(i) -- | | | - -- Raise_Current_Excep + -- Complete_And_Propagate_Occurrence procedure Reraise; pragma No_Return (Reraise); @@ -887,14 +902,47 @@ package body Ada.Exceptions is 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 -- @@ -905,6 +953,7 @@ package body Ada.Exceptions is Message : String := "") is EF : Exception_Id := E; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin -- Raise CE if E = Null_ID (AI-446) @@ -915,13 +964,14 @@ package body Ada.Exceptions is -- 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; ---------------------------- @@ -932,12 +982,13 @@ package body Ada.Exceptions is (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; ------------------------------ @@ -948,12 +999,13 @@ package body Ada.Exceptions is (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; ------------------------------------- @@ -1001,22 +1053,51 @@ package body Ada.Exceptions is 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; ------------------------- @@ -1082,14 +1163,15 @@ package body Ada.Exceptions is 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; -------------------- @@ -1097,14 +1179,20 @@ package body Ada.Exceptions is -------------------- 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 ??? @@ -1112,7 +1200,7 @@ package body Ada.Exceptions is Abort_Defer.all; end if; - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (Excep); end Raise_With_Msg; -------------------------------------- @@ -1400,7 +1488,7 @@ package body Ada.Exceptions is 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 @@ -1409,8 +1497,9 @@ package body Ada.Exceptions is -- 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; ------------- @@ -1418,12 +1507,15 @@ package body Ada.Exceptions is ------------- 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; -------------------------------------- @@ -1451,14 +1543,11 @@ package body Ada.Exceptions is 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; ------------------------------- @@ -1471,8 +1560,7 @@ package body Ada.Exceptions is 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; --------------------------------- @@ -1480,9 +1568,12 @@ package body Ada.Exceptions is --------------------------------- 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; --------------------- @@ -1494,10 +1585,14 @@ package body Ada.Exceptions is 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); diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index e346a2715f5..bb597ed0982 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -302,6 +302,10 @@ private 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) @@ -339,12 +343,13 @@ private -- 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; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 6c05b6e6482..1201ab0a443 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -93,7 +93,8 @@ package body Ada.Exceptions is --------------------------------- procedure Set_Exception_C_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Msg1 : System.Address; Line : Integer := 0; Column : Integer := 0; @@ -107,7 +108,8 @@ package body Ada.Exceptions is -- 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 @@ -966,8 +968,8 @@ package body Ada.Exceptions is (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) @@ -977,7 +979,7 @@ package body Ada.Exceptions is -- 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; @@ -990,8 +992,9 @@ package body Ada.Exceptions is (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; @@ -1004,8 +1007,9 @@ package body Ada.Exceptions is (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 @@ -1065,8 +1069,9 @@ package body Ada.Exceptions is (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; @@ -1135,8 +1140,9 @@ package body Ada.Exceptions is 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; @@ -1402,8 +1408,8 @@ package body Ada.Exceptions is 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 @@ -1411,7 +1417,8 @@ package body Ada.Exceptions is -- 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; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 37cb115988d..aa91cdcfe8f 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -558,13 +558,13 @@ package body Exception_Data is ------------------------- 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; @@ -654,13 +654,13 @@ package body Exception_Data is ----------------------- 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; diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index bf241da6127..10e91bf1e64 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -39,6 +39,8 @@ with System.Storage_Elements; use System.Storage_Elements; separate (Ada.Exceptions) package body Exception_Propagation is + use Exception_Traces; + ------------------------------------------------ -- Entities to interface with the GCC runtime -- ------------------------------------------------ @@ -110,7 +112,7 @@ package body Exception_Propagation is 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; @@ -151,7 +153,7 @@ package body Exception_Propagation is Header : Unwind_Exception; -- ABI Exception header first - Occurrence : Exception_Occurrence; + Occurrence : aliased Exception_Occurrence; -- The Ada occurrence end record; @@ -177,7 +179,7 @@ package body Exception_Propagation is 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); @@ -297,6 +299,24 @@ package body Exception_Propagation is -- 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 -- -------------------------------- @@ -345,6 +365,7 @@ package body Exception_Propagation is -- 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; @@ -433,50 +454,9 @@ package body Exception_Propagation is -- 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; ------------------------------ diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index cbe8a5c1c38..ccedcb2d1ef 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -43,42 +43,29 @@ package body Exception_Propagation is 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 @@ -98,4 +85,13 @@ package body Exception_Propagation is end if; end Propagate_Exception; + ------------------------ + -- Propagate_Continue -- + ------------------------ + + procedure Propagate_Continue (Excep : EOA) is + begin + Propagate_Exception (Excep); + end Propagate_Continue; + end Exception_Propagation; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f64524e1893..e39b10dbb61 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -772,18 +772,19 @@ package body Exp_Ch3 is -------------------------------- 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, @@ -803,19 +804,17 @@ package body Exp_Ch3 is 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; ------------------------- @@ -826,8 +825,8 @@ package body Exp_Ch3 is 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); @@ -842,19 +841,20 @@ package body Exp_Ch3 is 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; @@ -875,13 +875,13 @@ package body Exp_Ch3 is 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)); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d9bd91975fc..3a34fbe6bfd 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3898,15 +3898,13 @@ package body Freeze is 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 diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 95c391378ad..5ee63d9896f 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -692,7 +692,9 @@ package body GNAT.Debug_Pools is -- 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; diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 2383aa86054..8aef5b09247 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -1213,9 +1213,23 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, #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 @@ -1295,7 +1309,10 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, 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) @@ -1353,7 +1370,26 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, __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, diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 6ea57752dc4..467a1e4356e 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -589,6 +589,16 @@ CND(ETOOMANYREFS, "Too many references") #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 **/ diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index 84c5d3b6480..2f7fee435cf 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -68,20 +68,21 @@ extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); #include #include +/* 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: @@ -92,93 +93,95 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, || 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). */ -- 2.34.1