/pliant/language/os/win32.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19  public 
 20    constant DUPLICATE_SAME_ACCESS 2 
 21   
 22  function os_DuplicateHandle src_process src_handle target_process target_handle access inherit options -> ok 
 23    arg Int src_process src_handle target_process ; arg_w Int target_handle ; arg Int access ; arg CBool inherit ; arg Int options ; arg CBool ok 
 24    external "kernel32.dll" "DuplicateHandle" 
 25   
 26     
 27  function os_CreateThread attributes stacksize routine parameter flags id -> handle 
 28    arg Address attributes ; arg Int stacksize ; arg Address routine parameter ; arg Int flags ; arg_w Int id ; arg Int handle 
 29    external "kernel32.dll" "CreateThread" 
 30     
 31  function os_GetCurrentThread -> handle 
 32    arg Int handle 
 33    external "kernel32.dll" "GetCurrentThread" 
 34     
 35  function os_SuspendThread handle -> count 
 36    arg Int handle ; arg Int count 
 37    external "kernel32.dll" "SuspendThread" 
 38     
 39  function os_ResumeThread handle -> count 
 40    arg Int handle ; arg Int count 
 41    external "kernel32.dll" "ResumeThread" 
 42     
 43  function os_TlsAlloc -> handle 
 44    arg Int handle 
 45    external "kernel32.dll" "TlsAlloc"  
 46   
 47  function os_TlsSetValue handle value 
 48    arg Int handle ; arg Address value 
 49    external "kernel32.dll" "TlsSetValue" 
 50   
 51  function os_TlsGetValue handle -> value 
 52    arg Int handle ; arg Address value 
 53    external "kernel32.dll" "TlsGetValue" 
 54   
 55  function os_Sleep ms 
 56    arg Int ms 
 57    external "kernel32.dll" "Sleep" 
 58     
 59  public 
 60    type os_SYSTEMTIME 
 61      packed 
 62      field uInt16 wYear wMonth wDayOfWeek wDay 
 63      field uInt16 wHour wMinute wSecond wMilliseconds 
 64   
 65  function os_GetSystemTime t 
 66    arg_w os_SYSTEMTIME t 
 67    external "kernel32.dll" "GetSystemTime" 
 68     
 69  function os_yield 
 70    os_Sleep 0   
 71   
 72   
 73  function os_GetCurrentProcess -> handle 
 74    arg Int handle 
 75    external "kernel32.dll" "GetCurrentProcess" 
 76   
 77  function os_GetCurrentProcessId -> id 
 78    arg Int id 
 79    external "kernel32.dll" "GetCurrentProcessId" 
 80   
 81  function os_getpid -> id 
 82    arg Int id 
 83    id := os_GetCurrentProcessId 
 84     
 85  function os_ExitProcess retcode 
 86    arg Int retcode 
 87    external "kernel32.dll" "ExitProcess" 
 88     
 89  function os_exit retcode 
 90    arg Int retcode 
 91    os_ExitProcess retcode 
 92   
 93  function os_GetEnvironmentStrings -> env 
 94    arg Address env 
 95    external "kernel32.dll" "GetEnvironmentStrings" 
 96   
 97  function os_environment_variable name -> value 
 98    arg Str name value 
 99    var Address env := os_GetEnvironmentStrings 
 100    var Int i := 0 
 101    while true 
 102      var Int j := i 
 103      while ((env translate Char j) map Char):number<>0 
 104        j := j+1 
 105      if j=i 
 106        return "" 
 107      (var Str v) set (env translate Char i) j-i false 
 108      var Int k := v search "=" -1 
 109      if k<>(-1) and lower:(v 0 k)=lower:name 
 110        return (v k+1 v:len) 
 111      i := j+1 
 112   
 113  export os_DuplicateHandle 
 114  export os_CreateThread os_GetCurrentThread os_SuspendThread os_ResumeThread 
 115  export os_TlsAlloc os_TlsSetValue os_TlsGetValue 
 116  export os_Sleep os_GetSystemTime os_yield 
 117  export os_GetCurrentProcess os_GetCurrentProcessId os_getpid os_ExitProcess os_exit 
 118  export os_GetEnvironmentStrings os_environment_variable 
 119   
 120  function os_CreateFile name access share security creation flags template -> handle 
 121    arg CStr name ; arg uInt access share ; arg Address security ; arg uInt creation flags ; arg Address template ; arg Int handle 
 122    external "kernel32.dll" "CreateFileA" 
 123     
 124  function os_ReadFile handle buffer size red overlapped -> ok 
 125    arg Int handle ; arg Address buffer ; arg Int size ; arg_w Int red ; arg Address overlapped ; arg CBool ok 
 126    external "kernel32.dll" "ReadFile" 
 127     
 128  function os_WriteFile handle buffer size written overlapped -> ok 
 129    arg Int handle ; arg Address buffer ; arg Int size ; arg_w Int written ; arg Address overlapped ; arg CBool ok 
 130    external "kernel32.dll" "WriteFile" 
 131     
 132  function os_CloseHandle handle -> ok 
 133    arg Int handle ; arg CBool ok 
 134    external "kernel32.dll" "CloseHandle" 
 135     
 136  function os_SetFilePointer handle low high method -> pos 
 137    arg Int handle ; arg uInt low ; arg_rw uInt high ; arg Int method; arg uInt pos 
 138    external "kernel32.dll" "SetFilePointer" 
 139     
 140  function os_DeleteFile name -> ok 
 141    arg CStr name ; arg CBool ok 
 142    external "kernel32.dll" "DeleteFileA" 
 143     
 144  function os_CreateDirectory name security -> ok 
 145    arg CStr name ; arg Address security ; arg CBool ok 
 146    external "kernel32.dll" "CreateDirectoryA" 
 147     
 148  function os_RemoveDirectory name -> ok 
 149    arg CStr name ; arg CBool ok 
 150    external "kernel32.dll" "RemoveDirectoryA" 
 151   
 152  function os_GetStdHandle id -> handle 
 153    arg Int id handle 
 154    external "kernel32.dll" "GetStdHandle" 
 155   
 156  public 
 157    constant os_GENERIC_READ     80000000h 
 158    constant os_GENERIC_WRITE    40000000h 
 159    constant os_FILE_SHARE_READ  00000001h 
 160    constant os_FILE_SHARE_WRITE 00000002h 
 161    constant os_CREATE_ALWAYS 2 
 162    constant os_OPEN_EXISTING 3 
 163    constant os_OPEN_ALWAYS 4 
 164    constant os_FILE_ATTRIBUTE_NORMAL 80h 
 165    constant os_FILE_FLAG_SEQUENTIAL_SCAN 08000000h 
 166    constant os_FILE_FLAG_RANDOM_ACCESS   10000000h 
 167   
 168    constant os_FILE_BEGIN 0 
 169    constant os_FILE_CURRENT 1 
 170    constant os_FILE_END 2 
 171   
 172    constant os_STD_INPUT_HANDLE  -10 
 173    constant os_STD_OUTPUT_HANDLE -11 
 174    constant os_STD_ERROR_HANDLE  -12 
 175   
 176  export os_CreateFile os_ReadFile os_WriteFile os_CloseHandle os_SetFilePointer 
 177  export os_DeleteFile os_CreateDirectory os_RemoveDirectory 
 178  export os_GetStdHandle 
 179   
 180   
 181  function os_GetConsoleMode handle mode -> ok 
 182    arg Int handle ; arg_w uInt mode ; arg CBool ok 
 183    external "kernel32.dll" "GetConsoleMode" 
 184   
 185  function os_SetConsoleMode handle mode -> ok 
 186    arg Int handle ; arg uInt mode ; arg CBool ok 
 187    external "kernel32.dll" "SetConsoleMode" 
 188     
 189  public 
 190    constant os_ENABLE_LINE_INPUT    0002h 
 191    constant os_ENABLE_ECHO_INPUT    0004h 
 192   
 193  export os_SetConsoleMode os_GetConsoleMode 
 194   
 195   
 196  public 
 197    constant os_MAX_PATH 260 
 198    constant os_FILE_ATTRIBUTE_DIRECTORY 00000010h 
 199    constant os_INVALID_HANDLE_VALUE -1 
 200   
 201  public 
 202   
 203    type os_FILETIME 
 204      packed 
 205      field uInt dwLowDateTime dwHighDateTime 
 206   
 207    type os_FIND_DATA 
 208      packed 
 209      field uInt dwFileAttributes 
 210      field os_FILETIME ftCreationTime 
 211      field os_FILETIME ftLastAccessTime 
 212      field os_FILETIME ftLastWriteTime 
 213      field uInt nFileSizeHigh 
 214      field uInt nFileSizeLow 
 215      field Int dwReserved0 
 216      field Int dwReserved1 
 217      field (Array Char os_MAX_PATH) cFileName 
 218      field (Array Char 16) cAlternateFileName 
 219   
 220  function os_FindFirstFile name data -> handle 
 221    arg CStr name ; arg_w os_FIND_DATA data ; arg Int handle 
 222    external "kernel32.dll" "FindFirstFileA" 
 223     
 224  function os_FindNextFile handle data -> ok 
 225    arg Int handle ; arg_w os_FIND_DATA data ; arg CBool ok 
 226    external "kernel32.dll" "FindNextFileA" 
 227     
 228  function os_FindClose handle -> ok 
 229    arg Int handle ; arg CBool ok 
 230    external "kernel32.dll" "FindClose" 
 231   
 232  export os_FindFirstFile os_FindNextFile os_FindClose 
 233   
 234  public 
 235    type os_EXCEPTION_RECORD 
 236      packed 
 237      field Int ExceptionCode 
 238      field Int ExceptionFlags 
 239      field Address ExceptionRecord 
 240      field Address ExceptionAddress 
 241      field Int NumberParameters 
 242      field (Array Int 15) ExceptionInformation 
 243    if processor_name="i386" 
 244      type os_FLOATING_SAVE_AREA 
 245        packed 
 246        field Int ControlWord StatusWord TagWord 
 247        field Int ErrorOffset ErrorSelector 
 248        field Int DataOffset DataSelector 
 249        field (Array Byte 80) RegisterArea 
 250        field Int Cr0NpxState 
 251      type os_CONTEXT  
 252        packed 
 253        field Int ContextFlags 
 254        field Int Dr0 Dr1 Dr2 Dr3 Dr6 Dr7 
 255        field os_FLOATING_SAVE_AREA FloatSave 
 256        field Int SegGs SegFs SegEs SegDs 
 257        field Int Edi Esi Ebx Edx Ecx Eax 
 258        field Int Ebp Eip SegCs EFlags Esp SegSs 
 259    type os_EXCEPTION_POINTERS 
 260      packed 
 261      field Pointer:os_EXCEPTION_RECORD ExceptionRecord 
 262      field Pointer:os_CONTEXT ContextRecord 
 263   
 264  public 
 265    constant os_EXCEPTION_EXECUTE_HANDLER     1 
 266    constant os_EXCEPTION_CONTINUE_SEARCH     0 
 267    constant os_EXCEPTION_CONTINUE_EXECUTION -1 
 268   
 269  function os_SetUnhandledExceptionFilter f 
 270    arg Address f 
 271    external "kernel32.dll" "SetUnhandledExceptionFilter" 
 272   
 273  public 
 274    constant os_SEM_FAILCRITICALERRORS          0001h 
 275    constant os_SEM_NOGPFAULTERRORBOX           0002h 
 276    constant os_SEM_SEM_NOALIGNMENTFAULTEXCEPT  0004h 
 277    constant os_SEM_NOOPENFILEERRORBOX          8000h 
 278   
 279  function os_SetErrorMode mode 
 280    arg Int mode 
 281    external "kernel32.dll" "SetErrorMode" 
 282   
 283  function os_SetConsoleCtrlHandler exec add -> ok 
 284    arg Address exec ; arg CBool add ok 
 285    external "kernel32.dll" "SetConsoleCtrlHandler" 
 286   
 287  constant CONTEXT_i386 10000h 
 288  public 
 289    constant CONTEXT_CONTROL (CONTEXT_i386 .or. 1) 
 290    constant CONTEXT_INTEGER (CONTEXT_i386 .or. 2) 
 291   
 292   
 293  function os_GetThreadContext handle c -> ok 
 294    arg Int handle ; arg_rw os_CONTEXT c ; arg CBool ok 
 295    external "kernel32.dll" "GetThreadContext" 
 296     
 297  export os_SetUnhandledExceptionFilter os_SetErrorMode os_SetConsoleCtrlHandler os_GetThreadContext 
 298   
 299   
 300  public 
 301    type os_MEMORYSTATUS 
 302      packed 
 303      field uInt dwLength <- 32   #    
 304      field uInt dwMemoryLoad     #   MemoryLoad contains percentage memory used 
 305      field uInt dwTotalPhys      #   TotalPhys contains total amount of physical memory in bytes 
 306      field uInt dwAvailPhys      #   AvailPhys contains available physical memory 
 307      field uInt dwTotalPageFile  #   TotalPageFile contains total amount of memory in the page file 
 308      field uInt dwAvailPageFile  #   AvailPageFile contains available amount of memory in the page file 
 309      field uInt dwTotalVirtual   #   TotalVirtual contains total amount of virtual memory 
 310      field uInt dwAvailVirtual   #   AvailVirtual contains available virtual memory 
 311   
 312  function os_GlobalMemoryStatus ms 
 313    arg_rw os_MEMORYSTATUS ms 
 314    external "kernel32.dll" "GlobalMemoryStatus" 
 315   
 316  export os_GlobalMemoryStatus 
 317   
 318  function os_GetLastError -> err 
 319    arg uInt err 
 320    external "kernel32.dll" "GetLastError"  
 321   
 322  export os_GetLastError 
 323   
 324  public 
 325    type os_PROCESS_INFORMATION 
 326      packed 
 327      field uInt hProcess 
 328      field uInt hThread 
 329      field uInt dwProcessId 
 330      field uInt dwThreadId  
 331   
 332    type os_STARTUPINFO 
 333      packed 
 334      field uInt cb <- 68 
 335      field Address Reserved <- null 
 336      field Address Desktop <- null 
 337      field Address Title <- null 
 338      field uInt X <- 0 
 339      field uInt Y <- 0 
 340      field uInt XSize <- 0 
 341      field uInt YSize <- 0 
 342      field uInt XCountChars <- 0 
 343      field uInt YCountChars <- 0 
 344      field uInt FillAttribute <- 0 
 345      field uInt Flags <- 0 
 346      field Int16 ShowWindow <- 1 
 347      field Int16 cbReserved2 <- 0 
 348      field uInt lpReserved2 <- 0 
 349      field uInt StdInput StdOutput StdError    
 350   
 351    type os_SECURITY_ATTRIBUTES 
 352      packed 
 353      field uInt nLength <- 12 
 354      field Address lpSecurityDescriptor 
 355      field CBool bInheritHandle 
 356   
 357    if false 
 358     # Constants for the Creation Flags 
 359     constant os_CREATE_BREAKAWAY_FROM_JOB            # The child processes of a process associated with a job are not associated with the job.  
 360     constant os_CREATE_DEFAULT_ERROR_MODE  04000000h # The new process does not inherit the error mode of the calling process. 
 361     constant os_CREATE_FORCEDOS            00002000h # the system will force the application to run as an MS-DOS-based application rather than as an OS/2-based application. 
 362     constant os_CREATE_NEW_CONSOLE         00000010h # The new process has a new console, instead of inheriting the parent's console. 
 363     constant os_CREATE_NEW_PROCESS_GROUP   00000200h # The new process is the root process of a new process group. 
 364     constant os_CREATE_NO_WINDOW           08000000h # If set, the console application is run without a console window. 
 365     constant os_CREATE_SEPARATE_WOW_VDM    00000800h # If set, the new process runs in a private Virtual DOS Machine (VDM). 
 366     constant os_CREATE_SHARED_WOW_VDM      00001000h # Run the new process in the shared Virtual DOS Machine. 
 367     constant os_CREATE_SUSPENDED           00000004h # The primary thread of the new process is created in a suspended state. 
 368     constant os_CREATE_UNICODE_ENVIRONMENT 00000400h # Indicates the format of the environ parameter. 
 369     constant os_DEBUG_PROCESS              00000001h # The calling process is treated as a debugger, and the new process is debugged. 
 370     constant os_DEBUG_ONLY_THIS_PROCESS    00000002h # If the calling process is being debugged, the new process becomes another process being debugged by the calling process's debugger. 
 371     constant os_DETACHED_PROCESS           00000008h # The new process does not have access to the console of the parent process. 
 372   
 373     # priority 
 374   
 375     constant os_ABOVE_NORMAL_PRIORITY_CLASS           # > NORMAL_PRIORITY_CLASS but < HIGH_PRIORITY_CLASS. 
 376     constant os_BELOW_NORMAL_PRIORITY_CLASS           # > IDLE_PRIORITY_CLASS but < NORMAL_PRIORITY_CLASS. 
 377     constant os_HIGH_PRIORITY_CLASS         00000080h # Indicates a process that performs time-critical tasks. 
 378     constant os_IDLE_PRIORITY_CLASS         00000040h # Indicates a process whose threads run only when the system is idle. 
 379     constant os_NORMAL_PRIORITY_CLASS       00000020h # Indicates a normal process with no special scheduling needs. 
 380     constant os_REALTIME_PRIORITY_CLASS     00000100h # Indicates a process that has the highest possible priority. 
 381   
 382  function os_CreateProcess name cmd patt tatt inherit createflags environ dir startupinfo pinfo -> ok 
 383     arg CStr name # string that specifies the module to execute. 
 384     arg CStr cmd # string that specifies the command line to execute. 
 385     arg os_SECURITY_ATTRIBUTES patt # whether the process handle can be inherited. null -> cannot. 
 386     arg os_SECURITY_ATTRIBUTES tatt # whether the thread handle can be inherited. null -> cannot. 
 387     arg CBool inherit # whether the new process inherits handles from the calling process.  
 388     arg uInt createflags # additional flags that control the priority class and the creation of the process. 
 389     arg Address environ # environment block for the new process. null -> environment of the calling process.  
 390     arg CStr dir # string that specifies the current drive and directory for the child process. 
 391     arg os_STARTUPINFO startupinfo # how the main window for the new process should appear. 
 392     arg_w os_PROCESS_INFORMATION pinfo # receives identification information about the new process. 
 393     arg CBool ok # success; if fails you should call os_GetLastError for info 
 394     external "kernel32.dll" "CreateProcessA" 
 395    
 396  function os_WaitForSingleObject handle time -> ret 
 397     arg uInt handle # handle to object 
 398     arg Int time ret # time-out interval (-1 is infinite wait) 
 399     external "kernel32.dll" "WaitForSingleObject" 
 400   
 401  export os_CreateProcess os_WaitForSingleObject 
 402   
 403  public 
 404    constant os_zlib_filename pliant_root_path+"binary\zlib.dll"