From: Thomas Quinot Date: Wed, 6 Jun 2007 10:46:09 +0000 (+0200) Subject: 2007-04-20 Thomas Quinot X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b9f3a4b07df15081483fd4caa5d1e29266917fa3;p=gcc.git 2007-04-20 Thomas Quinot Olivier Hainque * 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 --- diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 48633214f64..6af47c3686e 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -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 -- ------------------------------- diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index f42d094ae05..7b8326a6f30 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -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 diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 4047436e89b..4f6c4c165e4 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -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); - - 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; @@ -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 - 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;