File : a-elchha-vxworks-ppc-cert.adb
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-2015, 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 -- --
19 -- --
20 -- --
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
32 -- Default last chance handler for use with the AE653 Level A run-time library
33 -- and the VxWorks 6 Cert GOS on VxWorks 653 3.x
34
35 -- Logs error with health monitor, and dumps exception identity and partial
36 -- argument string for vxaddr2line for generation of a symbolic stack
37 -- backtrace.
38
39 -- This version cannot reference "adainit" to form the vxaddr2line arguments,
40 -- as it can be installed in a shared library, possibly with the cert run
41 -- time. "adainit" is only available in a partition containing an Ada main.
42
43 with GNAT.IO; use GNAT.IO;
44 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
45 with System.Standard_Library; use System.Standard_Library;
46 with System;
47
48 procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is
49
50 ----------------------
51 -- APEX definitions --
52 ----------------------
53
54 pragma Warnings (Off);
55 type Error_Code_Type is (
56 Deadline_Missed,
57 Application_Error,
58 Numeric_Error,
59 Illegal_Request,
60 Stack_Overflow,
61 Memory_Violation,
62 Hardware_Fault,
63 Power_Fail);
64 pragma Warnings (On);
65 pragma Convention (C, Error_Code_Type);
66 -- APEX Health Management error codes
67
68 subtype Message_Addr_Type is System.Address;
69
70 subtype Apex_Integer is Integer range -(2 ** 31) .. (2 ** 31) - 1;
71
72 Max_Error_Message_Size : constant := 128;
73
74 subtype Error_Message_Size_Type is Apex_Integer range
75 1 .. Max_Error_Message_Size;
76
77 pragma Warnings (Off);
78 type Return_Code_Type is (
79 No_Error, -- request valid and operation performed
80 No_Action, -- status of system unaffected by request
81 Not_Available, -- resource required by request unavailable
82 Invalid_Param, -- invalid parameter specified in request
83 Invalid_Config, -- parameter incompatible with configuration
84 Invalid_Mode, -- request incompatible with current mode
85 Timed_Out); -- time-out tied up with request has expired
86 pragma Warnings (On);
87 pragma Convention (C, Return_Code_Type);
88 -- APEX return codes
89
90 procedure Raise_Application_Error
91 (Error_Code : Error_Code_Type;
92 Message_Addr : Message_Addr_Type;
93 Length : Error_Message_Size_Type;
94 Return_Code : out Return_Code_Type);
95 pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR");
96
97 ----------------------
98 -- vThreads Imports --
99 ----------------------
100
101 procedure Stop (ID : Integer := 0);
102 pragma Import (C, Stop, "taskSuspend");
103 pragma No_Return (Stop);
104 -- Although taskSuspend returns a result, we ignore it,
105 -- since in this case (ID = 0 = taskIdSelf) it does not return
106
107 Result : Return_Code_Type;
108
109 Message : String (1 .. Max_Error_Message_Size);
110
111 Message_Length : Error_Message_Size_Type;
112
113 begin
114 if Except.Id.Name_Length + 25 > Max_Error_Message_Size then
115 Message_Length := Max_Error_Message_Size;
116 else
117 Message_Length := Except.Id.Name_Length + 25;
118 end if;
119
120 Message (1 .. 25) := "Unhandled Ada Exception: ";
121 Message (26 .. Message_Length - 1) :=
122 To_Ptr (Except.Id.Full_Name) (1 .. Message_Length - 26);
123 Message (Message_Length) := ASCII.NUL;
124
125 New_Line;
126 Put_Line ("In last chance handler");
127 Put_Line (Message (1 .. Message_Length - 1));
128 New_Line;
129
130 Put_Line ("traceback addresses for vxaddr2line:");
131
132 -- Dump backtrace PC values
133
134 for J in 1 .. Except.Num_Tracebacks loop
135 Put (Image_C (Except.Tracebacks (J)));
136 Put (" ");
137 end loop;
138
139 New_Line;
140
141 Raise_Application_Error
142 (Error_Code => Application_Error,
143 Message_Addr => Message_Addr_Type (Message (1)'Address),
144 Length => Message_Length,
145 Return_Code => Result);
146
147 Stop;
148 end Ada.Exceptions.Last_Chance_Handler;