1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2003 Free Software Foundation, Inc. -- 10-- -- 11-- This specification is derived from the Ada Reference Manual for use with -- 12-- GNAT. The copyright notice above, and the license provisions that follow -- 13-- apply solely to the contents of the part following the private keyword. -- 14-- -- 15-- GNAT is free software; you can redistribute it and/or modify it under -- 16-- terms of the GNU General Public License as published by the Free Soft- -- 17-- ware Foundation; either version 2, or (at your option) any later ver- -- 18-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 19-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 20-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 21-- for more details. You should have received a copy of the GNU General -- 22-- Public License distributed with GNAT; see file COPYING. If not, write -- 23-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 24-- MA 02111-1307, USA. -- 25-- -- 26-- As a special exception, if other files instantiate generics from this -- 27-- unit, or you link this unit with other files to produce an executable, -- 28-- this unit does not by itself cause the resulting executable to be -- 29-- covered by the GNU General Public License. This exception does not -- 30-- however invalidate any other reasons why the executable file might be -- 31-- covered by the GNU Public License. -- 32-- -- 33-- GNAT was originally developed by the GNAT team at New York University. -- 34-- Extensive contributions were provided by Ada Core Technologies Inc. -- 35-- -- 36------------------------------------------------------------------------------ 37 38-- Default version for most targets 39 40procedure Ada.Exceptions.Last_Chance_Handler 41 (Except : Exception_Occurrence) 42is 43 procedure Unhandled_Terminate; 44 pragma No_Return (Unhandled_Terminate); 45 pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); 46 -- Perform system dependent shutdown code 47 48 function Tailored_Exception_Information 49 (X : Exception_Occurrence) return String; 50 -- Exception information to be output in the case of automatic tracing 51 -- requested through GNAT.Exception_Traces. 52 -- 53 -- This is the same as Exception_Information if no backtrace decorator 54 -- is currently in place. Otherwise, this is Exception_Information with 55 -- the call chain raw addresses replaced by the result of a call to the 56 -- current decorator provided with the call chain addresses. 57 58 pragma Import 59 (Ada, Tailored_Exception_Information, 60 "__gnat_tailored_exception_information"); 61 62 procedure Tailored_Exception_Information 63 (X : Exception_Occurrence; 64 Buff : in out String; 65 Last : in out Integer); 66 -- Procedural version of the above function. Instead of returning the 67 -- result, this one is put in Buff (Buff'first .. Buff'first + Last) 68 69 procedure To_Stderr (S : String); 70 pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); 71 -- Little routine to output string to stderr 72 73 Nline : constant String := String'(1 => ASCII.LF); 74 -- Convenient shortcut 75 76 Msg : constant String := Except.Msg (1 .. Except.Msg_Length); 77 78 Max_Static_Exc_Info : constant := 1024; 79 -- This should be enough for most exception information cases 80 -- even though tailoring introduces some uncertainty. The 81 -- name+message should not exceed 320 chars, so that leaves at 82 -- least 35 backtrace slots (each slot needs 19 chars for 83 -- representing a 64 bit address). 84 85 subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info); 86 type Str_Ptr is access Exc_Info_Type; 87 Exc_Info : Str_Ptr; 88 Exc_Info_Last : Natural := 0; 89 -- Buffer that is allocated to store the tailored exception 90 -- information while Adafinal is run. This buffer is allocated 91 -- on the heap only when it is needed. It is better to allocate 92 -- on the heap than on the stack since stack overflows are more 93 -- common than heap overflows. 94 95 procedure Tailored_Exception_Information 96 (X : Exception_Occurrence; 97 Buff : in out String; 98 Last : in out Integer) 99 is 100 Info : constant String := Tailored_Exception_Information (X); 101 begin 102 Last := Info'Last; 103 Buff (1 .. Last) := Info; 104 end Tailored_Exception_Information; 105 106begin 107 -- First allocate & store the exception info in a buffer when 108 -- we know it will be needed. This needs to be done before 109 -- Adafinal because it implicitly uses the secondary stack. 110 111 if Except.Id.Full_Name.all (1) /= '_' 112 and then Except.Num_Tracebacks /= 0 113 then 114 Exc_Info := new Exc_Info_Type; 115 if Exc_Info /= null then 116 Tailored_Exception_Information 117 (Except, Exc_Info.all, Exc_Info_Last); 118 end if; 119 end if; 120 121 -- Let's shutdown the runtime now. The rest of the procedure 122 -- needs to be careful not to use anything that would require 123 -- runtime support. In particular, functions returning strings 124 -- are banned since the sec stack is no longer functional. 125 System.Standard_Library.Adafinal; 126 127 -- Check for special case of raising _ABORT_SIGNAL, which is not 128 -- really an exception at all. We recognize this by the fact that 129 -- it is the only exception whose name starts with underscore. 130 131 if Except.Id.Full_Name.all (1) = '_' then 132 To_Stderr (Nline); 133 To_Stderr ("Execution terminated by abort of environment task"); 134 To_Stderr (Nline); 135 136 -- If no tracebacks, we print the unhandled exception in the old style 137 -- (i.e. the style used before ZCX was implemented). We do this to 138 -- retain compatibility. 139 140 elsif Except.Num_Tracebacks = 0 then 141 To_Stderr (Nline); 142 To_Stderr ("raised "); 143 To_Stderr (Except.Id.Full_Name.all (1 .. Except.Id.Name_Length - 1)); 144 145 if Msg'Length /= 0 then 146 To_Stderr (" : "); 147 To_Stderr (Msg); 148 end if; 149 150 To_Stderr (Nline); 151 152 -- Traceback exists 153 154 else 155 -- Note we can have this whole information output twice if 156 -- this occurrence gets reraised up to here. 157 158 To_Stderr (Nline); 159 To_Stderr ("Execution terminated by unhandled exception"); 160 To_Stderr (Nline); 161 To_Stderr (Exc_Info (1 .. Exc_Info_Last)); 162 end if; 163 164 Unhandled_Terminate; 165end Ada.Exceptions.Last_Chance_Handler; 166