Skip to content

R
riscv-gcc-1
Commit e187fa72 by Arnaud Charlet
Options

[multiple changes] 

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).

From-SVN: r189530
parent 59a6c9d5
Showing with 287 additions and 187 deletions
gcc/ada/ChangeLog
2012-07-16 Robert Dewar <dewar@adacore.com> 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. * a-direct.adb, g-dirope.adb: Minor reformatting.
2012-07-16 Tristan Gingold <gingold@adacore.com> 2012-07-16 Tristan Gingold <gingold@adacore.com>
......
gcc/ada/a-except-2005.ads
...@@ -302,6 +302,10 @@ private ...@@ -302,6 +302,10 @@ private
Id : Exception_Id; Id : Exception_Id;
-- Exception_Identity for this exception occurrence -- 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; Msg_Length : Natural := 0;
-- Length of message (zero = no message) -- Length of message (zero = no message)
...@@ -339,12 +343,13 @@ private ...@@ -339,12 +343,13 @@ private
-- Functions for implementing Exception_Occurrence stream attributes -- Functions for implementing Exception_Occurrence stream attributes
Null_Occurrence : constant Exception_Occurrence := ( Null_Occurrence : constant Exception_Occurrence := (
Id => null, Id => null,
Msg_Length => 0, Machine_Occurrence => System.Null_Address,
Msg => (others => ' '), Msg_Length => 0,
Exception_Raised => False, Msg => (others => ' '),
Pid => 0, Exception_Raised => False,
Num_Tracebacks => 0, Pid => 0,
Tracebacks => (others => TBE.Null_TB_Entry)); Num_Tracebacks => 0,
Tracebacks => (others => TBE.Null_TB_Entry));
end Ada.Exceptions; end Ada.Exceptions;
gcc/ada/a-except.adb
...@@ -93,7 +93,8 @@ package body Ada.Exceptions is ...@@ -93,7 +93,8 @@ package body Ada.Exceptions is
--------------------------------- ---------------------------------
procedure Set_Exception_C_Msg procedure Set_Exception_C_Msg
(Id : Exception_Id; (Excep : EOA;
Id : Exception_Id;
Msg1 : System.Address; Msg1 : System.Address;
Line : Integer := 0; Line : Integer := 0;
Column : Integer := 0; Column : Integer := 0;
...@@ -107,7 +108,8 @@ package body Ada.Exceptions is ...@@ -107,7 +108,8 @@ package body Ada.Exceptions is
-- additional null terminated string is added to the message. -- additional null terminated string is added to the message.
procedure Set_Exception_Msg procedure Set_Exception_Msg
(Id : Exception_Id; (Excep : EOA;
Id : Exception_Id;
Message : String); Message : String);
-- This routine is called to setup the exception referenced by the -- This routine is called to setup the exception referenced by the
-- Current_Excep field in the TSD to contain the indicated Id value and -- Current_Excep field in the TSD to contain the indicated Id value and
...@@ -966,8 +968,8 @@ package body Ada.Exceptions is ...@@ -966,8 +968,8 @@ package body Ada.Exceptions is
(E : Exception_Id; (E : Exception_Id;
Message : String := "") Message : String := "")
is is
EF : Exception_Id := E; EF : Exception_Id := E;
Excep : constant EOA := Get_Current_Excep.all;
begin begin
-- Raise CE if E = Null_ID (AI-446) -- Raise CE if E = Null_ID (AI-446)
...@@ -977,7 +979,7 @@ package body Ada.Exceptions is ...@@ -977,7 +979,7 @@ package body Ada.Exceptions is
-- Go ahead and raise appropriate exception -- Go ahead and raise appropriate exception
Exception_Data.Set_Exception_Msg (EF, Message); Exception_Data.Set_Exception_Msg (Excep, EF, Message);
Abort_Defer.all; Abort_Defer.all;
Raise_Current_Excep (EF); Raise_Current_Excep (EF);
end Raise_Exception; end Raise_Exception;
...@@ -990,8 +992,9 @@ package body Ada.Exceptions is ...@@ -990,8 +992,9 @@ package body Ada.Exceptions is
(E : Exception_Id; (E : Exception_Id;
Message : String := "") Message : String := "")
is is
Excep : constant EOA := Get_Current_Excep.all;
begin begin
Exception_Data.Set_Exception_Msg (E, Message); Exception_Data.Set_Exception_Msg (Excep, E, Message);
Abort_Defer.all; Abort_Defer.all;
Raise_Current_Excep (E); Raise_Current_Excep (E);
end Raise_Exception_Always; end Raise_Exception_Always;
...@@ -1004,8 +1007,9 @@ package body Ada.Exceptions is ...@@ -1004,8 +1007,9 @@ package body Ada.Exceptions is
(E : Exception_Id; (E : Exception_Id;
Message : String := "") Message : String := "")
is is
Excep : constant EOA := Get_Current_Excep.all;
begin 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 -- Do not call Abort_Defer.all, as specified by the spec
...@@ -1065,8 +1069,9 @@ package body Ada.Exceptions is ...@@ -1065,8 +1069,9 @@ package body Ada.Exceptions is
(E : Exception_Id; (E : Exception_Id;
M : System.Address) M : System.Address)
is is
Excep : constant EOA := Get_Current_Excep.all;
begin begin
Exception_Data.Set_Exception_C_Msg (E, M); Exception_Data.Set_Exception_C_Msg (Excep, E, M);
Abort_Defer.all; Abort_Defer.all;
Process_Raise_Exception (E); Process_Raise_Exception (E);
end Raise_From_Signal_Handler; end Raise_From_Signal_Handler;
...@@ -1135,8 +1140,9 @@ package body Ada.Exceptions is ...@@ -1135,8 +1140,9 @@ package body Ada.Exceptions is
L : Integer; L : Integer;
M : System.Address := System.Null_Address) M : System.Address := System.Null_Address)
is is
Excep : constant EOA := Get_Current_Excep.all;
begin 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; Abort_Defer.all;
Raise_Current_Excep (E); Raise_Current_Excep (E);
end Raise_With_Location_And_Msg; end Raise_With_Location_And_Msg;
...@@ -1402,8 +1408,8 @@ package body Ada.Exceptions is ...@@ -1402,8 +1408,8 @@ package body Ada.Exceptions is
procedure Rcheck_PE_Finalize_Raised_Exception procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer) (File : System.Address; Line : Integer)
is 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 begin
-- This is "finalize/adjust raised exception". This subprogram is always -- This is "finalize/adjust raised exception". This subprogram is always
-- called with abort deferred, unlike all other Rcheck_* routines, it -- called with abort deferred, unlike all other Rcheck_* routines, it
...@@ -1411,7 +1417,8 @@ package body Ada.Exceptions is ...@@ -1411,7 +1417,8 @@ package body Ada.Exceptions is
-- This is consistent with Raise_From_Controlled_Operation -- 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); Raise_Current_Excep (E);
end Rcheck_PE_Finalize_Raised_Exception; end Rcheck_PE_Finalize_Raised_Exception;
......
gcc/ada/a-exexda.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -558,13 +558,13 @@ package body Exception_Data is ...@@ -558,13 +558,13 @@ package body Exception_Data is
------------------------- -------------------------
procedure Set_Exception_C_Msg procedure Set_Exception_C_Msg
(Id : Exception_Id; (Excep : EOA;
Id : Exception_Id;
Msg1 : System.Address; Msg1 : System.Address;
Line : Integer := 0; Line : Integer := 0;
Column : Integer := 0; Column : Integer := 0;
Msg2 : System.Address := System.Null_Address) Msg2 : System.Address := System.Null_Address)
is is
Excep : constant EOA := Get_Current_Excep.all;
Remind : Integer; Remind : Integer;
Ptr : Natural; Ptr : Natural;
...@@ -654,13 +654,13 @@ package body Exception_Data is ...@@ -654,13 +654,13 @@ package body Exception_Data is
----------------------- -----------------------
procedure Set_Exception_Msg procedure Set_Exception_Msg
(Id : Exception_Id; (Excep : EOA;
Id : Exception_Id;
Message : String) Message : String)
is is
Len : constant Natural := Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length); Natural'Min (Message'Length, Exception_Msg_Max_Length);
First : constant Integer := Message'First; First : constant Integer := Message'First;
Excep : constant EOA := Get_Current_Excep.all;
begin begin
Excep.Exception_Raised := False; Excep.Exception_Raised := False;
Excep.Msg_Length := Len; Excep.Msg_Length := Len;
......
gcc/ada/a-exexpr-gcc.adb
...@@ -39,6 +39,8 @@ with System.Storage_Elements; use System.Storage_Elements; ...@@ -39,6 +39,8 @@ with System.Storage_Elements; use System.Storage_Elements;
separate (Ada.Exceptions) separate (Ada.Exceptions)
package body Exception_Propagation is package body Exception_Propagation is
use Exception_Traces;
------------------------------------------------ ------------------------------------------------
-- Entities to interface with the GCC runtime -- -- Entities to interface with the GCC runtime --
------------------------------------------------ ------------------------------------------------
...@@ -110,7 +112,7 @@ package body Exception_Propagation is ...@@ -110,7 +112,7 @@ package body Exception_Propagation is
Private2 : Unwind_Word; Private2 : Unwind_Word;
-- Usual exception structure has only two private fields, but the SEH -- 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. -- fields on all platforms, wasting a few bytes on some.
Private3 : Unwind_Word; Private3 : Unwind_Word;
...@@ -151,7 +153,7 @@ package body Exception_Propagation is ...@@ -151,7 +153,7 @@ package body Exception_Propagation is
Header : Unwind_Exception; Header : Unwind_Exception;
-- ABI Exception header first -- ABI Exception header first
Occurrence : Exception_Occurrence; Occurrence : aliased Exception_Occurrence;
-- The Ada occurrence -- The Ada occurrence
end record; end record;
...@@ -177,7 +179,7 @@ package body Exception_Propagation is ...@@ -177,7 +179,7 @@ package body Exception_Propagation is
type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
function To_GCC_Exception is new 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 function To_GNAT_GCC_Exception is new
Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access); Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
...@@ -297,6 +299,24 @@ package body Exception_Propagation is ...@@ -297,6 +299,24 @@ package body Exception_Propagation is
-- exceptions on targets which always handle exceptions (such as SEH). -- exceptions on targets which always handle exceptions (such as SEH).
-- The handler will simply call Unhandled_Except_Handler. -- 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 -- -- GNAT_GCC_Exception_Cleanup --
-------------------------------- --------------------------------
...@@ -345,6 +365,7 @@ package body Exception_Propagation is ...@@ -345,6 +365,7 @@ package body Exception_Propagation is
-- A default one -- A default one
Excep.Id := Foreign_Exception'Access; Excep.Id := Foreign_Exception'Access;
Excep.Machine_Occurrence := GCC_Exception.all'Address;
Excep.Msg_Length := 0; Excep.Msg_Length := 0;
Excep.Exception_Raised := True; Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID; Excep.Pid := Local_Partition_ID;
...@@ -433,50 +454,9 @@ package body Exception_Propagation is ...@@ -433,50 +454,9 @@ package body Exception_Propagation is
-- Propagate_Exception -- -- Propagate_Exception --
------------------------- -------------------------
-- Build an object suitable for the libgcc processing and call procedure Propagate_Exception (Excep : EOA) is
-- 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;
begin begin
-- Compute the backtrace for this occurrence if the corresponding Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
-- 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));
end Propagate_Exception; end Propagate_Exception;
------------------------------ ------------------------------
......
gcc/ada/a-exexpr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,42 +43,29 @@ package body Exception_Propagation is ...@@ -43,42 +43,29 @@ package body Exception_Propagation is
pragma No_Return (builtin_longjmp); pragma No_Return (builtin_longjmp);
pragma Import (Intrinsic, builtin_longjmp, "__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 function Allocate_Occurrence return EOA is
is
Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
Excep : constant EOA := Get_Current_Excep.all;
begin begin
-- Compute the backtrace for this occurrence if corresponding binder return Get_Current_Excep.all;
-- option has been set. Call_Chain takes care of the reraise case. end Allocate_Occurrence;
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
-- 2. introducing a behavior inconsistency between -------------------------
-- the tasking and non-tasking cases, -- Propagate_Exception --
-------------------------
-- we have simply removed it
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 -- If the jump buffer pointer is non-null, transfer control using
-- it. Otherwise announce an unhandled exception (note that this -- it. Otherwise announce an unhandled exception (note that this
-- means that we have no finalizations to do other than at the outer -- means that we have no finalizations to do other than at the outer
...@@ -98,4 +85,13 @@ package body Exception_Propagation is ...@@ -98,4 +85,13 @@ package body Exception_Propagation is
end if; end if;
end Propagate_Exception; end Propagate_Exception;
------------------------
-- Propagate_Continue --
------------------------
procedure Propagate_Continue (Excep : EOA) is
begin
Propagate_Exception (Excep);
end Propagate_Continue;
end Exception_Propagation; end Exception_Propagation;
gcc/ada/exp_ch3.adb
...@@ -772,18 +772,19 @@ package body Exp_Ch3 is ...@@ -772,18 +772,19 @@ package body Exp_Ch3 is
-------------------------------- --------------------------------
procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nod); Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure -- Name for argument of invariant procedure
Object_Entity : constant Node_Id := Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name); Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument -- The procedure declaration entity for the argument
Body_Stmts : List_Id; Body_Stmts : List_Id;
Index_List : List_Id; Index_List : List_Id;
Proc_Id : Entity_Id; Proc_Id : Entity_Id;
Proc_Body : Node_Id; Proc_Body : Node_Id;
function Build_Component_Invariant_Call return Node_Id; function Build_Component_Invariant_Call return Node_Id;
-- Create one statement to verify invariant on one array component, -- Create one statement to verify invariant on one array component,
...@@ -803,19 +804,17 @@ package body Exp_Ch3 is ...@@ -803,19 +804,17 @@ package body Exp_Ch3 is
function Build_Component_Invariant_Call return Node_Id is function Build_Component_Invariant_Call return Node_Id is
Comp : Node_Id; Comp : Node_Id;
begin begin
Comp := Comp :=
Make_Indexed_Component (Loc, Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc), Prefix => New_Occurrence_Of (Object_Entity, Loc),
Expressions => Index_List); Expressions => Index_List);
return return
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
New_Occurrence_Of New_Occurrence_Of
(Invariant_Procedure (Component_Type (A_Type)), Loc), (Invariant_Procedure (Component_Type (A_Type)), Loc),
Parameter_Associations => New_List (Comp)); Parameter_Associations => New_List (Comp));
end Build_Component_Invariant_Call; end Build_Component_Invariant_Call;
------------------------- -------------------------
...@@ -826,8 +825,8 @@ package body Exp_Ch3 is ...@@ -826,8 +825,8 @@ package body Exp_Ch3 is
Index : Entity_Id; Index : Entity_Id;
begin begin
-- If all dimensions dealt with, we simply check invariant of -- If all dimensions dealt with, we simply check invariant of the
-- the component -- component.
if N > Number_Dimensions (A_Type) then if N > Number_Dimensions (A_Type) then
return New_List (Build_Component_Invariant_Call); return New_List (Build_Component_Invariant_Call);
...@@ -842,19 +841,20 @@ package body Exp_Ch3 is ...@@ -842,19 +841,20 @@ package body Exp_Ch3 is
return New_List ( return New_List (
Make_Implicit_Loop_Statement (Nod, Make_Implicit_Loop_Statement (Nod,
Identifier => Empty, Identifier => Empty,
Iteration_Scheme => Iteration_Scheme =>
Make_Iteration_Scheme (Loc, Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification => Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc, Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index, Defining_Identifier => Index,
Discrete_Subtype_Definition => Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc), Prefix =>
New_Occurrence_Of (Object_Entity, Loc),
Attribute_Name => Name_Range, Attribute_Name => Name_Range,
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, N))))), Make_Integer_Literal (Loc, N))))),
Statements => Check_One_Dimension (N + 1))); Statements => Check_One_Dimension (N + 1)));
end if; end if;
end Check_One_Dimension; end Check_One_Dimension;
...@@ -875,13 +875,13 @@ package body Exp_Ch3 is ...@@ -875,13 +875,13 @@ package body Exp_Ch3 is
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id, Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List ( Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity, Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (A_Type, Loc)))), Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
Declarations => New_List, Declarations => Empty_List,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts)); Statements => Body_Stmts));
......
gcc/ada/freeze.adb
...@@ -3898,15 +3898,13 @@ package body Freeze is ...@@ -3898,15 +3898,13 @@ package body Freeze is
end; end;
end if; end if;
-- For a record (sub)type, freeze all the component types (RM -- For a record type or record subtype, freeze all component types
-- 13.14(15). We test for E_Record_(sub)Type here, rather than using -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than
-- Is_Record_Type, because we don't want to attempt the freeze for -- using Is_Record_Type, because we don't want to attempt the freeze
-- the case of a private type with record extension (we will do that -- for the case of a private type with record extension (we will do
-- later when the full type is frozen). -- that later when the full type is frozen).
elsif Ekind (E) = E_Record_Type elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then
or else Ekind (E) = E_Record_Subtype
then
Freeze_Record_Type (E); Freeze_Record_Type (E);
-- For a concurrent type, freeze corresponding record type. This -- For a concurrent type, freeze corresponding record type. This
......
gcc/ada/g-debpoo.adb
...@@ -692,7 +692,9 @@ package body GNAT.Debug_Pools is ...@@ -692,7 +692,9 @@ package body GNAT.Debug_Pools is
-- Use standard (i.e. through malloc) allocations. This automatically -- Use standard (i.e. through malloc) allocations. This automatically
-- raises Storage_Error if needed. We also try once more to physically -- raises Storage_Error if needed. We also try once more to physically
-- release memory, so that even marked blocks, in the advanced scanning, -- 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 begin
P := new Local_Storage_Array; P := new Local_Storage_Array;
......
gcc/ada/raise-gcc.c
...@@ -1213,9 +1213,23 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, ...@@ -1213,9 +1213,23 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
#ifdef __SEH__ #ifdef __SEH__
#define STATUS_USER_DEFINED (1U << 29) #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 EXCEPTION_DISPOSITION __gnat_SEH_error_handler
(struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); (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. */ /* Unwind opcodes. */
#define UWOP_PUSH_NONVOL 0 #define UWOP_PUSH_NONVOL 0
#define UWOP_ALLOC_LARGE 1 #define UWOP_ALLOC_LARGE 1
...@@ -1295,7 +1309,10 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, ...@@ -1295,7 +1309,10 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
exceptions. */ exceptions. */
if (!(ms_exc->ExceptionCode & STATUS_USER_DEFINED)) if (!(ms_exc->ExceptionCode & STATUS_USER_DEFINED))
{ {
struct Exception_Data *exception;
const char *msg;
ULONG64 excpip = (ULONG64) ms_exc->ExceptionAddress; ULONG64 excpip = (ULONG64) ms_exc->ExceptionAddress;
if (excpip != 0 if (excpip != 0
&& excpip >= (ms_disp->ImageBase && excpip >= (ms_disp->ImageBase
+ ms_disp->FunctionEntry->BeginAddress) + ms_disp->FunctionEntry->BeginAddress)
...@@ -1353,7 +1370,26 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, ...@@ -1353,7 +1370,26 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
__gnat_adjust_context __gnat_adjust_context
((unsigned char *)(mf_imagebase + mf_func->UnwindData), mf_rsp); ((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, return _GCC_specific_handler (ms_exc, this_frame, ms_orig_context,
......
gcc/ada/s-oscons-tmplt.c
...@@ -589,6 +589,16 @@ CND(ETOOMANYREFS, "Too many references") ...@@ -589,6 +589,16 @@ CND(ETOOMANYREFS, "Too many references")
#endif #endif
CND(EWOULDBLOCK, "Operation would block") 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 ** Terminal I/O constants
**/ **/
......
gcc/ada/seh_init.c
...@@ -68,20 +68,21 @@ extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); ...@@ -68,20 +68,21 @@ extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
#include <windows.h> #include <windows.h>
#include <excpt.h> #include <excpt.h>
/* Prototypes. */
extern void _global_unwind2 (void *); extern void _global_unwind2 (void *);
EXCEPTION_DISPOSITION __gnat_SEH_error_handler EXCEPTION_DISPOSITION __gnat_SEH_error_handler
(struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); (struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
EXCEPTION_DISPOSITION struct Exception_Data *
__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, __gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg);
void *EstablisherFrame,
struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED,
void *DispatcherContext ATTRIBUTE_UNUSED)
{
struct Exception_Data *exception;
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) switch (ExceptionRecord->ExceptionCode)
{ {
case EXCEPTION_ACCESS_VIOLATION: case EXCEPTION_ACCESS_VIOLATION:
...@@ -92,93 +93,95 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, ...@@ -92,93 +93,95 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
|| IsBadCodePtr || IsBadCodePtr
((void *)(ExceptionRecord->ExceptionInformation[1] + 4096))) ((void *)(ExceptionRecord->ExceptionInformation[1] + 4096)))
{ {
exception = &program_error; *msg = "EXCEPTION_ACCESS_VIOLATION";
msg = "EXCEPTION_ACCESS_VIOLATION"; return &program_error;
} }
else else
{ {
/* otherwise it is a stack overflow */ /* 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: case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
exception = &constraint_error; *msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED";
msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED"; return &constraint_error;
break;
case EXCEPTION_DATATYPE_MISALIGNMENT: case EXCEPTION_DATATYPE_MISALIGNMENT:
exception = &constraint_error; *msg = "EXCEPTION_DATATYPE_MISALIGNMENT";
msg = "EXCEPTION_DATATYPE_MISALIGNMENT"; return &constraint_error;
break;
case EXCEPTION_FLT_DENORMAL_OPERAND: case EXCEPTION_FLT_DENORMAL_OPERAND:
exception = &constraint_error; *msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; return &constraint_error;
break;
case EXCEPTION_FLT_DIVIDE_BY_ZERO: case EXCEPTION_FLT_DIVIDE_BY_ZERO:
exception = &constraint_error; *msg = "EXCEPTION_FLT_DENORMAL_OPERAND";
msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; return &constraint_error;
break;
case EXCEPTION_FLT_INVALID_OPERATION: case EXCEPTION_FLT_INVALID_OPERATION:
exception = &constraint_error; *msg = "EXCEPTION_FLT_INVALID_OPERATION";
msg = "EXCEPTION_FLT_INVALID_OPERATION"; return &constraint_error;
break;
case EXCEPTION_FLT_OVERFLOW: case EXCEPTION_FLT_OVERFLOW:
exception = &constraint_error; *msg = "EXCEPTION_FLT_OVERFLOW";
msg = "EXCEPTION_FLT_OVERFLOW"; return &constraint_error;
break;
case EXCEPTION_FLT_STACK_CHECK: case EXCEPTION_FLT_STACK_CHECK:
exception = &program_error; *msg = "EXCEPTION_FLT_STACK_CHECK";
msg = "EXCEPTION_FLT_STACK_CHECK"; return &program_error;
break;
case EXCEPTION_FLT_UNDERFLOW: case EXCEPTION_FLT_UNDERFLOW:
exception = &constraint_error; *msg = "EXCEPTION_FLT_UNDERFLOW";
msg = "EXCEPTION_FLT_UNDERFLOW"; return &constraint_error;
break;
case EXCEPTION_INT_DIVIDE_BY_ZERO: case EXCEPTION_INT_DIVIDE_BY_ZERO:
exception = &constraint_error; *msg = "EXCEPTION_INT_DIVIDE_BY_ZERO";
msg = "EXCEPTION_INT_DIVIDE_BY_ZERO"; return &constraint_error;
break;
case EXCEPTION_INT_OVERFLOW: case EXCEPTION_INT_OVERFLOW:
exception = &constraint_error; *msg = "EXCEPTION_INT_OVERFLOW";
msg = "EXCEPTION_INT_OVERFLOW"; return &constraint_error;
break;
case EXCEPTION_INVALID_DISPOSITION: case EXCEPTION_INVALID_DISPOSITION:
exception = &program_error; *msg = "EXCEPTION_INVALID_DISPOSITION";
msg = "EXCEPTION_INVALID_DISPOSITION"; return &program_error;
break;
case EXCEPTION_NONCONTINUABLE_EXCEPTION: case EXCEPTION_NONCONTINUABLE_EXCEPTION:
exception = &program_error; *msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION";
msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION"; return &program_error;
break;
case EXCEPTION_PRIV_INSTRUCTION: case EXCEPTION_PRIV_INSTRUCTION:
exception = &program_error; *msg = "EXCEPTION_PRIV_INSTRUCTION";
msg = "EXCEPTION_PRIV_INSTRUCTION"; return &program_error;
break;
case EXCEPTION_SINGLE_STEP: case EXCEPTION_SINGLE_STEP:
exception = &program_error; *msg = "EXCEPTION_SINGLE_STEP";
msg = "EXCEPTION_SINGLE_STEP"; return &program_error;
break;
case EXCEPTION_STACK_OVERFLOW: case EXCEPTION_STACK_OVERFLOW:
exception = &storage_error; *msg = "EXCEPTION_STACK_OVERFLOW";
msg = "EXCEPTION_STACK_OVERFLOW"; return &storage_error;
break;
default: 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__) #if defined (_WIN64) && defined (__SEH__)
/* On Windows x64, do not transform other exception as they could /* On Windows x64, do not transform other exception as they could
be caught by user (when SEH is used to propagate exceptions). */ be caught by user (when SEH is used to propagate exceptions). */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment