/src/code/win32.lisp
Lisp | 1186 lines | 757 code | 132 blank | 297 comment | 0 complexity | 4d55d271932c8b5a1293a6b3199e1bdb MD5 | raw file
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 696UNIX 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, 750File kind as secondary. 751 752Unless kind is false, null truename shouldn't be interpreted as error or file 753absense." 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))))