src/code/win32.lisp

   1 ;;;; This file contains Win32 support routines that SBCL needs to
   2 ;;;; implement itself, in addition to those that apply to Win32 in
   3 ;;;; unix.lisp.  In theory, some of these functions might someday be
   4 ;;;; useful to the end user.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!WIN32")
  16
  17 ;;; Alien definitions for commonly used Win32 types.  Woe unto whoever
  18 ;;; tries to untangle this someday for 64-bit Windows.
  19 ;;;
  20 ;;; FIXME: There used to be many more here, which are now groveled,
  21 ;;; but groveling HANDLE makes it unsigned, which currently breaks the
  22 ;;; build. --NS 2006-06-18
  23 (define-alien-type handle int-ptr)
  24 (define-alien-type system-string
  25                    #!-sb-unicode c-string
  26                    #!+sb-unicode (c-string :external-format :ucs-2))
  27
  28 (defconstant default-environment-length 1024)
  29
  30 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
  31 ;;; to a pointer.
  32 (defconstant invalid-handle -1)
  33
  34 ;;;; Error Handling
  35
  36 ;;; Retrieve the calling thread's last-error code value.  The
  37 ;;; last-error code is maintained on a per-thread basis.
  38 (define-alien-routine ("GetLastError@0" get-last-error) dword)
  39
  40 ;;; Flag constants for FORMAT-MESSAGE.
  41 (defconstant format-message-from-system #x1000)
  42
  43 ;;; Format an error message based on a lookup table.  See MSDN for the
  44 ;;; full meaning of the all options---most are not used when getting
  45 ;;; system error codes.
  46 (define-alien-routine ("FormatMessageA@28" format-message) dword
  47   (flags dword)
  48   (source (* t))
  49   (message-id dword)
  50   (language-id dword)
  51   (buffer c-string)
  52   (size dword)
  53   (arguments (* t)))
  54
  55 ;;;; File Handles
  56
  57 ;;; Get the operating system handle for a C file descriptor.  Returns
  58 ;;; INVALID-HANDLE on failure.
  59 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
  60   (fd int))
  61
  62 ;;; Read data from a file handle into a buffer.  This may be used
  63 ;;; synchronously or with "overlapped" (asynchronous) I/O.
  64 (define-alien-routine ("ReadFile@20" read-file) bool
  65   (file handle)
  66   (buffer (* t))
  67   (bytes-to-read dword)
  68   (bytes-read (* dword))
  69   (overlapped (* t)))
  70
  71 ;;; Write data from a buffer to a file handle.  This may be used
  72 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
  73 (define-alien-routine ("WriteFile@20" write-file) bool
  74   (file handle)
  75   (buffer (* t))
  76   (bytes-to-write dword)
  77   (bytes-written (* dword))
  78   (overlapped (* t)))
  79
  80 ;;; Copy data from a named or anonymous pipe into a buffer without
  81 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
  82 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
  83 ;;; Return TRUE on success, FALSE on failure.
  84 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
  85   (pipe handle)
  86   (buffer (* t))
  87   (buffer-size dword)
  88   (bytes-read (* dword))
  89   (bytes-avail (* dword))
  90   (bytes-left-this-message (* dword)))
  91
  92 ;;; Flush the console input buffer if HANDLE is a console handle.
  93 ;;; Returns true on success, false if the handle does not refer to a
  94 ;;; console.
  95 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
  96   (handle handle))
  97
  98 ;;; Read data from the console input buffer without removing it,
  99 ;;; without blocking.  Buffer should be large enough for LENGTH *
 100 ;;; INPUT-RECORD-SIZE bytes.
 101 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
 102   (handle handle)
 103   (buffer (* t))
 104   (length dword)
 105   (nevents (* dword)))
 106
 107 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
 108 ;;; isn't a unified interface to do this---we have to know what sort
 109 ;;; of handle we have.  Of course, there's no way to actually
 110 ;;; introspect it, so we have to try various things until we find
 111 ;;; something that works.  Returns true if there could be input
 112 ;;; available, or false if there is not.
 113 (defun handle-listen (handle)
 114   (with-alien ((avail dword)
 115                (buf (array char #.input-record-size)))
 116     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
 117       (return-from handle-listen (plusp avail)))
 118
 119     (unless (zerop (peek-console-input handle
 120                                        (cast buf (* t))
 121                                        input-record-size (addr avail)))
 122       (return-from handle-listen (plusp avail)))
 123
 124     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
 125     ;; HANDLE is a socket.
 126     t))
 127
 128 ;;; Listen for input on a C runtime file handle.  Returns true if
 129 ;;; there could be input available, or false if there is not.
 130 (defun fd-listen (fd)
 131   (let ((handle (get-osfhandle fd)))
 132     (if handle
 133         (handle-listen handle)
 134         t)))
 135
 136 ;;; Clear all available input from a file handle.
 137 (defun handle-clear-input (handle)
 138   (flush-console-input-buffer handle)
 139   (with-alien ((buf (array char 1024))
 140                (count dword))
 141     (loop
 142      (unless (handle-listen handle)
 143        (return))
 144      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
 145        (return))
 146      (when (< count 1024)
 147        (return)))))
 148
 149 ;;; Clear all available input from a C runtime file handle.
 150 (defun fd-clear-input (fd)
 151   (let ((handle (get-osfhandle fd)))
 152     (when handle
 153       (handle-clear-input handle))))
 154
 155 ;;;; System Functions
 156
 157 ;;; Sleep for MILLISECONDS milliseconds.
 158 (define-alien-routine ("Sleep@4" millisleep) void
 159   (milliseconds dword))
 160
 161 #!+sb-unicode
 162 (progn
 163   (defvar *ansi-codepage* nil)
 164   (defvar *oem-codepage* nil)
 165   (defvar *codepage-to-external-format* (make-hash-table)))
 166
 167 #!+sb-unicode
 168 (dolist
 169     (cp '(;;037       IBM EBCDIC - U.S./Canada
 170           (437 :CP437) ;; OEM - United States
 171           ;;500       IBM EBCDIC - International
 172           ;;708       Arabic - ASMO 708
 173           ;;709       Arabic - ASMO 449+, BCON V4
 174           ;;710       Arabic - Transparent Arabic
 175           ;;720       Arabic - Transparent ASMO
 176           ;;737       OEM - Greek (formerly 437G)
 177           ;;775       OEM - Baltic
 178           (850 :CP850)     ;; OEM - Multilingual Latin I
 179           (852 :CP852)     ;; OEM - Latin II
 180           (855 :CP855)     ;; OEM - Cyrillic (primarily Russian)
 181           (857 :CP857)     ;; OEM - Turkish
 182           ;;858       OEM - Multilingual Latin I + Euro symbol
 183           (860 :CP860)     ;; OEM - Portuguese
 184           (861 :CP861)     ;; OEM - Icelandic
 185           (862 :CP862)     ;; OEM - Hebrew
 186           (863 :CP863)     ;; OEM - Canadian-French
 187           (864 :CP864)     ;; OEM - Arabic
 188           (865 :CP865)     ;; OEM - Nordic
 189           (866 :CP866)     ;; OEM - Russian
 190           (869 :CP869)     ;; OEM - Modern Greek
 191           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
 192           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
 193           ;;875       IBM EBCDIC - Modern Greek
 194           (932 :CP932)     ;; ANSI/OEM - Japanese, Shift-JIS
 195           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
 196           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
 197           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
 198           ;;1026      IBM EBCDIC - Turkish (Latin-5)
 199           ;;1047      IBM EBCDIC - Latin 1/Open System
 200           ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
 201           ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
 202           ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
 203           ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
 204           ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
 205           ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
 206           ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
 207           ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
 208           ;;1148      IBM EBCDIC - International (500 + Euro symbol)
 209           ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
 210           (1200 :UCS-2LE)    ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
 211           (1201 :UCS-2BE)    ;; Unicode UCS-2 Big-Endian
 212           (1250 :CP1250)     ;; ANSI - Central European
 213           (1251 :CP1251)     ;; ANSI - Cyrillic
 214           (1252 :CP1252)     ;; ANSI - Latin I
 215           (1253 :CP1253)     ;; ANSI - Greek
 216           (1254 :CP1254)     ;; ANSI - Turkish
 217           (1255 :CP1255)     ;; ANSI - Hebrew
 218           (1256 :CP1256)     ;; ANSI - Arabic
 219           (1257 :CP1257)     ;; ANSI - Baltic
 220           (1258 :CP1258)     ;; ANSI/OEM - Vietnamese
 221           ;;1361      Korean (Johab)
 222           ;;10000 MAC - Roman
 223           ;;10001     MAC - Japanese
 224           ;;10002     MAC - Traditional Chinese (Big5)
 225           ;;10003     MAC - Korean
 226           ;;10004     MAC - Arabic
 227           ;;10005     MAC - Hebrew
 228           ;;10006     MAC - Greek I
 229           (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
 230           ;;10008     MAC - Simplified Chinese (GB 2312)
 231           ;;10010     MAC - Romania
 232           ;;10017     MAC - Ukraine
 233           ;;10021     MAC - Thai
 234           ;;10029     MAC - Latin II
 235           ;;10079     MAC - Icelandic
 236           ;;10081     MAC - Turkish
 237           ;;10082     MAC - Croatia
 238           ;;12000     Unicode UCS-4 Little-Endian
 239           ;;12001     Unicode UCS-4 Big-Endian
 240           ;;20000     CNS - Taiwan
 241           ;;20001     TCA - Taiwan
 242           ;;20002     Eten - Taiwan
 243           ;;20003     IBM5550 - Taiwan
 244           ;;20004     TeleText - Taiwan
 245           ;;20005     Wang - Taiwan
 246           ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
 247           ;;20106     IA5 German (7-bit)
 248           ;;20107     IA5 Swedish (7-bit)
 249           ;;20108     IA5 Norwegian (7-bit)
 250           ;;20127     US-ASCII (7-bit)
 251           ;;20261     T.61
 252           ;;20269     ISO 6937 Non-Spacing Accent
 253           ;;20273     IBM EBCDIC - Germany
 254           ;;20277     IBM EBCDIC - Denmark/Norway
 255           ;;20278     IBM EBCDIC - Finland/Sweden
 256           ;;20280     IBM EBCDIC - Italy
 257           ;;20284     IBM EBCDIC - Latin America/Spain
 258           ;;20285     IBM EBCDIC - United Kingdom
 259           ;;20290     IBM EBCDIC - Japanese Katakana Extended
 260           ;;20297     IBM EBCDIC - France
 261           ;;20420     IBM EBCDIC - Arabic
 262           ;;20423     IBM EBCDIC - Greek
 263           ;;20424     IBM EBCDIC - Hebrew
 264           ;;20833     IBM EBCDIC - Korean Extended
 265           ;;20838     IBM EBCDIC - Thai
 266           (20866 :KOI8-R) ;; Russian - KOI8-R
 267           ;;20871     IBM EBCDIC - Icelandic
 268           ;;20880     IBM EBCDIC - Cyrillic (Russian)
 269           ;;20905     IBM EBCDIC - Turkish
 270           ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
 271           ;;20932     JIS X 0208-1990 & 0121-1990
 272           ;;20936     Simplified Chinese (GB2312)
 273           ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
 274           ;;21027     (deprecated)
 275           (21866 :KOI8-U)      ;; Ukrainian (KOI8-U)
 276           (28591 :LATIN-1)     ;; ISO 8859-1 Latin I
 277           (28592 :ISO-8859-2)  ;; ISO 8859-2 Central Europe
 278           (28593 :ISO-8859-3)  ;; ISO 8859-3 Latin 3
 279           (28594 :ISO-8859-4)  ;; ISO 8859-4 Baltic
 280           (28595 :ISO-8859-5)  ;; ISO 8859-5 Cyrillic
 281           (28596 :ISO-8859-6)  ;; ISO 8859-6 Arabic
 282           (28597 :ISO-8859-7)  ;; ISO 8859-7 Greek
 283           (28598 :ISO-8859-8)  ;; ISO 8859-8 Hebrew
 284           (28599 :ISO-8859-9)  ;; ISO 8859-9 Latin 5
 285           (28605 :LATIN-9)     ;; ISO 8859-15 Latin 9
 286           ;;29001     Europa 3
 287           (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
 288           ;;50220     ISO 2022 Japanese with no halfwidth Katakana
 289           ;;50221     ISO 2022 Japanese with halfwidth Katakana
 290           ;;50222     ISO 2022 Japanese JIS X 0201-1989
 291           ;;50225     ISO 2022 Korean
 292           ;;50227     ISO 2022 Simplified Chinese
 293           ;;50229     ISO 2022 Traditional Chinese
 294           ;;50930     Japanese (Katakana) Extended
 295           ;;50931     US/Canada and Japanese
 296           ;;50933     Korean Extended and Korean
 297           ;;50935     Simplified Chinese Extended and Simplified Chinese
 298           ;;50936     Simplified Chinese
 299           ;;50937     US/Canada and Traditional Chinese
 300           ;;50939     Japanese (Latin) Extended and Japanese
 301           (51932 :EUC-JP) ;; EUC - Japanese
 302           ;;51936     EUC - Simplified Chinese
 303           ;;51949     EUC - Korean
 304           ;;51950     EUC - Traditional Chinese
 305           ;;52936     HZ-GB2312 Simplified Chinese
 306           ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
 307           ;;57002     ISCII Devanagari
 308           ;;57003     ISCII Bengali
 309           ;;57004     ISCII Tamil
 310           ;;57005     ISCII Telugu
 311           ;;57006     ISCII Assamese
 312           ;;57007     ISCII Oriya
 313           ;;57008     ISCII Kannada
 314           ;;57009     ISCII Malayalam
 315           ;;57010     ISCII Gujarati
 316           ;;57011     ISCII Punjabi
 317           ;;65000     Unicode UTF-7
 318           (65001 :UTF8))) ;; Unicode UTF-8
 319   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
 320
 321 #!+sb-unicode
 322 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
 323 ;; the console just behave differently?
 324 (progn
 325   (declaim (ftype (function () keyword) ansi-codepage))
 326   (defun ansi-codepage ()
 327     (or *ansi-codepage*
 328         (setq *ansi-codepage*
 329               (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
 330                        *codepage-to-external-format*
 331                        :latin-1))))
 332
 333   (declaim (ftype (function () keyword) oem-codepage))
 334   (defun oem-codepage ()
 335     (or *oem-codepage*
 336         (setq *oem-codepage*
 337             (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
 338                      *codepage-to-external-format*
 339                      :latin-1)))))
 340
 341 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
 342 (declaim (ftype (function () keyword) console-input-codepage))
 343 (defun console-input-codepage ()
 344   (or #!+sb-unicode
 345       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
 346                *codepage-to-external-format*)
 347       :latin-1))
 348
 349 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
 350 (declaim (ftype (function () keyword) console-output-codepage))
 351 (defun console-output-codepage ()
 352   (or #!+sb-unicode
 353       (gethash (alien-funcall
 354                 (extern-alien "GetConsoleOutputCP@0" (function UINT)))
 355                *codepage-to-external-format*)
 356       :latin-1))
 357
 358 (define-alien-routine ("LocalFree@4" local-free) void
 359   (lptr (* t)))
 360
 361 (defmacro cast-and-free (value &key (type 'system-string)
 362                                 (free-function 'free-alien))
 363   `(prog1 (cast ,value ,type)
 364      (,free-function ,value)))
 365
 366 (eval-when (:compile-toplevel :load-toplevel :execute)
 367 (defmacro with-funcname ((name description) &body body)
 368   `(let
 369      ((,name (etypecase ,description
 370                (string ,description)
 371                (cons (destructuring-bind (s &optional (l 0) c) ,description
 372                        (format nil "~A~A~A" s
 373                                (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
 374                                l))))))
 375      ,@body)))
 376
 377 (defmacro make-system-buffer (x)
 378  `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
 379
 380 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
 381 ;;; macros in this file, are only used in this file, and could be
 382 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
 383
 384 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
 385   (with-funcname (sname name)
 386     `(locally
 387        (declare (optimize (sb!c::float-accuracy 0)))
 388        (let ((result (alien-funcall
 389                        (extern-alien ,sname
 390                                      (function ,ret-type ,@arg-types))
 391                        ,@args)))
 392          (declare (ignorable result))
 393          ,success-form))))
 394
 395 ;;; This is like SYSCALL, but if it fails, signal an error instead of
 396 ;;; returning error codes. Should only be used for syscalls that will
 397 ;;; never really get an error.
 398 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
 399   (with-funcname (sname name)
 400     `(locally
 401        (declare (optimize (sb!c::float-accuracy 0)))
 402        (let ((result (alien-funcall
 403                        (extern-alien ,sname (function bool ,@arg-types))
 404                        ,@args)))
 405          (when (zerop result)
 406            (win32-error ,sname))
 407          ,success-form))))
 408
 409 (defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
 410   (with-funcname (sname name)
 411     `(with-alien ((,func (function ,ret-type ,@arg-types)
 412                          :extern ,sname))
 413        ,@body)))
 414
 415 (defmacro void-syscall* ((name &rest arg-types) &rest args)
 416   `(syscall* (,name ,@arg-types) (values t 0) ,@args))
 417
 418 (defun get-last-error-message (err)
 419   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
 420   (with-alien ((amsg (* char)))
 421     (syscall (("FormatMessage" 28 t)
 422               dword dword dword dword dword (* (* char)) dword dword)
 423              (cast-and-free amsg :free-function local-free)
 424              (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
 425              0 err 0 (addr amsg) 0 0)))
 426
 427 (defmacro win32-error (func-name &optional err)
 428   `(let ((err-code ,(or err `(get-last-error))))
 429      (declare (type (unsigned-byte 32) err-code))
 430      (error "~%Win32 Error [~A] - ~A~%~A"
 431             ,func-name
 432             err-code
 433             (get-last-error-message err-code))))
 434
 435 (defun get-folder-pathname (csidl)
 436   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
 437   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 438     (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
 439              (parse-native-namestring
 440                (concatenate 'string (cast-and-free apath) "\\"))
 441              0 csidl 0 0 apath)))
 442
 443 (defun sb!unix:posix-getcwd ()
 444   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 445     (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
 446       (let ((ret (alien-funcall afunc (1+ max_path) apath)))
 447         (when (zerop ret)
 448           (win32-error "GetCurrentDirectory"))
 449         (when (> ret (1+ max_path))
 450           (free-alien apath)
 451           (setf apath (make-system-buffer ret))
 452           (alien-funcall afunc ret apath))
 453         (cast-and-free apath)))))
 454
 455 (defun sb!unix:unix-mkdir (name mode)
 456   (declare (type sb!unix:unix-pathname name)
 457            (type sb!unix:unix-file-mode mode)
 458            (ignore mode))
 459   (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0))
 460
 461 (defun sb!unix:unix-rename (name1 name2)
 462   (declare (type sb!unix:unix-pathname name1 name2))
 463   (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2))
 464
 465 (defun sb!unix::posix-getenv (name)
 466   (declare (type simple-string name))
 467   (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
 468     (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
 469                         dword system-string (* char) dword)
 470       (let ((ret (alien-funcall afunc name aenv default-environment-length)))
 471         (when (> ret default-environment-length)
 472           (free-alien aenv)
 473           (setf aenv (make-system-buffer ret))
 474           (alien-funcall afunc name aenv ret))
 475         (if (> ret 0)
 476             (cast-and-free aenv)
 477             (free-alien aenv))))))
 478
 479 ;; GET-CURRENT-PROCESS
 480 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
 481 ;; process.
 482 ;;
 483 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
 484 (declaim (inline get-current-process))
 485 (define-alien-routine ("GetCurrentProcess@0" get-current-process) handle)
 486
 487 ;;;; Process time information
 488
 489 (defconstant 100ns-per-internal-time-unit
 490   (/ 10000000 sb!xc:internal-time-units-per-second))
 491
 492 ;; FILETIME
 493 ;; The FILETIME structure is a 64-bit value representing the number of
 494 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
 495 ;;
 496 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
 497 (define-alien-type FILETIME (sb!alien:unsigned 64))
 498
 499 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
 500                               &body forms)
 501   `(with-alien ((,creation-time filetime)
 502                 (,exit-time filetime)
 503                 (,kernel-time filetime)
 504                 (,user-time filetime))
 505      (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
 506                 (* filetime) (* filetime))
 507                (progn ,@forms)
 508                (get-current-process)
 509                (addr ,creation-time)
 510                (addr ,exit-time)
 511                (addr ,kernel-time)
 512                (addr ,user-time))))
 513
 514 (declaim (inline system-internal-real-time))
 515
 516 (let ((epoch 0))
 517   (declare (unsigned-byte epoch))
 518   ;; FIXME: For optimization ideas see the unix implementation.
 519   (defun reinit-internal-real-time ()
 520     (setf epoch 0
 521           epoch (get-internal-real-time)))
 522   (defun get-internal-real-time ()
 523     (- (with-alien ((system-time filetime))
 524          (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
 525                   (values (floor system-time 100ns-per-internal-time-unit))
 526                   (addr system-time)))
 527        epoch)))
 528
 529 (defun system-internal-run-time ()
 530   (with-process-times (creation-time exit-time kernel-time user-time)
 531     (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
 532
 533 ;; SETENV
 534 ;; The SetEnvironmentVariable function sets the contents of the specified
 535 ;; environment variable for the current process.
 536 ;;
 537 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
 538 (defun setenv (name value)
 539   (declare (type simple-string name value))
 540   (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
 541                  name value))
 542
 543 (defmacro c-sizeof (s)
 544   "translate alien size (in bits) to c-size (in bytes)"
 545   `(/ (alien-size ,s) 8))
 546
 547 ;; OSVERSIONINFO
 548 ;; The OSVERSIONINFO data structure contains operating system version
 549 ;; information. The information includes major and minor version numbers,
 550 ;; a build number, a platform identifier, and descriptive text about
 551 ;; the operating system. This structure is used with the GetVersionEx function.
 552 ;;
 553 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
 554 (define-alien-type nil
 555   (struct OSVERSIONINFO
 556     (dwOSVersionInfoSize dword)
 557     (dwMajorVersion dword)
 558     (dwMinorVersion dword)
 559     (dwBuildNumber dword)
 560     (dwPlatformId dword)
 561     (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
 562
 563 (defun get-version-ex ()
 564   (with-alien ((info (struct OSVERSIONINFO)))
 565     (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
 566     (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
 567               (values (slot info 'dwMajorVersion)
 568                       (slot info 'dwMinorVersion)
 569                       (slot info 'dwBuildNumber)
 570                       (slot info 'dwPlatformId)
 571                       (cast (slot info 'szCSDVersion) system-string))
 572               (addr info))))
 573
 574 ;; GET-COMPUTER-NAME
 575 ;; The GetComputerName function retrieves the NetBIOS name of the local
 576 ;; computer. This name is established at system startup, when the system
 577 ;; reads it from the registry.
 578 ;;
 579 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
 580 (declaim (ftype (function () simple-string) get-computer-name))
 581 (defun get-computer-name ()
 582   (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
 583                (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
 584     (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
 585       (when (zerop (alien-funcall afunc aname (addr length)))
 586         (let ((err (get-last-error)))
 587           (unless (= err ERROR_BUFFER_OVERFLOW)
 588             (win32-error "GetComputerName" err))
 589           (free-alien aname)
 590           (setf aname (make-system-buffer length))
 591           (alien-funcall afunc aname (addr length))))
 592       (cast-and-free aname))))