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
  25 (define-alien-type lispbool (boolean 32))
  26
  27 (define-alien-type system-string
  28                    #!-sb-unicode c-string
  29                    #!+sb-unicode (c-string :external-format :ucs-2))
  30
  31 (defconstant default-environment-length 1024)
  32
  33 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
  34 ;;; to a pointer.
  35 (defconstant invalid-handle -1)
  36
  37 ;;;; Error Handling
  38
  39 ;;; Retrieve the calling thread's last-error code value.  The
  40 ;;; last-error code is maintained on a per-thread basis.
  41 (define-alien-routine ("GetLastError@0" get-last-error) dword)
  42
  43 ;;; Flag constants for FORMAT-MESSAGE.
  44 (defconstant format-message-from-system #x1000)
  45
  46 ;;; Format an error message based on a lookup table.  See MSDN for the
  47 ;;; full meaning of the all options---most are not used when getting
  48 ;;; system error codes.
  49 (define-alien-routine ("FormatMessageA@28" format-message) dword
  50   (flags dword)
  51   (source (* t))
  52   (message-id dword)
  53   (language-id dword)
  54   (buffer c-string)
  55   (size dword)
  56   (arguments (* t)))
  57
  58 ;;;; File Handles
  59
  60 ;;; Get the operating system handle for a C file descriptor.  Returns
  61 ;;; INVALID-HANDLE on failure.
  62 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
  63   (fd int))
  64
  65 ;;; Read data from a file handle into a buffer.  This may be used
  66 ;;; synchronously or with "overlapped" (asynchronous) I/O.
  67 (define-alien-routine ("ReadFile@20" read-file) bool
  68   (file handle)
  69   (buffer (* t))
  70   (bytes-to-read dword)
  71   (bytes-read (* dword))
  72   (overlapped (* t)))
  73
  74 ;;; Write data from a buffer to a file handle.  This may be used
  75 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
  76 (define-alien-routine ("WriteFile@20" write-file) bool
  77   (file handle)
  78   (buffer (* t))
  79   (bytes-to-write dword)
  80   (bytes-written (* dword))
  81   (overlapped (* t)))
  82
  83 ;;; Copy data from a named or anonymous pipe into a buffer without
  84 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
  85 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
  86 ;;; Return TRUE on success, FALSE on failure.
  87 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
  88   (pipe handle)
  89   (buffer (* t))
  90   (buffer-size dword)
  91   (bytes-read (* dword))
  92   (bytes-avail (* dword))
  93   (bytes-left-this-message (* dword)))
  94
  95 ;;; Flush the console input buffer if HANDLE is a console handle.
  96 ;;; Returns true on success, false if the handle does not refer to a
  97 ;;; console.
  98 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
  99   (handle handle))
 100
 101 ;;; Read data from the console input buffer without removing it,
 102 ;;; without blocking.  Buffer should be large enough for LENGTH *
 103 ;;; INPUT-RECORD-SIZE bytes.
 104 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
 105   (handle handle)
 106   (buffer (* t))
 107   (length dword)
 108   (nevents (* dword)))
 109
 110 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
 111 ;;; isn't a unified interface to do this---we have to know what sort
 112 ;;; of handle we have.  Of course, there's no way to actually
 113 ;;; introspect it, so we have to try various things until we find
 114 ;;; something that works.  Returns true if there could be input
 115 ;;; available, or false if there is not.
 116 (defun handle-listen (handle)
 117   (with-alien ((avail dword)
 118                (buf (array char #.input-record-size)))
 119     (when
 120         ;; Make use of the fact that console handles are technically no
 121         ;; real handles, and unlike those, have these bits set:
 122         (= 3 (logand 3 handle))
 123       (return-from handle-listen
 124         (alien-funcall (extern-alien "win32_tty_listen"
 125                                      (function boolean handle))
 126                        handle)))
 127     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
 128       (return-from handle-listen (plusp avail)))
 129
 130     (unless (zerop (peek-console-input handle
 131                                        (cast buf (* t))
 132                                        1 (addr avail)))
 133       (return-from handle-listen (plusp avail)))
 134
 135     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
 136     ;; HANDLE is a socket.
 137     t))
 138
 139 ;;; Listen for input on a C runtime file handle.  Returns true if
 140 ;;; there could be input available, or false if there is not.
 141 (defun fd-listen (fd)
 142   (let ((handle (get-osfhandle fd)))
 143     (if handle
 144         (handle-listen handle)
 145         t)))
 146
 147 ;;; Clear all available input from a file handle.
 148 (defun handle-clear-input (handle)
 149   (flush-console-input-buffer handle)
 150   (with-alien ((buf (array char 1024))
 151                (count dword))
 152     (loop
 153      (unless (handle-listen handle)
 154        (return))
 155      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
 156        (return))
 157      (when (< count 1024)
 158        (return)))))
 159
 160 ;;; Clear all available input from a C runtime file handle.
 161 (defun fd-clear-input (fd)
 162   (let ((handle (get-osfhandle fd)))
 163     (when handle
 164       (handle-clear-input handle))))
 165
 166 ;;;; System Functions
 167
 168 #!-sb-thread
 169 (define-alien-routine ("Sleep@4" millisleep) void
 170   (milliseconds dword))
 171
 172 #!+sb-thread
 173 (defun sb!unix:nanosleep (sec nsec)
 174   (let ((*allow-with-interrupts* *interrupts-enabled*))
 175     (without-interrupts
 176       (let ((timer (sb!impl::os-create-wtimer)))
 177         (sb!impl::os-set-wtimer timer sec nsec)
 178         (unwind-protect
 179              (do () ((with-local-interrupts
 180                        (zerop (sb!impl::os-wait-for-wtimer timer)))))
 181           (sb!impl::os-close-wtimer timer))))))
 182
 183 #!+sb-unicode
 184 (progn
 185   (defvar *ansi-codepage* nil)
 186   (defvar *oem-codepage* nil)
 187   (defvar *codepage-to-external-format* (make-hash-table)))
 188
 189 #!+sb-unicode
 190 (dolist
 191     (cp '(;;037       IBM EBCDIC - U.S./Canada
 192           (437 :CP437) ;; OEM - United States
 193           ;;500       IBM EBCDIC - International
 194           ;;708       Arabic - ASMO 708
 195           ;;709       Arabic - ASMO 449+, BCON V4
 196           ;;710       Arabic - Transparent Arabic
 197           ;;720       Arabic - Transparent ASMO
 198           ;;737       OEM - Greek (formerly 437G)
 199           ;;775       OEM - Baltic
 200           (850 :CP850)     ;; OEM - Multilingual Latin I
 201           (852 :CP852)     ;; OEM - Latin II
 202           (855 :CP855)     ;; OEM - Cyrillic (primarily Russian)
 203           (857 :CP857)     ;; OEM - Turkish
 204           ;;858       OEM - Multilingual Latin I + Euro symbol
 205           (860 :CP860)     ;; OEM - Portuguese
 206           (861 :CP861)     ;; OEM - Icelandic
 207           (862 :CP862)     ;; OEM - Hebrew
 208           (863 :CP863)     ;; OEM - Canadian-French
 209           (864 :CP864)     ;; OEM - Arabic
 210           (865 :CP865)     ;; OEM - Nordic
 211           (866 :CP866)     ;; OEM - Russian
 212           (869 :CP869)     ;; OEM - Modern Greek
 213           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
 214           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
 215           ;;875       IBM EBCDIC - Modern Greek
 216           (932 :CP932)     ;; ANSI/OEM - Japanese, Shift-JIS
 217           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
 218           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
 219           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
 220           ;;1026      IBM EBCDIC - Turkish (Latin-5)
 221           ;;1047      IBM EBCDIC - Latin 1/Open System
 222           ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
 223           ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
 224           ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
 225           ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
 226           ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
 227           ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
 228           ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
 229           ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
 230           ;;1148      IBM EBCDIC - International (500 + Euro symbol)
 231           ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
 232           (1200 :UCS-2LE)    ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
 233           (1201 :UCS-2BE)    ;; Unicode UCS-2 Big-Endian
 234           (1250 :CP1250)     ;; ANSI - Central European
 235           (1251 :CP1251)     ;; ANSI - Cyrillic
 236           (1252 :CP1252)     ;; ANSI - Latin I
 237           (1253 :CP1253)     ;; ANSI - Greek
 238           (1254 :CP1254)     ;; ANSI - Turkish
 239           (1255 :CP1255)     ;; ANSI - Hebrew
 240           (1256 :CP1256)     ;; ANSI - Arabic
 241           (1257 :CP1257)     ;; ANSI - Baltic
 242           (1258 :CP1258)     ;; ANSI/OEM - Vietnamese
 243           ;;1361      Korean (Johab)
 244           ;;10000 MAC - Roman
 245           ;;10001     MAC - Japanese
 246           ;;10002     MAC - Traditional Chinese (Big5)
 247           ;;10003     MAC - Korean
 248           ;;10004     MAC - Arabic
 249           ;;10005     MAC - Hebrew
 250           ;;10006     MAC - Greek I
 251           (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
 252           ;;10008     MAC - Simplified Chinese (GB 2312)
 253           ;;10010     MAC - Romania
 254           ;;10017     MAC - Ukraine
 255           ;;10021     MAC - Thai
 256           ;;10029     MAC - Latin II
 257           ;;10079     MAC - Icelandic
 258           ;;10081     MAC - Turkish
 259           ;;10082     MAC - Croatia
 260           ;;12000     Unicode UCS-4 Little-Endian
 261           ;;12001     Unicode UCS-4 Big-Endian
 262           ;;20000     CNS - Taiwan
 263           ;;20001     TCA - Taiwan
 264           ;;20002     Eten - Taiwan
 265           ;;20003     IBM5550 - Taiwan
 266           ;;20004     TeleText - Taiwan
 267           ;;20005     Wang - Taiwan
 268           ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
 269           ;;20106     IA5 German (7-bit)
 270           ;;20107     IA5 Swedish (7-bit)
 271           ;;20108     IA5 Norwegian (7-bit)
 272           ;;20127     US-ASCII (7-bit)
 273           ;;20261     T.61
 274           ;;20269     ISO 6937 Non-Spacing Accent
 275           ;;20273     IBM EBCDIC - Germany
 276           ;;20277     IBM EBCDIC - Denmark/Norway
 277           ;;20278     IBM EBCDIC - Finland/Sweden
 278           ;;20280     IBM EBCDIC - Italy
 279           ;;20284     IBM EBCDIC - Latin America/Spain
 280           ;;20285     IBM EBCDIC - United Kingdom
 281           ;;20290     IBM EBCDIC - Japanese Katakana Extended
 282           ;;20297     IBM EBCDIC - France
 283           ;;20420     IBM EBCDIC - Arabic
 284           ;;20423     IBM EBCDIC - Greek
 285           ;;20424     IBM EBCDIC - Hebrew
 286           ;;20833     IBM EBCDIC - Korean Extended
 287           ;;20838     IBM EBCDIC - Thai
 288           (20866 :KOI8-R) ;; Russian - KOI8-R
 289           ;;20871     IBM EBCDIC - Icelandic
 290           ;;20880     IBM EBCDIC - Cyrillic (Russian)
 291           ;;20905     IBM EBCDIC - Turkish
 292           ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
 293           ;;20932     JIS X 0208-1990 & 0121-1990
 294           ;;20936     Simplified Chinese (GB2312)
 295           ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
 296           ;;21027     (deprecated)
 297           (21866 :KOI8-U)      ;; Ukrainian (KOI8-U)
 298           (28591 :LATIN-1)     ;; ISO 8859-1 Latin I
 299           (28592 :ISO-8859-2)  ;; ISO 8859-2 Central Europe
 300           (28593 :ISO-8859-3)  ;; ISO 8859-3 Latin 3
 301           (28594 :ISO-8859-4)  ;; ISO 8859-4 Baltic
 302           (28595 :ISO-8859-5)  ;; ISO 8859-5 Cyrillic
 303           (28596 :ISO-8859-6)  ;; ISO 8859-6 Arabic
 304           (28597 :ISO-8859-7)  ;; ISO 8859-7 Greek
 305           (28598 :ISO-8859-8)  ;; ISO 8859-8 Hebrew
 306           (28599 :ISO-8859-9)  ;; ISO 8859-9 Latin 5
 307           (28605 :LATIN-9)     ;; ISO 8859-15 Latin 9
 308           ;;29001     Europa 3
 309           (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
 310           ;;50220     ISO 2022 Japanese with no halfwidth Katakana
 311           ;;50221     ISO 2022 Japanese with halfwidth Katakana
 312           ;;50222     ISO 2022 Japanese JIS X 0201-1989
 313           ;;50225     ISO 2022 Korean
 314           ;;50227     ISO 2022 Simplified Chinese
 315           ;;50229     ISO 2022 Traditional Chinese
 316           ;;50930     Japanese (Katakana) Extended
 317           ;;50931     US/Canada and Japanese
 318           ;;50933     Korean Extended and Korean
 319           ;;50935     Simplified Chinese Extended and Simplified Chinese
 320           ;;50936     Simplified Chinese
 321           ;;50937     US/Canada and Traditional Chinese
 322           ;;50939     Japanese (Latin) Extended and Japanese
 323           (51932 :EUC-JP) ;; EUC - Japanese
 324           ;;51936     EUC - Simplified Chinese
 325           ;;51949     EUC - Korean
 326           ;;51950     EUC - Traditional Chinese
 327           ;;52936     HZ-GB2312 Simplified Chinese
 328           ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
 329           ;;57002     ISCII Devanagari
 330           ;;57003     ISCII Bengali
 331           ;;57004     ISCII Tamil
 332           ;;57005     ISCII Telugu
 333           ;;57006     ISCII Assamese
 334           ;;57007     ISCII Oriya
 335           ;;57008     ISCII Kannada
 336           ;;57009     ISCII Malayalam
 337           ;;57010     ISCII Gujarati
 338           ;;57011     ISCII Punjabi
 339           ;;65000     Unicode UTF-7
 340           (65001 :UTF8))) ;; Unicode UTF-8
 341   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
 342
 343 #!+sb-unicode
 344 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
 345 ;; the console just behave differently?
 346 (progn
 347   (declaim (ftype (function () keyword) ansi-codepage))
 348   (defun ansi-codepage ()
 349     (or *ansi-codepage*
 350         (setq *ansi-codepage*
 351               (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
 352                        *codepage-to-external-format*
 353                        :latin-1))))
 354
 355   (declaim (ftype (function () keyword) oem-codepage))
 356   (defun oem-codepage ()
 357     (or *oem-codepage*
 358         (setq *oem-codepage*
 359             (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
 360                      *codepage-to-external-format*
 361                      :latin-1)))))
 362
 363 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
 364 (declaim (ftype (function () keyword) console-input-codepage))
 365 (defun console-input-codepage ()
 366   (or #!+sb-unicode
 367       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
 368                *codepage-to-external-format*)
 369       :latin-1))
 370
 371 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
 372 (declaim (ftype (function () keyword) console-output-codepage))
 373 (defun console-output-codepage ()
 374   (or #!+sb-unicode
 375       (gethash (alien-funcall
 376                 (extern-alien "GetConsoleOutputCP@0" (function UINT)))
 377                *codepage-to-external-format*)
 378       :latin-1))
 379
 380 (define-alien-routine ("LocalFree@4" local-free) void
 381   (lptr (* t)))
 382
 383 (defmacro cast-and-free (value &key (type 'system-string)
 384                                 (free-function 'free-alien))
 385   `(prog1 (cast ,value ,type)
 386      (,free-function ,value)))
 387
 388 (eval-when (:compile-toplevel :load-toplevel :execute)
 389 (defmacro with-funcname ((name description) &body body)
 390   `(let
 391      ((,name (etypecase ,description
 392                (string ,description)
 393                (cons (destructuring-bind (s &optional (l 0) c) ,description
 394                        (format nil "~A~A~A" s
 395                                (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
 396                                l))))))
 397      ,@body)))
 398
 399 (defmacro make-system-buffer (x)
 400  `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
 401
 402 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
 403 ;;; macros in this file, are only used in this file, and could be
 404 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
 405
 406 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
 407   (with-funcname (sname name)
 408     `(locally
 409        (declare (optimize (sb!c::float-accuracy 0)))
 410        (let ((result (alien-funcall
 411                        (extern-alien ,sname
 412                                      (function ,ret-type ,@arg-types))
 413                        ,@args)))
 414          (declare (ignorable result))
 415          ,success-form))))
 416
 417 ;;; This is like SYSCALL, but if it fails, signal an error instead of
 418 ;;; returning error codes. Should only be used for syscalls that will
 419 ;;; never really get an error.
 420 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
 421   (with-funcname (sname name)
 422     `(locally
 423        (declare (optimize (sb!c::float-accuracy 0)))
 424        (let ((result (alien-funcall
 425                        (extern-alien ,sname (function bool ,@arg-types))
 426                        ,@args)))
 427          (when (zerop result)
 428            (win32-error ,sname))
 429          ,success-form))))
 430
 431 (defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
 432   (with-funcname (sname name)
 433     `(with-alien ((,func (function ,ret-type ,@arg-types)
 434                          :extern ,sname))
 435        ,@body)))
 436
 437 (defmacro void-syscall* ((name &rest arg-types) &rest args)
 438   `(syscall* (,name ,@arg-types) (values t 0) ,@args))
 439
 440 (defun get-last-error-message (err)
 441   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
 442   (with-alien ((amsg (* char)))
 443     (syscall (("FormatMessage" 28 t)
 444               dword dword dword dword dword (* (* char)) dword dword)
 445              (cast-and-free amsg :free-function local-free)
 446              (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
 447              0 err 0 (addr amsg) 0 0)))
 448
 449 (defmacro win32-error (func-name &optional err)
 450   `(let ((err-code ,(or err `(get-last-error))))
 451      (declare (type (unsigned-byte 32) err-code))
 452      (error "~%Win32 Error [~A] - ~A~%~A"
 453             ,func-name
 454             err-code
 455             (get-last-error-message err-code))))
 456
 457 (defun get-folder-namestring (csidl)
 458   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
 459   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 460     (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
 461              (concatenate 'string (cast-and-free apath) "\\")
 462              0 csidl 0 0 apath)))
 463
 464 (defun get-folder-pathname (csidl)
 465   (parse-native-namestring (get-folder-namestring csidl)))
 466
 467 (defun sb!unix:posix-getcwd ()
 468   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
 469     (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
 470       (let ((ret (alien-funcall afunc (1+ max_path) apath)))
 471         (when (zerop ret)
 472           (win32-error "GetCurrentDirectory"))
 473         (when (> ret (1+ max_path))
 474           (free-alien apath)
 475           (setf apath (make-system-buffer ret))
 476           (alien-funcall afunc ret apath))
 477         (cast-and-free apath)))))
 478
 479 (defun sb!unix:unix-mkdir (name mode)
 480   (declare (type sb!unix:unix-pathname name)
 481            (type sb!unix:unix-file-mode mode)
 482            (ignore mode))
 483   (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0))
 484
 485 (defun sb!unix:unix-rename (name1 name2)
 486   (declare (type sb!unix:unix-pathname name1 name2))
 487   (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2))
 488
 489 (defun sb!unix::posix-getenv (name)
 490   (declare (type simple-string name))
 491   (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
 492     (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
 493                         dword system-string (* char) dword)
 494       (let ((ret (alien-funcall afunc name aenv default-environment-length)))
 495         (when (> ret default-environment-length)
 496           (free-alien aenv)
 497           (setf aenv (make-system-buffer ret))
 498           (alien-funcall afunc name aenv ret))
 499         (if (> ret 0)
 500             (cast-and-free aenv)
 501             (free-alien aenv))))))
 502
 503 ;; GET-CURRENT-PROCESS
 504 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
 505 ;; process.
 506 ;;
 507 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
 508 (declaim (inline get-current-process))
 509 (define-alien-routine ("GetCurrentProcess@0" get-current-process) handle)
 510
 511 ;;;; Process time information
 512
 513 (defconstant 100ns-per-internal-time-unit
 514   (/ 10000000 sb!xc:internal-time-units-per-second))
 515
 516 ;; FILETIME
 517 ;; The FILETIME structure is a 64-bit value representing the number of
 518 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
 519 ;;
 520 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
 521 (define-alien-type FILETIME (sb!alien:unsigned 64))
 522
 523 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
 524                               &body forms)
 525   `(with-alien ((,creation-time filetime)
 526                 (,exit-time filetime)
 527                 (,kernel-time filetime)
 528                 (,user-time filetime))
 529      (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
 530                 (* filetime) (* filetime))
 531                (progn ,@forms)
 532                (get-current-process)
 533                (addr ,creation-time)
 534                (addr ,exit-time)
 535                (addr ,kernel-time)
 536                (addr ,user-time))))
 537
 538 (declaim (inline system-internal-real-time))
 539
 540 (let ((epoch 0))
 541   (declare (unsigned-byte epoch))
 542   ;; FIXME: For optimization ideas see the unix implementation.
 543   (defun reinit-internal-real-time ()
 544     (setf epoch 0
 545           epoch (get-internal-real-time)))
 546   (defun get-internal-real-time ()
 547     (- (with-alien ((system-time filetime))
 548          (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
 549                   (values (floor system-time 100ns-per-internal-time-unit))
 550                   (addr system-time)))
 551        epoch)))
 552
 553 (defun system-internal-run-time ()
 554   (with-process-times (creation-time exit-time kernel-time user-time)
 555     (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
 556
 557 (define-alien-type hword (unsigned 16))
 558
 559 (define-alien-type systemtime
 560     (struct systemtime
 561             (year hword)
 562             (month hword)
 563             (weekday hword)
 564             (day hword)
 565             (hour hword)
 566             (minute hword)
 567             (second hword)
 568             (millisecond hword)))
 569
 570 ;; Obtained with, but the XC can't deal with that -- but
 571 ;; it's not like the value is ever going to change...
 572 ;; (with-alien ((filetime filetime)
 573 ;;              (epoch systemtime))
 574 ;;   (setf (slot epoch 'year) 1970
 575 ;;         (slot epoch 'month) 1
 576 ;;         (slot epoch 'day) 1
 577 ;;         (slot epoch 'hour) 0
 578 ;;         (slot epoch 'minute) 0
 579 ;;         (slot epoch 'second) 0
 580 ;;         (slot epoch 'millisecond) 0)
 581 ;;   (syscall (("SystemTimeToFileTime" 8) void
 582 ;;             (* systemtime) (* filetime))
 583 ;;            filetime
 584 ;;            (addr epoch)
 585 ;;            (addr filetime)))
 586 (defconstant +unix-epoch-filetime+ 116444736000000000)
 587
 588 #!-sb-fluid
 589 (declaim (inline get-time-of-day))
 590 (defun get-time-of-day ()
 591   "Return the number of seconds and microseconds since the beginning of the
 592 UNIX epoch: January 1st 1970."
 593   (with-alien ((system-time filetime))
 594     (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
 595              (multiple-value-bind (sec 100ns)
 596                  (floor (- system-time +unix-epoch-filetime+)
 597                         (* 100ns-per-internal-time-unit
 598                            internal-time-units-per-second))
 599                (values sec (floor 100ns 10)))
 600              (addr system-time))))
 601
 602 ;; SETENV
 603 ;; The SetEnvironmentVariable function sets the contents of the specified
 604 ;; environment variable for the current process.
 605 ;;
 606 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
 607 (defun setenv (name value)
 608   (declare (type simple-string name value))
 609   (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
 610                  name value))
 611
 612 (defmacro c-sizeof (s)
 613   "translate alien size (in bits) to c-size (in bytes)"
 614   `(/ (alien-size ,s) 8))
 615
 616 ;; OSVERSIONINFO
 617 ;; The OSVERSIONINFO data structure contains operating system version
 618 ;; information. The information includes major and minor version numbers,
 619 ;; a build number, a platform identifier, and descriptive text about
 620 ;; the operating system. This structure is used with the GetVersionEx function.
 621 ;;
 622 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
 623 (define-alien-type nil
 624   (struct OSVERSIONINFO
 625     (dwOSVersionInfoSize dword)
 626     (dwMajorVersion dword)
 627     (dwMinorVersion dword)
 628     (dwBuildNumber dword)
 629     (dwPlatformId dword)
 630     (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
 631
 632 (defun get-version-ex ()
 633   (with-alien ((info (struct OSVERSIONINFO)))
 634     (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
 635     (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
 636               (values (slot info 'dwMajorVersion)
 637                       (slot info 'dwMinorVersion)
 638                       (slot info 'dwBuildNumber)
 639                       (slot info 'dwPlatformId)
 640                       (cast (slot info 'szCSDVersion) system-string))
 641               (addr info))))
 642
 643 ;; GET-COMPUTER-NAME
 644 ;; The GetComputerName function retrieves the NetBIOS name of the local
 645 ;; computer. This name is established at system startup, when the system
 646 ;; reads it from the registry.
 647 ;;
 648 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
 649 (declaim (ftype (function () simple-string) get-computer-name))
 650 (defun get-computer-name ()
 651   (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
 652                (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
 653     (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
 654       (when (zerop (alien-funcall afunc aname (addr length)))
 655         (let ((err (get-last-error)))
 656           (unless (= err ERROR_BUFFER_OVERFLOW)
 657             (win32-error "GetComputerName" err))
 658           (free-alien aname)
 659           (setf aname (make-system-buffer length))
 660           (alien-funcall afunc aname (addr length))))
 661       (cast-and-free aname))))
 662
 663 (define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
 664   (handle handle)
 665   (offset long-long)
 666   (new-position long-long :out)
 667   (whence dword))
 668
 669 ;; File mapping support routines
 670 (define-alien-routine (#!+sb-unicode "CreateFileMappingW"
 671                        #!-sb-unicode "CreateFileMappingA"
 672                        create-file-mapping)
 673     handle
 674   (handle handle)
 675   (security-attributes (* t))
 676   (protection dword)
 677   (maximum-size-high dword)
 678   (maximum-size-low dword)
 679   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
 680
 681 (define-alien-routine ("MapViewOfFile" map-view-of-file)
 682     system-area-pointer
 683   (file-mapping handle)
 684   (desired-access dword)
 685   (offset-high dword)
 686   (offset-low dword)
 687   (size dword))
 688
 689 (define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
 690   (address (* t)))
 691
 692 (define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
 693   (address (* t))
 694   (length dword))
 695
 696 ;; Constants for CreateFile `disposition'.
 697 (defconstant file-create-new 1)
 698 (defconstant file-create-always 2)
 699 (defconstant file-open-existing 3)
 700 (defconstant file-open-always 4)
 701 (defconstant file-truncate-existing 5)
 702
 703 ;; access rights
 704 (defconstant access-generic-read #x80000000)
 705 (defconstant access-generic-write #x40000000)
 706 (defconstant access-generic-execute #x20000000)
 707 (defconstant access-generic-all #x10000000)
 708 (defconstant access-file-append-data #x4)
 709
 710 ;; share modes
 711 (defconstant file-share-delete #x04)
 712 (defconstant file-share-read #x01)
 713 (defconstant file-share-write #x02)
 714
 715 ;; CreateFile (the real file-opening workhorse)
 716 (define-alien-routine (#!+sb-unicode "CreateFileW"
 717                        #!-sb-unicode "CreateFileA"
 718                        create-file)
 719     handle
 720   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
 721   (desired-access dword)
 722   (share-mode dword)
 723   (security-attributes (* t))
 724   (creation-disposition dword)
 725   (flags-and-attributes dword)
 726   (template-file handle))
 727
 728 (defconstant file-attribute-readonly #x1)
 729 (defconstant file-attribute-hidden #x2)
 730 (defconstant file-attribute-system #x4)
 731 (defconstant file-attribute-directory #x10)
 732 (defconstant file-attribute-archive #x20)
 733 (defconstant file-attribute-device #x40)
 734 (defconstant file-attribute-normal #x80)
 735 (defconstant file-attribute-temporary #x100)
 736 (defconstant file-attribute-sparse #x200)
 737 (defconstant file-attribute-reparse-point #x400)
 738 (defconstant file-attribute-reparse-compressed #x800)
 739 (defconstant file-attribute-reparse-offline #x1000)
 740 (defconstant file-attribute-not-content-indexed #x2000)
 741 (defconstant file-attribute-encrypted #x4000)
 742
 743 (defconstant file-flag-overlapped #x40000000)
 744 (defconstant file-flag-sequential-scan #x8000000)
 745
 746 ;; GetFileAttribute is like a tiny subset of fstat(),
 747 ;; enough to distinguish directories from anything else.
 748 (define-alien-routine (#!+sb-unicode "GetFileAttributesW"
 749                        #!-sb-unicode "GetFileAttributesA"
 750                        get-file-attributes)
 751     dword
 752   (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
 753
 754 (define-alien-routine ("CloseHandle" close-handle) bool
 755   (handle handle))
 756
 757 (define-alien-routine ("_open_osfhandle" open-osfhandle)
 758     int
 759   (handle handle)
 760   (flags int))
 761
 762 ;; Intended to be an imitation of sb!unix:unix-open based on
 763 ;; CreateFile, as complete as possibly.
 764 ;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
 765
 766 (defun unixlike-open (path flags mode &optional revertable)
 767   (declare (type sb!unix:unix-pathname path)
 768            (type fixnum flags)
 769            (type sb!unix:unix-file-mode mode)
 770            (ignorable mode))
 771   (let* ((disposition-flags
 772           (logior
 773            (if (zerop (logand sb!unix:o_creat flags)) 0 #b100)
 774            (if (zerop (logand sb!unix:o_excl flags)) 0 #b010)
 775            (if (zerop (logand sb!unix:o_trunc flags)) 0 #b001)))
 776          (create-disposition
 777           ;; there are 8 combinations of creat|excl|trunc, some of
 778           ;; them are equivalent. Case stmt below maps them to 5
 779           ;; dispositions (see CreateFile manual).
 780           (case disposition-flags
 781             ((#b110 #b111) file-create-new)
 782             ((#b001 #b011) file-truncate-existing)
 783             ((#b000 #b010) file-open-existing)
 784             (#b100 file-open-always)
 785             (#b101 file-create-always))))
 786     (let ((handle
 787            (create-file path
 788                         (logior
 789                          (if revertable #x10000 0)
 790                          (if (plusp (logand sb!unix:o_append flags))
 791                              access-file-append-data
 792                              0)
 793                          (ecase (logand 3 flags)
 794                            (0 FILE_GENERIC_READ)
 795                            (1 FILE_GENERIC_WRITE)
 796                            ((2 3) (logior FILE_GENERIC_READ
 797                                           FILE_GENERIC_WRITE))))
 798                         (logior FILE_SHARE_READ
 799                                 FILE_SHARE_WRITE)
 800                         nil
 801                         create-disposition
 802                         (logior
 803                          file-attribute-normal
 804                          file-flag-overlapped
 805                          file-flag-sequential-scan)
 806                         0)))
 807       (if (eql handle invalid-handle)
 808           (values nil
 809                   (let ((error-code (get-last-error)))
 810                     (case error-code
 811                       (#.error_file_not_found
 812                        sb!unix:enoent)
 813                       ((#.error_already_exists #.error_file_exists)
 814                        sb!unix:eexist)
 815                       (otherwise (- error-code)))))
 816           (progn
 817             ;; FIXME: seeking to the end is not enough for real APPEND
 818             ;; semantics, but it's better than nothing.
 819             ;;   -- AK
 820             ;;
 821             ;; On the other hand, the CL spec implies the "better than
 822             ;; nothing" seek-once semantics implemented here, and our
 823             ;; POSIX backend is incorrect in implementing :APPEND as
 824             ;; O_APPEND.  Other CL implementations get this right across
 825             ;; platforms.
 826             ;;
 827             ;; Of course, it would be nice if we had :IF-EXISTS
 828             ;; :ATOMICALLY-APPEND separately as an extension, and in
 829             ;; that case, we will have to worry about supporting it
 830             ;; here after all.
 831             ;;
 832             ;; I've tested this only very briefly (on XP and Windows 7),
 833             ;; but my impression is that WriteFile (without documenting
 834             ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
 835             ;; offset in our overlapped structure, WriteFile seeks to the
 836             ;; end for us.  Should we depend on that?  How do we communicate
 837             ;; our desire to do so to the runtime?
 838             ;;   -- DFL
 839             ;;
 840             (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
 841             (let ((fd (open-osfhandle handle (logior sb!unix::o_binary flags))))
 842               (if (minusp fd)
 843                   (values nil (sb!unix::get-errno))
 844                   (values fd 0))))))))
 845
 846 (define-alien-routine ("closesocket" close-socket) int (handle handle))
 847 (define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
 848   (how int))
 849
 850 (define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
 851   (from-process handle)
 852   (from-handle handle)
 853   (to-process handle)
 854   (to-handle handle :out)
 855   (access dword)
 856   (inheritp lispbool)
 857   (options dword))
 858
 859 (defconstant +handle-flag-inherit+ 1)
 860 (defconstant +handle-flag-protect-from-close+ 2)
 861
 862 (define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
 863   (handle handle)
 864   (mask dword)
 865   (flags dword))
 866
 867 (define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
 868   (handle handle)
 869   (flags dword :out))
 870
 871 (define-alien-routine getsockopt int
 872   (handle handle)
 873   (level int)
 874   (opname int)
 875   (dataword int-ptr :in-out)
 876   (socklen int :in-out))
 877
 878 (defconstant sol_socket #xFFFF)
 879 (defconstant so_type #x1008)
 880
 881 (defun socket-handle-p (handle)
 882   (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
 883
 884 (defconstant ebadf 9)
 885
 886 ;;; For sockets, CloseHandle first and closesocket() afterwards is
 887 ;;; legal: winsock tracks its handles separately (that's why we have
 888 ;;; the problem with simple _close in the first place).
 889 ;;;
 890 ;;; ...Seems to be the problem on some OSes, though. We could
 891 ;;; duplicate a handle and attempt close-socket on a duplicated one,
 892 ;;; but it also have some problems...
 893 ;;;
 894 ;;; For now, we protect socket handle from close with SetHandleInformation,
 895 ;;; then call CRT _close() that fails to close a handle but _gets rid of fd_,
 896 ;;; and then we close a handle ourserves.
 897
 898 (defun unixlike-close (fd)
 899   (let ((handle (get-osfhandle fd)))
 900     (flet ((close-protection (enable)
 901              (set-handle-information handle 2 (if enable 2 0))))
 902       (if (= handle invalid-handle)
 903           (values nil ebadf)
 904           (progn
 905             (when (and (socket-handle-p handle) (close-protection t))
 906               (shutdown-socket handle 2)
 907               (alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
 908               (close-protection nil)
 909               (close-socket handle))
 910             (sb!unix::void-syscall ("close" int) fd))))))