------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N I T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VxWorks version of this package
with System.OS_Interface;
-- used for various Constants, Signal and types
with Interfaces.C;
-- used for int and other types
with Ada.Exceptions;
-- used for Raise_Exception
package body System.Init is
-- This unit contains initialization circuits that are system dependent.
use Ada.Exceptions;
use System.OS_Interface;
use type Interfaces.C.int;
-- Copies of global values computed by the binder
Gl_Main_Priority : Integer := -1;
pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
Gl_Time_Slice_Val : Integer := -1;
pragma Export (C, Gl_Time_Slice_Val, "__gl_time_slice_val");
Gl_Wc_Encoding : Character := 'n';
pragma Export (C, Gl_Wc_Encoding, "__gl_wc_encoding");
Gl_Locking_Policy : Character := ' ';
pragma Export (C, Gl_Locking_Policy, "__gl_locking_policy");
Gl_Queuing_Policy : Character := ' ';
pragma Export (C, Gl_Queuing_Policy, "__gl_queuing_policy");
Gl_Task_Dispatching_Policy : Character := ' ';
pragma Export (C, Gl_Task_Dispatching_Policy,
"__gl_task_dispatching_policy");
Gl_Restrictions : Address := Null_Address;
pragma Export (C, Gl_Restrictions, "__gl_restrictions");
Gl_Interrupt_States : Address := Null_Address;
pragma Export (C, Gl_Interrupt_States, "__gl_interrupt_states");
Gl_Num_Interrupt_States : Integer := 0;
pragma Export (C, Gl_Num_Interrupt_States, "__gl_num_interrupt_states");
Gl_Unreserve_All_Interrupts : Integer := 0;
pragma Export (C, Gl_Unreserve_All_Interrupts,
"__gl_unreserve_all_interrupts");
Gl_Exception_Tracebacks : Integer := 0;
pragma Export (C, Gl_Exception_Tracebacks, "__gl_exception_tracebacks");
Gl_Zero_Cost_Exceptions : Integer := 0;
pragma Export (C, Gl_Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
Already_Called : Boolean := False;
Handler_Installed : Integer := 0;
-- Indication of whether synchronous signal handlers have already been
-- installed by a previous call to Install_Handler.
pragma Export (C, Handler_Installed, "__gnat_handler_installed");
------------------------
-- Local procedures --
------------------------
procedure GNAT_Error_Handler (Sig : Signal);
-- Common procedure that is executed when a SIGFPE, SIGILL,
-- SIGSEGV, or SIGBUS is captured.
------------------------
-- GNAT_Error_Handler --
------------------------
procedure GNAT_Error_Handler (Sig : Signal) is
Mask : aliased sigset_t;
Result : int;
begin
-- VxWorks will always mask out the signal during the signal
-- handler and will reenable it on a longjmp. GNAT does not
-- generate a longjmp to return from a signal handler so the
-- signal will still be masked unless we unmask it.
Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
Result := sigdelset (Mask'Access, Sig);
Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
case Sig is
when SIGFPE =>
Raise_Exception (Constraint_Error'Identity, "SIGFPE");
when SIGILL =>
Raise_Exception (Constraint_Error'Identity, "SIGILL");
when SIGSEGV =>
Raise_Exception
(Program_Error'Identity,
"erroneous memory access");
when SIGBUS =>
Raise_Exception
(Storage_Error'Identity,
"stack overflow or SIGBUS");
when others =>
Raise_Exception (Program_Error'Identity, "unhandled signal");
end case;
end GNAT_Error_Handler;
-----------------
-- Set_Globals --
-----------------
-- This routine is called from the binder generated main program. It
-- copies the values for global quantities computed by the binder
-- into the following global locations. The reason that we go through
-- this copy, rather than just define the global locations in the
-- binder generated file, is that they are referenced from the
-- runtime, which may be in a shared library, and the binder file is
-- not in the shared library. Global references across library
-- boundaries like this are not handled correctly in all systems.
procedure Set_Globals
(Main_Priority : Integer;
Time_Slice_Value : Integer;
WC_Encoding : Character;
Locking_Policy : Character;
Queuing_Policy : Character;
Task_Dispatching_Policy : Character;
Restrictions : System.Address;
Interrupt_States : System.Address;
Num_Interrupt_States : Integer;
Unreserve_All_Interrupts : Integer;
Exception_Tracebacks : Integer;
Zero_Cost_Exceptions : Integer) is
begin
-- If this procedure has been already called once, check that the
-- arguments in this call are consistent with the ones in the
-- previous calls. Otherwise, raise a Program_Error exception.
--
-- We do not check for consistency of the wide character encoding
-- method. This default affects only Wide_Text_IO where no
-- explicit coding method is given, and there is no particular
-- reason to let this default be affected by the source
-- representation of a library in any case.
--
-- We do not check either for the consistency of exception tracebacks,
-- because exception tracebacks are not normally set in Stand-Alone
-- libraries. If a library or the main program set the exception
-- tracebacks, then they are never reset afterwards (see below).
--
-- The value of main_priority is meaningful only when we are
-- invoked from the main program elaboration routine of an Ada
-- application. Checking the consistency of this parameter should
-- therefore not be done. Since it is assured that the main
-- program elaboration will always invoke this procedure before
-- any library elaboration routine, only the value of
-- main_priority during the first call should be taken into
-- account and all the subsequent ones should be ignored. Note
-- that the case where the main program is not written in Ada is
-- also properly handled, since the default value will then be
-- used for this parameter.
--
-- For identical reasons, the consistency of time_slice_val should
-- not be checked.
if Already_Called then
if (Gl_Locking_Policy /= Locking_Policy) or
(Gl_Queuing_Policy /= Queuing_Policy) or
(Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or
(Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or
(Gl_Exception_Tracebacks /= Exception_Tracebacks) or
(Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
then
raise Program_Error;
end if;
-- If either a library or the main program set the exception
-- traceback flag, it is never reset later.
if Gl_Exception_Tracebacks /= 0 then
Gl_Exception_Tracebacks := Exception_Tracebacks;
end if;
else
Already_Called := True;
Gl_Main_Priority := Main_Priority;
Gl_Time_Slice_Val := Time_Slice_Value;
Gl_Wc_Encoding := WC_Encoding;
Gl_Locking_Policy := Locking_Policy;
Gl_Queuing_Policy := Queuing_Policy;
Gl_Task_Dispatching_Policy := Task_Dispatching_Policy;
Gl_Restrictions := Restrictions;
Gl_Interrupt_States := Interrupt_States;
Gl_Num_Interrupt_States := Num_Interrupt_States;
Gl_Unreserve_All_Interrupts := Unreserve_All_Interrupts;
Gl_Exception_Tracebacks := Exception_Tracebacks;
Gl_Zero_Cost_Exceptions := Zero_Cost_Exceptions;
end if;
end Set_Globals;
---------------------
-- Install_Handler --
---------------------
procedure Install_Handler is
Mask : aliased sigset_t;
Signal_Action : aliased struct_sigaction;
Result : Interfaces.C.int;
begin
-- Set up signal handler to map synchronous signals to appropriate
-- exceptions. Make sure that the handler isn't interrupted by
-- another signal that might cause a scheduling event!
Signal_Action.sa_handler := GNAT_Error_Handler'Address;
Signal_Action.sa_flags := SA_ONSTACK;
Result := sigemptyset (Mask'Access);
Signal_Action.sa_mask := Mask;
Result := sigaction
(Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
Result := sigaction
(Signal (SIGILL), Signal_Action'Unchecked_Access, null);
Result := sigaction
(Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
Result := sigaction
(Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
Handler_Installed := 1;
end Install_Handler;
end System.Init;