File : a-except.adb
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
5 -- A D A . E X C E P T I O N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.129.2.1 $
10 -- --
-- Copyright (C) 1992-2002 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- --
15 -- ware Foundation; either version 2, 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 --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
25 -- 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. --
30 -- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
35
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with System.Exception_Tables.
40 with Ada.Unchecked_Deallocation;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with System; use System;
45 with System.Exception_Table; use System.Exception_Table;
with System.Exceptions; use System.Exceptions;
with System.Standard_Library; use System.Standard_Library;
with System.Storage_Elements; use System.Storage_Elements;
with System.Soft_Links; use System.Soft_Links;
50 with System.Machine_State_Operations; use System.Machine_State_Operations;
with System.Traceback;
with Unchecked_Conversion;
55 package body Ada.Exceptions is
procedure builtin_longjmp (buffer : Address; Flag : Integer);
pragma No_Return (builtin_longjmp);
pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
60
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.
65
type Subprogram_Descriptor_List_Ptr is
access all Subprogram_Descriptor_List;
Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
70 -- This location is initialized by Register_Exceptions to point to a
-- list of pointers to procedure descriptors, sorted into ascending
-- order of PC addresses.
--
-- Note that SDP_Table_Build is called *before* this unit (or any
75 -- other unit) is elaborated. That's important, because exceptions can
-- and do occur during elaboration of units, and must be handled during
-- elaboration. This means that we are counting on the fact that the
-- initialization of Subprogram_Descriptors to null is done by the
-- load process and NOT by an explicit assignment during elaboration.
80
Num_Subprogram_Descriptors : Natural;
-- Number of subprogram descriptors, the useful descriptors are stored
-- in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There
-- can be unused entries at the end of the array due to elimination of
85 -- duplicated entries (which can arise from use of pragma Import).
Exception_Tracebacks : Integer;
pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
-- Boolean indicating whether tracebacks should be stored in exception
90 -- occurrences.
Zero_Cost_Exceptions : Integer;
pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
-- Boolean indicating if we are handling exceptions using a zero cost
95 -- mechanism.
--
-- ??? We currently have two alternatives for this scheme : one using
-- front-end tables and one using back-end tables. The former is known to
-- only work for GNAT3 and the latter is known to only work for GNAT5.
100 -- Both are present in this implementation and it would be good to have
-- separate bodies at some point.
--
-- Note that although we currently do not support it, the GCC3 back-end
-- tables are also potentially useable for setjmp/longjmp processing.
105
Nline : constant String := String' (1 => ASCII.LF);
-- Convenient shortcut
------------------------------------------------
110 -- Entities to interface with the GCC runtime --
------------------------------------------------
-- These come from "C++ ABI for Itanium : Exception handling", which is
-- the reference for GCC. They are used only when we are relying on
115 -- back-end tables for exception propagation, which in turn is currenly
-- only the case for Zero_Cost_Exceptions in GNAT5.
-- Return codes from the GCC runtime functions used to propagate
-- an exception.
120
type Unwind_Reason_Code is
(URC_NO_REASON,
URC_FOREIGN_EXCEPTION_CAUGHT,
URC_PHASE2_ERROR,
125 URC_PHASE1_ERROR,
URC_NORMAL_STOP,
URC_END_OF_STACK,
URC_HANDLER_FOUND,
URC_INSTALL_CONTEXT,
130 URC_CONTINUE_UNWIND);
-- ??? pragma Unreferenced is unknown until 3.15, so we need to disable
-- warnings around it to fix the bootstrap path.
135 pragma Warnings (Off);
pragma Unreferenced
(URC_NO_REASON,
URC_FOREIGN_EXCEPTION_CAUGHT,
URC_PHASE2_ERROR,
140 URC_PHASE1_ERROR,
URC_NORMAL_STOP,
URC_END_OF_STACK,
URC_HANDLER_FOUND,
URC_INSTALL_CONTEXT,
145 URC_CONTINUE_UNWIND);
pragma Warnings (On);
pragma Convention (C, Unwind_Reason_Code);
150 -- Mandatory common header for any exception object handled by the
-- GCC unwinding runtime.
subtype Exception_Class is String (1 .. 8);
155 GNAT_Exception_Class : constant Exception_Class
:= "GNU" & ASCII.NUL & "Ada" & ASCII.NUL;
type Unwind_Exception is record
Class : Exception_Class := GNAT_Exception_Class;
160 Cleanup : System.Address := System.Null_Address;
Private1 : Integer;
Private2 : Integer;
end record;
165 pragma Convention (C, Unwind_Exception);
for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
-- A GNAT exception object to be dealt with by the personality routine
170 -- called by the GCC unwinding runtime. This structure shall match the
-- one in raise.c and is currently experimental as it might be merged
-- with the GNAT runtime definition some day.
type GNAT_GCC_Exception is record
175 Header : Unwind_Exception;
-- Exception header first, as required by the ABI.
Id : Exception_Id;
-- Usual Exception identifier
180
Handled_By_Others : Boolean;
-- Is this exception handled by "when others" ?
Has_Cleanup : Boolean;
185 -- Did we see any at-end handler while walking up the stack
-- searching for a handler ? This is used to determine if we
-- start the propagation again after having tried once without
-- finding a true handler for the exception.
190 Select_Cleanups : Boolean;
-- Do we consider at-end handlers as legitimate handlers for the
-- exception ? This is used to control the propagation process
-- as described in Raise_Current_Excep.
end record;
195
pragma Convention (C, GNAT_GCC_Exception);
-- GCC runtime functions used
200 function Unwind_RaiseException
(E : access GNAT_GCC_Exception)
return Unwind_Reason_Code;
pragma Import (C, Unwind_RaiseException, "_Unwind_RaiseException");
205 -----------------------
-- Local Subprograms --
-----------------------
-- Note: the exported subprograms in this package body are called directly
210 -- from C clients using the given external name, even though they are not
-- technically visible in the Ada sense.
procedure AAA;
-- Mark start of procedures in this unit
215
procedure ZZZ;
-- Mark end of procedures in this package
function Address_Image (A : System.Address) return String;
220 -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
-- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
-- in lower case.
procedure Call_Chain (Excep : EOA);
225 -- Store up to Max_Tracebacks in Excep, corresponding to the current
-- call chain.
procedure Free
is new Ada.Unchecked_Deallocation
230 (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);
procedure Process_Raise_Exception
(E : Exception_Id;
From_Signal_Handler : Boolean);
235 pragma Inline (Process_Raise_Exception);
pragma No_Return (Process_Raise_Exception);
-- This is the lowest level raise routine. It raises the exception
-- referenced by Current_Excep.all in the TSD, without deferring abort
-- (the caller must ensure that abort is deferred on entry).
240 --
-- This is actually the common implementation for Raise_Current_Excep and
-- Raise_From_Signal_Handler, with a couple of operations inhibited when
-- called from the latter. The origin of the call is indicated by the
-- From_Signal_Handler argument.
245 --
-- The Inline pragma is there for efficiency reasons.
procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State);
pragma No_Return (Propagate_Exception_With_FE_Support);
250 -- This procedure propagates the exception represented by the occurrence
-- referenced by Current_Excep in the TSD for the current task. M is the
-- initial machine state, representing the site of the exception raise
-- operation.
--
255 -- The procedure searches the front end exception tables for an applicable
-- handler, calling Pop_Frame as needed. If and when it locates an
-- applicable handler, Enter_Handler is called to actually enter this
-- handler. If the search is unable to locate an applicable handler,
-- execution is terminated by calling Unhandled_Exception_Terminate.
260
procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State);
pragma No_Return (Propagate_Exception_With_GCC_Support);
-- This procedure propagates the exception represented by the occurrence
-- referenced by Current_Excep in the TSD for the current task. M is the
265 -- initial machine state, representing the site of the exception raise
-- operation. It is currently not used and is there for the purpose of
-- interface consistency against Propagate_Exception_With_FE_Support.
--
-- The procedure builds an object suitable for the libgcc processing and
270 -- calls Unwind_RaiseException to actually throw, taking care of handling
-- the two phase scheme it implements.
procedure Raise_Current_Excep (E : Exception_Id);
pragma No_Return (Raise_Current_Excep);
275 pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
-- This is a simple wrapper to Process_Raise_Exception setting the
-- From_Signal_Handler argument to False.
--
-- This external name for Raise_Current_Excep is historical, and probably
280 -- should be changed but for now we keep it, because gdb and gigi know
-- about it.
procedure Raise_Exception_No_Defer
(E : Exception_Id; Message : String := "");
285 pragma Export (Ada, Raise_Exception_No_Defer,
"ada__exceptions__raise_exception_no_defer");
pragma No_Return (Raise_Exception_No_Defer);
-- Similar to Raise_Exception, but with no abort deferral
290 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
295 -- exception occurrence referenced by the Current_Excep in the TSD.
-- Abort is deferred before the raise call.
procedure Raise_With_Location
(E : Exception_Id;
300 F : Big_String_Ptr;
L : Integer);
pragma No_Return (Raise_With_Location);
-- Raise an exception with given exception id value. A filename and line
-- number is associated with the raise and is stored in the exception
305 -- occurrence.
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
310 L : Integer;
M : Big_String_Ptr);
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
315 -- occurrence and in addition a string message M is appended to this.
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
Line : Integer);
320 pragma No_Return (Raise_Constraint_Error);
pragma Export
(C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
-- Raise constraint error with file:line information
325 procedure Raise_Constraint_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr);
pragma No_Return (Raise_Constraint_Error_Msg);
330 pragma Export
(C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
-- Raise constraint error with file:line + msg information
procedure Raise_Program_Error
335 (File : Big_String_Ptr;
Line : Integer);
pragma No_Return (Raise_Program_Error);
pragma Export
(C, Raise_Program_Error, "__gnat_raise_program_error");
340 -- Raise program error with file:line information
procedure Raise_Program_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
345 Msg : Big_String_Ptr);
pragma No_Return (Raise_Program_Error_Msg);
pragma Export
(C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
-- Raise program error with file:line + msg information
350
procedure Raise_Storage_Error
(File : Big_String_Ptr;
Line : Integer);
pragma No_Return (Raise_Storage_Error);
355 pragma Export
(C, Raise_Storage_Error, "__gnat_raise_storage_error");
-- Raise storage error with file:line information
procedure Raise_Storage_Error_Msg
360 (File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr);
pragma No_Return (Raise_Storage_Error_Msg);
pragma Export
365 (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
-- Raise storage error with file:line + reason msg information
-- The exception raising process and the automatic tracing mechanism rely
-- on some careful use of flags attached to the exception occurrence. The
370 -- graph below illustrates the relations between the Raise_ subprograms
-- and identifies the points where basic flags such as Exception_Raised
-- are initialized.
--
-- (i) signs indicate the flags initialization points. R stands for Raise,
375 -- W for With, and E for Exception.
--
-- R_No_Msg R_E R_Pe R_Ce R_Se
-- | | | | |
-- +--+ +--+ +---+ | +---+
380 -- | | | | |
-- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc R_W_C_Msg
-- | | | | | |
-- +------------+ | +-----------+ +--+ +--+ |
-- | | | | | |
385 -- | | | Set_E_C_Msg(i) |
-- | | | |
-- | | | +--------------------------+
-- | | | |
-- Raise_Current_Excep
390
procedure Reraise;
pragma No_Return (Reraise);
pragma Export (C, Reraise, "__gnat_reraise");
-- Reraises the exception referenced by the Current_Excep field of
395 -- the TSD (all fields of this exception occurrence are set). Abort
-- is deferred before the reraise operation.
function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean;
-- Used in call to sort SDP table (SDP_Table_Build), compares two elements
400
procedure SDP_Table_Sort_Move (From : Natural; To : Natural);
-- Used in call to sort SDP table (SDP_Table_Build), moves one element
procedure Set_Exception_C_Msg
405 (Id : Exception_Id;
Msg1 : Big_String_Ptr;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null);
-- This routine is called to setup the exception referenced by the
410 -- 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
415 -- terminated string is added to the message.
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
-- Little routine to output string to stderr that is also used
420 -- in the tasking run time.
procedure Unhandled_Exception_Terminate;
pragma No_Return (Unhandled_Exception_Terminate);
-- This procedure is called to terminate execution following an unhandled
425 -- 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
---------------------------------
430 -- Debugger Interface Routines --
---------------------------------
-- The routines here are null routines that normally have no effect.
-- they are provided for the debugger to place breakpoints on their
435 -- entry points to get control on an exception.
procedure Notify_Exception
(Id : Exception_Id;
Handler : Code_Loc;
440 Is_Others : Boolean);
pragma Export (C, Notify_Exception, "__gnat_notify_exception");
-- This routine is called whenever an exception is signalled. The Id
-- parameter is the Exception_Id of the exception being raised. The
-- second parameter Handler is Null_Loc if the exception is unhandled,
445 -- and is otherwise the entry point of the handler that will handle
-- the exception. Is_Others is True if the handler is an others handler
-- and False otherwise. In the unhandled exception case, if possible
-- (and certainly if zero cost exception handling is active), the
-- stack is still intact when this procedure is called. Note that this
450 -- routine is entered before any finalization handlers are entered if
-- the exception is unhandled by a "real" exception handler.
procedure Unhandled_Exception;
pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
455 -- This routine is called in addition to Notify_Exception in the
-- unhandled exception case. The fact that there are two routines
-- which are somewhat redundant is historical. Notify_Exception
-- certainly is complete enough, but GDB still uses this routine.
460 -----------------------------
-- Run-Time Check Routines --
-----------------------------
-- These routines are called from the runtime to raise a specific
465 -- 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).
470 procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer);
475 procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer);
480 procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer);
485 procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer);
490 procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer);
495 procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
500 pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
505 pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
510 pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
515 pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
520 pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
525 pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
530 ---------------------------------------------
-- These strings are null-terminated and are used by Rcheck_nn. The
-- strings correspond to the definitions for Types.RT_Exception_Code.
535 use ASCII;
Rmsg_00 : constant String := "access check failed" & NUL;
Rmsg_01 : constant String := "access parameter is null" & NUL;
Rmsg_02 : constant String := "discriminant check failed" & NUL;
540 Rmsg_03 : constant String := "divide by zero" & NUL;
Rmsg_04 : constant String := "explicit raise" & NUL;
Rmsg_05 : constant String := "index check failed" & NUL;
Rmsg_06 : constant String := "invalid data" & NUL;
Rmsg_07 : constant String := "length check failed" & NUL;
545 Rmsg_08 : constant String := "overflow check failed" & NUL;
Rmsg_09 : constant String := "partition check failed" & NUL;
Rmsg_10 : constant String := "range check failed" & NUL;
Rmsg_11 : constant String := "tag check failed" & NUL;
Rmsg_12 : constant String := "access before elaboration" & NUL;
550 Rmsg_13 : constant String := "accessibility check failed" & NUL;
Rmsg_14 : constant String := "all guards closed" & NUL;
Rmsg_15 : constant String := "explicit raise" & NUL;
Rmsg_16 : constant String := "finalize raised exception" & NUL;
Rmsg_17 : constant String := "invalid data" & NUL;
555 Rmsg_18 : constant String := "misaligned address value" & NUL;
Rmsg_19 : constant String := "missing return" & NUL;
Rmsg_20 : constant String := "potentially blocking operation" & NUL;
Rmsg_21 : constant String := "stubbed subprogram called" & NUL;
Rmsg_22 : constant String := "unchecked union restriction" & NUL;
560 Rmsg_23 : constant String := "empty storage pool" & NUL;
Rmsg_24 : constant String := "explicit raise" & NUL;
Rmsg_25 : constant String := "infinite recursion" & NUL;
Rmsg_26 : constant String := "object too large" & NUL;
Rmsg_27 : constant String := "restriction violation" & NUL;
565
--------------------------------------
-- Calls to Run-Time Check Routines --
--------------------------------------
570 procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address));
end Rcheck_00;
575 procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address));
end Rcheck_01;
580 procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address));
end Rcheck_02;
585 procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address));
end Rcheck_03;
590 procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address));
end Rcheck_04;
595 procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address));
end Rcheck_05;
600 procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address));
end Rcheck_06;
605 procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address));
end Rcheck_07;
610 procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address));
end Rcheck_08;
615 procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address));
end Rcheck_09;
620 procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address));
end Rcheck_10;
625 procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address));
end Rcheck_11;
630 procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address));
end Rcheck_12;
635 procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address));
end Rcheck_13;
640 procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address));
end Rcheck_14;
645 procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address));
end Rcheck_15;
650 procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address));
end Rcheck_16;
655 procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address));
end Rcheck_17;
660 procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address));
end Rcheck_18;
665 procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address));
end Rcheck_19;
670 procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address));
end Rcheck_20;
675 procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address));
end Rcheck_21;
680 procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address));
end Rcheck_22;
685 procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address));
end Rcheck_23;
690 procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
end Rcheck_24;
695 procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address));
end Rcheck_25;
700 procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address));
end Rcheck_26;
705 procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address));
end Rcheck_27;
710 ---------------------------------------
-- Exception backtracing subprograms --
---------------------------------------
-- What is automatically output when exception tracing is on basically
715 -- corresponds to the usual exception information, but with the call
-- chain backtrace possibly tailored by a backtrace decorator. Modifying
-- Exception_Information itself is not a good idea because the decorated
-- output is completely out of control and would break all our code
-- related to the streaming of exceptions.
720 --
-- We then provide an alternative function to Exception_Information to
-- compute the possibly tailored output, which is equivalent if no
-- decorator is currently set :
725 function Tailored_Exception_Information
(X : Exception_Occurrence)
return String;
-- Exception information to be output in the case of automatic tracing
-- requested through GNAT.Exception_Traces.
730 --
-- This is the same as Exception_Information if no backtrace decorator
-- is currently in place. Otherwise, this is Exception_Information with
-- the call chain raw addresses replaced by the result of a call to the
-- current decorator provided with the call chain addresses.
735
pragma Export
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
-- This function is used within this package but also from within
740 -- System.Tasking.Stages.
--
-- The output of Exception_Information and Tailored_Exception_Information
-- share a common part which was formerly built using local procedures
-- within Exception_Information. These procedures have been extracted from
745 -- their original place to be available to Tailored_Exception_Information
-- also.
--
-- Each of these procedures appends some input to an information string
-- currently being built. The Ptr argument represents the last position
750 -- in this string at which a character has been written.
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
755 Last : in out Integer);
-- procedural version of the above function. Instead of returning the
-- result, this one is put in Buff (Buff'first .. Buff'first + Last)
procedure Append_Info_Nat
760 (N : Natural;
Info : in out String;
Ptr : in out Natural);
-- Append the image of N at the end of the provided information string
765 procedure Append_Info_NL
(Info : in out String;
Ptr : in out Natural);
-- Append a LF at the end of the provided information string
770 procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural);
-- Append a string at the end of the provided information string
775
-- To build Exception_Information and Tailored_Exception_Information,
-- we then use three intermediate functions :
function Basic_Exception_Information
780 (X : Exception_Occurrence)
return String;
-- Returns the basic exception information string associated with a
-- given exception occurrence. This is the common part shared by both
-- Exception_Information and Tailored_Exception_Infomation.
785
function Basic_Exception_Traceback
(X : Exception_Occurrence)
return String;
-- Returns an image of the complete call chain associated with an
790 -- exception occurence in its most basic form, that is as a raw sequence
-- of hexadecimal binary addresses.
function Tailored_Exception_Traceback
(X : Exception_Occurrence)
795 return String;
-- Returns an image of the complete call chain associated with an
-- exception occurrence, either in its basic form if no decorator is
-- in place, or as formatted by the decorator otherwise.
800 -- The overall organization of the exception information related code
-- is summarized below :
--
-- Exception_Information
-- |
805 -- +-------+--------+
-- | |
-- Basic_Exc_Info & Basic_Exc_Tback
--
--
810 -- Tailored_Exception_Information
-- |
-- +----------+----------+
-- | |
-- Basic_Exc_Info & Tailored_Exc_Tback
815 -- |
-- +-----------+------------+
-- | |
-- Basic_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise
820
----------------------------------------------
-- Run-Time Exception Notification Routines --
----------------------------------------------
825 -- The notification routines described above are low level "handles" for
-- the debugger but what needs to be done at the notification points
-- always involves more than just calling one of these routines. The
-- routines below provide a common run-time interface for this purpose,
-- with variations depending on the handled/not handled status of the
830 -- occurrence. They are exported to be usable by the Ada exception
-- handling personality routine when the GCC 3 mechanism is used.
procedure Notify_Handled_Exception
(Handler : Code_Loc;
835 Is_Others : Boolean;
Low_Notify : Boolean);
pragma Export (C, Notify_Handled_Exception,
"__gnat_notify_handled_exception");
-- Routine to call when a handled occurrence is about to be propagated.
840 -- Low_Notify might be set to false to skip the low level debugger
-- notification, which is useful when the information it requires is
-- not available, like in the SJLJ case.
procedure Notify_Unhandled_Exception (Id : Exception_Id);
845 pragma Export (C, Notify_Unhandled_Exception,
"__gnat_notify_unhandled_exception");
-- Routine to call when an unhandled occurrence is about to be propagated.
--------------------------------
850 -- Import Run-Time C Routines --
--------------------------------
-- The purpose of the following pragma Imports is to ensure that we
-- generate appropriate subprogram descriptors for all C routines in
855 -- the standard GNAT library that can raise exceptions. This ensures
-- that the exception propagation can properly find these routines
pragma Warnings (Off); -- so old compiler does not complain
pragma Propagate_Exceptions;
860
procedure Unhandled_Terminate;
pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
-----------------------
865 -- Polling Interface --
-----------------------
type Unsigned is mod 2 ** 32;
870 Counter : Unsigned := 0;
-- This counter is provided for convenience. It can be used in Poll to
-- perform periodic but not systematic operations.
procedure Poll is separate;
875 -- The actual polling routine is separate, so that it can easily
-- be replaced with a target dependent version.
---------
-- AAA --
880 ---------
-- This dummy procedure gives us the start of the PC range for addresses
-- within the exception unit itself. We hope that gigi/gcc keep all the
-- procedures in their original order!
885
procedure AAA is
begin
null;
end AAA;
890
-------------------
-- Address_Image --
-------------------
895 function Address_Image (A : Address) return String is
S : String (1 .. 18);
P : Natural;
N : Integer_Address;
900 H : constant array (Integer range 0 .. 15) of Character :=
"0123456789abcdef";
begin
P := S'Last;
N := To_Integer (A);
905 while N /= 0 loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
end loop;
910
S (P - 1) := '0';
S (P) := 'x';
return S (P - 1 .. S'Last);
end Address_Image;
915
---------------------
-- Append_Info_Nat --
---------------------
920 procedure Append_Info_Nat
(N : Natural;
Info : in out String;
Ptr : in out Natural)
is
925 begin
if N > 9 then
Append_Info_Nat (N / 10, Info, Ptr);
end if;
930 Ptr := Ptr + 1;
Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
end Append_Info_Nat;
--------------------
935 -- Append_Info_NL --
--------------------
procedure Append_Info_NL
(Info : in out String;
940 Ptr : in out Natural)
is
begin
Ptr := Ptr + 1;
Info (Ptr) := ASCII.LF;
945 end Append_Info_NL;
------------------------
-- Append_Info_String --
------------------------
950
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural)
955 is
Last : Natural := Integer'Min (Ptr + S'Length, Info'Last);
begin
Info (Ptr + 1 .. Last) := S;
960 Ptr := Last;
end Append_Info_String;
---------------------------------
-- Basic_Exception_Information --
965 ---------------------------------
function Basic_Exception_Information
(X : Exception_Occurrence)
return String
970 is
Name : constant String := Exception_Name (X);
Msg : constant String := Exception_Message (X);
-- Exception name and message that are going to be included in the
-- information to return, if not empty.
975
Name_Len : constant Natural := Name'Length;
Msg_Len : constant Natural := Msg'Length;
-- Length of these strings, useful to compute the size of the string
-- we have to allocate for the complete result as well as in the body
980 -- of this procedure.
Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
-- Maximum length of the information string we will build, with :
--
985 -- 50 = 16 + 2 for the text associated with the name
-- + 9 + 2 for the text associated with the message
-- + 5 + 2 for the text associated with the pid
-- + 14 for the text image of the pid itself and a margin.
--
990 -- This is indeed a maximum since some data may not appear at all if
-- not relevant. For example, nothing related to the exception message
-- will be there if this message is empty.
--
-- WARNING : Do not forget to update these numbers if anything
995 -- involved in the computation changes.
Info : String (1 .. Info_Maxlen);
-- Information string we are going to build, containing the common
-- part shared by Exc_Info and Tailored_Exc_Info.
1000
Ptr : Natural := 0;
begin
-- Output exception name and message except for _ABORT_SIGNAL, where
1005 -- these two lines are omitted (see discussion above).
if Name (1) /= '_' then
Append_Info_String ("Exception name: ", Info, Ptr);
Append_Info_String (Name, Info, Ptr);
1010 Append_Info_NL (Info, Ptr);
if Msg_Len /= 0 then
Append_Info_String ("Message: ", Info, Ptr);
Append_Info_String (Msg, Info, Ptr);
1015 Append_Info_NL (Info, Ptr);
end if;
end if;
-- Output PID line if non-zero
1020
if X.Pid /= 0 then
Append_Info_String ("PID: ", Info, Ptr);
Append_Info_Nat (X.Pid, Info, Ptr);
Append_Info_NL (Info, Ptr);
1025 end if;
return Info (1 .. Ptr);
end Basic_Exception_Information;
1030 -------------------------------
-- Basic_Exception_Traceback --
-------------------------------
function Basic_Exception_Traceback
1035 (X : Exception_Occurrence)
return String
is
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
-- Maximum length of the information string we are building, with :
1040 -- 33 = 31 + 4 for the text before and after the traceback, and
-- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
--
-- WARNING : Do not forget to update these numbers if anything
-- involved in the computation changes.
1045
Info : String (1 .. Info_Maxlen);
-- Information string we are going to build, containing an image
-- of the call chain associated with the exception occurrence in its
-- most basic form, that is as a sequence of binary addresses.
1050
Ptr : Natural := 0;
begin
if X.Num_Tracebacks > 0 then
1055 Append_Info_String ("Call stack traceback locations:", Info, Ptr);
Append_Info_NL (Info, Ptr);
for J in 1 .. X.Num_Tracebacks loop
Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr);
1060 exit when J = X.Num_Tracebacks;
Append_Info_String (" ", Info, Ptr);
end loop;
Append_Info_NL (Info, Ptr);
1065 end if;
return Info (1 .. Ptr);
end Basic_Exception_Traceback;
1070 -----------------
-- Break_Start --
-----------------
procedure Break_Start is
1075 begin
null;
end Break_Start;
----------------
1080 -- Call_Chain --
----------------
procedure Call_Chain (Excep : EOA) is
begin
1085 if Excep.Num_Tracebacks /= 0 then
-- This is a reraise, no need to store a new (wrong) chain.
return;
end if;
1090 System.Traceback.Call_Chain
(Excep.Tracebacks'Address,
Max_Tracebacks,
Excep.Num_Tracebacks,
AAA'Address,
1095 ZZZ'Address);
end Call_Chain;
------------------------------
-- Current_Target_Exception --
1100 ------------------------------
function Current_Target_Exception return Exception_Occurrence is
begin
return Null_Occurrence;
1105 end Current_Target_Exception;
-------------------
-- EId_To_String --
-------------------
1110
function EId_To_String (X : Exception_Id) return String is
begin
if X = Null_Id then
return "";
1115 else
return Exception_Name (X);
end if;
end EId_To_String;
1120 ------------------
-- EO_To_String --
------------------
-- We use the null string to represent the null occurrence, otherwise
1125 -- we output the Exception_Information string for the occurrence.
function EO_To_String (X : Exception_Occurrence) return String is
begin
if X.Id = Null_Id then
1130 return "";
else
return Exception_Information (X);
end if;
end EO_To_String;
1135
------------------------
-- Exception_Identity --
------------------------
1140 function Exception_Identity
(X : Exception_Occurrence)
return Exception_Id
is
begin
1145 if X.Id = Null_Id then
raise Constraint_Error;
else
return X.Id;
end if;
1150 end Exception_Identity;
---------------------------
-- Exception_Information --
---------------------------
1155
-- The format of the string is:
-- Exception_Name: nnnnn
-- Message: mmmmm
1160 -- PID: ppp
-- Call stack traceback locations:
-- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh
-- where
1165
-- nnnn is the fully qualified name of the exception in all upper
-- case letters. This line is always present.
-- mmmm is the message (this line present only if message is non-null)
1170
-- ppp is the Process Id value as a decimal integer (this line is
-- present only if the Process Id is non-zero). Currently we are
-- not making use of this field.
1175 -- The Call stack traceback locations line and the following values
-- are present only if at least one traceback location was recorded.
-- the values are given in C style format, with lower case letters
-- for a-f, and only as many digits present as are necessary.
1180 -- The line terminator sequence at the end of each line, including the
-- last line is a CR-LF sequence (16#0D# followed by 16#0A#).
-- The Exception_Name and Message lines are omitted in the abort
-- signal case, since this is not really an exception, and the only
1185 -- use of this routine is internal for printing termination output.
-- WARNING: 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.
1190
function Exception_Information (X : Exception_Occurrence) return String is
-- This information is now built using the circuitry introduced in
-- association with the support of traceback decorators, as the
1195 -- catenation of the exception basic information and the call chain
-- backtrace in its basic form.
Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Basic_Exception_Traceback (X);
1200
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
Info : String (1 .. Basic_Len + Tback_Len);
1205 Ptr : Natural := 0;
begin
Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
1210
return Info;
end Exception_Information;
-----------------------
1215 -- Exception_Message --
-----------------------
function Exception_Message (X : Exception_Occurrence) return String is
begin
1220 if X.Id = Null_Id then
raise Constraint_Error;
end if;
return X.Msg (1 .. X.Msg_Length);
1225 end Exception_Message;
--------------------
-- Exception_Name --
--------------------
1230
function Exception_Name (Id : Exception_Id) return String is
begin
if Id = null then
raise Constraint_Error;
1235 end if;
return Id.Full_Name.all (1 .. Id.Name_Length - 1);
end Exception_Name;
1240 function Exception_Name (X : Exception_Occurrence) return String is
begin
return Exception_Name (X.Id);
end Exception_Name;
1245 ---------------------------
-- Exception_Name_Simple --
---------------------------
function Exception_Name_Simple (X : Exception_Occurrence) return String is
1250 Name : constant String := Exception_Name (X);
P : Natural;
begin
P := Name'Length;
1255 while P > 1 loop
exit when Name (P - 1) = '.';
P := P - 1;
end loop;
1260 return Name (P .. Name'Length);
end Exception_Name_Simple;
-----------------------------
-- Process_Raise_Exception --
1265 -----------------------------
procedure Process_Raise_Exception
(E : Exception_Id;
From_Signal_Handler : Boolean)
1270 is
pragma Inspection_Point (E);
-- This is so the debugger can reliably inspect the parameter
Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
1275 Mstate_Ptr : constant Machine_State :=
Machine_State (Get_Machine_State_Addr.all);
Excep : EOA := Get_Current_Excep.all;
begin
1280 -- 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. 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
1285 -- of this procedure.
-- Processing varies between zero cost and setjmp/lonjmp processing.
if Zero_Cost_Exceptions /= 0 then
1290
-- Use the front-end tables to propagate if we have them, otherwise
-- resort to the GCC back-end alternative. The backtrace for the
-- occurrence is stored while walking up the stack, and thus stops
-- in the handler's frame if there is one. Notifications are also
1295 -- not performed here since it is not yet known if the exception is
-- handled.
-- Set the machine state unless we are raising from a signal handler
-- since it has already been set properly in that case.
1300
if not From_Signal_Handler then
Set_Machine_State (Mstate_Ptr);
end if;
1305 if Subprogram_Descriptors /= null then
Propagate_Exception_With_FE_Support (Mstate_Ptr);
else
Propagate_Exception_With_GCC_Support (Mstate_Ptr);
end if;
1310
else
-- Compute the backtrace for this occurrence if the corresponding
-- binder option has been set and we are not raising from a signal
1315 -- handler. Call_Chain takes care of the reraise case.
if not From_Signal_Handler
and then Exception_Tracebacks /= 0
then
1320 Call_Chain (Excep);
end if;
-- If the jump buffer pointer is non-null, transfer control using
-- it. Otherwise announce an unhandled exception (note that this
1325 -- 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
1330 if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
Notify_Handled_Exception (Null_Loc, False, False);
-- The low level debugger notification is skipped from the
1335 -- call above because we do not have the necessary information
-- to "feed" it properly.
end if;
1340 builtin_longjmp (Jumpbuf_Ptr, 1);
else
Notify_Unhandled_Exception (E);
Unhandled_Exception_Terminate;
1345 end if;
end if;
end Process_Raise_Exception;
1350 -----------------------------------------
-- Propagate_Exception_With_FE_Support --
-----------------------------------------
procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is
1355 Excep : constant EOA := Get_Current_Excep.all;
Loc : Code_Loc;
Lo, Hi : Natural;
Pdesc : Natural;
Hrec : Handler_Record_Ptr;
1360 Info : Subprogram_Info_Type;
type Machine_State_Record is
new Storage_Array (1 .. Machine_State_Length);
for Machine_State_Record'Alignment use Standard'Maximum_Alignment;
1365
procedure Duplicate_Machine_State (Dest, Src : Machine_State);
-- Copy Src into Dest, assuming that a Machine_State is pointing to
-- an area of Machine_State_Length bytes.
1370 procedure Duplicate_Machine_State (Dest, Src : Machine_State) is
type Machine_State_Record_Access is access Machine_State_Record;
function To_MSR is new Unchecked_Conversion
(Machine_State, Machine_State_Record_Access);
1375 begin
To_MSR (Dest).all := To_MSR (Src).all;
end Duplicate_Machine_State;
-- Data for handling the finalization handler case. A simple approach
1380 -- in this routine would simply to unwind stack frames till we find a
-- handler and then enter it. But this is undesirable in the case where
-- we have only finalization handlers, and no "real" handler, i.e. a
-- case where we have an unhandled exception.
1385 -- In this case we prefer to signal unhandled exception with the stack
-- intact, and entering finalization handlers would destroy the stack
-- state. To deal with this, as we unwind the stack, we note the first
-- finalization handler, and remember it in the following variables.
-- We then continue to unwind. If and when we find a "real", i.e. non-
1390 -- finalization handler, then we use these variables to pass control to
-- the finalization handler.
FH_Found : Boolean := False;
-- Set when a finalization handler is found
1395
FH_Mstate : aliased Machine_State_Record;
-- Records the machine state for the finalization handler
FH_Handler : Code_Loc := Null_Address;
1400 -- Record handler address for finalization handler
FH_Num_Trb : Natural := 0;
-- Save number of tracebacks for finalization handler
1405 begin
-- Loop through stack frames as exception propagates
Main_Loop : loop
Loc := Get_Code_Loc (Mstate);
1410 exit Main_Loop when Loc = Null_Loc;
-- Record location unless it is inside this unit. Note: this
-- test should really say Code_Address, but Address is the same
-- as Code_Address for unnested subprograms, and Code_Address
1415 -- would cause a bootstrap problem
if Loc < AAA'Address or else Loc > ZZZ'Address then
-- Record location unless we already recorded max tracebacks
1420
if Excep.Num_Tracebacks /= Max_Tracebacks then
-- Do not record location if it is the return point from
-- a reraise call from within a cleanup handler
1425
if not Excep.Cleanup_Flag then
Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1;
Excep.Tracebacks (Excep.Num_Tracebacks) := Loc;
1430 -- For reraise call from cleanup handler, skip entry and
-- clear the flag so that we will start to record again
else
Excep.Cleanup_Flag := False;
1435 end if;
end if;
end if;
-- Do binary search on procedure table
1440
Lo := 1;
Hi := Num_Subprogram_Descriptors;
-- Binary search loop
1445
loop
Pdesc := (Lo + Hi) / 2;
-- Note that Loc is expected to be the procedure's call point
1450 -- and not the return point.
if Loc < Subprogram_Descriptors (Pdesc).Code then
Hi := Pdesc - 1;
1455 elsif Pdesc < Num_Subprogram_Descriptors
and then Loc > Subprogram_Descriptors (Pdesc + 1).Code
then
Lo := Pdesc + 1;
1460 else
exit;
end if;
-- This happens when the current Loc is completely outside of
1465 -- the range of the program, which usually means that we reached
-- the top level frame (e.g __start). In this case we have an
-- unhandled exception.
exit Main_Loop when Hi < Lo;
1470 end loop;
-- Come here with Subprogram_Descriptors (Pdesc) referencing the
-- procedure descriptor that applies to this PC value. Now do a
-- serial search to see if any handler is applicable to this PC
1475 -- value, and to the exception that we are propagating
for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop
Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J);
1480 if Loc >= Hrec.Lo and then Loc < Hrec.Hi then
-- PC range is applicable, see if handler is for this exception
-- First test for case of "all others" (finalization) handler.
1485 -- We do not enter such a handler until we are sure there is
-- a real handler further up the stack.
if Hrec.Id = All_Others_Id then
1490 -- If this is the first finalization handler, then
-- save the machine state so we can enter it later
-- without having to repeat the search.
if not FH_Found then
1495 FH_Found := True;
Duplicate_Machine_State
(Machine_State (FH_Mstate'Address), Mstate);
FH_Handler := Hrec.Handler;
FH_Num_Trb := Excep.Num_Tracebacks;
1500 end if;
-- Normal (non-finalization exception with matching Id)
elsif Excep.Id = Hrec.Id
1505 or else (Hrec.Id = Others_Id
and not Excep.Id.Not_Handled_By_Others)
then
-- Perform the necessary notification tasks.
1510 Notify_Handled_Exception
(Hrec.Handler, Hrec.Id = Others_Id, True);
-- If we already encountered a finalization handler, then
-- reset the context to that handler, and enter it.
1515
if FH_Found then
Excep.Num_Tracebacks := FH_Num_Trb;
Excep.Cleanup_Flag := True;
1520 Enter_Handler
(Machine_State (FH_Mstate'Address), FH_Handler);
-- If we have not encountered a finalization handler,
-- then enter the current handler.
1525
else
Enter_Handler (Mstate, Hrec.Handler);
end if;
end if;
1530 end if;
end loop;
Info := Subprogram_Descriptors (Pdesc).Subprogram_Info;
exit Main_Loop when Info = No_Info;
1535 Pop_Frame (Mstate, Info);
end loop Main_Loop;
-- Fall through if no "real" exception handler found. First thing is to
-- perform the necessary notification tasks with the stack intact.
1540
Notify_Unhandled_Exception (Excep.Id);
-- If there were finalization handlers, then enter the top one.
-- Just because there is no handler does not mean we don't have
1545 -- to still execute all finalizations and cleanups before
-- terminating. Note that the process of calling cleanups
-- does not disturb the back trace stack, since he same
-- exception occurrence gets reraised, and new traceback
-- entries added as we go along.
1550
if FH_Found then
Excep.Num_Tracebacks := FH_Num_Trb;
Excep.Cleanup_Flag := True;
Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler);
1555 end if;
-- If no cleanups, then this is the real unhandled termination
Unhandled_Exception_Terminate;
1560
end Propagate_Exception_With_FE_Support;
------------------------------------------
-- Propagate_Exception_With_GCC_Support --
1565 ------------------------------------------
procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is
Excep : EOA := Get_Current_Excep.all;
This_Exception : aliased GNAT_GCC_Exception;
1570 Status : Unwind_Reason_Code;
begin
-- ??? Nothing is currently done for backtracing purposes. We could
-- have used the personality routine to record the addresses while
1575 -- walking up the stack, but this method has two drawbacks : 1/ the
-- trace is incomplete if the exception is handled since we don't walk
-- up the frame with the handler, and 2/ we will miss frames if the
-- exception propagates through frames for which our personality
-- routine is not called (e.g. if C or C++ frames are on the way).
1580
-- Fill in the useful flags for the personality routine called for each
-- frame via the call to Unwind_RaiseException below.
This_Exception.Id := Excep.Id;
1585 This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
This_Exception.Has_Cleanup := False;
-- We are looking for a regular handler first. If there is one, either
-- it or the first at-end handler before it will be entered. If there
1590 -- is none, control will normally get back to after the call, with
-- Has_Cleanup set to true if at least one at-end handler has been
-- found while walking up the stack.
This_Exception.Select_Cleanups := False;
1595
Status := Unwind_RaiseException (This_Exception'Access);
-- If we get here we know the exception is not handled, as otherwise
-- Unwind_RaiseException arranges for a handler to be entered. We might
1600 -- have met cleanups handlers, though, requiring to start again with
-- the Select_Cleanups flag set to True.
-- Before restarting for cleanups, take the necessary steps to enable
-- the debugger to gain control while the stack is still intact. Flag
1605 -- the occurrence as raised to avoid notifying again in case cleanup
-- handlers are entered later.
if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
1610 Notify_Unhandled_Exception (Excep.Id);
end if;
-- Now raise again selecting cleanups as true handlers. Only do this if
-- we know at least one such handler exists since otherwise we would
1615 -- perform a complete stack upwalk for nothing.
if This_Exception.Has_Cleanup then
This_Exception.Select_Cleanups := True;
Status := Unwind_RaiseException (This_Exception'Access);
1620
-- The first cleanup found is entered. It performs its job, raises
-- the initial exception again, and the flow goes back to the first
-- step above with the stack in a different state.
end if;
1625
-- We get here when there is no handler to be run at all. The debugger
-- has been notified before the second step above.
Unhandled_Exception_Terminate;
1630
end Propagate_Exception_With_GCC_Support;
----------------------------
-- Raise_Constraint_Error --
1635 ----------------------------
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
Line : Integer)
1640 is
begin
Raise_With_Location (Constraint_Error_Def'Access, File, Line);
end Raise_Constraint_Error;
1645 --------------------------------
-- Raise_Constraint_Error_Msg --
--------------------------------
procedure Raise_Constraint_Error_Msg
1650 (File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
begin
1655 Raise_With_Location_And_Msg
(Constraint_Error_Def'Access, File, Line, Msg);
end Raise_Constraint_Error_Msg;
-------------------------
1660 -- Raise_Current_Excep --
-------------------------
procedure Raise_Current_Excep (E : Exception_Id) is
begin
1665 Process_Raise_Exception (E => E, From_Signal_Handler => False);
end Raise_Current_Excep;
---------------------
-- Raise_Exception --
1670 ---------------------
procedure Raise_Exception
(E : Exception_Id;
Message : String := "")
1675 is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
Excep : constant EOA := Get_Current_Excep.all;
1680 begin
if E /= null then
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (1 .. Len);
Raise_With_Msg (E);
1685 end if;
end Raise_Exception;
----------------------------
-- Raise_Exception_Always --
1690 ----------------------------
procedure Raise_Exception_Always
(E : Exception_Id;
Message : String := "")
1695 is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
Excep : constant EOA := Get_Current_Excep.all;
1700
begin
Excep.Msg_Length := Len;
Excep.Msg (1 .. Len) := Message (1 .. Len);
Raise_With_Msg (E);
1705 end Raise_Exception_Always;
-------------------------------
-- Raise_From_Signal_Handler --
-------------------------------
1710
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : Big_String_Ptr)
is
1715 begin
Set_Exception_C_Msg (E, M);
Abort_Defer.all;
Process_Raise_Exception (E => E, From_Signal_Handler => True);
end Raise_From_Signal_Handler;
1720
------------------
-- Raise_No_Msg --
------------------
1725 procedure Raise_No_Msg (E : Exception_Id) is
Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Msg_Length := 0;
1730 Raise_With_Msg (E);
end Raise_No_Msg;
-------------------------
-- Raise_Program_Error --
1735 -------------------------
procedure Raise_Program_Error
(File : Big_String_Ptr;
Line : Integer)
1740 is
begin
Raise_With_Location (Program_Error_Def'Access, File, Line);
end Raise_Program_Error;
1745 -----------------------------
-- Raise_Program_Error_Msg --
-----------------------------
procedure Raise_Program_Error_Msg
1750 (File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
begin
1755 Raise_With_Location_And_Msg
(Program_Error_Def'Access, File, Line, Msg);
end Raise_Program_Error_Msg;
-------------------------
1760 -- Raise_Storage_Error --
-------------------------
procedure Raise_Storage_Error
(File : Big_String_Ptr;
1765 Line : Integer)
is
begin
Raise_With_Location (Storage_Error_Def'Access, File, Line);
end Raise_Storage_Error;
1770
-----------------------------
-- Raise_Storage_Error_Msg --
-----------------------------
1775 procedure Raise_Storage_Error_Msg
(File : Big_String_Ptr;
Line : Integer;
Msg : Big_String_Ptr)
is
1780 begin
Raise_With_Location_And_Msg
(Storage_Error_Def'Access, File, Line, Msg);
end Raise_Storage_Error_Msg;
1785 ----------------------
-- Raise_With_C_Msg --
----------------------
procedure Raise_With_C_Msg
1790 (E : Exception_Id;
M : Big_String_Ptr)
is
begin
Set_Exception_C_Msg (E, M);
1795 Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_C_Msg;
-------------------------
1800 -- Raise_With_Location --
-------------------------
procedure Raise_With_Location
(E : Exception_Id;
1805 F : Big_String_Ptr;
L : Integer)
is
begin
Set_Exception_C_Msg (E, F, L);
1810 Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Location;
---------------------------------
1815 -- Raise_With_Location_And_Msg --
---------------------------------
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
1820 F : Big_String_Ptr;
L : Integer;
M : Big_String_Ptr)
is
begin
1825 Set_Exception_C_Msg (E, F, L, M);
Abort_Defer.all;
Raise_Current_Excep (E);
end Raise_With_Location_And_Msg;
1830 --------------------
-- Raise_With_Msg --
--------------------
procedure Raise_With_Msg (E : Exception_Id) is
1835 Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Id := E;
1840 Excep.Num_Tracebacks := 0;
Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
Abort_Defer.all;
Raise_Current_Excep (E);
1845 end Raise_With_Msg;
-------------
-- Reraise --
-------------
1850
procedure Reraise is
Excep : constant EOA := Get_Current_Excep.all;
begin
1855 Abort_Defer.all;
Raise_Current_Excep (Excep.Id);
end Reraise;
------------------------
1860 -- Reraise_Occurrence --
------------------------
procedure Reraise_Occurrence (X : Exception_Occurrence) is
begin
1865 if X.Id /= null then
Abort_Defer.all;
Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end if;
1870 end Reraise_Occurrence;
-------------------------------
-- Reraise_Occurrence_Always --
-------------------------------
1875
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
Abort_Defer.all;
Save_Occurrence (Get_Current_Excep.all.all, X);
1880 Raise_Current_Excep (X.Id);
end Reraise_Occurrence_Always;
---------------------------------
-- Reraise_Occurrence_No_Defer --
1885 ---------------------------------
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
begin
Save_Occurrence (Get_Current_Excep.all.all, X);
1890 Raise_Current_Excep (X.Id);
end Reraise_Occurrence_No_Defer;
---------------------
-- Save_Occurrence --
1895 ---------------------
procedure Save_Occurrence
(Target : out Exception_Occurrence;
Source : Exception_Occurrence)
1900 is
begin
Target.Id := Source.Id;
Target.Msg_Length := Source.Msg_Length;
Target.Num_Tracebacks := Source.Num_Tracebacks;
1905 Target.Pid := Source.Pid;
Target.Cleanup_Flag := Source.Cleanup_Flag;
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
1910
Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
Source.Tracebacks (1 .. Target.Num_Tracebacks);
end Save_Occurrence;
1915 function Save_Occurrence
(Source : Exception_Occurrence)
return EOA
is
Target : EOA := new Exception_Occurrence;
1920
begin
Save_Occurrence (Target.all, Source);
return Target;
end Save_Occurrence;
1925
---------------------
-- SDP_Table_Build --
---------------------
1930 procedure SDP_Table_Build
(SDP_Addresses : System.Address;
SDP_Count : Natural;
Elab_Addresses : System.Address;
Elab_Addr_Count : Natural)
1935 is
type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr;
type SDLP_Array_Ptr is access all SDLP_Array;
function To_SDLP_Array_Ptr is new Unchecked_Conversion
1940 (System.Address, SDLP_Array_Ptr);
T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses);
type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc;
1945 type Elab_Array_Ptr is access all Elab_Array;
function To_Elab_Array_Ptr is new Unchecked_Conversion
(System.Address, Elab_Array_Ptr);
1950 EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses);
Ndes : Natural;
Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
1955 begin
-- If first call, then initialize count of subprogram descriptors
if Subprogram_Descriptors = null then
Num_Subprogram_Descriptors := 0;
1960 end if;
-- First count number of subprogram descriptors. This count includes
-- entries with duplicated code addresses (resulting from Import).
1965 Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count;
for J in T'Range loop
Ndes := Ndes + T (J).Count;
end loop;
1970 -- Now, allocate the new table (extra zero'th element is for sort call)
-- after having saved the previous one
Previous_Subprogram_Descriptors := Subprogram_Descriptors;
Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes);
1975
-- If there was a previous Subprogram_Descriptors table, copy it back
-- into the new one being built. Then free the memory used for the
-- previous table.
1980 for J in 1 .. Num_Subprogram_Descriptors loop
Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J);
end loop;
Free (Previous_Subprogram_Descriptors);
1985
-- Next, append the elaboration routine addresses, building dummy
-- SDP's for them as we go through the list.
Ndes := Num_Subprogram_Descriptors;
1990 for J in EA'Range loop
Ndes := Ndes + 1;
Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0;
Subprogram_Descriptors (Ndes).all :=
1995 Subprogram_Descriptor'
(Num_Handlers => 0,
Code => Fetch_Code (EA (J)),
Subprogram_Info => EA (J),
Handler_Records => (1 .. 0 => null));
2000 end loop;
-- Now copy in pointers to SDP addresses of application subprograms
for J in T'Range loop
2005 for K in 1 .. T (J).Count loop
Ndes := Ndes + 1;
Subprogram_Descriptors (Ndes) := T (J).SDesc (K);
Subprogram_Descriptors (Ndes).Code :=
Fetch_Code (T (J).SDesc (K).Code);
2010 end loop;
end loop;
-- Now we need to sort the table into ascending PC order
2015 Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access);
-- Now eliminate duplicate entries. Note that in the case where
-- entries have duplicate code addresses, the code for the Lt
-- routine ensures that the interesting one (i.e. the one with
2020 -- handler entries if there are any) comes first.
Num_Subprogram_Descriptors := 1;
for J in 2 .. Ndes loop
2025 if Subprogram_Descriptors (J).Code /=
Subprogram_Descriptors (Num_Subprogram_Descriptors).Code
then
Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1;
Subprogram_Descriptors (Num_Subprogram_Descriptors) :=
2030 Subprogram_Descriptors (J);
end if;
end loop;
end SDP_Table_Build;
2035
-----------------------
-- SDP_Table_Sort_Lt --
-----------------------
2040 function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is
SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code;
SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code;
begin
2045 if SDC1 < SDC2 then
return True;
elsif SDC1 > SDC2 then
return False;
2050
-- For two descriptors for the same procedure, we want the more
-- interesting one first. A descriptor with an exception handler
-- is more interesting than one without. This happens if the less
-- interesting one came from a pragma Import.
2055
else
return Subprogram_Descriptors (Op1).Num_Handlers /= 0
and then Subprogram_Descriptors (Op2).Num_Handlers = 0;
end if;
2060 end SDP_Table_Sort_Lt;
--------------------------
-- SDP_Table_Sort_Move --
--------------------------
2065
procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is
begin
Subprogram_Descriptors (To) := Subprogram_Descriptors (From);
end SDP_Table_Sort_Move;
2070
-------------------------
-- Set_Exception_C_Msg --
-------------------------
2075 procedure Set_Exception_C_Msg
(Id : Exception_Id;
Msg1 : Big_String_Ptr;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null)
2080 is
Excep : constant EOA := Get_Current_Excep.all;
Val : Integer := Line;
Remind : Integer;
Size : Integer := 1;
2085 Ptr : Natural;
begin
Excep.Exception_Raised := False;
Excep.Id := Id;
2090 Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
Excep.Msg_Length := 0;
Excep.Cleanup_Flag := False;
2095 while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
2100 end loop;
-- Append line number if present
if Line > 0 then
2105
-- Compute the number of needed characters
while Val > 0 loop
Val := Val / 10;
2110 Size := Size + 1;
end loop;
-- If enough characters are available, put the line number
2115 if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
Excep.Msg (Excep.Msg_Length + 1) := ':';
Excep.Msg_Length := Excep.Msg_Length + Size;
Val := Line;
Size := 0;
2120
while Val > 0 loop
Remind := Val rem 10;
Val := Val / 10;
Excep.Msg (Excep.Msg_Length - Size) :=
2125 Character'Val (Remind + Character'Pos ('0'));
Size := Size + 1;
end loop;
end if;
end if;
2130
-- Append second message if present
if Msg2 /= null
and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
2135 then
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := ' ';
Ptr := 1;
2140 while Msg2 (Ptr) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
2145 Ptr := Ptr + 1;
end loop;
end if;
end Set_Exception_C_Msg;
2150 -------------------
-- String_To_EId --
-------------------
function String_To_EId (S : String) return Exception_Id is
2155 begin
if S = "" then
return Null_Id;
else
return Exception_Id (Internal_Exception (S));
2160 end if;
end String_To_EId;
------------------
-- String_To_EO --
2165 ------------------
function String_To_EO (S : String) return Exception_Occurrence is
From : Natural;
To : Integer;
2170
X : Exception_Occurrence;
-- This is the exception occurrence we will create
procedure Bad_EO;
2175 pragma No_Return (Bad_EO);
-- Signal bad exception occurrence string
procedure Next_String;
-- On entry, To points to last character of previous line of the
2180 -- message, terminated by LF. On return, From .. To are set to
-- specify the next string, or From > To if there are no more lines.
procedure Bad_EO is
begin
2185 Raise_Exception
(Program_Error'Identity,
"bad exception occurrence in stream input");
end Bad_EO;
2190 procedure Next_String is
begin
From := To + 2;
if From < S'Last then
2195 To := From + 1;
while To < S'Last - 1 loop
if To >= S'Last then
Bad_EO;
2200 elsif S (To + 1) = ASCII.LF then
exit;
else
To := To + 1;
end if;
2205 end loop;
end if;
end Next_String;
-- Start of processing for String_To_EO
2210
begin
if S = "" then
return Null_Occurrence;
2215 else
X.Cleanup_Flag := False;
To := S'First - 2;
Next_String;
2220
if S (From .. From + 15) /= "Exception name: " then
Bad_EO;
end if;
2225 X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
Next_String;
if From <= To and then S (From) = 'M' then
2230 if S (From .. From + 8) /= "Message: " then
Bad_EO;
end if;
X.Msg_Length := To - From - 8;
2235 X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
Next_String;
else
X.Msg_Length := 0;
2240 end if;
X.Pid := 0;
if From <= To and then S (From) = 'P' then
2245 if S (From .. From + 3) /= "PID:" then
Bad_EO;
end if;
From := From + 5; -- skip past PID: space
2250
while From <= To loop
X.Pid := X.Pid * 10 +
(Character'Pos (S (From)) - Character'Pos ('0'));
From := From + 1;
2255 end loop;
Next_String;
end if;
2260 X.Num_Tracebacks := 0;
if From <= To then
if S (From .. To) /= "Call stack traceback locations:" then
Bad_EO;
2265 end if;
Next_String;
loop
exit when From > To;
2270
declare
Ch : Character;
C : Integer_Address;
N : Integer_Address;
2275
begin
if S (From) /= '0'
or else S (From + 1) /= 'x'
then
2280 Bad_EO;
else
From := From + 2;
end if;
2285 C := 0;
while From <= To loop
Ch := S (From);
if Ch in '0' .. '9' then
2290 N :=
Character'Pos (S (From)) - Character'Pos ('0');
elsif Ch in 'a' .. 'f' then
N :=
2295 Character'Pos (S (From)) - Character'Pos ('a') + 10;
elsif Ch = ' ' then
From := From + 1;
exit;
2300
else
Bad_EO;
end if;
2305 C := C * 16 + N;
From := From + 1;
end loop;
2310 if X.Num_Tracebacks = Max_Tracebacks then
Bad_EO;
end if;
X.Num_Tracebacks := X.Num_Tracebacks + 1;
2315 X.Tracebacks (X.Num_Tracebacks) := To_Address (C);
end;
end loop;
end if;
2320 -- If an exception was converted to a string, it must have
-- already been raised, so flag it accordingly and we are done.
X.Exception_Raised := True;
return X;
2325 end if;
end String_To_EO;
----------------------------------
-- Tailored_Exception_Traceback --
2330 ----------------------------------
function Tailored_Exception_Traceback
(X : Exception_Occurrence)
return String
2335 is
-- We indeed reference the decorator *wrapper* from here and not the
-- decorator itself. The purpose of the local variable Wrapper is to
-- prevent a potential crash by race condition in the code below. The
-- atomicity of this assignment is enforced by pragma Atomic in
2340 -- System.Soft_Links.
-- The potential race condition here, if no local variable was used,
-- relates to the test upon the wrapper's value and the call, which
-- are not performed atomically. With the local variable, potential
2345 -- changes of the wrapper's global value between the test and the
-- call become inoffensive.
Wrapper : constant Traceback_Decorator_Wrapper_Call :=
Traceback_Decorator_Wrapper;
2350
begin
if Wrapper = null then
return Basic_Exception_Traceback (X);
else
2355 return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
end if;
end Tailored_Exception_Traceback;
------------------------------------
2360 -- Tailored_Exception_Information --
------------------------------------
function Tailored_Exception_Information
(X : Exception_Occurrence)
2365 return String
is
-- The tailored exception information is simply the basic information
-- associated with the tailored call chain backtrace.
2370 Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Tailored_Exception_Traceback (X);
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
2375
Info : String (1 .. Basic_Len + Tback_Len);
Ptr : Natural := 0;
begin
2380 Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info;
end Tailored_Exception_Information;
2385
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
Last : in out Integer)
2390 is
begin
Append_Info_String (Basic_Exception_Information (X), Buff, Last);
Append_Info_String (Tailored_Exception_Traceback (X), Buff, Last);
end Tailored_Exception_Information;
2395
-------------------------
-- Unhandled_Exception --
-------------------------
2400 procedure Unhandled_Exception is
begin
null;
end Unhandled_Exception;
2405 ----------------------
-- Notify_Exception --
----------------------
procedure Notify_Exception
2410 (Id : Exception_Id;
Handler : Code_Loc;
Is_Others : Boolean)
is
begin
2415 null;
end Notify_Exception;
------------------------------
-- Notify_Handled_Exception --
2420 ------------------------------
procedure Notify_Handled_Exception
(Handler : Code_Loc;
Is_Others : Boolean;
2425 Low_Notify : Boolean)
is
Excep : constant EOA := Get_Current_Excep.all;
begin
2430 -- Notify the debugger that we have found a handler and are about to
-- propagate an exception, but only if specifically told to do so.
if Low_Notify then
Notify_Exception (Excep.Id, Handler, Is_Others);
2435 end if;
-- Output some exception information if necessary, as specified by
-- GNAT.Exception_Traces. Take care not to output information about
-- internal exceptions.
2440 --
-- ??? In the ZCX case, the traceback entries we have at this point
-- only include the ones we stored while walking up the stack *up to
-- the handler*. All the frames above the subprogram in which the
-- handler is found are missing.
2445
if Exception_Trace = Every_Raise
and then not Excep.Id.Not_Handled_By_Others
then
To_Stderr (Nline);
2450 To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end if;
2455 end Notify_Handled_Exception;
------------------------------
-- Notify_Handled_Exception --
------------------------------
2460
procedure Notify_Unhandled_Exception (Id : Exception_Id) is
begin
-- Simply perform the two necessary low level notification calls.
2465 Unhandled_Exception;
Notify_Exception (Id, Null_Loc, False);
end Notify_Unhandled_Exception;
2470 -----------------------------------
-- Unhandled_Exception_Terminate --
-----------------------------------
type FILEs is new System.Address;
2475 type int is new Integer;
procedure Unhandled_Exception_Terminate is
Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
2480 -- This occurrence will be used to display a message after finalization.
-- It is necessary to save a copy here, or else the designated value
-- could be overwritten if an exception is raised during finalization
-- (even if that exception is caught).
2485 Msg : constant String := Excep.Msg (1 .. Excep.Msg_Length);
Max_Static_Exc_Info : constant := 1024;
-- That should be enough for most exception information cases
-- eventhough tailorisation introduce some uncertainty. the
2490 -- name+message should not exceed 320 chars, so that leaves at
-- least 35 backtrace slots (each slot needs 19 chars for
-- representing a 64 bit address).
subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info);
2495 type Str_Ptr is access Exc_Info_Type;
Exc_Info : Str_Ptr;
Exc_Info_Last : Natural := 0;
-- Buffer that is allocated to store the tailored exception
-- information while Adafinal is run. This buffer is allocated
2500 -- on the heap only when it is needed. It is better to allocate
-- on the heap than on the stack since stack overflows are more
-- common that heap overflows.
-- Start of processing for Unhandled_Exception_Terminate
2505
begin
-- First allocate & store the exception info in a buffer when
-- we know it will be needed. This needs to be done before
-- Adafinal because it implicitly uses the secondary stack.
2510
if Excep.Id.Full_Name.all (1) /= '_'
and then Excep.Num_Tracebacks /= 0
then
Exc_Info := new Exc_Info_Type;
2515 if Exc_Info /= null then
Tailored_Exception_Information
(Excep.all, Exc_Info.all, Exc_Info_Last);
end if;
end if;
2520
-- Let's shutdown the runtime now. The rest of the procedure
-- needs to be careful not to use anything that would require
-- runtime support. In particular, function returing strings
-- are banned since the sec stack is not functional anymore
2525
System.Standard_Library.Adafinal;
-- Check for special case of raising _ABORT_SIGNAL, which is not
-- really an exception at all. We recognize this by the fact that
2530 -- it is the only exception whose name starts with underscore.
if Excep.Id.Full_Name.all (1) = '_' then
To_Stderr (Nline);
To_Stderr ("Execution terminated by abort of environment task");
2535 To_Stderr (Nline);
-- If no tracebacks, we print the unhandled exception in the old style
-- (i.e. the style used before ZCX was implemented). We do this to
-- retain compatibility, especially with the nightly scripts, but
2540 -- this can be removed at some point ???
elsif Excep.Num_Tracebacks = 0 then
To_Stderr (Nline);
To_Stderr ("raised ");
2545 To_Stderr (Excep.Id.Full_Name.all (1 .. Excep.Id.Name_Length - 1));
if Msg'Length /= 0 then
To_Stderr (" : ");
To_Stderr (Msg);
2550 end if;
To_Stderr (Nline);
else -- Traceback exists
2555
-- Note we can have this whole information output twice if
-- this occurrence gets reraised up to here.
To_Stderr (Nline);
2560 To_Stderr ("Execution terminated by unhandled exception");
To_Stderr (Nline);
To_Stderr (Exc_Info (1 .. Exc_Info_Last));
end if;
2565 -- Perform system dependent shutdown code
declare
procedure Unhandled_Terminate;
pragma No_Return (Unhandled_Terminate);
2570 pragma Import
(C, Unhandled_Terminate, "__gnat_unhandled_terminate");
begin
Unhandled_Terminate;
2575 end;
end Unhandled_Exception_Terminate;
------------------------------
2580 -- Raise_Exception_No_Defer --
------------------------------
procedure Raise_Exception_No_Defer
(E : Exception_Id;
2585 Message : String := "")
is
Len : constant Natural :=
Natural'Min (Message'Length, Exception_Msg_Max_Length);
2590 Excep : constant EOA := Get_Current_Excep.all;
begin
Excep.Exception_Raised := False;
Excep.Msg_Length := Len;
2595 Excep.Msg (1 .. Len) := Message (1 .. Len);
Excep.Id := E;
Excep.Num_Tracebacks := 0;
Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
2600
-- DO NOT CALL Abort_Defer.all; !!!!
Raise_Current_Excep (E);
end Raise_Exception_No_Defer;
2605
---------------
-- To_Stderr --
---------------
2610 procedure To_Stderr (S : String) is
procedure put_char_stderr (C : int);
pragma Import (C, put_char_stderr, "put_char_stderr");
begin
2615 for J in 1 .. S'Length loop
if S (J) /= ASCII.CR then
put_char_stderr (Character'Pos (S (J)));
end if;
end loop;
2620 end To_Stderr;
---------
-- ZZZ --
---------
2625
-- This dummy procedure gives us the end of the PC range for addresses
-- within the exception unit itself. We hope that gigi/gcc keeps all the
-- procedures in their original order!
2630 procedure ZZZ is
begin
null;
end ZZZ;
2635 begin
-- Allocate the Non-Tasking Machine_State
Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
end Ada.Exceptions;