-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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. --
-- --
------------------------------------------------------------------------------
--- This version is used for all Ada 2005 builds. It differs from a-except.ads
--- only with respect to the addition of Wide_[Wide]Exception_Name functions.
+-- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005.
+-- It is used in all situations except for the build of the compiler and
+-- other basic tools. For these latter builds, we use an Ada 95-only version.
-- The reason for this splitting off of a separate version is that bootstrap
-- compilers often will be used that do not support Ada 2005 features, and
-- Ada.Exceptions is part of the compiler sources.
--- The base version of this unit Ada.Exceptions omits the Wide version of
--- Exception_Name and is used to build the compiler and other basic tools.
-
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
-- elaboration circularities with System.Exception_Tables.
with System; use System;
+with System.Exceptions; use System.Exceptions;
+with System.Exceptions_Debug; use System.Exceptions_Debug;
with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links;
with System.WCh_Con; use System.WCh_Con;
-- Store up to Max_Tracebacks in Excep, corresponding to the current
-- call chain.
+ function Image (Index : Integer) return String;
+ -- Return string image corresponding to Index
+
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
-- Little routine to output string to stderr that is also used
---------------------------------
procedure Set_Exception_C_Msg
- (Id : Exception_Id;
- Msg1 : System.Address;
- Line : Integer := 0;
- Msg2 : System.Address := System.Null_Address);
+ (Id : Exception_Id;
+ Msg1 : System.Address;
+ Line : Integer := 0;
+ Column : Integer := 0;
+ Msg2 : System.Address := System.Null_Address);
-- 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. Msg1 is a null terminated string which is generated
-- as the exception message. If line is non-zero, then a colon and
-- the decimal representation of this integer is appended to the
- -- message. When Msg2 is non-null, a space and this additional null
- -- terminated string is added to the message.
+ -- message. Ditto for Column. When Msg2 is non-null, a space and this
+ -- additional null terminated string is added to the message.
procedure Set_Exception_Msg
(Id : Exception_Id;
-- Exception propagation routines --
------------------------------------
- procedure Setup_Exception
- (Excep : EOA;
- Current : EOA;
- Reraised : Boolean := False);
- -- Perform the necessary operations to prepare the propagation of Excep
- -- in a task where Current is the current occurrence. Excep is assumed
- -- to be a valid (non null) pointer.
- --
- -- This should be called before any (re-)setting of the current
- -- occurrence. Any such (re-)setting shall take care *not* to clobber
- -- the Private_Data component.
- --
- -- Having Current provided as an argument (instead of retrieving it via
- -- Get_Current_Excep internally) is required to allow one task to setup
- -- an exception for another task, which is used by Transfer_Occurrence.
-
- procedure Propagate_Exception
- (E : Exception_Id;
- From_Signal_Handler : Boolean);
+ procedure Propagate_Exception;
pragma No_Return (Propagate_Exception);
-- This procedure propagates the exception represented by the occurrence
-- referenced by Current_Excep in the TSD for the current task.
procedure Raise_Current_Excep (E : Exception_Id);
pragma No_Return (Raise_Current_Excep);
pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
- -- This is a simple wrapper to Exception_Propagation.Propagate_Exception
- -- setting the From_Signal_Handler argument to False.
+ -- This is a simple wrapper to Exception_Propagation.Propagate_Exception.
--
-- This external name for Raise_Current_Excep is historical, and probably
-- should be changed but for now we keep it, because gdb and gigi know
(E : Exception_Id;
F : System.Address;
L : Integer;
+ C : Integer := 0;
M : System.Address := System.Null_Address);
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 column and a string message M may be
+ -- appended to this (if not null/0).
procedure Raise_Constraint_Error
(File : System.Address;
-- Raise constraint error with file:line information
procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address);
+ (File : System.Address;
+ Line : Integer;
+ Column : Integer;
+ Msg : System.Address);
pragma No_Return (Raise_Constraint_Error_Msg);
pragma Export
(C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
- -- Raise constraint error with file:line + msg information
+ -- Raise constraint error with file:line:col + msg information
procedure Raise_Program_Error
(File : System.Address;
-- 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
- -- data has to be copied in various situations is better made explicit.
- -- The following procedures provide an internal interface to help making
- -- this explicit.
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence);
- -- Copy all the components of Source to Target, except the
- -- Private_Data pointer.
-
procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access;
Source : Exception_Occurrence);
-- 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).
+ -- These routines 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
+ -- RT_Exception_Code'Val (5)).
procedure Rcheck_00 (File : System.Address; Line : Integer);
procedure Rcheck_01 (File : System.Address; Line : Integer);
procedure Rcheck_19 (File : System.Address; Line : Integer);
procedure Rcheck_20 (File : System.Address; Line : Integer);
procedure Rcheck_21 (File : System.Address; Line : Integer);
- procedure Rcheck_22 (File : System.Address; Line : Integer);
procedure Rcheck_23 (File : System.Address; Line : Integer);
procedure Rcheck_24 (File : System.Address; Line : Integer);
procedure Rcheck_25 (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);
+ procedure Rcheck_34 (File : System.Address; Line : Integer);
+
+ procedure Rcheck_00_Ext
+ (File : System.Address; Line, Column : Integer);
+ procedure Rcheck_05_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
+ procedure Rcheck_06_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
+ procedure Rcheck_12_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer);
+
+ procedure Rcheck_22 (File : System.Address; Line : Integer);
+ -- This routine is separated out because it has quite different behavior
+ -- from the others. This is the "finalize/adjust raised exception". This
+ -- subprogram is always called with abort deferred, unlike all other
+ -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer.
+ --
+ -- It should probably have a distinguished name ???
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");
+ pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
+
+ pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext");
+ pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext");
+ pragma Export (C, Rcheck_06_Ext, "__gnat_rcheck_06_ext");
+ pragma Export (C, Rcheck_12_Ext, "__gnat_rcheck_12_ext");
-- 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);
+ pragma No_Return (Rcheck_34);
+
+ pragma No_Return (Rcheck_00_Ext);
+ pragma No_Return (Rcheck_05_Ext);
+ pragma No_Return (Rcheck_06_Ext);
+ pragma No_Return (Rcheck_12_Ext);
---------------------------------------------
-- 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 := "improper use of generic subtype" &
+ " with predicate" & NUL;
+ Rmsg_19 : 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 := "illegal use of remote access-to-" &
- "class-wide type, see RM E.4(18)" & 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_20 : constant String := "duplicated entry address" & NUL;
+ Rmsg_21 : constant String := "explicit raise" & NUL;
+ Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
+ Rmsg_23 : constant String := "implicit return with No_Return" & NUL;
+ Rmsg_24 : constant String := "misaligned address value" & NUL;
+ Rmsg_25 : constant String := "missing return" & NUL;
+ Rmsg_26 : constant String := "overlaid controlled object" & NUL;
+ Rmsg_27 : constant String := "potentially blocking operation" & NUL;
+ Rmsg_28 : constant String := "stubbed subprogram called" & NUL;
+ Rmsg_29 : constant String := "unchecked union restriction" & NUL;
+ Rmsg_30 : constant String := "actual/returned class-wide" &
+ " value not transportable" & NUL;
+ Rmsg_31 : constant String := "empty storage pool" & NUL;
+ Rmsg_32 : constant String := "explicit raise" & NUL;
+ Rmsg_33 : constant String := "infinite recursion" & NUL;
+ Rmsg_34 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
-- in case we do not want any exception tracing support. This is
-- why this package is separated.
- -----------------
- -- Local_Raise --
- -----------------
+ -----------
+ -- Image --
+ -----------
- procedure Local_Raise (Excep : Exception_Id) is
- pragma Warnings (Off, Excep);
+ function Image (Index : Integer) return String is
+ Result : constant String := Integer'Image (Index);
begin
- return;
- end Local_Raise;
+ if Result (1) = ' ' then
+ return Result (2 .. Result'Last);
+ else
+ return Result;
+ end if;
+ end Image;
-----------------------
-- Stream Attributes --
-- Raise_Constraint_Error --
----------------------------
- procedure Raise_Constraint_Error
- (File : System.Address;
- Line : Integer)
- is
+ procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
begin
- Raise_With_Location_And_Msg
- (Constraint_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
end Raise_Constraint_Error;
--------------------------------
--------------------------------
procedure Raise_Constraint_Error_Msg
- (File : System.Address;
- Line : Integer;
- Msg : System.Address)
+ (File : System.Address;
+ Line : Integer;
+ Column : Integer;
+ Msg : System.Address)
is
begin
Raise_With_Location_And_Msg
- (Constraint_Error_Def'Access, File, Line, Msg);
+ (Constraint_Error_Def'Access, File, Line, Column, Msg);
end Raise_Constraint_Error_Msg;
-------------------------
-------------------------
procedure Raise_Current_Excep (E : Exception_Id) is
-
- pragma Inspection_Point (E);
- -- This is so the debugger can reliably inspect the parameter when
- -- inserting a breakpoint at the start of this procedure.
-
- Id : Exception_Id := E;
- 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
- Exception_Propagation.Propagate_Exception
- (E => E, From_Signal_Handler => False);
+ begin
+ Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
+ Exception_Propagation.Propagate_Exception;
end Raise_Current_Excep;
---------------------
(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 we simply return, which is correct Ada 95
- -- semantics. If we are operating in Ada 2005 mode, then the expander
- -- generates a raise Constraint_Error immediately following the call
- -- to provide the required Ada 2005 semantics (see AI-329). We do it
- -- this way to avoid having run time dependencies on the Ada version.
+ -- Go ahead and raise appropriate exception
+
+ Exception_Data.Set_Exception_Msg (EF, Message);
- return;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Raise_Current_Excep (EF);
end Raise_Exception;
----------------------------
is
begin
Exception_Data.Set_Exception_Msg (E, Message);
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (E);
end Raise_Exception_Always;
+ ------------------------------
+ -- Raise_Exception_No_Defer --
+ ------------------------------
+
+ procedure Raise_Exception_No_Defer
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ begin
+ Exception_Data.Set_Exception_Msg (E, Message);
+
+ -- Do not call Abort_Defer.all, as specified by the spec
+
+ Raise_Current_Excep (E);
+ end Raise_Exception_No_Defer;
+
+ -------------------------------------
+ -- 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);
+ Orig_Prefix_Length : constant Natural :=
+ Integer'Min (Prefix'Length, Orig_Msg'Length);
+ Orig_Prefix : String renames Orig_Msg
+ (Orig_Msg'First ..
+ Orig_Msg'First + Orig_Prefix_Length - 1);
+ begin
+ -- Message already has the proper prefix, just re-raise
+
+ if Orig_Prefix = Prefix then
+ Raise_Exception_No_Defer
+ (E => Program_Error'Identity,
+ Message => Orig_Msg);
+
+ else
+ declare
+ New_Msg : constant String := Prefix & Exception_Name (X);
+
+ begin
+ -- No message present, just provide our own
+
+ if Orig_Msg = "" then
+ Raise_Exception_No_Defer
+ (E => Program_Error'Identity,
+ Message => New_Msg);
+
+ -- Message present, add informational prefix
+
+ else
+ Raise_Exception_No_Defer
+ (E => Program_Error'Identity,
+ Message => New_Msg & ": " & Orig_Msg);
+ end if;
+ end;
+ end if;
+ end Raise_From_Controlled_Operation;
+
-------------------------------
-- Raise_From_Signal_Handler --
-------------------------------
is
begin
Exception_Data.Set_Exception_C_Msg (E, M);
- Abort_Defer.all;
- Exception_Propagation.Propagate_Exception
- (E => E, From_Signal_Handler => True);
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Raise_Current_Excep (E);
end Raise_From_Signal_Handler;
-------------------------
Line : Integer)
is
begin
- Raise_With_Location_And_Msg
- (Program_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
end Raise_Program_Error;
-----------------------------
is
begin
Raise_With_Location_And_Msg
- (Program_Error_Def'Access, File, Line, Msg);
+ (Program_Error_Def'Access, File, Line, M => Msg);
end Raise_Program_Error_Msg;
-------------------------
Line : Integer)
is
begin
- Raise_With_Location_And_Msg
- (Storage_Error_Def'Access, File, Line);
+ Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
end Raise_Storage_Error;
-----------------------------
is
begin
Raise_With_Location_And_Msg
- (Storage_Error_Def'Access, File, Line, Msg);
+ (Storage_Error_Def'Access, File, Line, M => Msg);
end Raise_Storage_Error_Msg;
---------------------------------
(E : Exception_Id;
F : System.Address;
L : Integer;
+ C : Integer := 0;
M : System.Address := System.Null_Address)
is
begin
- Exception_Data.Set_Exception_C_Msg (E, F, L, M);
- Abort_Defer.all;
+ Exception_Data.Set_Exception_C_Msg (E, F, L, C, M);
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
Raise_Current_Excep (E);
end Raise_With_Location_And_Msg;
Excep : constant EOA := Get_Current_Excep.all;
begin
- Exception_Propagation.Setup_Exception (Excep, Excep);
-
Excep.Exception_Raised := False;
Excep.Id := E;
Excep.Num_Tracebacks := 0;
- Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
- Abort_Defer.all;
+
+ -- The following is a common pattern, should be abstracted
+ -- into a procedure call ???
+
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
Raise_Current_Excep (E);
end Raise_With_Msg;
procedure Rcheck_00 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
end Rcheck_00;
procedure Rcheck_01 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
end Rcheck_01;
procedure Rcheck_02 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
end Rcheck_02;
procedure Rcheck_03 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
end Rcheck_03;
procedure Rcheck_04 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
end Rcheck_04;
procedure Rcheck_05 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
end Rcheck_05;
procedure Rcheck_06 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
end Rcheck_06;
procedure Rcheck_07 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
end Rcheck_07;
procedure Rcheck_08 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
end Rcheck_08;
procedure Rcheck_09 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
end Rcheck_09;
procedure Rcheck_10 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
end Rcheck_10;
procedure Rcheck_11 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
end Rcheck_11;
procedure Rcheck_12 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
end Rcheck_12;
procedure Rcheck_13 (File : System.Address; Line : Integer) is
begin
- Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
+ Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
end Rcheck_13;
procedure Rcheck_14 (File : System.Address; Line : Integer) is
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
end Rcheck_21;
- procedure Rcheck_22 (File : System.Address; Line : Integer) is
- begin
- Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
- end Rcheck_22;
-
procedure Rcheck_23 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
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
begin
- Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address);
+ Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_30;
procedure Rcheck_31 (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;
+
+ procedure Rcheck_34 (File : System.Address; Line : Integer) is
+ begin
+ Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
+ end Rcheck_34;
+
+ procedure Rcheck_00_Ext (File : System.Address; Line, Column : Integer) is
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
+ end Rcheck_00_Ext;
+
+ procedure Rcheck_05_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer)
+ is
+ Msg : constant String :=
+ Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF &
+ "index " & Image (Index) & " not in " & Image (First) &
+ ".." & Image (Last) & ASCII.NUL;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_05_Ext;
+
+ procedure Rcheck_06_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer)
+ is
+ Msg : constant String :=
+ Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF &
+ "value " & Image (Index) & " not in " & Image (First) &
+ ".." & Image (Last) & ASCII.NUL;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_06_Ext;
+
+ procedure Rcheck_12_Ext
+ (File : System.Address; Line, Column, Index, First, Last : Integer)
+ is
+ Msg : constant String :=
+ Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF &
+ "value " & Image (Index) & " not in " & Image (First) &
+ ".." & Image (Last) & ASCII.NUL;
+ begin
+ Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+ end Rcheck_12_Ext;
+
+ ---------------
+ -- Rcheck_22 --
+ ---------------
+
+ procedure Rcheck_22 (File : System.Address; Line : Integer) is
+ E : constant Exception_Id := Program_Error_Def'Access;
+
+ begin
+ -- This is "finalize/adjust raised exception". This subprogram is always
+ -- called with abort deferred, unlike all other Rcheck_* routines, it
+ -- needs to call Raise_Exception_No_Defer.
+
+ -- This is consistent with Raise_From_Controlled_Operation
+
+ Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
+ Raise_Current_Excep (E);
+ end Rcheck_22;
+
-------------
-- Reraise --
-------------
procedure Reraise is
Excep : constant EOA := Get_Current_Excep.all;
-
begin
- Abort_Defer.all;
- Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True);
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (Excep.Id);
end Reraise;
procedure Reraise_Occurrence (X : Exception_Occurrence) is
begin
if X.Id /= null then
- Abort_Defer.all;
- Exception_Propagation.Setup_Exception
- (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end if;
end Reraise_Occurrence;
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
- Abort_Defer.all;
- Exception_Propagation.Setup_Exception
- (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
+
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_Always;
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
begin
- Exception_Propagation.Setup_Exception
- (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_No_Defer;
Source : Exception_Occurrence)
is
begin
- Save_Occurrence_No_Private (Target, Source);
- end Save_Occurrence;
-
- function Save_Occurrence (Source : Exception_Occurrence) return EOA is
- Target : constant EOA := new Exception_Occurrence;
- begin
- Save_Occurrence (Target.all, Source);
- return Target;
- end Save_Occurrence;
-
- --------------------------------
- -- Save_Occurrence_No_Private --
- --------------------------------
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence)
- is
- begin
Target.Id := Source.Id;
Target.Msg_Length := Source.Msg_Length;
Target.Num_Tracebacks := Source.Num_Tracebacks;
Target.Pid := Source.Pid;
- Target.Cleanup_Flag := Source.Cleanup_Flag;
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
Source.Tracebacks (1 .. Target.Num_Tracebacks);
- end Save_Occurrence_No_Private;
-
- -------------------------
- -- Transfer_Occurrence --
- -------------------------
+ end Save_Occurrence;
- procedure Transfer_Occurrence
- (Target : Exception_Occurrence_Access;
- Source : Exception_Occurrence)
- is
+ function Save_Occurrence (Source : Exception_Occurrence) return EOA is
+ Target : constant EOA := new Exception_Occurrence;
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.
-
- Exception_Propagation.Setup_Exception (Target, Target);
- Save_Occurrence_No_Private (Target.all, Source);
- end Transfer_Occurrence;
+ Save_Occurrence (Target.all, Source);
+ return Target;
+ end Save_Occurrence;
-------------------
-- String_To_EId --
function String_To_EO (S : String) return Exception_Occurrence
renames Stream_Attributes.String_To_EO;
- ------------------------------
- -- Raise_Exception_No_Defer --
- ------------------------------
-
- procedure Raise_Exception_No_Defer
- (E : Exception_Id;
- Message : String := "")
- is
- begin
- Exception_Data.Set_Exception_Msg (E, Message);
-
- -- Do not call Abort_Defer.all, as specified by the spec
-
- Raise_Current_Excep (E);
- end Raise_Exception_No_Defer;
-
---------------
-- To_Stderr --
---------------
procedure To_Stderr (C : Character) is
-
type int is new Integer;
procedure put_char_stderr (C : int);
end To_Stderr;
-------------------------
+ -- Transfer_Occurrence --
+ -------------------------
+
+ procedure Transfer_Occurrence
+ (Target : Exception_Occurrence_Access;
+ Source : Exception_Occurrence)
+ is
+ begin
+ Save_Occurrence (Target.all, Source);
+ end Transfer_Occurrence;
+
+ ------------------------
+ -- Triggered_By_Abort --
+ ------------------------
+
+ function Triggered_By_Abort return Boolean is
+ Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
+
+ begin
+ return Ex /= null
+ and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
+ end Triggered_By_Abort;
+
+ -------------------------
-- Wide_Exception_Name --
-------------------------
-- Encoding method for source, as exported by binder
function Wide_Exception_Name
- (Id : Exception_Id) return Wide_String is
+ (Id : Exception_Id) return Wide_String
+ is
+ S : constant String := Exception_Name (Id);
+ W : Wide_String (1 .. S'Length);
+ L : Natural;
begin
- return String_To_Wide_String
- (Exception_Name (Id), Get_WC_Encoding_Method (WC_Encoding));
+ String_To_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
end Wide_Exception_Name;
function Wide_Exception_Name
- (X : Exception_Occurrence) return Wide_String is
+ (X : Exception_Occurrence) return Wide_String
+ is
+ S : constant String := Exception_Name (X);
+ W : Wide_String (1 .. S'Length);
+ L : Natural;
begin
- return String_To_Wide_String
- (Exception_Name (X), Get_WC_Encoding_Method (WC_Encoding));
+ String_To_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
end Wide_Exception_Name;
----------------------------
function Wide_Wide_Exception_Name
(Id : Exception_Id) return Wide_Wide_String
is
+ S : constant String := Exception_Name (Id);
+ W : Wide_Wide_String (1 .. S'Length);
+ L : Natural;
begin
- return String_To_Wide_Wide_String
- (Exception_Name (Id), Get_WC_Encoding_Method (WC_Encoding));
+ String_To_Wide_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
end Wide_Wide_Exception_Name;
function Wide_Wide_Exception_Name
(X : Exception_Occurrence) return Wide_Wide_String
is
+ S : constant String := Exception_Name (X);
+ W : Wide_Wide_String (1 .. S'Length);
+ L : Natural;
begin
- return String_To_Wide_Wide_String
- (Exception_Name (X), Get_WC_Encoding_Method (WC_Encoding));
+ String_To_Wide_Wide_String
+ (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+ return W (1 .. L);
end Wide_Wide_Exception_Name;
--------------------------
OSDN Git Service
