File : s-init-lynxos178-cert.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                           S Y S T E M . I N I T                          --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --          Copyright (C) 2013-2014, 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 -- In particular,  you can freely  distribute your programs  built with the --
  23 -- GNAT Pro compiler, including any required library run-time units,  using --
  24 -- any licensing terms  of your choosing.  See the AdaCore Software License --
  25 -- for full details.                                                        --
  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 --  This is the Level A cert version for LynxOS 178
  33 
  34 --  This file should be kept synchronized with init.c, s-osvers-*.ads, and
  35 --  s-init-xi-sparc.adb. All these files implement the required functionality
  36 --  for different targets.
  37 
  38 with Interfaces.C;
  39 
  40 package body System.Init is
  41 
  42    use Interfaces.C;
  43 
  44    Stack_Limit_Hook : System.Address;
  45    pragma Export (C, Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
  46    --  Used when stack limit checking is the stack overflow checking method
  47 
  48    -----------------------------
  49    -- Binder Generated Values --
  50    -----------------------------
  51 
  52    Gl_Main_Priority : Integer := -1;
  53    pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
  54 
  55    Gl_Main_CPU : Integer := -1;
  56    pragma Export (C, Gl_Main_CPU, "__gl_main_cpu");
  57 
  58    ------------------------
  59    -- Signal Definitions --
  60    ------------------------
  61 
  62    NSIG : constant := 64;
  63    --  Number of signals on the target OS
  64 
  65    type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
  66 
  67    SIGILL  : constant :=  4; --  illegal instruction (not reset)
  68    SIGFPE  : constant :=  8; --  floating point exception
  69    SIGBUS  : constant := 10; --  bus error
  70    SIGSEGV : constant := 11; --  segmentation violation
  71 
  72    SIG_SETMASK : constant := 2;
  73 
  74    type sigset_t is array (1 .. 2) of long;
  75 
  76    type struct_sigaction is record
  77       sa_handler : System.Address;
  78       sa_mask    : sigset_t;
  79       sa_flags   : int;
  80    end record;
  81    pragma Convention (C, struct_sigaction);
  82    type struct_sigaction_ptr is access all struct_sigaction;
  83 
  84    function sigaction
  85      (sig  : Signal;
  86       act  : struct_sigaction_ptr;
  87       oact : struct_sigaction_ptr) return int;
  88    pragma Import (C, sigaction, "sigaction");
  89 
  90    function sigemptyset (set : access sigset_t) return int;
  91    pragma Import (C, sigemptyset, "sigemptyset");
  92 
  93    function sigdelset (set : access sigset_t; sig : Signal) return int;
  94    pragma Import (C, sigdelset, "sigdelset");
  95 
  96    type sigset_t_ptr is access all sigset_t;
  97 
  98    function pthread_sigmask
  99      (How  : int;
 100       Set  : sigset_t_ptr;
 101       Oset : sigset_t_ptr) return int;
 102    pragma Import (C, pthread_sigmask, "pthread_sigmask");
 103 
 104    ----------------------
 105    -- Local Procedures --
 106    ----------------------
 107 
 108    procedure GNAT_Error_Handler (Sig : Signal);
 109    pragma No_Return (GNAT_Error_Handler);
 110    --  Common procedure that is executed when a SIGFPE, SIGILL, SIGSEGV, or
 111    --  SIGBUS is captured.
 112 
 113    ------------------------
 114    -- GNAT_Error_Handler --
 115    ------------------------
 116 
 117    procedure GNAT_Error_Handler (Sig : Signal) is
 118       Mask   : aliased sigset_t;
 119       Result : int;
 120       pragma Unreferenced (Result);
 121    begin
 122       Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
 123       Result := sigdelset (Mask'Unchecked_Access, Sig);
 124       Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
 125 
 126       case Sig is
 127          when SIGFPE =>
 128             raise Constraint_Error with "SIGFPE";
 129 
 130          when SIGILL =>
 131             raise Constraint_Error with "SIGILL";
 132 
 133          when SIGSEGV =>
 134             raise Storage_Error with "SIGSEGV";
 135 
 136          when SIGBUS =>
 137             raise Program_Error with "SIGBUS";
 138 
 139          when others =>
 140             raise Program_Error with "unexpected signal";
 141       end case;
 142    end GNAT_Error_Handler;
 143 
 144    ---------------------
 145    -- Install_Handler --
 146    ---------------------
 147 
 148    procedure Install_Handler is
 149       Mask          : aliased sigset_t;
 150       Signal_Action : aliased struct_sigaction;
 151 
 152       Result : Interfaces.C.int;
 153       pragma Unreferenced (Result);
 154 
 155    begin
 156       --  Set up signal handler to map synchronous signals to appropriate
 157       --  exceptions. Make sure that the handler isn't interrupted by another
 158       --  signal that might cause a scheduling event.
 159 
 160       Signal_Action.sa_handler := GNAT_Error_Handler'Address;
 161       Signal_Action.sa_flags := 0;
 162       Result := sigemptyset (Mask'Unchecked_Access);
 163       Signal_Action.sa_mask := Mask;
 164 
 165       Result :=
 166         sigaction (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
 167 
 168       Result :=
 169         sigaction (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
 170 
 171       Result :=
 172         sigaction (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
 173 
 174       Result :=
 175         sigaction (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
 176    end Install_Handler;
 177 
 178    ------------------------
 179    -- Runtime_Initialize --
 180    ------------------------
 181 
 182    procedure Runtime_Initialize is
 183    begin
 184       Install_Handler;
 185    end Runtime_Initialize;
 186 
 187    ----------------------
 188    -- Runtime_Finalize --
 189    ----------------------
 190 
 191    procedure Runtime_Finalize is
 192    begin
 193       null;
 194    end Runtime_Finalize;
 195 
 196 end System.Init;