Skip to content

R
riscv-gcc-1
Commit 5accd7b6 by Arnaud Charlet
Options

[multiple changes] 

2011-08-29  Yannick Moy  <moy@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
	library-level subprogram.
	* sem_prag.adb (Check_Test_Case): Stricter rules for test-case
	placement.
	(Analyze_Pragma): Change name "Normal" for "Nominal" in test-case
	component.
	* snames.ads-tmpl: Change name "Normal" for "Nominal" in test-case
	component.
	* gnat_rm.texi: Update doc for Test_Case pragma.

2011-08-29  Tristan Gingold  <gingold@adacore.com>

	* a-exexpr-gcc.adb (Unwind_Exception): Remove default value, made it
	convention C.
	(GCC_Exception_Access): New type.
	(Unwind_DeleteException): New imported procedure
	(Foreign_Exception): Import it.
	(GNAT_GCC_Exception): Simply have the occurrence inside.
	(To_GCC_Exception): New function.
	(To_GNAT_GCC_Exception): New function.
	(GNAT_GCC_Exception_Cleanup): New procedure..
	(Propagate_GCC_Exception): New procedure.
	(Reraise_GCC_Exception): New procedure.
	(Setup_Current_Excep): New procedure.
	(CleanupUnwind_Handler): Change type of UW_Exception parameter.
	(Unwind_RaiseException): Ditto.
	(Unwind_ForcedUnwind): Ditto.
	(Remove): Removed.
	(Begin_Handler): Change type of parameter.
	(End_Handler): Ditto. Now delete the exception if still present.
	(Setup_Key): Removed.
	(Is_Setup_And_Not_Propagated): Removed.
	(Set_Setup_And_Not_Propagated): Ditto.
	(Clear_Setup_And_Not_Propagated): Ditto.
	(Save_Occurrence_And_Private): Ditto.
	(EID_For): Add 'not null' constraint on parameter.
	(Setup_Exception): Does nothing.
	(Propagate_Exception): Simplified.
	* exp_ch11.adb (Expand_N_Raise_Statement): In back-end exception model,
	re-raise is not expanded anymore.
	* s-except.ads (Foreign_Exception): New exception - placeholder for
	non Ada exceptions.
	* raise-gcc.c (__gnat_setup_current_excep): Declare
	(CXX_EXCEPTION_CLASS): Define (not yet used)
	(GNAT_EXCEPTION_CLASS): Define.
	(is_handled_by): Handle foreign exceptions.
	(PERSONALITY_FUNCTION): Call __gnat_setup_current_excep.

2011-08-29  Jose Ruiz  <ruiz@adacore.com>

	* a-synbar.adb (Synchronous_Barrier): Some additional clarification.

