gcc/ada/libgnat/a-elchha__vxworks-ppc-full.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-2019, 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
  32 pragma Warnings (Off);
  33 with System.Standard_Library;
  34 pragma Warnings (On);
  35
  36 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
  37 with 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
  45 procedure 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
 114 begin
 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;
 150 end Ada.Exceptions.Last_Chance_Handler;