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.
6 ;;;; This software is part of the SBCL system. See the README file for
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.
15 (in-package "SB!WIN32")
17 ;;; Alien definitions for commonly used Win32 types. Woe unto whoever
18 ;;; tries to untangle this someday for 64-bit Windows.
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)
25 (define-alien-type lispbool (boolean 32))
27 (define-alien-type system-string
28 #!-sb-unicode c-string
29 #!+sb-unicode (c-string :external-format :ucs-2))
31 (define-alien-type tchar #!-sb-unicode char
32 #!+sb-unicode (unsigned 16))
34 (defconstant default-environment-length 1024)
36 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
38 (defconstant invalid-handle -1)
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)
55 (defconstant file-flag-overlapped #x40000000)
56 (defconstant file-flag-sequential-scan #x8000000)
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)
65 (defconstant invalid-file-attributes (mod -1 (ash 1 32)))
67 ;;;; File Type Introspection by handle
68 (define-alien-routine ("GetFileType" get-file-type) dword
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)
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.
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.
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.
95 ;;; -- comment from AK's branch
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)
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
109 (define-alien-routine ("_close" real-crt-close) int
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
117 (bytes-to-read dword)
118 (bytes-read (* dword))
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
126 (bytes-to-write dword)
127 (bytes-written (* dword))
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
138 (bytes-read (* dword))
139 (bytes-avail (* dword))
140 (bytes-left-this-message (* dword)))
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
145 (define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool
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
157 (define-alien-routine ("socket_input_available" socket-input-available) int
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)))
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))
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)))
181 (return-from handle-listen (= res 1))))
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)))
189 (handle-listen handle)
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))
198 (unless (handle-listen handle)
200 (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
205 ;;; Clear all available input from a C runtime file handle.
206 (defun fd-clear-input (fd)
207 (let ((handle (get-osfhandle fd)))
209 (handle-clear-input handle))))
211 ;;;; System Functions
214 (define-alien-routine ("Sleep" millisleep) void
215 (milliseconds dword))
218 (defun sb!unix:nanosleep (sec nsec)
219 (let ((*allow-with-interrupts* *interrupts-enabled*))
221 (let ((timer (sb!impl::os-create-wtimer)))
222 (sb!impl::os-set-wtimer timer sec nsec)
224 (do () ((with-local-interrupts
225 (zerop (sb!impl::os-wait-for-wtimer timer)))))
226 (sb!impl::os-close-wtimer timer))))))
228 (define-alien-routine ("win32_wait_object_or_signal" wait-object-or-signal)
234 (defvar *ansi-codepage* nil)
235 (defvar *oem-codepage* nil)
236 (defvar *codepage-to-external-format* (make-hash-table)))
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)
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)
294 ;;10001 MAC - Japanese
295 ;;10002 MAC - Traditional Chinese (Big5)
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
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
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)
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)
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
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
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
382 ;;57006 ISCII Assamese
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)))
393 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
394 ;; the console just behave differently?
396 (declaim (ftype (function () keyword) ansi-codepage))
397 (defun ansi-codepage ()
399 (setq *ansi-codepage*
400 (gethash (alien-funcall (extern-alien "GetACP" (function UINT)))
401 *codepage-to-external-format*
404 (declaim (ftype (function () keyword) oem-codepage))
405 (defun oem-codepage ()
408 (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT)))
409 *codepage-to-external-format*
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 ()
416 (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT)))
417 *codepage-to-external-format*)
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 ()
424 (gethash (alien-funcall
425 (extern-alien "GetConsoleOutputCP" (function UINT)))
426 *codepage-to-external-format*)
429 (define-alien-routine ("LocalFree" local-free) void
432 (defmacro cast-and-free (value &key (type 'system-string)
433 (free-function 'free-alien))
434 `(prog1 (cast ,value ,type)
435 (,free-function ,value)))
437 (eval-when (:compile-toplevel :load-toplevel :execute)
438 (defmacro with-funcname ((name description) &body body)
440 ((,name (etypecase ,description
441 (string ,description)
442 (cons (destructuring-bind (s &optional c) ,description
444 (if c #!-sb-unicode "A" #!+sb-unicode "W" "")))))))
447 (defmacro make-system-buffer (x)
448 `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
450 (defmacro with-handle ((var initform
451 &key (close-operator 'close-handle))
455 (let ((,var ,initform))
457 (with-local-interrupts
459 (,close-operator ,var))))))
461 (define-alien-type pathname-buffer
462 (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0)))
464 (define-alien-type long-pathname-buffer
465 #!+sb-unicode (array char 65536)
466 #!-sb-unicode pathname-buffer)
468 (defmacro decode-system-string (alien)
469 `(cast (cast ,alien (* char)) system-string))
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.
475 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
476 (with-funcname (sname name)
478 (declare (optimize (sb!c::float-accuracy 0)))
479 (let ((result (alien-funcall
481 (function ,ret-type ,@arg-types))
483 (declare (ignorable result))
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)
492 (declare (optimize (sb!c::float-accuracy 0)))
493 (let ((result (alien-funcall
494 (extern-alien ,sname (function bool ,@arg-types))
497 (win32-error ,sname))
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)
506 (defmacro void-syscall* ((name &rest arg-types) &rest args)
507 `(syscall* (,name ,@arg-types) (values t 0) ,@args))
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"
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))))
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"
529 (format-system-message err-code))))
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)))))
538 (defun get-folder-pathname (csidl)
539 (parse-native-namestring (get-folder-namestring csidl)))
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)))))
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))))))
553 (defun sb!unix:unix-mkdir (name mode)
554 (declare (type sb!unix:unix-pathname name)
555 (type sb!unix:unix-file-mode mode)
557 (syscall (("CreateDirectory" t) lispbool system-string (* t))
558 (values result (if result 0 (get-last-error)))
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)))
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)
575 (setf aenv (make-system-buffer ret))
576 (alien-funcall afunc name aenv ret))
579 (free-alien aenv))))))
581 ;; GET-CURRENT-PROCESS
582 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
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)
589 ;;;; Process time information
591 (defconstant 100ns-per-internal-time-unit
592 (/ 10000000 sb!xc:internal-time-units-per-second))
595 ;; The FILETIME structure is a 64-bit value representing the number of
596 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
598 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
599 (define-alien-type FILETIME (sb!alien:unsigned 64))
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.
607 (define-alien-type FILETIME-MEMBER
608 (struct nil (low dword) (high dword)))
610 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
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))
619 (get-current-process)
620 (addr ,creation-time)
625 (declaim (inline system-internal-real-time))
628 (declare (unsigned-byte epoch))
629 ;; FIXME: For optimization ideas see the unix implementation.
630 (defun reinit-internal-real-time ()
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))
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))))
644 (define-alien-type hword (unsigned 16))
646 (define-alien-type systemtime
655 (millisecond hword)))
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))
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)
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))))
692 ;; Data for FindFirstFileExW and GetFileAttributesEx
693 (define-alien-type find-data
696 (ctime filetime-member)
697 (atime filetime-member)
698 (mtime filetime-member)
703 (long-name (array tchar #.max_path))
704 (short-name (array tchar 14))))
706 (define-alien-type file-attributes
709 (ctime filetime-member)
710 (atime filetime-member)
711 (mtime filetime-member)
715 (define-alien-routine ("FindClose" find-close) lispbool
718 (defun attribute-file-kind (dword)
719 (if (logtest file-attribute-directory dword)
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)
728 (- (floor (deref (cast (slot file-attributes 'mtime)
731 +common-lisp-epoch-filetime-seconds+))
732 native-namestring 0 file-attributes)))
734 (defun native-probe-file-name (native-namestring)
735 "Return truename \(using GetLongPathName\) as primary value,
736 File kind as secondary.
738 Unless kind is false, null truename shouldn't be interpreted as error or file
740 (with-alien ((file-attributes file-attributes)
741 (buffer long-pathname-buffer))
742 (syscall (("GetFileAttributesEx" t) lispbool
743 system-string int file-attributes)
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)
751 (slot file-attributes 'attributes))))
752 native-namestring 0 file-attributes)))
754 (defun native-delete-file (native-namestring)
755 (syscall (("DeleteFile" t) lispbool system-string)
756 result native-namestring))
758 (defun native-delete-directory (native-namestring)
759 (syscall (("RemoveDirectory" t) lispbool system-string)
760 result native-namestring))
762 (defun native-call-with-directory-iterator (function namestring errorp)
763 (declare (type (or null string) 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)
771 (win32-error "FindFirstFile")
777 :close-operator find-close)
779 (dx-flet ((one-iter ()
783 (let ((name (decode-system-string
784 (slot find-data 'long-name)))
785 (attributes (slot find-data 'attributes)))
787 (syscall (("FindNextFile" t) lispbool
788 handle find-data) result
790 (cond ((equal name ".") (go :next))
791 ((equal name "..") (go :next))
793 (return-from one-iter
797 (funcall function #'one-iter)))))))
800 ;; The SetEnvironmentVariable function sets the contents of the specified
801 ;; environment variable for the current process.
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))
807 (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
809 (void-syscall* (("SetEnvironmentVariable" t) system-string int-ptr)
812 ;; Let SETENV be an accessor for POSIX-GETENV.
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)
819 (posix-getenv name)))
821 (defmacro c-sizeof (s)
822 "translate alien size (in bits) to c-size (in bytes)"
823 `(/ (alien-size ,s) 8))
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.
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)
839 (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
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))
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.
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))
868 (setf aname (make-system-buffer length))
869 (alien-funcall afunc aname (addr length))))
870 (cast-and-free aname))))
872 (define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
875 (new-position long-long :out)
878 (defun lseeki64 (handle offset whence)
879 (multiple-value-bind (moved to-place)
880 (set-file-pointer-ex handle offset whence)
883 (values -1 (get-last-error)))))
885 ;; File mapping support routines
886 (define-alien-routine (#!+sb-unicode "CreateFileMappingW"
887 #!-sb-unicode "CreateFileMappingA"
891 (security-attributes (* t))
893 (maximum-size-high dword)
894 (maximum-size-low dword)
895 (name system-string))
897 (define-alien-routine ("MapViewOfFile" map-view-of-file)
899 (file-mapping handle)
900 (desired-access dword)
905 (define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
908 (define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
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)
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)
928 (defconstant file-share-delete #x04)
929 (defconstant file-share-read #x01)
930 (defconstant file-share-write #x02)
932 ;; CreateFile (the real file-opening workhorse).
933 (define-alien-routine (#!+sb-unicode "CreateFileW"
934 #!-sb-unicode "CreateFileA"
937 (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
938 (desired-access dword)
940 (security-attributes (* t))
941 (creation-disposition dword)
942 (flags-and-attributes dword)
943 (template-file handle))
945 ;; GetFileSizeEx doesn't work with block devices :[
946 (define-alien-routine ("GetFileSizeEx" get-file-size-ex)
948 (handle handle) (file-size (signed 64) :in-out))
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"
956 (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
958 (define-alien-routine ("CloseHandle" close-handle) bool
961 (define-alien-routine ("_open_osfhandle" real-open-osfhandle)
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.
970 (defun unixlike-open (path flags mode &optional revertable)
971 (declare (type sb!unix:unix-pathname path)
973 (type sb!unix:unix-file-mode mode)
975 (let* ((disposition-flags
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)))
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))))
993 (if revertable #x10000 0)
994 (if (plusp (logand sb!unix:o_append flags))
995 access-file-append-data
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
1007 file-attribute-normal
1008 file-flag-overlapped
1009 file-flag-sequential-scan)
1011 (if (eql handle invalid-handle)
1013 (let ((error-code (get-last-error)))
1015 (#.error_file_not_found
1017 ((#.error_already_exists #.error_file_exists)
1019 (otherwise error-code))))
1021 ;; FIXME: seeking to the end is not enough for real APPEND
1022 ;; semantics, but it's better than nothing.
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
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
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?
1044 (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
1045 (values handle 0))))))
1047 (define-alien-routine ("closesocket" close-socket) int (handle handle))
1048 (define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
1051 (define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
1052 (from-process handle)
1053 (from-handle handle)
1055 (to-handle handle :out)
1060 (defconstant +handle-flag-inherit+ 1)
1061 (defconstant +handle-flag-protect-from-close+ 2)
1063 (define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
1068 (define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
1072 (define-alien-routine getsockopt int
1076 (dataword int-ptr :in-out)
1077 (socklen int :in-out))
1079 (defconstant sol_socket #xFFFF)
1080 (defconstant so_type #x1008)
1082 (defun socket-handle-p (handle)
1083 (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
1085 (defconstant ebadf 9)
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).
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...
1095 (defun unixlike-close (fd)
1096 (if (or (zerop (close-socket fd))
1098 t (values nil ebadf)))
1100 (defconstant +std-input-handle+ -10)
1101 (defconstant +std-output-handle+ -11)
1102 (defconstant +std-error-handle+ -12)
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))
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+)))
1117 (defconstant +duplicate-same-access+ 2)
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+)
1125 (prog1 handle (real-crt-close fd))
1126 (win32-error 'duplicate-and-unwrap-fd)))))
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))
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))))
1140 (defun windows-isatty (handle)
1141 (if (= file-type-char (get-file-type handle))
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))))
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))
1155 (win32-error '(setf inheritable-handle-p))))
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+)
1163 (values nil (get-last-error))))))
1165 (defun call-with-crt-fd (thunk handle &optional (flags 0))
1166 (multiple-value-bind (duplicate errno)
1167 (sb!unix:unix-dup handle)
1169 (let ((fd (real-open-osfhandle duplicate flags)))
1170 (unwind-protect (funcall thunk fd)
1171 (real-crt-close fd)))
1172 (values nil errno))))
1176 (define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool
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)
1190 (define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool
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))
1199 (return-from crypt-gen-random (values nil (get-last-error))))
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))
1205 (values nil (get-last-error)))))
1206 (unless (%crypt-release-context context 0)
1207 (win32-error '%crypt-release-context)))))