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