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