mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-04 14:51:06 +08:00
2007-04-20 Thomas Quinot <quinot@adacore.com>
Olivier Hainque <hainque@adacore.com> * a-except-2005.ads, a-except-2005.adb (Raise_From_Controlled_Operation): New procedure in (private part of) Ada.Exceptions (standard runtime version). Used to provide informational exception message when Program_Error is raised as a result of an Adjust or Finalize operation propagating an exception. (Rmsg_28): Fix description for E.4(18) check. (Raise_Current_Excep): Call Debug_Raise_Exception just before propagation starts, to let debuggers know about the event in a reliable fashion. Take the address of E and dereference to make sure it is homed on stack and prevent the stores from being deleted, necessary for proper debugger behavior on "break exception" hits. (Local_Raise): Moved to System.Exceptions * s-finimp.adb (Raise_From_Finalize): Code to construct an appropriate exception message from the current occurrence and raise Program_Error has been moved to Ada.Exceptions.Raise_From_Controlled_Operation. From-SVN: r125457
This commit is contained in:
Thomas Quinot
Arnaud Charlet
parent
1c8e4e2e55
commit
b9f3a4b07d
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, 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- --
|
||||
@ -49,6 +49,7 @@ pragma Polling (Off);
|
||||
-- elaboration circularities with System.Exception_Tables.
|
||||
|
||||
with System; use System;
|
||||
with System.Exceptions; use System.Exceptions;
|
||||
with System.Standard_Library; use System.Standard_Library;
|
||||
with System.Soft_Links; use System.Soft_Links;
|
||||
with System.WCh_Con; use System.WCh_Con;
|
||||
@ -570,8 +571,8 @@ package body Ada.Exceptions is
|
||||
Rmsg_25 : constant String := "potentially blocking operation" & NUL;
|
||||
Rmsg_26 : constant String := "stubbed subprogram called" & NUL;
|
||||
Rmsg_27 : constant String := "unchecked union restriction" & NUL;
|
||||
Rmsg_28 : constant String := "illegal use of remote access-to-" &
|
||||
"class-wide type, see RM E.4(18)" & NUL;
|
||||
Rmsg_28 : constant String := "actual/returned class-wide value "
|
||||
& "not transportable" & NUL;
|
||||
Rmsg_29 : constant String := "empty storage pool" & NUL;
|
||||
Rmsg_30 : constant String := "explicit raise" & NUL;
|
||||
Rmsg_31 : constant String := "infinite recursion" & NUL;
|
||||
@ -760,16 +761,6 @@ package body Ada.Exceptions is
|
||||
-- in case we do not want any exception tracing support. This is
|
||||
-- why this package is separated.
|
||||
|
||||
-----------------
|
||||
-- Local_Raise --
|
||||
-----------------
|
||||
|
||||
procedure Local_Raise (Excep : Exception_Id) is
|
||||
pragma Warnings (Off, Excep);
|
||||
begin
|
||||
return;
|
||||
end Local_Raise;
|
||||
|
||||
-----------------------
|
||||
-- Stream Attributes --
|
||||
-----------------------
|
||||
@ -815,19 +806,28 @@ package body Ada.Exceptions is
|
||||
-- This is so the debugger can reliably inspect the parameter when
|
||||
-- inserting a breakpoint at the start of this procedure.
|
||||
|
||||
Id : Exception_Id := E;
|
||||
-- To provide support for breakpoints on unhandled exceptions, the
|
||||
-- debugger will also need to be able to inspect the value of E from
|
||||
-- inner frames so we need to make sure that its value is also spilled
|
||||
-- on stack. We take the address and dereference using volatile local
|
||||
-- objects for this purpose.
|
||||
|
||||
-- The pragma Warnings (Off) are needed because the compiler knows that
|
||||
-- these locals are not referenced and that this use of pragma Volatile
|
||||
-- is peculiar!
|
||||
|
||||
type EID_Access is access Exception_Id;
|
||||
|
||||
Access_To_E : EID_Access := E'Unrestricted_Access;
|
||||
pragma Volatile (Access_To_E);
|
||||
pragma Warnings (Off, Access_To_E);
|
||||
|
||||
Id : Exception_Id := Access_To_E.all;
|
||||
pragma Volatile (Id);
|
||||
pragma Warnings (Off, Id);
|
||||
-- In order to provide support for breakpoints on unhandled exceptions,
|
||||
-- the debugger will also need to be able to inspect the value of E from
|
||||
-- another (inner) frame. So we need to make sure that if E is passed in
|
||||
-- a register, its value is also spilled on stack. For this, we store
|
||||
-- the parameter value in a local variable, and add a pragma Volatile to
|
||||
-- make sure it is spilled. The pragma Warnings (Off) is needed because
|
||||
-- the compiler knows that Id is not referenced and that this use of
|
||||
-- pragma Volatile is peculiar!
|
||||
|
||||
begin
|
||||
Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
|
||||
Exception_Propagation.Propagate_Exception
|
||||
(E => E, From_Signal_Handler => False);
|
||||
end Raise_Current_Excep;
|
||||
@ -870,6 +870,46 @@ package body Ada.Exceptions is
|
||||
Raise_Current_Excep (E);
|
||||
end Raise_Exception_Always;
|
||||
|
||||
-------------------------------------
|
||||
-- Raise_From_Controlled_Operation --
|
||||
-------------------------------------
|
||||
|
||||
procedure Raise_From_Controlled_Operation
|
||||
(X : Ada.Exceptions.Exception_Occurrence)
|
||||
is
|
||||
Prefix : constant String := "adjust/finalize raised ";
|
||||
Orig_Msg : constant String := Exception_Message (X);
|
||||
New_Msg : constant String := Prefix & Exception_Name (X);
|
||||
|
||||
begin
|
||||
if Orig_Msg'Length >= Prefix'Length
|
||||
and then
|
||||
Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) =
|
||||
Prefix
|
||||
then
|
||||
-- Message already has proper prefix, just re-reraise PROGRAM_ERROR
|
||||
|
||||
Raise_Exception_No_Defer
|
||||
(E => Program_Error'Identity,
|
||||
Message => Orig_Msg);
|
||||
|
||||
elsif Orig_Msg = "" then
|
||||
|
||||
-- No message present: just provide our own
|
||||
|
||||
Raise_Exception_No_Defer
|
||||
(E => Program_Error'Identity,
|
||||
Message => New_Msg);
|
||||
|
||||
else
|
||||
-- Message present, add informational prefix
|
||||
|
||||
Raise_Exception_No_Defer
|
||||
(E => Program_Error'Identity,
|
||||
Message => New_Msg & ": " & Orig_Msg);
|
||||
end if;
|
||||
end Raise_From_Controlled_Operation;
|
||||
|
||||
-------------------------------
|
||||
-- Raise_From_Signal_Handler --
|
||||
-------------------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
@ -209,15 +209,6 @@ private
|
||||
-- private barrier, so we can place this function in the private part
|
||||
-- where the compiler can find it, but the spec is unchanged.)
|
||||
|
||||
procedure Local_Raise (Excep : Exception_Id);
|
||||
pragma Export (Ada, Local_Raise);
|
||||
-- This is a dummy routine, used only by the debugger for the purpose of
|
||||
-- logging local raise statements that were transformed into a direct goto
|
||||
-- to the handler code. The compiler in this case generates:
|
||||
--
|
||||
-- Local_Raise (exception_id);
|
||||
-- goto Handler
|
||||
|
||||
procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
|
||||
pragma No_Return (Raise_Exception_Always);
|
||||
pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception");
|
||||
@ -245,6 +236,12 @@ private
|
||||
-- PC value in the machine state or in some other way ask the operating
|
||||
-- system to return here rather than to the original location.
|
||||
|
||||
procedure Raise_From_Controlled_Operation
|
||||
(X : Ada.Exceptions.Exception_Occurrence);
|
||||
pragma No_Return (Raise_From_Controlled_Operation);
|
||||
-- Raise Program_Error, proviving information about X (an exception
|
||||
-- raised during a controlled operation) in the exception message.
|
||||
|
||||
procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
|
||||
pragma No_Return (Reraise_Occurrence_Always);
|
||||
-- This differs from Raise_Occurrence only in that the caller guarantees
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, 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- --
|
||||
@ -36,7 +36,6 @@ with Ada.Tags;
|
||||
|
||||
with System.Soft_Links;
|
||||
|
||||
with Unchecked_Conversion;
|
||||
with System.Restrictions;
|
||||
|
||||
package body System.Finalization_Implementation is
|
||||
@ -55,17 +54,17 @@ package body System.Finalization_Implementation is
|
||||
type RC_Ptr is access all Record_Controller;
|
||||
|
||||
function To_RC_Ptr is
|
||||
new Unchecked_Conversion (Address, RC_Ptr);
|
||||
new Ada.Unchecked_Conversion (Address, RC_Ptr);
|
||||
|
||||
procedure Raise_Exception_No_Defer
|
||||
(E : Exception_Id;
|
||||
Message : String := "");
|
||||
pragma Import (Ada, Raise_Exception_No_Defer,
|
||||
"ada__exceptions__raise_exception_no_defer");
|
||||
pragma No_Return (Raise_Exception_No_Defer);
|
||||
-- Raise an exception without deferring abort. Note that we have to
|
||||
-- use this rather kludgy Ada Import interface, since this subprogram
|
||||
-- is not available in the visible spec of Ada.Exceptions.
|
||||
procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
|
||||
pragma Import
|
||||
(Ada, Raise_From_Controlled_Operation,
|
||||
"ada__exceptions__raise_from_controlled_operation");
|
||||
pragma No_Return (Raise_From_Controlled_Operation);
|
||||
-- Raise Program_Error from an exception that occurred during an Adjust or
|
||||
-- Finalize operation. We use this rather kludgy Ada Import interface
|
||||
-- because this procedure is not available in the visible part of the
|
||||
-- Ada.Exceptions spec.
|
||||
|
||||
procedure Raise_From_Finalize
|
||||
(L : Finalizable_Ptr;
|
||||
@ -335,7 +334,7 @@ package body System.Finalization_Implementation is
|
||||
type Ptr is access all Fake_Exception_Occurence;
|
||||
|
||||
function To_Ptr is new
|
||||
Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
|
||||
Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
|
||||
|
||||
X : Exception_Id := Null_Id;
|
||||
|
||||
@ -437,7 +436,7 @@ package body System.Finalization_Implementation is
|
||||
|
||||
type Obj_Ptr is access all Faked_Type_Of_Obj;
|
||||
function To_Obj_Ptr is
|
||||
new Unchecked_Conversion (Address, Obj_Ptr);
|
||||
new Ada.Unchecked_Conversion (Address, Obj_Ptr);
|
||||
|
||||
begin
|
||||
return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
|
||||
@ -497,7 +496,6 @@ package body System.Finalization_Implementation is
|
||||
From_Abort : Boolean;
|
||||
E_Occ : Exception_Occurrence)
|
||||
is
|
||||
Msg : constant String := Exception_Message (E_Occ);
|
||||
P : Finalizable_Ptr := L;
|
||||
Q : Finalizable_Ptr;
|
||||
|
||||
@ -517,24 +515,15 @@ package body System.Finalization_Implementation is
|
||||
P := Q;
|
||||
end loop;
|
||||
|
||||
-- If finalization from an Abort, then nothing to do
|
||||
|
||||
if From_Abort then
|
||||
-- If finalization from an Abort, then nothing to do
|
||||
|
||||
null;
|
||||
|
||||
-- If no message, then add our own message saying what happened
|
||||
|
||||
elsif Msg = "" then
|
||||
Raise_Exception_No_Defer
|
||||
(E => Program_Error'Identity,
|
||||
Message => "exception " &
|
||||
Exception_Name (E_Occ) &
|
||||
" raised during finalization");
|
||||
|
||||
-- If there was a message, pass it on
|
||||
|
||||
else
|
||||
Raise_Exception_No_Defer (Program_Error'Identity, Msg);
|
||||
-- Else raise Program_Error with an appropriate message
|
||||
|
||||
Raise_From_Controlled_Operation (E_Occ);
|
||||
end if;
|
||||
end Raise_From_Finalize;
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user