Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --

--                                                                          --

--                   S Y S T E M . O S _ I N T E R F A C E                  --

--                                                                          --

--                                  S p e c                                 --

--                                                                          --

--             Copyright (C) 1991-1994, Florida State University            --

--             Copyright (C) 1995-2005, 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,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, 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 a NT (native) version of this package

--  This package encapsulates all direct interfaces to OS services

--  that are needed by children of System.

--  PLEASE DO NOT add any with-clauses to this package or remove the pragma

--  Preelaborate. This package is designed to be a bottom-level (leaf) package.

with Interfaces.C;

with Interfaces.C.Strings;

with Unchecked_Conversion;

package System.OS_Interface is

   pragma Preelaborate;

   pragma Linker_Options ("-mthreads");

   subtype int  is Interfaces.C.int;

   subtype long is Interfaces.C.long;

   -------------------

   -- General Types --

   -------------------

   type DWORD is new Interfaces.C.unsigned_long;

   type WORD  is new Interfaces.C.unsigned_short;

   --  The LARGE_INTEGER type is actually a fixed point type

   --  that only can represent integers. The reason for this is

   --  easier conversion to Duration or other fixed point types.

   --  (See Operations.Clock)

   type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;

   subtype PSZ   is Interfaces.C.Strings.chars_ptr;

   subtype PCHAR is Interfaces.C.Strings.chars_ptr;

   subtype PVOID is System.Address;

   Null_Void : constant PVOID := System.Null_Address;

   type PLONG  is access all Interfaces.C.long;

   type PDWORD is access all DWORD;

   type BOOL is new Boolean;

   for BOOL'Size use Interfaces.C.unsigned_long'Size;

   -------------------------

   -- Handles for objects --

   -------------------------

   type HANDLE is new Interfaces.C.long;

   type PHANDLE is access all HANDLE;

   subtype Thread_Id is HANDLE;

   -----------

   -- Errno --

   -----------

   NO_ERROR : constant := 0;

   FUNC_ERR : constant := -1;

   -------------

   -- Signals --

   -------------

   Max_Interrupt : constant := 31;

   type Signal is new int range 0 .. Max_Interrupt;

   for Signal'Size use int'Size;

   SIGINT     : constant := 2; --  interrupt (Ctrl-C)

   SIGILL     : constant := 4; --  illegal instruction (not reset)

   SIGFPE     : constant := 8; --  floating point exception

   SIGSEGV    : constant := 11; -- segmentation violation

   SIGTERM    : constant := 15; -- software termination signal from kill

   SIGBREAK   : constant := 21; -- break (Ctrl-Break)

   SIGABRT    : constant := 22; -- used by abort, replace SIGIOT in the future

   type sigset_t is private;

   type isr_address is access procedure (sig : int);

   function intr_attach (sig : int; handler : isr_address) return long;

   pragma Import (C, intr_attach, "signal");

   Intr_Attach_Reset : constant Boolean := True;

   --  True if intr_attach is reset after an interrupt handler is called

   procedure kill (sig : Signal);

   pragma Import (C, kill, "raise");

   ---------------------

   -- Time Management --

   ---------------------

   procedure Sleep (dwMilliseconds : DWORD);

   pragma Import (Stdcall, Sleep, External_Name => "Sleep");

   type SYSTEMTIME is record

      wYear         : WORD;

      wMonth        : WORD;

      wDayOfWeek    : WORD;

      wDay          : WORD;

      wHour         : WORD;

      wMinute       : WORD;

      wSecond       : WORD;

      wMilliseconds : WORD;

   end record;

   procedure GetSystemTime (pSystemTime : access SYSTEMTIME);

   pragma Import (Stdcall, GetSystemTime, "GetSystemTime");

   procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);

   pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");

   function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL;

   pragma Import (Stdcall, SetSystemTime, "SetSystemTime");

   function FileTimeToSystemTime

     (lpFileTime   : access Long_Long_Integer;

      lpSystemTime : access SYSTEMTIME) return BOOL;

   pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");

   function SystemTimeToFileTime

     (lpSystemTime : access SYSTEMTIME;

      lpFileTime   : access Long_Long_Integer) return BOOL;

   pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");

   function FileTimeToLocalFileTime

     (lpFileTime      : access Long_Long_Integer;

      lpLocalFileTime : access Long_Long_Integer) return BOOL;

   pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");

   function LocalFileTimeToFileTime

     (lpFileTime      : access Long_Long_Integer;

      lpLocalFileTime : access Long_Long_Integer) return BOOL;

   pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");

   function QueryPerformanceCounter

     (lpPerformanceCount : access LARGE_INTEGER) return BOOL;

   pragma Import

     (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");

   function QueryPerformanceFrequency

     (lpFrequency : access LARGE_INTEGER) return BOOL;

   pragma Import

     (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");

   -------------

   -- Threads --

   -------------

   type Thread_Body is access

     function (arg : System.Address) return System.Address;

   function Thread_Body_Access is new

     Unchecked_Conversion (System.Address, Thread_Body);

   procedure SwitchToThread;

   pragma Import (Stdcall, SwitchToThread, "SwitchToThread");

   -----------------------

   -- Critical sections --

   -----------------------

   type CRITICAL_SECTION is private;

   procedure InitializeCriticalSection

     (pCriticalSection : access CRITICAL_SECTION);

   pragma Import

     (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");

   procedure EnterCriticalSection

     (pCriticalSection : access CRITICAL_SECTION);

   pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");

   procedure LeaveCriticalSection

     (pCriticalSection : access CRITICAL_SECTION);

   pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");

   procedure DeleteCriticalSection

     (pCriticalSection : access CRITICAL_SECTION);

   pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");

   -------------------------------------------------------------

   -- Thread Creation, Activation, Suspension And Termination --

   -------------------------------------------------------------

   type PTHREAD_START_ROUTINE is access function

     (pThreadParameter : PVOID) return DWORD;

   pragma Convention (Stdcall, PTHREAD_START_ROUTINE);

   function To_PTHREAD_START_ROUTINE is new

     Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);

   type SECURITY_ATTRIBUTES is record

      nLength              : DWORD;

      pSecurityDescriptor  : PVOID;

      bInheritHandle       : BOOL;

   end record;

   type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES;

   function CreateThread

     (pThreadAttributes    : PSECURITY_ATTRIBUTES;

      dwStackSize          : DWORD;

      pStartAddress        : PTHREAD_START_ROUTINE;

      pParameter           : PVOID;

      dwCreationFlags      : DWORD;

      pThreadId            : PDWORD) return HANDLE;

   pragma Import (Stdcall, CreateThread, "CreateThread");

   function BeginThreadEx

     (pThreadAttributes    : PSECURITY_ATTRIBUTES;

      dwStackSize          : DWORD;

      pStartAddress        : PTHREAD_START_ROUTINE;

      pParameter           : PVOID;

      dwCreationFlags      : DWORD;

      pThreadId            : PDWORD) return HANDLE;

   pragma Import (C, BeginThreadEx, "_beginthreadex");

   Debug_Process              : constant := 16#00000001#;

   Debug_Only_This_Process    : constant := 16#00000002#;

   Create_Suspended           : constant := 16#00000004#;

   Detached_Process           : constant := 16#00000008#;

   Create_New_Console         : constant := 16#00000010#;

   Create_New_Process_Group   : constant := 16#00000200#;

   Create_No_window           : constant := 16#08000000#;

   Profile_User               : constant := 16#10000000#;

   Profile_Kernel             : constant := 16#20000000#;

   Profile_Server             : constant := 16#40000000#;

   function GetExitCodeThread

     (hThread   : HANDLE;

      pExitCode : PDWORD) return BOOL;

   pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");

   function ResumeThread (hThread : HANDLE) return DWORD;

   pragma Import (Stdcall, ResumeThread, "ResumeThread");

   function SuspendThread (hThread : HANDLE) return DWORD;

   pragma Import (Stdcall, SuspendThread, "SuspendThread");

   procedure ExitThread (dwExitCode : DWORD);

   pragma Import (Stdcall, ExitThread, "ExitThread");

   procedure EndThreadEx (dwExitCode : DWORD);

   pragma Import (C, EndThreadEx, "_endthreadex");

   function TerminateThread

     (hThread    : HANDLE;

      dwExitCode : DWORD) return BOOL;

   pragma Import (Stdcall, TerminateThread, "TerminateThread");

   function GetCurrentThread return HANDLE;

   pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");

   function GetCurrentProcess return HANDLE;

   pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");

   function GetCurrentThreadId return DWORD;

   pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");

   function TlsAlloc return DWORD;

   pragma Import (Stdcall, TlsAlloc, "TlsAlloc");

   function TlsGetValue (dwTlsIndex : DWORD) return PVOID;

   pragma Import (Stdcall, TlsGetValue, "TlsGetValue");

   function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL;

   pragma Import (Stdcall, TlsSetValue, "TlsSetValue");

   function TlsFree (dwTlsIndex : DWORD) return BOOL;

   pragma Import (Stdcall, TlsFree, "TlsFree");

   TLS_Nothing : constant := DWORD'Last;

   procedure ExitProcess (uExitCode : Interfaces.C.unsigned);

   pragma Import (Stdcall, ExitProcess, "ExitProcess");

   function WaitForSingleObject

     (hHandle        : HANDLE;

      dwMilliseconds : DWORD) return DWORD;

   pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");

   function WaitForSingleObjectEx

     (hHandle        : HANDLE;

      dwMilliseconds : DWORD;

      fAlertable     : BOOL) return DWORD;

   pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");

   Wait_Infinite : constant := DWORD'Last;

   WAIT_TIMEOUT  : constant := 16#0000_0102#;

   WAIT_FAILED   : constant := 16#FFFF_FFFF#;

   ------------------------------------

   -- Semaphores, Events and Mutexes --

   ------------------------------------

   function CloseHandle (hObject : HANDLE) return BOOL;

   pragma Import (Stdcall, CloseHandle, "CloseHandle");

   function CreateSemaphore

     (pSemaphoreAttributes : PSECURITY_ATTRIBUTES;

      lInitialCount        : Interfaces.C.long;

      lMaximumCount        : Interfaces.C.long;

      pName                : PSZ) return HANDLE;

   pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");

   function OpenSemaphore

     (dwDesiredAccess : DWORD;

      bInheritHandle  : BOOL;

      pName           : PSZ) return HANDLE;

   pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");

   function ReleaseSemaphore

     (hSemaphore     : HANDLE;

      lReleaseCount  : Interfaces.C.long;

      pPreviousCount : PLONG) return BOOL;

   pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");

   function CreateEvent

     (pEventAttributes : PSECURITY_ATTRIBUTES;

      bManualReset     : BOOL;

      bInitialState    : BOOL;

      pName            : PSZ) return HANDLE;

   pragma Import (Stdcall, CreateEvent, "CreateEventA");

   function OpenEvent

     (dwDesiredAccess : DWORD;

      bInheritHandle  : BOOL;

      pName           : PSZ) return HANDLE;

   pragma Import (Stdcall, OpenEvent, "OpenEventA");

   function SetEvent (hEvent : HANDLE) return BOOL;

   pragma Import (Stdcall, SetEvent, "SetEvent");

   function ResetEvent (hEvent : HANDLE) return BOOL;

   pragma Import (Stdcall, ResetEvent, "ResetEvent");

   function PulseEvent (hEvent : HANDLE) return BOOL;

   pragma Import (Stdcall, PulseEvent, "PulseEvent");

   function CreateMutex

     (pMutexAttributes : PSECURITY_ATTRIBUTES;

      bInitialOwner    : BOOL;

      pName            : PSZ) return HANDLE;

   pragma Import (Stdcall, CreateMutex, "CreateMutexA");

   function OpenMutex

     (dwDesiredAccess : DWORD;

      bInheritHandle  : BOOL;

      pName           : PSZ) return HANDLE;

   pragma Import (Stdcall, OpenMutex, "OpenMutexA");

   function ReleaseMutex (hMutex : HANDLE) return BOOL;

   pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");

   ---------------------------------------------------

   -- Accessing properties of Threads and Processes --

   ---------------------------------------------------

   -----------------

   --  Priorities --

   -----------------

   function SetThreadPriority

     (hThread   : HANDLE;

      nPriority : Interfaces.C.int) return BOOL;

   pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");

   function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int;

   pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");

   function SetPriorityClass

     (hProcess        : HANDLE;

      dwPriorityClass : DWORD) return BOOL;

   pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");

   procedure SetThreadPriorityBoost

     (hThread              : HANDLE;

      DisablePriorityBoost : BOOL);

   pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");

   Normal_Priority_Class   : constant := 16#00000020#;

   Idle_Priority_Class     : constant := 16#00000040#;

   High_Priority_Class     : constant := 16#00000080#;

   Realtime_Priority_Class : constant := 16#00000100#;

   Thread_Priority_Idle          : constant := -15;

   Thread_Priority_Lowest        : constant := -2;

   Thread_Priority_Below_Normal  : constant := -1;

   Thread_Priority_Normal        : constant := 0;

   Thread_Priority_Above_Normal  : constant := 1;

   Thread_Priority_Highest       : constant := 2;

   Thread_Priority_Time_Critical : constant := 15;

   Thread_Priority_Error_Return  : constant := Interfaces.C.long'Last;

   function GetLastError return DWORD;

   pragma Import (Stdcall, GetLastError, "GetLastError");

private

   type sigset_t is new Interfaces.C.unsigned_long;

   type CRITICAL_SECTION is record

      DebugInfo      : System.Address;

      --  The following three fields control entering and

      --  exiting the critical section for the resource

      LockCount      : Long_Integer;

      RecursionCount : Long_Integer;

      OwningThread   : HANDLE;

      LockSemaphore  : HANDLE;

      Reserved       : DWORD;

   end record;

end System.OS_Interface;