diff options
Diffstat (limited to 'gcc/ada/5zinit.adb')
| -rw-r--r-- | gcc/ada/5zinit.adb | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/gcc/ada/5zinit.adb b/gcc/ada/5zinit.adb new file mode 100644 index 00000000000..c947057f044 --- /dev/null +++ b/gcc/ada/5zinit.adb @@ -0,0 +1,285 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. + + procedure Install_Handler; + pragma Export (C, Install_Handler, "__gnat_install_handler"); + -- Install handler for the synchronous signals. The C profile + -- here is what is expected by the binder-generated main. + + ------------------------ + -- 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_Signal_Handlers -- + ----------------------------- + + function Install_Signal_Handlers return Interfaces.C.int is + begin + Install_Handler; + return 0; + end Install_Signal_Handlers; + + --------------------- + -- 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; |