a-except.ads, [...]: (Rmsg_28): Fix description for E.4(18) check.

2007-04-20  Thomas Quinot  <quinot@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* a-except.ads, a-except.adb: (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.
	(Local_Raise): Moved to System.Exceptions
	More convenient to have this as a separate unit

	* s-except.adb, s-except.ads: New files.

	* a-exextr.adb (Unhandled_Exception): Delete - replaced by
	Debug_Unhandled_Exception in System.Exceptions where it belongs
	together with a couple of other debug helpers.
	(Notify_Unhandled_Exception): Use Debug_Unhandled_Exception instead of
	the former Unhandled_Exception.

	* exp_ch11.ads, exp_ch11.adb: (Possible_Local_Raise): New procedure
	(Warn_No_Exception_Propagation): New procedure
	(Warn_If_No_Propagation): Rewritten for new warning generation
	(Expand_Exception_Handlers): New warning generation
	(Expand_N_Raise_xxx_Error): Rewritten for new warnings
	(Add_Exception_Label): Use Special_Exception_Package_Used for test
	instead of Most_Recent_Exception_Used (accomodates Exception_Traces)
	(Expand_Local_Exception_Handlers): Unconditionally add extra block wrap
	even if restriction is set (makes life easier in Check_Returns)
	(Expand_Local_Exception_Handlers): Follow renamed entity chain when
	checking exception identities.
	(Expand_Local_Exception_Handlers): Do not optimize when all others case
	(Expand_Local_Exception_Handlers): Set Exception_Junk flag on generated
	block for handler (used by Check_Returns)
	(Expand_Local_Exception_Handlers): Local_Raise now takes an address
	(Expand_N_Handled_Sequence_Of_Statements): Properly handle -gnatd.x to
	remove all exception handlers when optimizing local raise statements.
	(Find_Local_Handler): Use Get_Renamed_Entity
	(Expand_N_Handled_Sequence_Of_Statements): If the handled sequence is
	marked analyzed after expanding exception handlers, do not generate
	redundant cleanup actions, because they have been constructed already.

From-SVN: r125375

1 files changed, 45 insertions, 13 deletions

diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb
index 41d7e02..0048622 100644
--- a/gcc/ada/a-except.adb
+++ b/gcc/ada/a-except.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- --
@@ -50,6 +50,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;
 
@@ -521,8 +522,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;
@@ -690,16 +691,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 --
    -----------------------
@@ -800,6 +791,7 @@ package body Ada.Exceptions is
       --  pragma Volatile is peculiar!
 
    begin
+      Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
       Process_Raise_Exception (E);
    end Raise_Current_Excep;
 
@@ -837,6 +829,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 --
    -------------------------------