path: root/gcc/ada/5zinit.adb

------------------------------------------------------------------------------
--                                                                          --
--                 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;