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                                        1 (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 #!-sb-thread
 158 (define-alien-routine ("Sleep@4" millisleep) void
 159   (milliseconds dword))
 160
 161 #!+sb-thread
 162 (defun sb!unix:nanosleep (sec nsec)
 163   (let ((*allow-with-interrupts* *interrupts-enabled*))
 164     (without-interrupts
 165       (let ((timer (sb!impl::os-create-wtimer)))
 166         (sb!impl::os-set-wtimer timer sec nsec)
 167         (unwind-protect
 168              (do () ((with-local-interrupts
 169                        (zerop (sb!impl::os-wait-for-wtimer timer)))))
 170           (sb!impl::os-close-wtimer timer))))))
 171
 172 #!+sb-unicode
 173 (progn
 174   (defvar *ansi-codepage* nil)
 175   (defvar *oem-codepage* nil)
 176   (defvar *codepage-to-external-format* (make-hash-table)))
 177
 178 #!+sb-unicode
 179 (dolist
 180     (cp '(;;037       IBM EBCDIC - U.S./Canada
 181           (437 :CP437) ;; OEM - United States
 182           ;;500       IBM EBCDIC - International
 183           ;;708       Arabic - ASMO 708
 184           ;;709       Arabic - ASMO 449+, BCON V4
 185           ;;710       Arabic - Transparent Arabic
 186           ;;720       Arabic - Transparent ASMO
 187           ;;737       OEM - Greek (formerly 437G)
 188           ;;775       OEM - Baltic
 189           (850 :CP850)     ;; OEM - Multilingual Latin I
 190           (852 :CP852)     ;; OEM - Latin II
 191           (855 :CP855)     ;; OEM - Cyrillic (primarily Russian)
 192           (857 :CP857)     ;; OEM - Turkish
 193           ;;858       OEM - Multilingual Latin I + Euro symbol
 194           (860 :CP860)     ;; OEM - Portuguese
 195           (861 :CP861)     ;; OEM - Icelandic
 196           (862 :CP862)     ;; OEM - Hebrew
 197           (863 :CP863)     ;; OEM - Canadian-French
 198           (864 :CP864)     ;; OEM - Arabic
 199           (865 :CP865)     ;; OEM - Nordic
 200           (866 :CP866)     ;; OEM - Russian
 201           (869 :CP869)     ;; OEM - Modern Greek
 202           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
 203           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
 204           ;;875       IBM EBCDIC - Modern Greek
 205           (932 :CP932)     ;; ANSI/OEM - Japanese, Shift-JIS
 206           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
 207           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
 208           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
 209           ;;1026      IBM EBCDIC - Turkish (Latin-5)
 210           ;;1047      IBM EBCDIC - Latin 1/Open System
 211           ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
 212           ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
 213           ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
 214           ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
 215           ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
 216           ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
 217           ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
 218           ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
 219           ;;1148      IBM EBCDIC - International (500 + Euro symbol)
 220           ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
 221           (1200 :UCS-2LE)    ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
 222           (1201 :UCS-2BE)    ;; Unicode UCS-2 Big-Endian
 223           (1250 :CP1250)     ;; ANSI - Central European
 224           (1251 :CP1251)     ;; ANSI - Cyrillic
 225           (1252 :CP1252)     ;; ANSI - Latin I
 226           (1253 :CP1253)     ;; ANSI - Greek
 227           (1254 :CP1254)     ;; ANSI - Turkish
 228           (1255 :CP1255)     ;; ANSI - Hebrew
 229           (1256 :CP1256)     ;; ANSI - Arabic
 230           (1257 :CP1257)     ;; ANSI - Baltic
 231           (1258 :CP1258)     ;; ANSI/OEM - Vietnamese
 232           ;;1361      Korean (Johab)
 233           ;;10000 MAC - Roman
 234           ;;10001     MAC - Japanese
 235           ;;10002     MAC - Traditional Chinese (Big5)
 236           ;;10003     MAC - Korean
 237           ;;10004     MAC - Arabic
 238           ;;10005     MAC - Hebrew
 239           ;;10006     MAC - Greek I
 240           (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
 241           ;;10008     MAC - Simplified Chinese (GB 2312)
 242           ;;10010     MAC - Romania
 243           ;;10017     MAC - Ukraine
 244           ;;10021     MAC - Thai
 245           ;;10029     MAC - Latin II
 246           ;;10079     MAC - Icelandic
 247           ;;10081     MAC - Turkish
 248           ;;10082     MAC - Croatia
 249           ;;12000     Unicode UCS-4 Little-Endian
 250           ;;12001     Unicode UCS-4 Big-Endian
 251           ;;20000     CNS - Taiwan
 252           ;;20001     TCA - Taiwan
 253           ;;20002     Eten - Taiwan
 254           ;;20003     IBM5550 - Taiwan
 255           ;;20004     TeleText - Taiwan
 256           ;;20005     Wang - Taiwan
 257           ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
 258           ;;20106     IA5 German (7-bit)
 259           ;;20107     IA5 Swedish (7-bit)
 260           ;;20108     IA5 Norwegian (7-bit)
 261           ;;20127     US-ASCII (7-bit)
 262           ;;20261     T.61
 263           ;;20269     ISO 6937 Non-Spacing Accent
 264           ;;20273     IBM EBCDIC - Germany
 265           ;;20277     IBM EBCDIC - Denmark/Norway
 266           ;;20278     IBM EBCDIC - Finland/Sweden
 267           ;;20280     IBM EBCDIC - Italy
 268           ;;20284     IBM EBCDIC - Latin America/Spain
 269           ;;20285     IBM EBCDIC - United Kingdom
 270           ;;20290     IBM EBCDIC - Japanese Katakana Extended
 271           ;;20297     IBM EBCDIC - France
 272           ;;20420     IBM EBCDIC - Arabic
 273           ;;20423     IBM EBCDIC - Greek
 274           ;;20424     IBM EBCDIC - Hebrew
 275           ;;20833     IBM EBCDIC - Korean Extended
 276           ;;20838     IBM EBCDIC - Thai
 277           (20866 :KOI8-R) ;; Russian - KOI8-R
 278           ;;20871     IBM EBCDIC - Icelandic
 279           ;;20880     IBM EBCDIC - Cyrillic (Russian)
 280           ;;20905     IBM EBCDIC - Turkish
 281           ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
 282           ;;20932     JIS X 0208-1990 & 0121-1990
 283           ;;20936     Simplified Chinese (GB2312)
 284           ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
 285           ;;21027     (deprecated)
 286           (21866 :KOI8-U)      ;; Ukrainian (KOI8-U)
 287           (28591 :LATIN-1)     ;; ISO 8859-1 Latin I
 288           (28592 :ISO-8859-2)  ;; ISO 8859-2 Central Europe
 289           (28593 :ISO-8859-3)  ;; ISO 8859-3 Latin 3
 290           (28594 :ISO-8859-4)  ;; ISO 8859-4 Baltic
 291           (28595 :ISO-8859-5)  ;; ISO 8859-5 Cyrillic
 292           (28596 :ISO-8859-6)  ;; ISO 8859-6 Arabic
 293           (28597 :ISO-8859-7)  ;; ISO 8859-7 Greek
 294           (28598 :ISO-8859-8)  ;; ISO 8859-8 Hebrew
 295           (28599 :ISO-8859-9)  ;; ISO 8859-9 Latin 5
 296           (28605 :LATIN-9)     ;; ISO 8859-15 Latin 9
 297           ;;29001     Europa 3
 298           (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
 299           ;;50220     ISO 2022 Japanese with no halfwidth Katakana
 300           ;;50221     ISO 2022 Japanese with halfwidth Katakana
 301           ;;50222     ISO 2022 Japanese JIS X 0201-1989
 302           ;;50225     ISO 2022 Korean
 303           ;;50227     ISO 2022 Simplified Chinese
 304           ;;50229     ISO 2022 Traditional Chinese
 305           ;;50930     Japanese (Katakana) Extended
 306           ;;50931     US/Canada and Japanese
 307           ;;50933     Korean Extended and Korean
 308           ;;50935     Simplified Chinese Extended and Simplified Chinese
 309           ;;50936     Simplified Chinese
 310           ;;50937     US/Canada and Traditional Chinese
 311           ;;50939     Japanese (Latin) Extended and Japanese
 312           (51932 :EUC-JP) ;; EUC - Japanese
 313           ;;51936     EUC - Simplified Chinese
 314           ;;51949     EUC - Korean
 315           ;;51950     EUC - Traditional Chinese
 316           ;;52936     HZ-GB2312 Simplified Chinese
 317           ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
 318           ;;57002     ISCII Devanagari
 319           ;;57003     ISCII Bengali
 320           ;;57004     ISCII Tamil
 321           ;;57005     ISCII Telugu
 322           ;;57006     ISCII Assamese
 323           ;;57007     ISCII Oriya
 324           ;;57008     ISCII Kannada
 325           ;;57009     ISCII Malayalam
 326           ;;57010     ISCII Gujarati
 327           ;;57011     ISCII Punjabi
 328           ;;65000     Unicode UTF-7
 329           (65001 :UTF8))) ;; Unicode UTF-8
 330   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
 331
 332 #!+sb-unicode
 333 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
 334 ;; the console just behave differently?
 335 (progn
 336   (declaim (ftype (function () keyword) ansi-codepage))
 337   (defun ansi-codepage ()
 338     (or *ansi-codepage*
 339         (setq *ansi-codepage*
 340               (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
 341                        *codepage-to-external-format*
 342                        :latin-1))))
 343
 344   (declaim (ftype (function () keyword) oem-codepage))
 345   (defun oem-codepage ()
 346     (or *oem-codepage*
 347         (setq *oem-codepage*
 348             (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
 349                      *codepage-to-external-format*
 350                      :latin-1)))))
 351
 352 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
 353 (declaim (ftype (function () keyword) console-input-codepage))
 354 (defun console-input-codepage ()
 355   (or #!+sb-unicode
 356       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
 357                *codepage-to-external-format*)
 358       :latin-1))
 359
 360 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
 361 (declaim (ftype (function () keyword) console-output-codepage))
 362 (defun console-output-codepage ()
 363   (or #!+sb-unicode
 364       (gethash (alien-funcall
 365                 (extern-alien "GetConsoleOutputCP@0" (function UINT)))
 366                *codepage-to-external-format*)
 367       :latin-1))
 368
 369 (define-alien-routine ("LocalFree@4" local-free) void
 370   (lptr (* t)))
 371
 372 (defmacro cast-and-free (value &key (type 'system-string)
 373                                 (free-function 'free-alien))
 374   `(prog1 (cast ,value ,type)
 375      (,free-function ,value)))
 376
 377 (eval-when (:compile-toplevel :load-toplevel :execute)
 378 (defmacro with-funcname ((name description) &body body)
 379   `(let
 380      ((,name (etypecase ,description
 381                (string ,description)
 382                (cons (destructuring-bind (s &optional (l 0) c) ,description
 383                        (format nil "~A~A~A" s
 384                                (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
 385                                l))))))
 386      ,@body)))
 387
 388 (defmacro make-system-buffer (x)
 389  `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
 390
 391 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
 392 ;;; macros in this file, are only used in this file, and could be
 393 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
 394
 395 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
 396   (with-funcname (sname name)
 397     `(locally
 398        (declare (optimize (sb!c::float-accuracy 0)))
 399        (let ((result (alien-funcall
 400                        (extern-alien ,sname
 401                                      (function ,ret-type ,@arg-types))
 402                        ,@args)))
 403          (declare (ignorable result))
 404          ,success-form))))
 405
 406 ;;; This is like SYSCALL, but if it fails, signal an error instead of
 407 ;;; returning error codes. Should only be used for syscalls that will
 408 ;;; never really get an error.
 409 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
 410   (with-funcname (sname name)
 411     `(locally
 412        (declare (optimize (sb!c::float-accuracy 0)))
 413        (let ((result (alien-funcall
 414                        (extern-alien ,sname (function bool ,@arg-types))
 415                        ,@args)))
 416          (when (zerop result)
 417            (win32-error ,sname))
 418          ,success-form))))
 419
 420 (defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
 421   (with-funcname (sname name)
 422     `(with-alien ((,func (function ,ret-type ,@arg-types)
 423                          :extern ,sname))
 424        ,@body)))
 425
 426 (defmacro void-syscall* ((name &rest arg-types) &rest args)
 427   `(syscall* (,name ,@arg-types) (values t 0) ,@args))
 428
 429 (defun get-last-error-message (err)
 430   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
 431   (with-alien ((amsg (* char)))
 432     (syscall (("FormatMessage" 28 t)
 433               dword dword dword dword dword (* (* char)) dword dword)
 434              (cast-and-free amsg :free-function local-free)
 435              (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
 436              0 err 0 (addr amsg) 0 0)))
 437
 438 (defmacro win32-error (func-name &optional err)
 439   `(let ((err-code ,(or err `(get-last-error))))
 440      (declare (type (unsigned-byte 32) err-code))
 441      (error "~%Win32 Error [~A] - ~A~%~A"
 442             ,func-name
 443             err-code
 444             (get-last-error-message err-code))))
 445
 446 (defun get-folder-namestring (csidl)
 447   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
 448   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 449     (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
 450              (concatenate 'string (cast-and-free apath) "\\")
 451              0 csidl 0 0 apath)))
 452
 453 (defun get-folder-pathname (csidl)
 454   (parse-native-namestring (get-folder-namestring csidl)))
 455
 456 (defun sb!unix:posix-getcwd ()
 457   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 458     (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
 459       (let ((ret (alien-funcall afunc (1+ max_path) apath)))
 460         (when (zerop ret)
 461           (win32-error "GetCurrentDirectory"))
 462         (when (> ret (1+ max_path))
 463           (free-alien apath)
 464           (setf apath (make-system-buffer ret))
 465           (alien-funcall afunc ret apath))
 466         (cast-and-free apath)))))
 467
 468 (defun sb!unix:unix-mkdir (name mode)
 469   (declare (type sb!unix:unix-pathname name)
 470            (type sb!unix:unix-file-mode mode)
 471            (ignore mode))
 472   (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0))
 473
 474 (defun sb!unix:unix-rename (name1 name2)
 475   (declare (type sb!unix:unix-pathname name1 name2))
 476   (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2))
 477
 478 (defun sb!unix::posix-getenv (name)
 479   (declare (type simple-string name))
 480   (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
 481     (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
 482                         dword system-string (* char) dword)
 483       (let ((ret (alien-funcall afunc name aenv default-environment-length)))
 484         (when (> ret default-environment-length)
 485           (free-alien aenv)
 486           (setf aenv (make-system-buffer ret))
 487           (alien-funcall afunc name aenv ret))
 488         (if (> ret 0)
 489             (cast-and-free aenv)
 490             (free-alien aenv))))))
 491
 492 ;; GET-CURRENT-PROCESS
 493 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
 494 ;; process.
 495 ;;
 496 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
 497 (declaim (inline get-current-process))
 498 (define-alien-routine ("GetCurrentProcess@0" get-current-process) handle)
 499
 500 ;;;; Process time information
 501
 502 (defconstant 100ns-per-internal-time-unit
 503   (/ 10000000 sb!xc:internal-time-units-per-second))
 504
 505 ;; FILETIME
 506 ;; The FILETIME structure is a 64-bit value representing the number of
 507 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
 508 ;;
 509 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
 510 (define-alien-type FILETIME (sb!alien:unsigned 64))
 511
 512 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
 513                               &body forms)
 514   `(with-alien ((,creation-time filetime)
 515                 (,exit-time filetime)
 516                 (,kernel-time filetime)
 517                 (,user-time filetime))
 518      (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
 519                 (* filetime) (* filetime))
 520                (progn ,@forms)
 521                (get-current-process)
 522                (addr ,creation-time)
 523                (addr ,exit-time)
 524                (addr ,kernel-time)
 525                (addr ,user-time))))
 526
 527 (declaim (inline system-internal-real-time))
 528
 529 (let ((epoch 0))
 530   (declare (unsigned-byte epoch))
 531   ;; FIXME: For optimization ideas see the unix implementation.
 532   (defun reinit-internal-real-time ()
 533     (setf epoch 0
 534           epoch (get-internal-real-time)))
 535   (defun get-internal-real-time ()
 536     (- (with-alien ((system-time filetime))
 537          (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
 538                   (values (floor system-time 100ns-per-internal-time-unit))
 539                   (addr system-time)))
 540        epoch)))
 541
 542 (defun system-internal-run-time ()
 543   (with-process-times (creation-time exit-time kernel-time user-time)
 544     (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
 545
 546 (define-alien-type hword (unsigned 16))
 547
 548 (define-alien-type systemtime
 549     (struct systemtime
 550             (year hword)
 551             (month hword)
 552             (weekday hword)
 553             (day hword)
 554             (hour hword)
 555             (minute hword)
 556             (second hword)
 557             (millisecond hword)))
 558
 559 ;; Obtained with, but the XC can't deal with that -- but
 560 ;; it's not like the value is ever going to change...
 561 ;; (with-alien ((filetime filetime)
 562 ;;              (epoch systemtime))
 563 ;;   (setf (slot epoch 'year) 1970
 564 ;;         (slot epoch 'month) 1
 565 ;;         (slot epoch 'day) 1
 566 ;;         (slot epoch 'hour) 0
 567 ;;         (slot epoch 'minute) 0
 568 ;;         (slot epoch 'second) 0
 569 ;;         (slot epoch 'millisecond) 0)
 570 ;;   (syscall (("SystemTimeToFileTime" 8) void
 571 ;;             (* systemtime) (* filetime))
 572 ;;            filetime
 573 ;;            (addr epoch)
 574 ;;            (addr filetime)))
 575 (defconstant +unix-epoch-filetime+ 116444736000000000)
 576
 577 #!-sb-fluid
 578 (declaim (inline get-time-of-day))
 579 (defun get-time-of-day ()
 580   "Return the number of seconds and microseconds since the beginning of the
 581 UNIX epoch: January 1st 1970."
 582   (with-alien ((system-time filetime))
 583     (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
 584              (multiple-value-bind (sec 100ns)
 585                  (floor (- system-time +unix-epoch-filetime+)
 586                         (* 100ns-per-internal-time-unit
 587                            internal-time-units-per-second))
 588                (values sec (floor 100ns 10)))
 589              (addr system-time))))
 590
 591 ;; SETENV
 592 ;; The SetEnvironmentVariable function sets the contents of the specified
 593 ;; environment variable for the current process.
 594 ;;
 595 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
 596 (defun setenv (name value)
 597   (declare (type simple-string name value))
 598   (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
 599                  name value))
 600
 601 (defmacro c-sizeof (s)
 602   "translate alien size (in bits) to c-size (in bytes)"
 603   `(/ (alien-size ,s) 8))
 604
 605 ;; OSVERSIONINFO
 606 ;; The OSVERSIONINFO data structure contains operating system version
 607 ;; information. The information includes major and minor version numbers,
 608 ;; a build number, a platform identifier, and descriptive text about
 609 ;; the operating system. This structure is used with the GetVersionEx function.
 610 ;;
 611 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
 612 (define-alien-type nil
 613   (struct OSVERSIONINFO
 614     (dwOSVersionInfoSize dword)
 615     (dwMajorVersion dword)
 616     (dwMinorVersion dword)
 617     (dwBuildNumber dword)
 618     (dwPlatformId dword)
 619     (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
 620
 621 (defun get-version-ex ()
 622   (with-alien ((info (struct OSVERSIONINFO)))
 623     (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
 624     (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
 625               (values (slot info 'dwMajorVersion)
 626                       (slot info 'dwMinorVersion)
 627                       (slot info 'dwBuildNumber)
 628                       (slot info 'dwPlatformId)
 629                       (cast (slot info 'szCSDVersion) system-string))
 630               (addr info))))
 631
 632 ;; GET-COMPUTER-NAME
 633 ;; The GetComputerName function retrieves the NetBIOS name of the local
 634 ;; computer. This name is established at system startup, when the system
 635 ;; reads it from the registry.
 636 ;;
 637 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
 638 (declaim (ftype (function () simple-string) get-computer-name))
 639 (defun get-computer-name ()
 640   (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
 641                (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
 642     (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
 643       (when (zerop (alien-funcall afunc aname (addr length)))
 644         (let ((err (get-last-error)))
 645           (unless (= err ERROR_BUFFER_OVERFLOW)
 646             (win32-error "GetComputerName" err))
 647           (free-alien aname)
 648           (setf aname (make-system-buffer length))
 649           (alien-funcall afunc aname (addr length))))
 650       (cast-and-free aname))))
 651
 652 ;; File mapping support routines
 653 (define-alien-routine (#!+sb-unicode "CreateFileMappingW"
 654                        #!-sb-unicode "CreateFileMappingA"
 655                        create-file-mapping)
 656     handle
 657   (handle handle)
 658   (security-attributes (* t))
 659   (protection dword)
 660   (maximum-size-high dword)
 661   (maximum-size-low dword)
 662   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
 663
 664 (define-alien-routine ("MapViewOfFile" map-view-of-file)
 665     system-area-pointer
 666   (file-mapping handle)
 667   (desired-access dword)
 668   (offset-high dword)
 669   (offset-low dword)
 670   (size dword))
 671
 672 (define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
 673   (address (* t)))
 674
 675 (define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
 676   (address (* t))
 677   (length dword))
 678
 679 ;; Constants for CreateFile `disposition'.
 680 (defconstant file-create-new 1)
 681 (defconstant file-create-always 2)
 682 (defconstant file-open-existing 3)
 683 (defconstant file-open-always 4)
 684 (defconstant file-truncate-existing 5)
 685
 686 ;; access rights
 687 (defconstant access-generic-read #x80000000)
 688 (defconstant access-generic-write #x40000000)
 689 (defconstant access-generic-execute #x20000000)
 690 (defconstant access-generic-all #x10000000)
 691 (defconstant access-file-append-data #x4)
 692
 693 ;; share modes
 694 (defconstant file-share-delete #x04)
 695 (defconstant file-share-read #x01)
 696 (defconstant file-share-write #x02)
 697
 698 ;; CreateFile (the real file-opening workhorse)
 699 (define-alien-routine (#!+sb-unicode "CreateFileW"
 700                        #!-sb-unicode "CreateFileA"
 701                        create-file)
 702     handle
 703   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
 704   (desired-access dword)
 705   (share-mode dword)
 706   (security-attributes (* t))
 707   (creation-disposition dword)
 708   (flags-and-attributes dword)
 709   (template-file handle))
 710
 711 (defconstant file-attribute-readonly #x1)
 712 (defconstant file-attribute-hidden #x2)
 713 (defconstant file-attribute-system #x4)
 714 (defconstant file-attribute-directory #x10)
 715 (defconstant file-attribute-archive #x20)
 716 (defconstant file-attribute-device #x40)
 717 (defconstant file-attribute-normal #x80)
 718 (defconstant file-attribute-temporary #x100)
 719 (defconstant file-attribute-sparse #x200)
 720 (defconstant file-attribute-reparse-point #x400)
 721 (defconstant file-attribute-reparse-compressed #x800)
 722 (defconstant file-attribute-reparse-offline #x1000)
 723 (defconstant file-attribute-not-content-indexed #x2000)
 724 (defconstant file-attribute-encrypted #x4000)
 725
 726 (defconstant file-flag-overlapped #x40000000)
 727
 728 ;; GetFileAttribute is like a tiny subset of fstat(),
 729 ;; enough to distinguish directories from anything else.
 730 (define-alien-routine (#!+sb-unicode "GetFileAttributesW"
 731                        #!-sb-unicode "GetFileAttributesA"
 732                        get-file-attributes)
 733     dword
 734   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
 735
 736 (define-alien-routine ("CloseHandle" close-handle) bool
 737   (handle handle))