From-SVN: r178204
parent 2ef48385
Showing with 358 additions and 411 deletions
gcc/ada/ChangeLog
2011-08-29 Yannick Moy <moy@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
library-level subprogram.
* sem_prag.adb (Check_Test_Case): Stricter rules for test-case
placement.
(Analyze_Pragma): Change name "Normal" for "Nominal" in test-case
component.
* snames.ads-tmpl: Change name "Normal" for "Nominal" in test-case
component.
* gnat_rm.texi: Update doc for Test_Case pragma.
2011-08-29 Tristan Gingold <gingold@adacore.com>
* a-exexpr-gcc.adb (Unwind_Exception): Remove default value, made it
convention C.
(GCC_Exception_Access): New type.
(Unwind_DeleteException): New imported procedure
(Foreign_Exception): Import it.
(GNAT_GCC_Exception): Simply have the occurrence inside.
(To_GCC_Exception): New function.
(To_GNAT_GCC_Exception): New function.
(GNAT_GCC_Exception_Cleanup): New procedure..
(Propagate_GCC_Exception): New procedure.
(Reraise_GCC_Exception): New procedure.
(Setup_Current_Excep): New procedure.
(CleanupUnwind_Handler): Change type of UW_Exception parameter.
(Unwind_RaiseException): Ditto.
(Unwind_ForcedUnwind): Ditto.
(Remove): Removed.
(Begin_Handler): Change type of parameter.
(End_Handler): Ditto. Now delete the exception if still present.
(Setup_Key): Removed.
(Is_Setup_And_Not_Propagated): Removed.
(Set_Setup_And_Not_Propagated): Ditto.
(Clear_Setup_And_Not_Propagated): Ditto.
(Save_Occurrence_And_Private): Ditto.
(EID_For): Add 'not null' constraint on parameter.
(Setup_Exception): Does nothing.
(Propagate_Exception): Simplified.
* exp_ch11.adb (Expand_N_Raise_Statement): In back-end exception model,
re-raise is not expanded anymore.
* s-except.ads (Foreign_Exception): New exception - placeholder for
non Ada exceptions.
* raise-gcc.c (__gnat_setup_current_excep): Declare
(CXX_EXCEPTION_CLASS): Define (not yet used)
(GNAT_EXCEPTION_CLASS): Define.
(is_handled_by): Handle foreign exceptions.
(PERSONALITY_FUNCTION): Call __gnat_setup_current_excep.
2011-08-29 Jose Ruiz <ruiz@adacore.com>
* a-synbar.adb (Synchronous_Barrier): Some additional clarification.
2011-08-29 Thomas Quinot <quinot@adacore.com>
* a-synbar-posix.adb: Minor reformatting.
......
gcc/ada/a-exexpr-gcc.adb
......@@ -104,11 +104,12 @@ package body Exception_Propagation is
-- Map the corresponding C type used in Unwind_Exception below
type Unwind_Exception is record
Class : Exception_Class := GNAT_Exception_Class;
Cleanup : System.Address := System.Null_Address;
Class : Exception_Class;
Cleanup : System.Address;
Private1 : Unwind_Word;
Private2 : Unwind_Word;
end record;
pragma Convention (C, Unwind_Exception);
-- Map the GCC struct used for exception handling
for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
......@@ -117,6 +118,19 @@ package body Exception_Propagation is
-- maximally aligned (see unwind.h). See additional comments on the
-- alignment below.
type GCC_Exception_Access is access all Unwind_Exception;
pragma Convention (C, GCC_Exception_Access);
-- Pointer to a GCC exception
procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
-- Procedure to free any GCC exception
Foreign_Exception : aliased System.Standard_Library.Exception_Data;
pragma Import (Ada, Foreign_Exception,
"system__exceptions__foreign_exception");
-- Id for foreign exceptions
--------------------------------------------------------------
-- GNAT Specific Entities To Deal With The GCC EH Circuitry --
--------------------------------------------------------------
......@@ -128,13 +142,8 @@ package body Exception_Propagation is
Header : Unwind_Exception;
-- ABI Exception header first
Id : Exception_Id;
-- GNAT Exception identifier. This is filled by Propagate_Exception
-- and then used by the personality routine to determine if the context
-- it examines contains a handler for the exception being propagated.
Next_Exception : EOA;
-- Used to create a linked list of exception occurrences
Occurrence : Exception_Occurrence;
-- The Ada occurrence
end record;
pragma Convention (C, GNAT_GCC_Exception);
......@@ -158,20 +167,40 @@ package body Exception_Propagation is
type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
function To_GNAT_GCC_Exception is new
Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
function To_GCC_Exception is new
Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access);
procedure Free is new Unchecked_Deallocation
(GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
procedure Free is new Unchecked_Deallocation
(Exception_Occurrence, EOA);
function To_GNAT_GCC_Exception is new
Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
Excep : not null GNAT_GCC_Exception_Access);
pragma Convention (C, GNAT_GCC_Exception_Cleanup);
-- Procedure called when a GNAT GCC exception is free.
procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access);
pragma No_Return (Propagate_GCC_Exception);
-- Propagate a GCC exception
procedure Reraise_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access);
pragma No_Return (Reraise_GCC_Exception);
pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
-- Called to implement raise without exception, ie reraise. Called
-- directly from gigi.
procedure Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access);
pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
-- Write Get_Current_Excep.all from GCC_Exception
function CleanupUnwind_Handler
(UW_Version : Integer;
UW_Phases : Unwind_Action;
UW_Eclass : Exception_Class;
UW_Exception : not null access GNAT_GCC_Exception;
UW_Exception : not null GCC_Exception_Access;
UW_Context : System.Address;
UW_Argument : System.Address) return Unwind_Reason_Code;
-- Hook called at each step of the forced unwinding we perform to
......@@ -183,57 +212,25 @@ package body Exception_Propagation is
-- __gnat stubs for these.
procedure Unwind_RaiseException
(UW_Exception : not null access GNAT_GCC_Exception);
(UW_Exception : not null GCC_Exception_Access);
pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
procedure Unwind_ForcedUnwind
(UW_Exception : not null access GNAT_GCC_Exception;
(UW_Exception : not null GCC_Exception_Access;
UW_Handler : System.Address;
UW_Argument : System.Address);
pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
------------------------------------------------------------------
-- Occurrence Stack Management Facilities for the GCC-EH Scheme --
------------------------------------------------------------------
function Remove
(Top : EOA;
Excep : GNAT_GCC_Exception_Access) return Boolean;
-- Remove Excep from the stack starting at Top.
-- Return True if Excep was found and removed, false otherwise.
-- Hooks called when entering/leaving an exception handler for a given
-- occurrence, aimed at handling the stack of active occurrences. The
-- calls are generated by gigi in tree_transform/N_Exception_Handler.
procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
pragma Export (C, Begin_Handler, "__gnat_begin_handler");
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
procedure End_Handler (GCC_Exception : GCC_Exception_Access);
pragma Export (C, End_Handler, "__gnat_end_handler");
Setup_Key : constant := 16#DEAD#;
-- To handle the case of a task "transferring" an exception occurrence to
-- another task, for instance via Exceptional_Complete_Rendezvous, we need
-- to be able to identify occurrences which have been Setup and not yet
-- Propagated. We hijack one of the common header fields for that purpose,
-- setting it to a special key value during the setup process, clearing it
-- at the very beginning of the propagation phase, and expecting it never
-- to be reset to the special value later on. A 16-bit value is used rather
-- than a 32-bit value for static compatibility with 16-bit targets such as
-- AAMP (where type Unwind_Word will be 16 bits).
function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
procedure Set_Setup_And_Not_Propagated (E : EOA);
procedure Clear_Setup_And_Not_Propagated (E : EOA);
procedure Save_Occurrence_And_Private
(Target : out Exception_Occurrence;
Source : Exception_Occurrence);
-- Copy all the components of Source to Target as well as the
-- Private_Data pointer.
--------------------------------------------------------------------
-- Accessors to Basic Components of a GNAT Exception Data Pointer --
--------------------------------------------------------------------
......@@ -254,7 +251,7 @@ package body Exception_Propagation is
function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
pragma Export (C, Import_Code_For, "__gnat_import_code_for");
function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
return Exception_Id;
pragma Export (C, EID_For, "__gnat_eid_for");
......@@ -274,64 +271,24 @@ package body Exception_Propagation is
All_Others_Value : constant Integer := 16#7FFF#;
pragma Export (C, All_Others_Value, "__gnat_all_others_value");
------------
-- Remove --
------------
function Remove
(Top : EOA;
Excep : GNAT_GCC_Exception_Access) return Boolean
is
Prev : GNAT_GCC_Exception_Access := null;
Iter : EOA := Top;
GCC_Exception : GNAT_GCC_Exception_Access;
begin
-- Pop stack
loop
pragma Assert (Iter.Private_Data /= System.Null_Address);
GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
if GCC_Exception = Excep then
if Prev = null then
-- Special case for the top of the stack: shift the contents
-- of the next item to the top, since top is at a fixed
-- location and can't be changed.
Iter := GCC_Exception.Next_Exception;
if Iter = null then
-- Stack is now empty
Top.Private_Data := System.Null_Address;
else
Save_Occurrence_And_Private (Top.all, Iter.all);
Free (Iter);
end if;
else
Prev.Next_Exception := GCC_Exception.Next_Exception;
Free (Iter);
end if;
Free (GCC_Exception);
--------------------------------
-- GNAT_GCC_Exception_Cleanup --
--------------------------------
return True;
end if;
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
Excep : not null GNAT_GCC_Exception_Access) is
pragma Unreferenced (Reason);
exit when GCC_Exception.Next_Exception = null;
procedure Free is new Unchecked_Deallocation
(GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
Prev := GCC_Exception;
Iter := GCC_Exception.Next_Exception;
end loop;
Copy : GNAT_GCC_Exception_Access := Excep;
begin
-- Simply free the memory
return False;
end Remove;
Free (Copy);
end GNAT_GCC_Exception_Cleanup;
---------------------------
-- CleanupUnwind_Handler --
......@@ -341,17 +298,16 @@ package body Exception_Propagation is
(UW_Version : Integer;
UW_Phases : Unwind_Action;
UW_Eclass : Exception_Class;
UW_Exception : not null access GNAT_GCC_Exception;
UW_Exception : not null GCC_Exception_Access;
UW_Context : System.Address;
UW_Argument : System.Address) return Unwind_Reason_Code
is
pragma Unreferenced
(UW_Version, UW_Eclass, UW_Exception, UW_Context, UW_Argument);
pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
begin
-- Terminate when the end of the stack is reached
if UW_Phases >= UA_END_OF_STACK then
Setup_Current_Excep (UW_Exception);
Unhandled_Exception_Terminate;
end if;
......@@ -362,54 +318,6 @@ package body Exception_Propagation is
return URC_NO_REASON;
end CleanupUnwind_Handler;
---------------------------------
-- Is_Setup_And_Not_Propagated --
---------------------------------
function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
GCC_E : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
end Is_Setup_And_Not_Propagated;
------------------------------------
-- Clear_Setup_And_Not_Propagated --
------------------------------------
procedure Clear_Setup_And_Not_Propagated (E : EOA) is
GCC_E : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
pragma Assert (GCC_E /= null);
GCC_E.Header.Private1 := 0;
end Clear_Setup_And_Not_Propagated;
----------------------------------
-- Set_Setup_And_Not_Propagated --
----------------------------------
procedure Set_Setup_And_Not_Propagated (E : EOA) is
GCC_E : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
pragma Assert (GCC_E /= null);
GCC_E.Header.Private1 := Setup_Key;
end Set_Setup_And_Not_Propagated;
--------------------------------
-- Save_Occurrence_And_Private --
--------------------------------
procedure Save_Occurrence_And_Private
(Target : out Exception_Occurrence;
Source : Exception_Occurrence)
is
begin
Save_Occurrence_No_Private (Target, Source);
Target.Private_Data := Source.Private_Data;
end Save_Occurrence_And_Private;
---------------------
-- Setup_Exception --
---------------------
......@@ -423,80 +331,56 @@ package body Exception_Propagation is
Current : EOA;
Reraised : Boolean := False)
is
Top : constant EOA := Current;
Next : EOA;
GCC_Exception : GNAT_GCC_Exception_Access;
pragma Unreferenced (Excep, Current, Reraised);
begin
-- The exception Excep is soon to be propagated, and the
-- storage used for that will be the occurrence statically allocated
-- for the current thread. This storage might currently be used for a
-- still active occurrence, so we need to push it on the thread's
-- occurrence stack (headed at that static occurrence) before it gets
-- clobbered.
-- What we do here is to trigger this push when need be, and allocate a
-- Private_Data block for the forthcoming Propagation.
-- Some tasking rendez-vous attempts lead to an occurrence transfer
-- from the server to the client (see Exceptional_Complete_Rendezvous).
-- In those cases Setup is called twice for the very same occurrence
-- before it gets propagated: once from the server, because this is
-- where the occurrence contents is elaborated and known, and then
-- once from the client when it detects the case and actually raises
-- the exception in its own context.
-- The Is_Setup_And_Not_Propagated predicate tells us when we are in
-- the second call to Setup for a Transferred occurrence, and there is
-- nothing to be done here in this situation. This predicate cannot be
-- True if we are dealing with a Reraise, and we may even be called
-- with a raw uninitialized Excep occurrence in this case so we should
-- not check anyway. Observe the front-end expansion for a "raise;" to
-- see that happening. We get a local occurrence and a direct call to
-- Save_Occurrence without the intermediate init-proc call.
if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
return;
end if;
-- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
-- local occurrence declarations together with save/restore operations
-- generated by the front-end, and this routine has nothing to do.
-- Allocate what will be the Private_Data block for the exception
-- to be propagated.
null;
end Setup_Exception;
GCC_Exception := new GNAT_GCC_Exception;
-------------------------
-- Setup_Current_Excep --
-------------------------
-- If the Top of the occurrence stack is not currently used for an
-- active exception (the stack is empty) we just need to setup the
-- Private_Data pointer.
procedure Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access) is
Excep : constant EOA := Get_Current_Excep.all;
begin
-- Setup the exception occurrence
-- Otherwise, we also need to shift the contents of the Top of the
-- stack in a freshly allocated entry and link everything together.
if GCC_Exception.Class = GNAT_Exception_Class then
if Top.Private_Data /= System.Null_Address then
Next := new Exception_Occurrence;
Save_Occurrence_And_Private (Next.all, Top.all);
-- From the GCC exception
GCC_Exception.Next_Exception := Next;
Top.Private_Data := GCC_Exception.all'Address;
end if;
declare
GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (GCC_Exception);
begin
Excep.all := GNAT_Occurrence.Occurrence;
end;
else
Top.Private_Data := GCC_Exception.all'Address;
-- A default one
Set_Setup_And_Not_Propagated (Top);
end Setup_Exception;
Excep.Id := Foreign_Exception'Access;
Excep.Msg_Length := 0;
Excep.Cleanup_Flag := False;
Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID;
Excep.Num_Tracebacks := 0;
Excep.Private_Data := System.Null_Address;
end if;
end Setup_Current_Excep;
-------------------
-- Begin_Handler --
-------------------
procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
pragma Unreferenced (GCC_Exception);
begin
-- Every necessary operation related to the occurrence stack has
-- already been performed by Propagate_Exception. This hook remains for
-- potential future necessity in optimizing the overall scheme, as well
-- a useful debugging tool.
null;
end Begin_Handler;
......@@ -504,13 +388,68 @@ package body Exception_Propagation is
-- End_Handler --
-----------------
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
Removed : Boolean;
procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
begin
Removed := Remove (Get_Current_Excep.all, GCC_Exception);
pragma Assert (Removed);
if GCC_Exception /= null then
-- The exception might have been reraised, in this case the cleanup
-- mustn't be called.
Unwind_DeleteException (GCC_Exception);
end if;
end End_Handler;
-----------------------------
-- Reraise_GCC_Exception --
-----------------------------
procedure Reraise_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
begin
-- Simply propagate it
Propagate_GCC_Exception (GCC_Exception);
end Reraise_GCC_Exception;
-----------------------------
-- Propagate_GCC_Exception --
-----------------------------
-- Call Unwind_RaiseException to actually throw, taking care of handling
-- the two phase scheme it implements.
procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
begin
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
-- there is no regular handler, it will return.
Unwind_RaiseException (GCC_Exception);
-- If we get here we know the exception is not handled, as otherwise
-- Unwind_RaiseException arranges for the handler to be entered. Take
-- the necessary steps to enable the debugger to gain control while the
-- stack is still intact.
Setup_Current_Excep (GCC_Exception);
Notify_Unhandled_Exception;
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
-- unwinding hook calls Unhandled_Exception_Terminate when end of stack
-- is reached.
Unwind_ForcedUnwind (GCC_Exception,
CleanupUnwind_Handler'Address,
System.Null_Address);
-- We get here in case of error.
-- The debugger has been notified before the second step above.
Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate;
end Propagate_GCC_Exception;
-------------------------
-- Propagate_Exception --
-------------------------
......@@ -530,18 +469,6 @@ package body Exception_Propagation is
GCC_Exception : GNAT_GCC_Exception_Access;
begin
pragma Assert (Excep.Private_Data /= System.Null_Address);
-- Retrieve the Private_Data for this occurrence and set the useful
-- flags for the personality routine, which will be called for each
-- frame via Unwind_RaiseException below.
GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
Clear_Setup_And_Not_Propagated (Excep);
GCC_Exception.Id := Excep.Id;
-- Compute the backtrace for this occurrence if the corresponding
-- binder option has been set. Call_Chain takes care of the reraise
-- case.
......@@ -565,32 +492,17 @@ package body Exception_Propagation is
Call_Chain (Excep);
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
-- there is no regular handler, it will return.
-- Allocate the GCC exception
Unwind_RaiseException (GCC_Exception);
GCC_Exception := new GNAT_GCC_Exception'
(Header => (Class => GNAT_Exception_Class,
Cleanup => GNAT_GCC_Exception_Cleanup'Address,
Private1 => 0,
Private2 => 0),
Occurrence => Excep.all);
-- If we get here we know the exception is not handled, as otherwise
-- Unwind_RaiseException arranges for the handler to be entered. Take
-- the necessary steps to enable the debugger to gain control while the
-- stack is still intact.
Notify_Unhandled_Exception;
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
-- unwinding hook calls Unhandled_Exception_Terminate when end of stack
-- is reached.
Unwind_ForcedUnwind (GCC_Exception,
CleanupUnwind_Handler'Address,
System.Null_Address);
-- We get here in case of error.
-- The debugger has been notified before the second step above.
Unhandled_Exception_Terminate;
-- Propagate it.
Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
end Propagate_Exception;
-------------
......@@ -598,10 +510,10 @@ package body Exception_Propagation is
-------------
function EID_For
(GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
(GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
is
begin
return GNAT_Exception.Id;
return GNAT_Exception.Occurrence.Id;
end EID_For;
---------------------
......@@ -633,67 +545,4 @@ package body Exception_Propagation is
return E.all.Lang;
end Language_For;
-----------
-- Notes --
-----------
-- The current model implemented for the stack of occurrences is a
-- simplification of previous attempts, which all proved to be flawed or
-- would have needed significant additional circuitry to be made to work
-- correctly.
-- We now represent every propagation by a new entry on the stack, which
-- means that an exception occurrence may appear more than once (e.g. when
-- it is reraised during the course of its own handler).
-- This may seem overcostly compared to the C++ model as implemented in
-- the g++ v3 libstd. This is actually understandable when one considers
-- the extra variations of possible run-time configurations induced by the
-- freedom offered by the Save_Occurrence/Reraise_Occurrence public
-- interface.
-- The basic point is that arranging for an occurrence to always appear at
-- most once on the stack requires a way to determine if a given occurrence
-- is already there, which is not as easy as it might seem.
-- An attempt was made to use the Private_Data pointer for this purpose.
-- It did not work because:
-- 1) The Private_Data has to be saved by Save_Occurrence to be usable
-- as a key in case of a later reraise,
-- 2) There is no easy way to synchronize End_Handler for an occurrence
-- and the data attached to potential copies, so these copies may end
-- up pointing to stale data. Moreover ...
-- 3) The same address may be reused for different occurrences, which
-- defeats the idea of using it as a key.
-- The example below illustrates:
-- Saved_CE : Exception_Occurrence;
-- begin
-- raise Constraint_Error;
-- exception
-- when CE: others =>
-- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA
-- end;
-- <= Saved_CE.PDA is stale (!)
-- begin
-- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!)
-- exception
-- when others =>
-- Reraise_Occurrence (Saved_CE);
-- end;
-- Not releasing the Private_Data via End_Handler could be an option,
-- but making this to work while still avoiding memory leaks is far
-- from trivial.
-- The current scheme has the advantage of being simple, and induces
-- extra costs only in reraise cases which is acceptable.
end Exception_Propagation;
gcc/ada/a-synbar.adb
......@@ -40,8 +40,11 @@ package body Ada.Synchronous_Barriers is
-- The condition "Wait'Count = Release_Threshold" opens the barrier when
-- the required number of tasks is reached. The condition "Keep_Open"
-- leaves the barrier open while there are queued tasks. While there are
-- tasks in the queue no new task will be queued, guaranteeing that the
-- barrier will remain open only for those tasks already inside.
-- tasks in the queue no new task will be queued (no new protected
-- action can be started on a protected object while another protected
-- action on the same protected object is underway, RM 9.5.1 (4)),
-- guaranteeing that the barrier will remain open only for those tasks
-- already inside the queue when the barrier was open.
entry Wait (Notified : out Boolean)
when Keep_Open or else Wait'Count = Release_Threshold
......
gcc/ada/exp_ch11.adb
......@@ -1665,6 +1665,15 @@ package body Exp_Ch11 is
-- does not have a choice parameter specification, then we provide one.
else
-- Don't expand if back end exception handling active
if VM_Target = No_VM
and then Exception_Mechanism = Back_End_Exceptions
then
return;
end if;
-- Find innermost enclosing exception handler (there must be one,
-- since the semantics has already verified that this raise statement
-- is valid, and a raise with no arguments is only permitted in the
......
gcc/ada/gnat_rm.texi
......@@ -5074,23 +5074,23 @@ Syntax:
@smallexample @c ada
pragma Test_Case (
[Name =>] static_string_Expression
,[Mode =>] (Normal | Robustness)
,[Mode =>] (Nominal | Robustness)
[, Requires => Boolean_Expression]
[, Ensures => Boolean_Expression]);
@end smallexample
@noindent
The @code{Test_Case} pragma allows defining fine-grain specifications
for use by testing and verification tools. The compiler only checks its
for use by testing and verification tools. The compiler checks its
validity but the presence of pragma @code{Test_Case} does not lead to
any modification of the code generated by the compiler.
@code{Test_Case} pragmas may only appear immediately following the
(separate) declaration of a subprogram. Only other pragmas may intervene
(that is appear between the subprogram declaration and its
postconditions).
(separate) declaration of a subprogram in a package declaration, inside
a package spec unit. Only other pragmas may intervene (that is appear
between the subprogram declaration and a test case).
The compiler checks that boolean expression given in @code{Requires} and
The compiler checks that boolean expressions given in @code{Requires} and
@code{Ensures} are valid, where the rules for @code{Requires} are the
same as the rule for an expression in @code{Precondition} and the rules
for @code{Ensures} are the same as the rule for an expression in
......@@ -5103,7 +5103,7 @@ package Math_Functions is
...
function Sqrt (Arg : Float) return Float;
pragma Test_Case (Name => "Test 1",
Mode => Normal,
Mode => Nominal,
Requires => Arg < 100,
Ensures => Sqrt'Result < 10);
...
......@@ -5113,10 +5113,10 @@ end Math_Functions;
@noindent
The meaning of a test case is that, if the associated subprogram is
executed in a context where @code{Requires} holds, then @code{Ensures}
should hold when the subprogram returns. Mode @code{Normal} indicates
that the input context should satisfy the normal precondition of the
should hold when the subprogram returns. Mode @code{Nominal} indicates
that the input context should satisfy the precondition of the
subprogram, and the output context should then satisfy its
postcondition. More @code{Robustness} indicates that the normal pre- and
postcondition. More @code{Robustness} indicates that the pre- and
postcondition of the subprogram should be ignored for this test case.
@node Pragma Thread_Local_Storage
......
gcc/ada/raise-gcc.c
......@@ -101,6 +101,7 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *);
_Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
extern void __gnat_setup_current_excep (_Unwind_Exception *);
#ifdef IN_RTS /* For eh personality routine */
......@@ -108,6 +109,10 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
#include "unwind-dw2-fde.h"
#include "unwind-pe.h"
/* The known and handled exception classes. */
#define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL
#define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL
/* --------------------------------------------------------------
-- The DB stuff below is there for debugging purposes only. --
......@@ -853,39 +858,51 @@ extern Exception_Id EID_For (_GNAT_Exception * e);
static int
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
{
/* Pointer to the GNAT exception data corresponding to the propagated
occurrence. */
_Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
/* Base matching rules: An exception data (id) matches itself, "when
all_others" matches anything and "when others" matches anything unless
explicitly stated otherwise in the propagated occurrence. */
bool is_handled =
choice == E
|| choice == GNAT_ALL_OTHERS
|| (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
/* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
may have different exception data pointers that should match for the
same condition code, if both an export and an import have been
registered. The import code for both the choice and the propagated
occurrence are expected to have been masked off regarding severity
bits already (at registration time for the former and from within the
low level exception vector for the latter). */
if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS)
{
/* Pointer to the GNAT exception data corresponding to the propagated
occurrence. */
_Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
/* Base matching rules: An exception data (id) matches itself, "when
all_others" matches anything and "when others" matches anything
unless explicitly stated otherwise in the propagated occurrence. */
bool is_handled =
choice == E
|| choice == GNAT_ALL_OTHERS
|| (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
/* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
may have different exception data pointers that should match for the
same condition code, if both an export and an import have been
registered. The import code for both the choice and the propagated
occurrence are expected to have been masked off regarding severity
bits already (at registration time for the former and from within the
low level exception vector for the latter). */
#ifdef VMS
#define Non_Ada_Error system__aux_dec__non_ada_error
extern struct Exception_Data Non_Ada_Error;
is_handled |=
(Language_For (E) == 'V'
&& choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
&& ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
&& Import_Code_For (choice) == Import_Code_For (E))
|| choice == (_Unwind_Ptr)&Non_Ada_Error));
# define Non_Ada_Error system__aux_dec__non_ada_error
extern struct Exception_Data Non_Ada_Error;
is_handled |=
(Language_For (E) == 'V'
&& choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
&& ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
&& Import_Code_For (choice) == Import_Code_For (E))
|| choice == (_Unwind_Ptr)&Non_Ada_Error));
#endif
return is_handled;
return is_handled;
}
else
{
# define Foreign_Exception system__exceptions__foreign_exception;
extern struct Exception_Data Foreign_Exception;
return choice == GNAT_ALL_OTHERS
|| choice == GNAT_OTHERS
|| choice == (_Unwind_Ptr)&Foreign_Exception;
}
}
/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
......@@ -1079,9 +1096,6 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
Condition Handling Facility. */
int uw_version = (int) version_arg;
_Unwind_Action uw_phases = (_Unwind_Action) phases_arg;
_GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
region_descriptor region;
action_descriptor action;
......@@ -1089,7 +1103,7 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
possible variation on VMS for IA64. */
if (uw_version != 1)
{
#if defined (VMS) && defined (__IA64)
#if defined (VMS) && defined (__IA64)
/* Assume we're called with sigargs/mechargs arguments if really
unexpected bits are set in our first two formals. Redirect to the
......@@ -1103,7 +1117,7 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
if ((unsigned int)uw_version & version_unexpected_bits_mask
&& (unsigned int)uw_phases & phases_unexpected_bits_mask)
return __gnat_handle_vms_condition (version_arg, phases_arg);
#endif
#endif
return _URC_FATAL_PHASE1_ERROR;
}
......@@ -1160,6 +1174,9 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
setup_to_install
(uw_context, uw_exception, action.landing_pad, action.ttype_filter);
/* Write current exception, so that it can be retrieved from Ada. */
__gnat_setup_current_excep (uw_exception);
return _URC_INSTALL_CONTEXT;
}
......
gcc/ada/s-except.ads
......@@ -81,4 +81,9 @@ package System.Exceptions is
private
ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
Foreign_Exception : exception;
pragma Unreferenced (Foreign_Exception);
-- This hidden exception is used to represent non-Ada exception to
-- Ada handlers. It is in fact referenced by its linking name.
end System.Exceptions;
gcc/ada/sem_ch13.adb
......@@ -1365,6 +1365,12 @@ package body Sem_Ch13 is
begin
Args := New_List;
if Nkind (Parent (N)) = N_Compilation_Unit then
Error_Msg_N
("incorrect placement of aspect `Test_Case`", E);
goto Continue;
end if;
if Nkind (Expr) /= N_Aggregate then
Error_Msg_NE
("wrong syntax for aspect `Test_Case` for &", Id, E);
......
gcc/ada/sem_prag.adb
......@@ -500,24 +500,13 @@ package body Sem_Prag is
procedure Check_Test_Case;
-- Called to process a test-case pragma. The treatment is similar to the
-- one for pre- and postcondition in Check_Precondition_Postcondition.
-- There are three cases:
--
-- The pragma appears after a subprogram spec
--
-- The first step is to analyze the pragma, but this is skipped if
-- the subprogram spec appears within a package specification
-- (because this is the case where we delay analysis till the end of
-- the spec). Then (whether or not it was analyzed), the pragma is
-- chained to the subprogram in question (using Spec_TC_List and
-- Next_Pragma).
--
-- The pragma appears at the start of subprogram body declarations
--
-- In this case an immediate return to the caller is made, and the
-- pragma is NOT analyzed.
--
-- In all other cases, an error message for bad placement is given
-- one for pre- and postcondition in Check_Precondition_Postcondition,
-- except the placement rules for the test-case pragma are stricter.
-- This pragma may only occur after a subprogram spec declared directly
-- in a package spec unit. In this case, the pragma is chained to the
-- subprogram in question (using Spec_TC_List and Next_Pragma) and
-- analysis of the pragma is delayed till the end of the spec. In
-- all other cases, an error message for bad placement is given.
procedure Check_Valid_Configuration_Pragma;
-- Legality checks for placement of a configuration pragma
......@@ -1972,9 +1961,9 @@ package body Sem_Prag is
PO : Node_Id;
procedure Chain_TC (PO : Node_Id);
-- If PO is an entry or a [generic] subprogram declaration node, then
-- the test-case applies to this subprogram and the processing for
-- the pragma is completed. Otherwise the pragma is misplaced.
-- If PO is a [generic] subprogram declaration node, then the
-- test-case applies to this subprogram and the processing for the
-- pragma is completed. Otherwise the pragma is misplaced.
--------------
-- Chain_TC --
......@@ -1993,20 +1982,22 @@ package body Sem_Prag is
("pragma% cannot be applied to abstract subprogram");
end if;
elsif Nkind (PO) = N_Entry_Declaration then
if From_Aspect_Specification (N) then
Error_Pragma ("aspect% cannot be applied to entry");
else
Error_Pragma ("pragma% cannot be applied to entry");
end if;
elsif not Nkind_In (PO, N_Subprogram_Declaration,
N_Generic_Subprogram_Declaration,
N_Entry_Declaration)
N_Generic_Subprogram_Declaration)
then
Pragma_Misplaced;
end if;
-- Here if we have [generic] subprogram or entry declaration
-- Here if we have [generic] subprogram declaration
if Nkind (PO) = N_Entry_Declaration then
S := Defining_Entity (PO);
else
S := Defining_Unit_Name (Specification (PO));
end if;
S := Defining_Unit_Name (Specification (PO));
-- Note: we do not analyze the pragma at this point. Instead we
-- delay this analysis until the end of the declarative part in
......@@ -2054,6 +2045,16 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
-- Test cases should only appear in package spec unit
if Get_Source_Unit (N) = No_Unit
or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
N_Package_Declaration,
N_Generic_Package_Declaration)
then
Pragma_Misplaced;
end if;
-- Search prior declarations
P := N;
......@@ -2082,7 +2083,18 @@ package body Sem_Prag is
elsif not Comes_From_Source (PO) then
null;
-- Only remaining possibility is subprogram declaration
-- Only remaining possibility is subprogram declaration. First
-- check that it is declared directly in a package declaration.
-- This may be either the package declaration for the current unit
-- being defined or a local package declaration.
elsif not Present (Parent (Parent (PO)))
or else not Present (Parent (Parent (Parent (PO))))
or else not Nkind_In (Parent (Parent (PO)),
N_Package_Declaration,
N_Generic_Package_Declaration)
then
Pragma_Misplaced;
else
Chain_TC (PO);
......@@ -2090,14 +2102,6 @@ package body Sem_Prag is
end if;
end loop;
-- If we fall through loop, pragma is at start of list, so see if it
-- is in the pragmas after a library level subprogram.
if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
Chain_TC (Unit (Parent (Parent (N))));
return;
end if;
-- If we fall through, pragma was misplaced
Pragma_Misplaced;
......@@ -13301,7 +13305,7 @@ package body Sem_Prag is
-- [, Requires => Boolean_EXPRESSION]
-- [, Ensures => Boolean_EXPRESSION]);
-- MODE_TYPE ::= Normal | Robustness
-- MODE_TYPE ::= Nominal | Robustness
when Pragma_Test_Case => Test_Case : declare
begin
......@@ -13314,7 +13318,7 @@ package body Sem_Prag is
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Check_Optional_Identifier (Arg2, Name_Mode);
Check_Arg_Is_One_Of (Arg2, Name_Normal, Name_Robustness);
Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
if Arg_Count = 4 then
Check_Identifier (Arg3, Name_Requires);
......
gcc/ada/snames.ads-tmpl
......@@ -661,7 +661,7 @@ package Snames is
Name_No_Requeue_Statements : constant Name_Id := N + $;
Name_No_Task_Attributes : constant Name_Id := N + $;
Name_No_Task_Attributes_Package : constant Name_Id := N + $;
Name_Normal : constant Name_Id := N + $;
Name_Nominal : constant Name_Id := N + $;
Name_On : constant Name_Id := N + $;
Name_Policy : constant Name_Id := N + $;
Name_Parameter_Types : constant Name_Id := N + $;
......
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