Commit b9f3a4b0 by Thomas Quinot Committed by Arnaud Charlet

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
parent 1c8e4e2e
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -49,6 +49,7 @@ pragma Polling (Off); ...@@ -49,6 +49,7 @@ pragma Polling (Off);
-- elaboration circularities with System.Exception_Tables. -- elaboration circularities with System.Exception_Tables.
with System; use System; with System; use System;
with System.Exceptions; use System.Exceptions;
with System.Standard_Library; use System.Standard_Library; with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links; with System.Soft_Links; use System.Soft_Links;
with System.WCh_Con; use System.WCh_Con; with System.WCh_Con; use System.WCh_Con;
...@@ -570,8 +571,8 @@ package body Ada.Exceptions is ...@@ -570,8 +571,8 @@ package body Ada.Exceptions is
Rmsg_25 : constant String := "potentially blocking operation" & NUL; Rmsg_25 : constant String := "potentially blocking operation" & NUL;
Rmsg_26 : constant String := "stubbed subprogram called" & NUL; Rmsg_26 : constant String := "stubbed subprogram called" & NUL;
Rmsg_27 : constant String := "unchecked union restriction" & NUL; Rmsg_27 : constant String := "unchecked union restriction" & NUL;
Rmsg_28 : constant String := "illegal use of remote access-to-" & Rmsg_28 : constant String := "actual/returned class-wide value "
"class-wide type, see RM E.4(18)" & NUL; & "not transportable" & NUL;
Rmsg_29 : constant String := "empty storage pool" & NUL; Rmsg_29 : constant String := "empty storage pool" & NUL;
Rmsg_30 : constant String := "explicit raise" & NUL; Rmsg_30 : constant String := "explicit raise" & NUL;
Rmsg_31 : constant String := "infinite recursion" & NUL; Rmsg_31 : constant String := "infinite recursion" & NUL;
...@@ -760,16 +761,6 @@ package body Ada.Exceptions is ...@@ -760,16 +761,6 @@ package body Ada.Exceptions is
-- in case we do not want any exception tracing support. This is -- in case we do not want any exception tracing support. This is
-- why this package is separated. -- 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 -- -- Stream Attributes --
----------------------- -----------------------
...@@ -815,19 +806,28 @@ package body Ada.Exceptions is ...@@ -815,19 +806,28 @@ package body Ada.Exceptions is
-- This is so the debugger can reliably inspect the parameter when -- This is so the debugger can reliably inspect the parameter when
-- inserting a breakpoint at the start of this procedure. -- 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 Volatile (Id);
pragma Warnings (Off, 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 begin
Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
Exception_Propagation.Propagate_Exception Exception_Propagation.Propagate_Exception
(E => E, From_Signal_Handler => False); (E => E, From_Signal_Handler => False);
end Raise_Current_Excep; end Raise_Current_Excep;
...@@ -870,6 +870,46 @@ package body Ada.Exceptions is ...@@ -870,6 +870,46 @@ package body Ada.Exceptions is
Raise_Current_Excep (E); Raise_Current_Excep (E);
end Raise_Exception_Always; 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 -- -- Raise_From_Signal_Handler --
------------------------------- -------------------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -209,15 +209,6 @@ private ...@@ -209,15 +209,6 @@ private
-- private barrier, so we can place this function in the private part -- private barrier, so we can place this function in the private part
-- where the compiler can find it, but the spec is unchanged.) -- 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 := ""); procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
pragma No_Return (Raise_Exception_Always); pragma No_Return (Raise_Exception_Always);
pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception");
...@@ -245,6 +236,12 @@ private ...@@ -245,6 +236,12 @@ private
-- PC value in the machine state or in some other way ask the operating -- PC value in the machine state or in some other way ask the operating
-- system to return here rather than to the original location. -- 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); procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_Always); pragma No_Return (Reraise_Occurrence_Always);
-- This differs from Raise_Occurrence only in that the caller guarantees -- This differs from Raise_Occurrence only in that the caller guarantees
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -36,7 +36,6 @@ with Ada.Tags; ...@@ -36,7 +36,6 @@ with Ada.Tags;
with System.Soft_Links; with System.Soft_Links;
with Unchecked_Conversion;
with System.Restrictions; with System.Restrictions;
package body System.Finalization_Implementation is package body System.Finalization_Implementation is
...@@ -55,17 +54,17 @@ package body System.Finalization_Implementation is ...@@ -55,17 +54,17 @@ package body System.Finalization_Implementation is
type RC_Ptr is access all Record_Controller; type RC_Ptr is access all Record_Controller;
function To_RC_Ptr is function To_RC_Ptr is
new Unchecked_Conversion (Address, RC_Ptr); new Ada.Unchecked_Conversion (Address, RC_Ptr);
procedure Raise_Exception_No_Defer procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
(E : Exception_Id; pragma Import
Message : String := ""); (Ada, Raise_From_Controlled_Operation,
pragma Import (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_from_controlled_operation");
"ada__exceptions__raise_exception_no_defer"); pragma No_Return (Raise_From_Controlled_Operation);
pragma No_Return (Raise_Exception_No_Defer); -- Raise Program_Error from an exception that occurred during an Adjust or
-- Raise an exception without deferring abort. Note that we have to -- Finalize operation. We use this rather kludgy Ada Import interface
-- use this rather kludgy Ada Import interface, since this subprogram -- because this procedure is not available in the visible part of the
-- is not available in the visible spec of Ada.Exceptions. -- Ada.Exceptions spec.
procedure Raise_From_Finalize procedure Raise_From_Finalize
(L : Finalizable_Ptr; (L : Finalizable_Ptr;
...@@ -335,7 +334,7 @@ package body System.Finalization_Implementation is ...@@ -335,7 +334,7 @@ package body System.Finalization_Implementation is
type Ptr is access all Fake_Exception_Occurence; type Ptr is access all Fake_Exception_Occurence;
function To_Ptr is new function To_Ptr is new
Unchecked_Conversion (Exception_Occurrence_Access, Ptr); Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
X : Exception_Id := Null_Id; X : Exception_Id := Null_Id;
...@@ -437,7 +436,7 @@ package body System.Finalization_Implementation is ...@@ -437,7 +436,7 @@ package body System.Finalization_Implementation is
type Obj_Ptr is access all Faked_Type_Of_Obj; type Obj_Ptr is access all Faked_Type_Of_Obj;
function To_Obj_Ptr is function To_Obj_Ptr is
new Unchecked_Conversion (Address, Obj_Ptr); new Ada.Unchecked_Conversion (Address, Obj_Ptr);
begin begin
return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address); return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
...@@ -497,7 +496,6 @@ package body System.Finalization_Implementation is ...@@ -497,7 +496,6 @@ package body System.Finalization_Implementation is
From_Abort : Boolean; From_Abort : Boolean;
E_Occ : Exception_Occurrence) E_Occ : Exception_Occurrence)
is is
Msg : constant String := Exception_Message (E_Occ);
P : Finalizable_Ptr := L; P : Finalizable_Ptr := L;
Q : Finalizable_Ptr; Q : Finalizable_Ptr;
...@@ -517,24 +515,15 @@ package body System.Finalization_Implementation is ...@@ -517,24 +515,15 @@ package body System.Finalization_Implementation is
P := Q; P := Q;
end loop; end loop;
-- If finalization from an Abort, then nothing to do
if From_Abort then if From_Abort then
null; -- If finalization from an Abort, then nothing to do
-- If no message, then add our own message saying what happened
elsif Msg = "" then null;
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 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 if;
end Raise_From_Finalize; end Raise_From_Finalize;
......
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