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

3 files changed, 88 insertions, 62 deletions

diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 4863321..6af47c3 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 f42d094..7b8326a 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 4047436..4f6c4c1 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;