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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125457
138bc75d-0d04-0410-961f-
82ee72b054a4
-- --
-- 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- --
-- 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;
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;
-- 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 --
-----------------------
-- 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;
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 --
-------------------------------
-- --
-- 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 --
-- 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");
-- 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
-- --
-- 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- --
with System.Soft_Links;
-with Unchecked_Conversion;
with System.Restrictions;
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);
-
- 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.
+ new Ada.Unchecked_Conversion (Address, RC_Ptr);
+
+ 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;
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;
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);
From_Abort : Boolean;
E_Occ : Exception_Occurrence)
is
- Msg : constant String := Exception_Message (E_Occ);
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
P := Q;
end loop;
- -- If finalization from an Abort, then nothing to do
-
if From_Abort then
- null;
-
- -- If no message, then add our own message saying what happened
+ -- If finalization from an Abort, then nothing to do
- 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
+ null;
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;
OSDN Git Service
