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-2018, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32pragma Warnings (Off);
33with System.Standard_Library;
34pragma Warnings (On);
35
36with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
37with GNAT.IO; use GNAT.IO;
38
39--  Default last chance handler for use with the full VxWorks 653 partition OS
40--  Ada run-time library.
41
42--  Logs error with health monitor, and dumps exception identity and argument
43--  string for vxaddr2line for generation of a symbolic stack backtrace.
44
45procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is
46
47   ----------------------
48   -- APEX definitions --
49   ----------------------
50
51   pragma Warnings (Off);
52   type Error_Code_Type is (
53      Deadline_Missed,
54      Application_Error,
55      Numeric_Error,
56      Illegal_Request,
57      Stack_Overflow,
58      Memory_Violation,
59      Hardware_Fault,
60      Power_Fail);
61   pragma Warnings (On);
62   pragma Convention (C, Error_Code_Type);
63   --  APEX Health Management error codes
64
65   type Message_Addr_Type is new System.Address;
66
67   type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1;
68   pragma Convention (C, Apex_Integer);
69
70   Max_Error_Message_Size : constant := 64;
71
72   type Error_Message_Size_Type is new Apex_Integer range
73      1 .. Max_Error_Message_Size;
74
75   pragma Warnings (Off);
76   type Return_Code_Type is (
77      No_Error,        --  request valid and operation performed
78      No_Action,       --  status of system unaffected by request
79      Not_Available,   --  resource required by request unavailable
80      Invalid_Param,   --  invalid parameter specified in request
81      Invalid_Config,  --  parameter incompatible with configuration
82      Invalid_Mode,    --  request incompatible with current mode
83      Timed_Out);      --  time-out tied up with request has expired
84   pragma Warnings (On);
85   pragma Convention (C, Return_Code_Type);
86   --  APEX return codes
87
88   procedure Raise_Application_Error
89     (Error_Code   : Error_Code_Type;
90      Message_Addr : Message_Addr_Type;
91      Length       : Error_Message_Size_Type;
92      Return_Code  : out Return_Code_Type);
93   pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR");
94
95   procedure Unhandled_Terminate;
96   pragma No_Return (Unhandled_Terminate);
97   pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
98   --  Perform system dependent shutdown code
99
100   procedure Adainit;
101   pragma Import (Ada, Adainit, "adainit");
102
103   Adainit_Addr : constant System.Address := Adainit'Code_Address;
104   --  Part of arguments to vxaddr2line
105
106   Result : Return_Code_Type;
107
108   Message      : String :=
109     Exception_Name (Except) &   ": " & ASCII.LF &
110     Exception_Message (Except) & ASCII.NUL;
111
112   Message_Length : Error_Message_Size_Type;
113
114begin
115   New_Line;
116   Put_Line ("In last chance handler");
117   Put_Line (Message (1 .. Message'Length - 1));
118   New_Line;
119
120   Put_Line ("adainit and traceback addresses for vxaddr2line:");
121
122   Put (Image_C (Adainit_Addr)); Put (" ");
123
124   for J in 1 .. Except.Num_Tracebacks loop
125      Put (Image_C (Except.Tracebacks (J)));
126      Put (" ");
127   end loop;
128
129   New_Line;
130
131   if Message'Length > Error_Message_Size_Type'Last then
132      Message_Length := Error_Message_Size_Type'Last;
133   else
134      Message_Length := Message'Length;
135   end if;
136
137   Raise_Application_Error
138     (Error_Code   => Application_Error,
139      Message_Addr => Message_Addr_Type (Message (1)'Address),
140      Length       => Message_Length,
141      Return_Code  => Result);
142
143   --  Shutdown the run-time library now. The rest of the procedure needs to be
144   --  careful not to use anything that would require runtime support. In
145   --  particular, functions returning strings are banned since the sec stack
146   --  is no longer functional.
147
148   System.Standard_Library.Adafinal;
149   Unhandled_Terminate;
150end Ada.Exceptions.Last_Chance_Handler;
151