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