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