-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- builds may be done with bootstrap compilers that cannot handle these
-- additions. The full version of Ada.Exceptions can be found in the files
-- a-except-2005.ads/adb, and is used for all other builds where full Ada
--- 2005 functionality is required. in particular, it is used for building
+-- 2005 functionality is required. In particular, it is used for building
-- run times on all targets.
-pragma Warnings (Off);
pragma Compiler_Unit;
-pragma Warnings (On);
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
package body Ada.Exceptions is
pragma Suppress (All_Checks);
- -- We definitely do not want exceptions occurring within this unit, or
- -- we are in big trouble. If an exceptional situation does occur, better
- -- that it not be raised, since raising it can cause confusing chaos.
+ -- We definitely do not want exceptions occurring within this unit, or we
+ -- are in big trouble. If an exceptional situation does occur, better that
+ -- it not be raised, since raising it can cause confusing chaos.
-----------------------
-- Local Subprograms --
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
- -- Little routine to output string to stderr that is also used
- -- in the tasking run time.
+ -- Little routine to output string to stderr that is also used in the
+ -- tasking run time.
procedure To_Stderr (C : Character);
pragma Inline (To_Stderr);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
- -- Little routine to output a character to stderr, used by some of
- -- the separate units below.
+ -- Little routine to output a character to stderr, used by some of the
+ -- separate units below.
package Exception_Data is
(Id : Exception_Id;
Message : String);
-- This routine is called to setup the exception referenced by the
- -- Current_Excep field in the TSD to contain the indicated Id value
- -- and message. Message is a string which is generated as the
- -- exception message.
+ -- Current_Excep field in the TSD to contain the indicated Id value and
+ -- message. Message is a string which is generated as the exception
+ -- message.
--------------------------------------
-- Exception information subprogram --
-- Call stack traceback locations: (only if at least one location)
-- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
--
- -- The lines are separated by a ASCII.LF character.
- -- The nnnn is the partition Id given as decimal digits.
+ -- The lines are separated by a ASCII.LF character
+ --
+ -- The nnnn is the partition Id given as decimal digits
+ --
-- The 0x... line represents traceback program counter locations, in
-- execution order with the first one being the exception location. It
-- is present only
--
- -- The Exception_Name and Message lines are omitted in the abort
- -- signal case, since this is not really an exception.
+ -- The Exception_Name and Message lines are omitted in the abort signal
+ -- case, since this is not really an exception.
- -- !! If the format of the generated string is changed, please note
- -- !! that an equivalent modification to the routine String_To_EO must
- -- !! be made to preserve proper functioning of the stream attributes.
+ -- Note: If the format of the generated string is changed, please note
+ -- that an equivalent modification to the routine String_To_EO must be
+ -- made to preserve proper functioning of the stream attributes.
---------------------------------------
-- Exception backtracing subprograms --
procedure Unhandled_Exception_Terminate;
pragma No_Return (Unhandled_Exception_Terminate);
- -- This procedure is called to terminate execution following an
- -- unhandled exception. The exception information, including
- -- traceback if available is output, and execution is then
- -- terminated. Note that at the point where this routine is
- -- called, the stack has typically been destroyed.
+ -- This procedure is called to terminate program execution following an
+ -- unhandled exception. The exception information, including traceback
+ -- if available is output, and execution is then terminated. Note that
+ -- at the point where this routine is called, the stack has typically
+ -- been destroyed.
end Exception_Traces;
procedure Raise_With_Msg (E : Exception_Id);
pragma No_Return (Raise_With_Msg);
pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
- -- Raises an exception with given exception id value. A message
- -- is associated with the raise, and has already been stored in the
- -- exception occurrence referenced by the Current_Excep in the TSD.
- -- Abort is deferred before the raise call.
+ -- Raises an exception with given exception id value. A message is
+ -- associated with the raise, and has already been stored in the exception
+ -- occurrence referenced by the Current_Excep in the TSD. Abort is deferred
+ -- before the raise call.
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
pragma No_Return (Raise_With_Location_And_Msg);
-- Raise an exception with given exception id value. A filename and line
-- number is associated with the raise and is stored in the exception
- -- occurrence and in addition a string message M is appended to
- -- this (if M is not null).
+ -- occurrence and in addition a string message M is appended to this
+ -- if M is not null.
procedure Raise_Constraint_Error
(File : System.Address;
procedure Reraise;
pragma No_Return (Reraise);
pragma Export (C, Reraise, "__gnat_reraise");
- -- Reraises the exception referenced by the Current_Excep field of
- -- the TSD (all fields of this exception occurrence are set). Abort
- -- is deferred before the reraise operation.
+ -- Reraises the exception referenced by the Current_Excep field of the TSD
+ -- (all fields of this exception occurrence are set). Abort is deferred
+ -- before the reraise operation.
-- Save_Occurrence variations: As the management of the private data
- -- attached to occurrences is delicate, wether or not pointers to such
+ -- attached to occurrences is delicate, whether or not pointers to such
-- data has to be copied in various situations is better made explicit.
-- The following procedures provide an internal interface to help making
-- this explicit.
-- Run-Time Check Routines --
-----------------------------
- -- These routines are called from the runtime to raise a specific
- -- exception with a reason message attached. The parameters are
- -- the file name and line number in each case. The names are keyed
- -- to the codes defined in Types.ads and a-types.h (for example,
- -- the name Rcheck_05 refers to the Reason whose Pos code is 5).
+ -- Routines to a specific exception with a reason message attached. The
+ -- parameters are the file name and line number in each case. The names are
+ -- keyed to the codes defined in types.ads and a-types.h (for example, the
+ -- name Rcheck_05 refers to the Reason RT_Exception_Code'Val (5)).
procedure Rcheck_00 (File : System.Address; Line : Integer);
procedure Rcheck_01 (File : System.Address; Line : Integer);
procedure Rcheck_30 (File : System.Address; Line : Integer);
procedure Rcheck_31 (File : System.Address; Line : Integer);
procedure Rcheck_32 (File : System.Address; Line : Integer);
+ procedure Rcheck_33 (File : System.Address; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
+ pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
-- None of these procedures ever returns (they raise an exception!). By
-- using pragma No_Return, we ensure that any junk code after the call,
pragma No_Return (Rcheck_29);
pragma No_Return (Rcheck_30);
pragma No_Return (Rcheck_32);
+ pragma No_Return (Rcheck_33);
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
Rmsg_13 : constant String := "tag check failed" & NUL;
Rmsg_14 : constant String := "access before elaboration" & NUL;
Rmsg_15 : constant String := "accessibility check failed" & NUL;
- Rmsg_16 : constant String := "all guards closed" & NUL;
- Rmsg_17 : constant String := "Current_Task referenced in entry" &
+ Rmsg_16 : constant String := "attempt to take address of" &
+ " intrinsic subprogram" & NUL;
+ Rmsg_17 : constant String := "all guards closed" & NUL;
+ Rmsg_18 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
- Rmsg_18 : constant String := "duplicated entry address" & NUL;
- Rmsg_19 : constant String := "explicit raise" & NUL;
- Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL;
- Rmsg_21 : constant String := "implicit return with No_Return" & NUL;
- Rmsg_22 : constant String := "misaligned address value" & NUL;
- Rmsg_23 : constant String := "missing return" & NUL;
- Rmsg_24 : constant String := "overlaid controlled object" & NUL;
- 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 := "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;
- Rmsg_32 : constant String := "object too large" & NUL;
+ Rmsg_19 : constant String := "duplicated entry address" & NUL;
+ Rmsg_20 : constant String := "explicit raise" & NUL;
+ Rmsg_21 : constant String := "finalize/adjust raised exception" & NUL;
+ Rmsg_22 : constant String := "implicit return with No_Return" & NUL;
+ Rmsg_23 : constant String := "misaligned address value" & NUL;
+ Rmsg_24 : constant String := "missing return" & NUL;
+ Rmsg_25 : constant String := "overlaid controlled object" & NUL;
+ Rmsg_26 : constant String := "potentially blocking operation" & NUL;
+ Rmsg_27 : constant String := "stubbed subprogram called" & NUL;
+ Rmsg_28 : constant String := "unchecked union restriction" & NUL;
+ Rmsg_29 : constant String := "actual/returned class-wide" &
+ " value not transportable" & NUL;
+ Rmsg_30 : constant String := "empty storage pool" & NUL;
+ Rmsg_31 : constant String := "explicit raise" & NUL;
+ Rmsg_32 : constant String := "infinite recursion" & NUL;
+ Rmsg_33 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
-- perform periodic but not systematic operations.
procedure Poll is separate;
- -- The actual polling routine is separate, so that it can easily
- -- be replaced with a target dependent version.
+ -- The actual polling routine is separate, so that it can easily be
+ -- replaced with a target dependent version.
------------------------------
-- Current_Target_Exception --
-- EO_To_String --
------------------
- -- We use the null string to represent the null occurrence, otherwise
- -- we output the Exception_Information string for the occurrence.
+ -- We use the null string to represent the null occurrence, otherwise we
+ -- output the Exception_Information string for the occurrence.
function EO_To_String (X : Exception_Occurrence) return String
renames Stream_Attributes.EO_To_String;
(X : Exception_Occurrence) return Exception_Id
is
begin
- -- Note that the following test used to be here for the original
- -- Ada 95 semantics, but these were modified by AI-241 to require
- -- returning Null_Id instead of raising Constraint_Error.
+ -- Note that the following test used to be here for the original Ada 95
+ -- semantics, but these were modified by AI-241 to require returning
+ -- Null_Id instead of raising Constraint_Error.
-- if X.Id = Null_Id then
-- raise Constraint_Error;
--------------------
package body Exception_Data is separate;
- -- This package can be easily dummied out if we do not want the
- -- basic support for exception messages (such as in Ada 83).
+ -- This package can be easily dummied out if we do not want the basic
+ -- support for exception messages (such as in Ada 83).
package body Exception_Propagation is
----------------------
package body Exception_Traces is separate;
- -- Depending on the underlying support for IO the implementation
- -- will differ. Moreover we would like to dummy out this package
- -- in case we do not want any exception tracing support. This is
- -- why this package is separated.
+ -- Depending on the underlying support for IO the implementation will
+ -- differ. Moreover we would like to dummy out this package in case we do
+ -- not want any exception tracing support. This is why this package is
+ -- separated.
-----------------------
-- Stream Attributes --
pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
begin
- -- WARNING: There should be no exception handler for this body
- -- because this would cause gigi to prepend a setup for a new
- -- jmpbuf to the sequence of statements in case of built-in sjljl.
- -- We would then always get this new buf in Jumpbuf_Ptr instead of the
- -- one for the exception we are handling, which would completely break
- -- the whole design of this procedure.
+ -- WARNING: There should be no exception handler for this body because
+ -- this would cause gigi to prepend a setup for a new jmpbuf to the
+ -- sequence of statements in case of built-in sjljl. We would then
+ -- always get this new buf in Jumpbuf_Ptr instead of the one for the
+ -- exception we are handling, which would completely break the whole
+ -- design of this procedure.
- -- If the jump buffer pointer is non-null, transfer control using
- -- it. Otherwise announce an unhandled exception (note that this
- -- means that we have no finalizations to do other than at the outer
- -- level). Perform the necessary notification tasks in both cases.
+ -- If the jump buffer pointer is non-null, transfer control using it.
+ -- Otherwise announce an unhandled exception (note that this means that
+ -- we have no finalizations to do other than at the outer level).
+ -- Perform the necessary notification tasks in both cases.
if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then
(E : Exception_Id;
Message : String := "")
is
+ EF : Exception_Id := E;
+
begin
- if E /= null then
- Exception_Data.Set_Exception_Msg (E, Message);
- Abort_Defer.all;
- Raise_Current_Excep (E);
+ -- Raise CE if E = Null_ID (AI-446)
+
+ if E = null then
+ EF := Constraint_Error'Identity;
end if;
- -- Note: if E is null then just return (Ada 95 semantics)
+ -- Go ahead and raise appropriate exception
- return;
+ Exception_Data.Set_Exception_Msg (EF, Message);
+ Abort_Defer.all;
+ Raise_Current_Excep (EF);
end Raise_Exception;
----------------------------
procedure Rcheck_29 (File : System.Address; Line : Integer) is
begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_29'Address);
+ Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
end Rcheck_29;
procedure Rcheck_30 (File : System.Address; Line : Integer) is
Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
end Rcheck_32;
+ procedure Rcheck_33 (File : System.Address; Line : Integer) is
+ begin
+ Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
+ end Rcheck_33;
+
-------------
-- Reraise --
-------------
begin
-- Setup Target as an exception to be propagated in the calling task
-- (rendezvous-wise), taking care not to clobber the associated private
- -- data. Target is expected to be a pointer to the calling task's
- -- fixed TSD occurrence, which is very different from Get_Current_Excep
- -- here because this subprogram is called from the called task.
+ -- data. Target is expected to be a pointer to the calling task's fixed
+ -- TSD occurrence, which is very different from Get_Current_Excep here
+ -- because this subprogram is called from the called task.
Save_Occurrence_No_Private (Target.all, Source);
end Transfer_Occurrence;
---------------
procedure To_Stderr (C : Character) is
-
type int is new Integer;
procedure put_char_stderr (C : int);
OSDN Git Service
