X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=9c5cc97922e4123fdca85db10ef08298199ad60f;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=e4152a8ce5a1b5885f8e47c411ea25b3cac73d16;hpb=568daf6b160280428701670b921f419aabd9eba0;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index e4152a8..9c5cc97 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -16,13 +16,20 @@ ;;; Alien definitions for commonly used Win32 types. Woe unto whoever ;;; tries to untangle this someday for 64-bit Windows. -(define-alien-type int-ptr long) +;;; +;;; FIXME: There used to be many more here, which are now groveled, +;;; but groveling HANDLE makes it unsigned, which currently breaks the +;;; build. --NS 2006-06-18 (define-alien-type handle int-ptr) -(define-alien-type dword unsigned-long) -(define-alien-type bool int) -(define-alien-type UINT unsigned-int) -(define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16) - #!-sb-unicode char) + +(define-alien-type lispbool (boolean 32)) + +(define-alien-type system-string + #!-sb-unicode c-string + #!+sb-unicode (c-string :external-format :ucs-2)) + +(define-alien-type tchar #!-sb-unicode char + #!+sb-unicode (unsigned 16)) (defconstant default-environment-length 1024) @@ -30,11 +37,42 @@ ;;; to a pointer. (defconstant invalid-handle -1) +(defconstant file-attribute-readonly #x1) +(defconstant file-attribute-hidden #x2) +(defconstant file-attribute-system #x4) +(defconstant file-attribute-directory #x10) +(defconstant file-attribute-archive #x20) +(defconstant file-attribute-device #x40) +(defconstant file-attribute-normal #x80) +(defconstant file-attribute-temporary #x100) +(defconstant file-attribute-sparse #x200) +(defconstant file-attribute-reparse-point #x400) +(defconstant file-attribute-reparse-compressed #x800) +(defconstant file-attribute-reparse-offline #x1000) +(defconstant file-attribute-not-content-indexed #x2000) +(defconstant file-attribute-encrypted #x4000) + +(defconstant file-flag-overlapped #x40000000) +(defconstant file-flag-sequential-scan #x8000000) + +;; Possible results of GetFileType. +(defconstant file-type-disk 1) +(defconstant file-type-char 2) +(defconstant file-type-pipe 3) +(defconstant file-type-remote 4) +(defconstant file-type-unknown 0) + +(defconstant invalid-file-attributes (mod -1 (ash 1 32))) + +;;;; File Type Introspection by handle +(define-alien-routine ("GetFileType" get-file-type) dword + (handle handle)) + ;;;; Error Handling ;;; Retrieve the calling thread's last-error code value. The ;;; last-error code is maintained on a per-thread basis. -(define-alien-routine ("GetLastError@0" get-last-error) dword) +(define-alien-routine ("GetLastError" get-last-error) dword) ;;; Flag constants for FORMAT-MESSAGE. (defconstant format-message-from-system #x1000) @@ -42,7 +80,7 @@ ;;; Format an error message based on a lookup table. See MSDN for the ;;; full meaning of the all options---most are not used when getting ;;; system error codes. -(define-alien-routine ("FormatMessageA@28" format-message) dword +(define-alien-routine ("FormatMessageA" format-message) dword (flags dword) (source (* t)) (message-id dword) @@ -53,14 +91,42 @@ ;;;; File Handles +;;; Historically, SBCL on Windows used CRT (lowio) file descriptors, +;;; unlike other Lisps. They really help to minimize required effort +;;; for porting Unix-specific software, at least to the level that it +;;; mostly works most of the time. +;;; +;;; Alastair Bridgewater recommended to switch away from CRT +;;; descriptors, and Anton Kovalenko thinks it's the time to heed his +;;; advice. I see that SBCL for Windows needs much more effort in the +;;; area of OS IO abstractions and the like; using or leaving lowio +;;; FDs doesn't change the big picture so much. +;;; +;;; Lowio layer, in exchange for `semi-automatic almost-portability', +;;; brings some significant problems, which a grown-up cross-platform +;;; CL implementation shouldn't have. Therefore, as its benefits +;;; become negligible, it's a good reason to throw it away. +;;; +;;; -- comment from AK's branch + +;;; For a few more releases, let's preserve old functions (now +;;; implemented as identity) for user code which might have had to peek +;;; into our internals in past versions when we hadn't been using +;;; handles yet. -- DFL, 2012 +(defun get-osfhandle (fd) fd) +(defun open-osfhandle (handle flags) (declare (ignore flags)) handle) + ;;; Get the operating system handle for a C file descriptor. Returns ;;; INVALID-HANDLE on failure. -(define-alien-routine ("_get_osfhandle" get-osfhandle) handle +(define-alien-routine ("_get_osfhandle" real-get-osfhandle) handle + (fd int)) + +(define-alien-routine ("_close" real-crt-close) int (fd int)) ;;; Read data from a file handle into a buffer. This may be used ;;; synchronously or with "overlapped" (asynchronous) I/O. -(define-alien-routine ("ReadFile@20" read-file) bool +(define-alien-routine ("ReadFile" read-file) bool (file handle) (buffer (* t)) (bytes-to-read dword) @@ -69,7 +135,7 @@ ;;; Write data from a buffer to a file handle. This may be used ;;; synchronously or with "overlapped" (asynchronous) I/O. -(define-alien-routine ("WriteFile@20" write-file) bool +(define-alien-routine ("WriteFile" write-file) bool (file handle) (buffer (* t)) (bytes-to-write dword) @@ -80,7 +146,7 @@ ;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read. ;;; Return TRUE on success, FALSE on failure. -(define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool +(define-alien-routine ("PeekNamedPipe" peek-named-pipe) bool (pipe handle) (buffer (* t)) (buffer-size dword) @@ -91,18 +157,21 @@ ;;; Flush the console input buffer if HANDLE is a console handle. ;;; Returns true on success, false if the handle does not refer to a ;;; console. -(define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool +(define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool (handle handle)) ;;; Read data from the console input buffer without removing it, ;;; without blocking. Buffer should be large enough for LENGTH * ;;; INPUT-RECORD-SIZE bytes. -(define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool +(define-alien-routine ("PeekConsoleInputA" peek-console-input) bool (handle handle) (buffer (* t)) (length dword) (nevents (* dword))) +(define-alien-routine ("socket_input_available" socket-input-available) int + (socket handle)) + ;;; Listen for input on a Windows file handle. Unlike UNIX, there ;;; isn't a unified interface to do this---we have to know what sort ;;; of handle we have. Of course, there's no way to actually @@ -112,14 +181,19 @@ (defun handle-listen (handle) (with-alien ((avail dword) (buf (array char #.input-record-size))) + (when + ;; Make use of the fact that console handles are technically no + ;; real handles, and unlike those, have these bits set: + (= 3 (logand 3 handle)) + (return-from handle-listen + (alien-funcall (extern-alien "win32_tty_listen" + (function boolean handle)) + handle))) (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil)) (return-from handle-listen (plusp avail))) - - (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail))) - (return-from handle-listen (plusp avail))) - - ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case - ;; HANDLE is a socket. + (let ((res (socket-input-available handle))) + (unless (zerop res) + (return-from handle-listen (= res 1)))) t)) ;;; Listen for input on a C runtime file handle. Returns true if @@ -151,326 +225,997 @@ ;;;; System Functions -;;; Sleep for MILLISECONDS milliseconds. -(define-alien-routine ("Sleep@4" millisleep) void +#!-sb-thread +(define-alien-routine ("Sleep" millisleep) void (milliseconds dword)) -#!+sb-unicode (defvar *ANSI-CODEPAGE* nil) -#!+sb-unicode (defvar *OEM-CODEPAGE* nil) +#!+sb-thread +(defun sb!unix:nanosleep (sec nsec) + (let ((*allow-with-interrupts* *interrupts-enabled*)) + (without-interrupts + (let ((timer (sb!impl::os-create-wtimer))) + (sb!impl::os-set-wtimer timer sec nsec) + (unwind-protect + (do () ((with-local-interrupts + (zerop (sb!impl::os-wait-for-wtimer timer))))) + (sb!impl::os-close-wtimer timer)))))) + +(define-alien-routine ("win32_wait_object_or_signal" wait-object-or-signal) + (signed 16) + (handle handle)) #!+sb-unicode -(defparameter *codepage-to-external-format* (make-hash-table)) +(progn + (defvar *ansi-codepage* nil) + (defvar *oem-codepage* nil) + (defvar *codepage-to-external-format* (make-hash-table))) #!+sb-unicode -(dolist (cp - '(;;037 IBM EBCDIC - U.S./Canada - (437 :CP437) ;; OEM - United States - ;;500 IBM EBCDIC - International - ;;708 Arabic - ASMO 708 - ;;709 Arabic - ASMO 449+, BCON V4 - ;;710 Arabic - Transparent Arabic - ;;720 Arabic - Transparent ASMO - ;;737 OEM - Greek (formerly 437G) - ;;775 OEM - Baltic - (850 :CP850) ;; OEM - Multilingual Latin I - (852 :CP852) ;; OEM - Latin II - (855 :CP855) ;; OEM - Cyrillic (primarily Russian) - (857 :CP857) ;; OEM - Turkish - ;;858 OEM - Multilingual Latin I + Euro symbol - (860 :CP860) ;; OEM - Portuguese - (861 :CP861) ;; OEM - Icelandic - (862 :CP862) ;; OEM - Hebrew - (863 :CP863) ;; OEM - Canadian-French - (864 :CP864) ;; OEM - Arabic - (865 :CP865) ;; OEM - Nordic - (866 :CP866) ;; OEM - Russian - (869 :CP869) ;; OEM - Modern Greek - ;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2) - (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15) - ;;875 IBM EBCDIC - Modern Greek - ;;932 ANSI/OEM - Japanese, Shift-JIS - ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore) - ;;949 ANSI/OEM - Korean (Unified Hangul Code) - ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC) - ;;1026 IBM EBCDIC - Turkish (Latin-5) - ;;1047 IBM EBCDIC - Latin 1/Open System - ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol) - ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol) - ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol) - ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol) - ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol) - ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol) - ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol) - ;;1147 IBM EBCDIC - France (20297 + Euro symbol) - ;;1148 IBM EBCDIC - International (500 + Euro symbol) - ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol) - ;;1200 Unicode UCS-2 Little-Endian (BMP of ISO 10646) - ;;1201 Unicode UCS-2 Big-Endian - (1250 :CP1250) ;; ANSI - Central European - (1251 :CP1251) ;; ANSI - Cyrillic - (1252 :CP1252) ;; ANSI - Latin I - (1253 :CP1253) ;; ANSI - Greek - (1254 :CP1254) ;; ANSI - Turkish - (1255 :CP1255) ;; ANSI - Hebrew - (1256 :CP1256) ;; ANSI - Arabic - (1257 :CP1257) ;; ANSI - Baltic - (1258 :CP1258) ;; ANSI/OEM - Vietnamese - ;;1361 Korean (Johab) - ;;10000 MAC - Roman - ;;10001 MAC - Japanese - ;;10002 MAC - Traditional Chinese (Big5) - ;;10003 MAC - Korean - ;;10004 MAC - Arabic - ;;10005 MAC - Hebrew - ;;10006 MAC - Greek I - (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic - ;;10008 MAC - Simplified Chinese (GB 2312) - ;;10010 MAC - Romania - ;;10017 MAC - Ukraine - ;;10021 MAC - Thai - ;;10029 MAC - Latin II - ;;10079 MAC - Icelandic - ;;10081 MAC - Turkish - ;;10082 MAC - Croatia - ;;12000 Unicode UCS-4 Little-Endian - ;;12001 Unicode UCS-4 Big-Endian - ;;20000 CNS - Taiwan - ;;20001 TCA - Taiwan - ;;20002 Eten - Taiwan - ;;20003 IBM5550 - Taiwan - ;;20004 TeleText - Taiwan - ;;20005 Wang - Taiwan - ;;20105 IA5 IRV International Alphabet No. 5 (7-bit) - ;;20106 IA5 German (7-bit) - ;;20107 IA5 Swedish (7-bit) - ;;20108 IA5 Norwegian (7-bit) - ;;20127 US-ASCII (7-bit) - ;;20261 T.61 - ;;20269 ISO 6937 Non-Spacing Accent - ;;20273 IBM EBCDIC - Germany - ;;20277 IBM EBCDIC - Denmark/Norway - ;;20278 IBM EBCDIC - Finland/Sweden - ;;20280 IBM EBCDIC - Italy - ;;20284 IBM EBCDIC - Latin America/Spain - ;;20285 IBM EBCDIC - United Kingdom - ;;20290 IBM EBCDIC - Japanese Katakana Extended - ;;20297 IBM EBCDIC - France - ;;20420 IBM EBCDIC - Arabic - ;;20423 IBM EBCDIC - Greek - ;;20424 IBM EBCDIC - Hebrew - ;;20833 IBM EBCDIC - Korean Extended - ;;20838 IBM EBCDIC - Thai - (20866 :KOI8-R) ;; Russian - KOI8-R - ;;20871 IBM EBCDIC - Icelandic - ;;20880 IBM EBCDIC - Cyrillic (Russian) - ;;20905 IBM EBCDIC - Turkish - ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol) - ;;20932 JIS X 0208-1990 & 0121-1990 - ;;20936 Simplified Chinese (GB2312) - ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian) - ;;21027 (deprecated) - (21866 :KOI8-U) ;; Ukrainian (KOI8-U) - (28591 :LATIN-1) ;; ISO 8859-1 Latin I - (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe - (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3 - (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic - (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic - (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic - (28597 :ISO-8859-7) ;; ISO 8859-7 Greek - (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew - (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5 - (28605 :LATIN-9) ;; ISO 8859-15 Latin 9 - ;;29001 Europa 3 - (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew - ;;50220 ISO 2022 Japanese with no halfwidth Katakana - ;;50221 ISO 2022 Japanese with halfwidth Katakana - ;;50222 ISO 2022 Japanese JIS X 0201-1989 - ;;50225 ISO 2022 Korean - ;;50227 ISO 2022 Simplified Chinese - ;;50229 ISO 2022 Traditional Chinese - ;;50930 Japanese (Katakana) Extended - ;;50931 US/Canada and Japanese - ;;50933 Korean Extended and Korean - ;;50935 Simplified Chinese Extended and Simplified Chinese - ;;50936 Simplified Chinese - ;;50937 US/Canada and Traditional Chinese - ;;50939 Japanese (Latin) Extended and Japanese - (51932 :EUC-JP) ;; EUC - Japanese - ;;51936 EUC - Simplified Chinese - ;;51949 EUC - Korean - ;;51950 EUC - Traditional Chinese - ;;52936 HZ-GB2312 Simplified Chinese - ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte) - ;;57002 ISCII Devanagari - ;;57003 ISCII Bengali - ;;57004 ISCII Tamil - ;;57005 ISCII Telugu - ;;57006 ISCII Assamese - ;;57007 ISCII Oriya - ;;57008 ISCII Kannada - ;;57009 ISCII Malayalam - ;;57010 ISCII Gujarati - ;;57011 ISCII Punjabi - ;;65000 Unicode UTF-7 - (65001 :UTF8))) ;; Unicode UTF-8 +(dolist + (cp '(;;037 IBM EBCDIC - U.S./Canada + (437 :CP437) ;; OEM - United States + ;;500 IBM EBCDIC - International + ;;708 Arabic - ASMO 708 + ;;709 Arabic - ASMO 449+, BCON V4 + ;;710 Arabic - Transparent Arabic + ;;720 Arabic - Transparent ASMO + ;;737 OEM - Greek (formerly 437G) + ;;775 OEM - Baltic + (850 :CP850) ;; OEM - Multilingual Latin I + (852 :CP852) ;; OEM - Latin II + (855 :CP855) ;; OEM - Cyrillic (primarily Russian) + (857 :CP857) ;; OEM - Turkish + ;;858 OEM - Multilingual Latin I + Euro symbol + (860 :CP860) ;; OEM - Portuguese + (861 :CP861) ;; OEM - Icelandic + (862 :CP862) ;; OEM - Hebrew + (863 :CP863) ;; OEM - Canadian-French + (864 :CP864) ;; OEM - Arabic + (865 :CP865) ;; OEM - Nordic + (866 :CP866) ;; OEM - Russian + (869 :CP869) ;; OEM - Modern Greek + ;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2) + (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15) + ;;875 IBM EBCDIC - Modern Greek + (932 :CP932) ;; ANSI/OEM - Japanese, Shift-JIS + ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore) + ;;949 ANSI/OEM - Korean (Unified Hangul Code) + ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC) + ;;1026 IBM EBCDIC - Turkish (Latin-5) + ;;1047 IBM EBCDIC - Latin 1/Open System + ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol) + ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol) + ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol) + ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol) + ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol) + ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol) + ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol) + ;;1147 IBM EBCDIC - France (20297 + Euro symbol) + ;;1148 IBM EBCDIC - International (500 + Euro symbol) + ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol) + (1200 :UCS-2LE) ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646) + (1201 :UCS-2BE) ;; Unicode UCS-2 Big-Endian + (1250 :CP1250) ;; ANSI - Central European + (1251 :CP1251) ;; ANSI - Cyrillic + (1252 :CP1252) ;; ANSI - Latin I + (1253 :CP1253) ;; ANSI - Greek + (1254 :CP1254) ;; ANSI - Turkish + (1255 :CP1255) ;; ANSI - Hebrew + (1256 :CP1256) ;; ANSI - Arabic + (1257 :CP1257) ;; ANSI - Baltic + (1258 :CP1258) ;; ANSI/OEM - Vietnamese + ;;1361 Korean (Johab) + ;;10000 MAC - Roman + ;;10001 MAC - Japanese + ;;10002 MAC - Traditional Chinese (Big5) + ;;10003 MAC - Korean + ;;10004 MAC - Arabic + ;;10005 MAC - Hebrew + ;;10006 MAC - Greek I + (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic + ;;10008 MAC - Simplified Chinese (GB 2312) + ;;10010 MAC - Romania + ;;10017 MAC - Ukraine + ;;10021 MAC - Thai + ;;10029 MAC - Latin II + ;;10079 MAC - Icelandic + ;;10081 MAC - Turkish + ;;10082 MAC - Croatia + ;;12000 Unicode UCS-4 Little-Endian + ;;12001 Unicode UCS-4 Big-Endian + ;;20000 CNS - Taiwan + ;;20001 TCA - Taiwan + ;;20002 Eten - Taiwan + ;;20003 IBM5550 - Taiwan + ;;20004 TeleText - Taiwan + ;;20005 Wang - Taiwan + ;;20105 IA5 IRV International Alphabet No. 5 (7-bit) + ;;20106 IA5 German (7-bit) + ;;20107 IA5 Swedish (7-bit) + ;;20108 IA5 Norwegian (7-bit) + ;;20127 US-ASCII (7-bit) + ;;20261 T.61 + ;;20269 ISO 6937 Non-Spacing Accent + ;;20273 IBM EBCDIC - Germany + ;;20277 IBM EBCDIC - Denmark/Norway + ;;20278 IBM EBCDIC - Finland/Sweden + ;;20280 IBM EBCDIC - Italy + ;;20284 IBM EBCDIC - Latin America/Spain + ;;20285 IBM EBCDIC - United Kingdom + ;;20290 IBM EBCDIC - Japanese Katakana Extended + ;;20297 IBM EBCDIC - France + ;;20420 IBM EBCDIC - Arabic + ;;20423 IBM EBCDIC - Greek + ;;20424 IBM EBCDIC - Hebrew + ;;20833 IBM EBCDIC - Korean Extended + ;;20838 IBM EBCDIC - Thai + (20866 :KOI8-R) ;; Russian - KOI8-R + ;;20871 IBM EBCDIC - Icelandic + ;;20880 IBM EBCDIC - Cyrillic (Russian) + ;;20905 IBM EBCDIC - Turkish + ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol) + ;;20932 JIS X 0208-1990 & 0121-1990 + ;;20936 Simplified Chinese (GB2312) + ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian) + ;;21027 (deprecated) + (21866 :KOI8-U) ;; Ukrainian (KOI8-U) + (28591 :LATIN-1) ;; ISO 8859-1 Latin I + (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe + (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3 + (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic + (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic + (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic + (28597 :ISO-8859-7) ;; ISO 8859-7 Greek + (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew + (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5 + (28605 :LATIN-9) ;; ISO 8859-15 Latin 9 + ;;29001 Europa 3 + (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew + ;;50220 ISO 2022 Japanese with no halfwidth Katakana + ;;50221 ISO 2022 Japanese with halfwidth Katakana + ;;50222 ISO 2022 Japanese JIS X 0201-1989 + ;;50225 ISO 2022 Korean + ;;50227 ISO 2022 Simplified Chinese + ;;50229 ISO 2022 Traditional Chinese + ;;50930 Japanese (Katakana) Extended + ;;50931 US/Canada and Japanese + ;;50933 Korean Extended and Korean + ;;50935 Simplified Chinese Extended and Simplified Chinese + ;;50936 Simplified Chinese + ;;50937 US/Canada and Traditional Chinese + ;;50939 Japanese (Latin) Extended and Japanese + (51932 :EUC-JP) ;; EUC - Japanese + ;;51936 EUC - Simplified Chinese + ;;51949 EUC - Korean + ;;51950 EUC - Traditional Chinese + ;;52936 HZ-GB2312 Simplified Chinese + ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte) + ;;57002 ISCII Devanagari + ;;57003 ISCII Bengali + ;;57004 ISCII Tamil + ;;57005 ISCII Telugu + ;;57006 ISCII Assamese + ;;57007 ISCII Oriya + ;;57008 ISCII Kannada + ;;57009 ISCII Malayalam + ;;57010 ISCII Gujarati + ;;57011 ISCII Punjabi + ;;65000 Unicode UTF-7 + (65001 :UTF8))) ;; Unicode UTF-8 (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp))) #!+sb-unicode -(declaim (ftype (function () keyword) ansi-codepage)) -#!+sb-unicode -(defun ansi-codepage () - (or *ANSI-CODEPAGE* - (setq *ANSI-CODEPAGE* - (or - (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT))) - *codepage-to-external-format*) - :LATIN-1)))) +;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas +;; the console just behave differently? +(progn + (declaim (ftype (function () keyword) ansi-codepage)) + (defun ansi-codepage () + (or *ansi-codepage* + (setq *ansi-codepage* + (gethash (alien-funcall (extern-alien "GetACP" (function UINT))) + *codepage-to-external-format* + :latin-1)))) -#!+sb-unicode -(declaim (ftype (function () keyword) oem-codepage)) -#!+sb-unicode -(defun oem-codepage () - (or *OEM-CODEPAGE* - (setq *OEM-CODEPAGE* - (or - (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT))) - *codepage-to-external-format*) - :LATIN-1)))) + (declaim (ftype (function () keyword) oem-codepage)) + (defun oem-codepage () + (or *oem-codepage* + (setq *oem-codepage* + (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT))) + *codepage-to-external-format* + :latin-1))))) ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp (declaim (ftype (function () keyword) console-input-codepage)) (defun console-input-codepage () (or #!+sb-unicode - (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT))) + (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT))) *codepage-to-external-format*) - :LATIN-1)) + :latin-1)) ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp (declaim (ftype (function () keyword) console-output-codepage)) (defun console-output-codepage () (or #!+sb-unicode - (gethash (alien-funcall (extern-alien "GetConsoleOutputCP@0" (function UINT))) + (gethash (alien-funcall + (extern-alien "GetConsoleOutputCP" (function UINT))) *codepage-to-external-format*) - :LATIN-1)) - -;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string -;;;; :external-format :ucs2), except that we do not have an -;;;; implementation of ucs2 yet. -(defmacro ucs2->string (astr &optional size) - #!-sb-unicode - (declare (ignore size)) - #!-sb-unicode - `(cast ,astr c-string) - #!+sb-unicode - (let ((str-len (or size `(do ((i 0 (1+ i))) ((zerop (deref ,astr i)) i))))) - `(let* ((l ,str-len) - (s (make-string l))) - (dotimes (i l) (setf (aref s i) (code-char (deref ,astr i)))) - s))) - -(defmacro ucs2->string&free (astr &optional size) - `(prog1 (ucs2->string ,astr ,size) (free-alien ,astr))) - -(define-alien-routine ("LocalFree@4" local-free) void + :latin-1)) + +(define-alien-routine ("LocalFree" local-free) void (lptr (* t))) +(defmacro cast-and-free (value &key (type 'system-string) + (free-function 'free-alien)) + `(prog1 (cast ,value ,type) + (,free-function ,value))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defmacro with-funcname ((name description) &body body) + `(let + ((,name (etypecase ,description + (string ,description) + (cons (destructuring-bind (s &optional c) ,description + (format nil "~A~A" s + (if c #!-sb-unicode "A" #!+sb-unicode "W" ""))))))) + ,@body))) + +(defmacro make-system-buffer (x) + `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x)) + +(defmacro with-handle ((var initform + &key (close-operator 'close-handle)) + &body body) + `(without-interrupts + (block nil + (let ((,var ,initform)) + (unwind-protect + (with-local-interrupts + ,@body) + (,close-operator ,var)))))) + +(define-alien-type pathname-buffer + (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0))) + +(define-alien-type long-pathname-buffer + #!+sb-unicode (array char 65536) + #!-sb-unicode pathname-buffer) + +(defmacro decode-system-string (alien) + `(cast (cast ,alien (* char)) system-string)) + +;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other +;;; macros in this file, are only used in this file, and could be +;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. + +(defmacro syscall ((name ret-type &rest arg-types) success-form &rest args) + (with-funcname (sname name) + `(locally + (declare (optimize (sb!c::float-accuracy 0))) + (let ((result (alien-funcall + (extern-alien ,sname + (function ,ret-type ,@arg-types)) + ,@args))) + (declare (ignorable result)) + ,success-form)))) + +;;; This is like SYSCALL, but if it fails, signal an error instead of +;;; returning error codes. Should only be used for syscalls that will +;;; never really get an error. +(defmacro syscall* ((name &rest arg-types) success-form &rest args) + (with-funcname (sname name) + `(locally + (declare (optimize (sb!c::float-accuracy 0))) + (let ((result (alien-funcall + (extern-alien ,sname (function bool ,@arg-types)) + ,@args))) + (when (zerop result) + (win32-error ,sname)) + ,success-form)))) + +(defmacro with-sysfun ((func name ret-type &rest arg-types) &body body) + (with-funcname (sname name) + `(with-alien ((,func (function ,ret-type ,@arg-types) + :extern ,sname)) + ,@body))) + +(defmacro void-syscall* ((name &rest arg-types) &rest args) + `(syscall* (,name ,@arg-types) (values t 0) ,@args)) + (defun get-last-error-message (err) "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp" - (with-alien ((amsg (* tchar))) - (let ((nchars - (alien-funcall - (extern-alien #!+sb-unicode "FormatMessageW@28" - #!-sb-unicode "FormatMessageA@28" - (function dword - dword dword dword dword (* (* tchar)) dword dword)) - (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM) - 0 err 0 (addr amsg) 0 0))) - (prog1 (ucs2->string amsg nchars) - (local-free amsg))))) - -(defmacro win32-error (func-name) - `(let ((err-code (sb!win32::get-last-error))) + (let ((message + (with-alien ((amsg (* char))) + (syscall (("FormatMessage" t) + dword dword dword dword dword (* (* char)) dword dword) + (cast-and-free amsg :free-function local-free) + (logior FORMAT_MESSAGE_ALLOCATE_BUFFER + FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_MAX_WIDTH_MASK) + 0 err 0 (addr amsg) 0 0)))) + (and message (string-right-trim '(#\Space) message)))) + +(defmacro win32-error (func-name &optional err) + `(let ((err-code ,(or err `(get-last-error)))) + (declare (type (unsigned-byte 32) err-code)) (error "~%Win32 Error [~A] - ~A~%~A" ,func-name err-code - (sb!win32::get-last-error-message err-code)))) + (get-last-error-message err-code)))) -(defun get-folder-path (CSIDL) +(defun get-folder-namestring (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" - (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH)))) - (alien-funcall - (extern-alien #!-sb-unicode "SHGetFolderPathA@20" - #!+sb-unicode "SHGetFolderPathW@20" - (function int handle int handle dword (* tchar))) - 0 CSIDL 0 0 apath) - (concatenate 'string (ucs2->string&free apath) "\\"))) + (with-alien ((apath pathname-buffer)) + (syscall (("SHGetFolderPath" t) int handle int handle dword (* char)) + (concatenate 'string (decode-system-string apath) "\\") + 0 csidl 0 0 (cast apath (* char))))) + +(defun get-folder-pathname (csidl) + (parse-native-namestring (get-folder-namestring csidl))) (defun sb!unix:posix-getcwd () - (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH))) - (afunc (function dword dword (* tchar)) - :extern #!-sb-unicode "GetCurrentDirectoryA@8" - #!+sb-unicode "GetCurrentDirectoryW@8")) - (let ((ret (alien-funcall afunc (1+ MAX_PATH) apath))) - (when (zerop ret) - (win32-error "GetCurrentDirectory")) - (when (> ret (1+ MAX_PATH)) - (free-alien apath) - (setf apath (make-alien tchar ret)) - (alien-funcall afunc ret apath)) - (ucs2->string&free apath ret)))) + (with-alien ((apath pathname-buffer)) + (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char)) + (let ((ret (alien-funcall afunc (1+ max_path) (cast apath (* char))))) + (when (zerop ret) + (win32-error "GetCurrentDirectory")) + (if (> ret (1+ max_path)) + (with-alien ((apath (* char) (make-system-buffer ret))) + (alien-funcall afunc ret apath) + (cast-and-free apath)) + (decode-system-string apath)))))) (defun sb!unix:unix-mkdir (name mode) (declare (type sb!unix:unix-pathname name) (type sb!unix:unix-file-mode mode) (ignore mode)) - (let ((name-length (length name))) - (with-alien ((apath (* tchar) (make-alien tchar (1+ name-length)))) - (dotimes (i name-length) (setf (deref apath i) (char-code (aref name i)))) - (setf (deref apath name-length) 0) - (when - (zerop (alien-funcall - (extern-alien #!-sb-unicode "CreateDirectoryA@8" - #!+sb-unicode "CreateDirectoryW@8" - (function bool (* tchar) dword)) - apath 0)) - (win32-error "CreateDirectory")) - (values t 0)))) + (syscall (("CreateDirectory" t) lispbool system-string (* t)) + (values result (if result 0 (- (get-last-error)))) + name nil)) (defun sb!unix:unix-rename (name1 name2) (declare (type sb!unix:unix-pathname name1 name2)) - (let ((name-length1 (length name1)) - (name-length2 (length name2))) - (with-alien ((apath1 (* tchar) (make-alien tchar (1+ name-length1))) - (apath2 (* tchar) (make-alien tchar (1+ name-length2)))) - (dotimes (i name-length1) (setf (deref apath1 i) (char-code (aref name1 i)))) - (setf (deref apath1 name-length1) 0) - (dotimes (i name-length2) (setf (deref apath2 i) (char-code (aref name2 i)))) - (setf (deref apath2 name-length2) 0) - (when - (zerop (alien-funcall - (extern-alien #!-sb-unicode "MoveFileA@8" - #!+sb-unicode "MoveFileW@8" - (function bool (* tchar) (* tchar))) - apath1 apath2)) - (win32-error "MoveFile")) - (values t 0)))) - + (syscall (("MoveFile" t) lispbool system-string system-string) + (values result (if result 0 (- (get-last-error)))) + name1 name2)) (defun sb!unix::posix-getenv (name) (declare (type simple-string name)) - (let ((name-length (length name))) - (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length))) - (aenv (* tchar) (make-alien tchar default-environment-length)) - (afunc (function dword (* tchar) (* tchar) dword) - :extern #!-sb-unicode "GetEnvironmentVariableA@12" - #!+sb-unicode "GetEnvironmentVariableW@12")) - (dotimes (i name-length) (setf (deref aname i) (char-code (aref name i)))) - (setf (deref aname name-length) 0) - (let ((ret (alien-funcall afunc aname aenv default-environment-length))) - (when (> ret default-environment-length) - (free-alien aenv) - (setf aenv (make-alien tchar ret)) - (alien-funcall afunc aname aenv ret)) - (if (> ret 0) - (ucs2->string&free aenv ret) - nil))))) + (with-alien ((aenv (* char) (make-system-buffer default-environment-length))) + (with-sysfun (afunc ("GetEnvironmentVariable" t) + dword system-string (* char) dword) + (let ((ret (alien-funcall afunc name aenv default-environment-length))) + (when (> ret default-environment-length) + (free-alien aenv) + (setf aenv (make-system-buffer ret)) + (alien-funcall afunc name aenv ret)) + (if (> ret 0) + (cast-and-free aenv) + (free-alien aenv)))))) + +;; GET-CURRENT-PROCESS +;; The GetCurrentProcess function retrieves a pseudo handle for the current +;; process. +;; +;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp +(declaim (inline get-current-process)) +(define-alien-routine ("GetCurrentProcess" get-current-process) handle) + +;;;; Process time information + +(defconstant 100ns-per-internal-time-unit + (/ 10000000 sb!xc:internal-time-units-per-second)) + +;; FILETIME +;; The FILETIME structure is a 64-bit value representing the number of +;; 100-nanosecond intervals since January 1, 1601 (UTC). +;; +;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp? +(define-alien-type FILETIME (sb!alien:unsigned 64)) + +;; FILETIME definition above is almost correct (on little-endian systems), +;; except for the wrong alignment if used in another structure: the real +;; definition is a struct of two dwords. +;; Let's define FILETIME-MEMBER for that purpose; it will be useful with +;; GetFileAttributesEx and FindFirstFileExW. + +(define-alien-type FILETIME-MEMBER + (struct nil (low dword) (high dword))) + +(defmacro with-process-times ((creation-time exit-time kernel-time user-time) + &body forms) + `(with-alien ((,creation-time filetime) + (,exit-time filetime) + (,kernel-time filetime) + (,user-time filetime)) + (syscall* (("GetProcessTimes") handle (* filetime) (* filetime) + (* filetime) (* filetime)) + (progn ,@forms) + (get-current-process) + (addr ,creation-time) + (addr ,exit-time) + (addr ,kernel-time) + (addr ,user-time)))) + +(declaim (inline system-internal-real-time)) + +(let ((epoch 0)) + (declare (unsigned-byte epoch)) + ;; FIXME: For optimization ideas see the unix implementation. + (defun reinit-internal-real-time () + (setf epoch 0 + epoch (get-internal-real-time))) + (defun get-internal-real-time () + (- (with-alien ((system-time filetime)) + (syscall (("GetSystemTimeAsFileTime") void (* filetime)) + (values (floor system-time 100ns-per-internal-time-unit)) + (addr system-time))) + epoch))) + +(defun system-internal-run-time () + (with-process-times (creation-time exit-time kernel-time user-time) + (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit)))) + +(define-alien-type hword (unsigned 16)) + +(define-alien-type systemtime + (struct systemtime + (year hword) + (month hword) + (weekday hword) + (day hword) + (hour hword) + (minute hword) + (second hword) + (millisecond hword))) + +;; Obtained with, but the XC can't deal with that -- but +;; it's not like the value is ever going to change... +;; (with-alien ((filetime filetime) +;; (epoch systemtime)) +;; (setf (slot epoch 'year) 1970 +;; (slot epoch 'month) 1 +;; (slot epoch 'day) 1 +;; (slot epoch 'hour) 0 +;; (slot epoch 'minute) 0 +;; (slot epoch 'second) 0 +;; (slot epoch 'millisecond) 0) +;; (syscall (("SystemTimeToFileTime" 8) void +;; (* systemtime) (* filetime)) +;; filetime +;; (addr epoch) +;; (addr filetime))) +(defconstant +unix-epoch-filetime+ 116444736000000000) +(defconstant +filetime-unit+ (* 100ns-per-internal-time-unit + internal-time-units-per-second)) +(defconstant +common-lisp-epoch-filetime-seconds+ 9435484800) + +#!-sb-fluid +(declaim (inline get-time-of-day)) +(defun get-time-of-day () + "Return the number of seconds and microseconds since the beginning of the +UNIX epoch: January 1st 1970." + (with-alien ((system-time filetime)) + (syscall (("GetSystemTimeAsFileTime") void (* filetime)) + (multiple-value-bind (sec 100ns) + (floor (- system-time +unix-epoch-filetime+) + (* 100ns-per-internal-time-unit + internal-time-units-per-second)) + (values sec (floor 100ns 10))) + (addr system-time)))) + +;; Data for FindFirstFileExW and GetFileAttributesEx +(define-alien-type find-data + (struct nil + (attributes dword) + (ctime filetime-member) + (atime filetime-member) + (mtime filetime-member) + (size-low dword) + (size-high dword) + (reserved0 dword) + (reserved1 dword) + (long-name (array tchar #.max_path)) + (short-name (array tchar 14)))) + +(define-alien-type file-attributes + (struct nil + (attributes dword) + (ctime filetime-member) + (atime filetime-member) + (mtime filetime-member) + (size-low dword) + (size-high dword))) + +(define-alien-routine ("FindClose" find-close) lispbool + (handle handle)) + +(defun attribute-file-kind (dword) + (if (logtest file-attribute-directory dword) + :directory :file)) + +(defun native-file-write-date (native-namestring) + "Return file write date, represented as CL universal time." + (with-alien ((file-attributes file-attributes)) + (syscall (("GetFileAttributesEx" t) lispbool + system-string int file-attributes) + (and result + (- (floor (deref (cast (slot file-attributes 'mtime) + (* filetime))) + +filetime-unit+) + +common-lisp-epoch-filetime-seconds+)) + native-namestring 0 file-attributes))) + +(defun native-probe-file-name (native-namestring) + "Return truename \(using GetLongPathName\) as primary value, +File kind as secondary. + +Unless kind is false, null truename shouldn't be interpreted as error or file +absense." + (with-alien ((file-attributes file-attributes) + (buffer long-pathname-buffer)) + (syscall (("GetFileAttributesEx" t) lispbool + system-string int file-attributes) + (values + (syscall (("GetLongPathName" t) dword + system-string long-pathname-buffer dword) + (and (plusp result) (decode-system-string buffer)) + native-namestring buffer 32768) + (and result + (attribute-file-kind + (slot file-attributes 'attributes)))) + native-namestring 0 file-attributes))) + +(defun native-delete-file (native-namestring) + (syscall (("DeleteFile" t) lispbool system-string) + result native-namestring)) + +(defun native-delete-directory (native-namestring) + (syscall (("RemoveDirectory" t) lispbool system-string) + result native-namestring)) + +(defun native-call-with-directory-iterator (function namestring errorp) + (declare (type (or null string) namestring) + (function function)) + (when namestring + (with-alien ((find-data find-data)) + (with-handle (handle (syscall (("FindFirstFile" t) handle + system-string find-data) + (if (eql result invalid-handle) + (if errorp + (win32-error "FindFirstFile") + (return)) + result) + (concatenate 'string + namestring "*.*") + find-data) + :close-operator find-close) + (let ((more t)) + (dx-flet ((one-iter () + (tagbody + :next + (when more + (let ((name (decode-system-string + (slot find-data 'long-name))) + (attributes (slot find-data 'attributes))) + (setf more + (syscall (("FindNextFile" t) lispbool + handle find-data) result + handle find-data)) + (cond ((equal name ".") (go :next)) + ((equal name "..") (go :next)) + (t + (return-from one-iter + (values name + (attribute-file-kind + attributes)))))))))) + (funcall function #'one-iter))))))) + +;; SETENV +;; The SetEnvironmentVariable function sets the contents of the specified +;; environment variable for the current process. +;; +;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp +(defun setenv (name value) + (declare (type (or null simple-string) value)) + (if value + (void-syscall* (("SetEnvironmentVariable" t) system-string system-string) + name value) + (void-syscall* (("SetEnvironmentVariable" t) system-string int-ptr) + name 0))) + +;; Let SETENV be an accessor for POSIX-GETENV. +;; +;; DFL: Merged this function because it seems useful to me. But +;; shouldn't we then define it on actual POSIX, too? +(defun (setf sb!unix::posix-getenv) (new-value name) + (if (setenv name new-value) + new-value + (posix-getenv name))) + +(defmacro c-sizeof (s) + "translate alien size (in bits) to c-size (in bytes)" + `(/ (alien-size ,s) 8)) + +;; OSVERSIONINFO +;; The OSVERSIONINFO data structure contains operating system version +;; information. The information includes major and minor version numbers, +;; a build number, a platform identifier, and descriptive text about +;; the operating system. This structure is used with the GetVersionEx function. +;; +;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp +(define-alien-type nil + (struct OSVERSIONINFO + (dwOSVersionInfoSize dword) + (dwMajorVersion dword) + (dwMinorVersion dword) + (dwBuildNumber dword) + (dwPlatformId dword) + (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256)))) + +(defun get-version-ex () + (with-alien ((info (struct OSVERSIONINFO))) + (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO))) + (syscall* (("GetVersionEx" t) (* (struct OSVERSIONINFO))) + (values (slot info 'dwMajorVersion) + (slot info 'dwMinorVersion) + (slot info 'dwBuildNumber) + (slot info 'dwPlatformId) + (cast (slot info 'szCSDVersion) system-string)) + (addr info)))) + +;; GET-COMPUTER-NAME +;; The GetComputerName function retrieves the NetBIOS name of the local +;; computer. This name is established at system startup, when the system +;; reads it from the registry. +;; +;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp +(declaim (ftype (function () simple-string) get-computer-name)) +(defun get-computer-name () + (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH))) + (length dword (1+ MAX_COMPUTERNAME_LENGTH))) + (with-sysfun (afunc ("GetComputerName" t) bool (* char) (* dword)) + (when (zerop (alien-funcall afunc aname (addr length))) + (let ((err (get-last-error))) + (unless (= err ERROR_BUFFER_OVERFLOW) + (win32-error "GetComputerName" err)) + (free-alien aname) + (setf aname (make-system-buffer length)) + (alien-funcall afunc aname (addr length)))) + (cast-and-free aname)))) + +(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool + (handle handle) + (offset long-long) + (new-position long-long :out) + (whence dword)) + +(defun lseeki64 (handle offset whence) + (multiple-value-bind (moved to-place) + (set-file-pointer-ex handle offset whence) + (if moved + (values to-place 0) + (values -1 (- (get-last-error)))))) + +;; File mapping support routines +(define-alien-routine (#!+sb-unicode "CreateFileMappingW" + #!-sb-unicode "CreateFileMappingA" + create-file-mapping) + handle + (handle handle) + (security-attributes (* t)) + (protection dword) + (maximum-size-high dword) + (maximum-size-low dword) + (name system-string)) + +(define-alien-routine ("MapViewOfFile" map-view-of-file) + system-area-pointer + (file-mapping handle) + (desired-access dword) + (offset-high dword) + (offset-low dword) + (size dword)) + +(define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool + (address (* t))) + +(define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool + (address (* t)) + (length dword)) + +;; Constants for CreateFile `disposition'. +(defconstant file-create-new 1) +(defconstant file-create-always 2) +(defconstant file-open-existing 3) +(defconstant file-open-always 4) +(defconstant file-truncate-existing 5) + +;; access rights +(defconstant access-generic-read #x80000000) +(defconstant access-generic-write #x40000000) +(defconstant access-generic-execute #x20000000) +(defconstant access-generic-all #x10000000) +(defconstant access-file-append-data #x4) +(defconstant access-delete #x00010000) + +;; share modes +(defconstant file-share-delete #x04) +(defconstant file-share-read #x01) +(defconstant file-share-write #x02) + +;; CreateFile (the real file-opening workhorse). +(define-alien-routine (#!+sb-unicode "CreateFileW" + #!-sb-unicode "CreateFileA" + create-file) + handle + (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)) + (desired-access dword) + (share-mode dword) + (security-attributes (* t)) + (creation-disposition dword) + (flags-and-attributes dword) + (template-file handle)) + +;; GetFileSizeEx doesn't work with block devices :[ +(define-alien-routine ("GetFileSizeEx" get-file-size-ex) + bool + (handle handle) (file-size (signed 64) :in-out)) + +;; GetFileAttribute is like a tiny subset of fstat(), +;; enough to distinguish directories from anything else. +(define-alien-routine (#!+sb-unicode "GetFileAttributesW" + #!-sb-unicode "GetFileAttributesA" + get-file-attributes) + dword + (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))) + +(define-alien-routine ("CloseHandle" close-handle) bool + (handle handle)) + +(define-alien-routine ("_open_osfhandle" real-open-osfhandle) + int + (handle handle) + (flags int)) + +;; Intended to be an imitation of sb!unix:unix-open based on +;; CreateFile, as complete as possibly. +;; FILE_FLAG_OVERLAPPED is a must for decent I/O. + +(defun unixlike-open (path flags mode &optional revertable) + (declare (type sb!unix:unix-pathname path) + (type fixnum flags) + (type sb!unix:unix-file-mode mode) + (ignorable mode)) + (let* ((disposition-flags + (logior + (if (zerop (logand sb!unix:o_creat flags)) 0 #b100) + (if (zerop (logand sb!unix:o_excl flags)) 0 #b010) + (if (zerop (logand sb!unix:o_trunc flags)) 0 #b001))) + (create-disposition + ;; there are 8 combinations of creat|excl|trunc, some of + ;; them are equivalent. Case stmt below maps them to 5 + ;; dispositions (see CreateFile manual). + (case disposition-flags + ((#b110 #b111) file-create-new) + ((#b001 #b011) file-truncate-existing) + ((#b000 #b010) file-open-existing) + (#b100 file-open-always) + (#b101 file-create-always)))) + (let ((handle + (create-file path + (logior + (if revertable #x10000 0) + (if (plusp (logand sb!unix:o_append flags)) + access-file-append-data + 0) + (ecase (logand 3 flags) + (0 FILE_GENERIC_READ) + (1 FILE_GENERIC_WRITE) + ((2 3) (logior FILE_GENERIC_READ + FILE_GENERIC_WRITE)))) + (logior FILE_SHARE_READ + FILE_SHARE_WRITE) + nil + create-disposition + (logior + file-attribute-normal + file-flag-overlapped + file-flag-sequential-scan) + 0))) + (if (eql handle invalid-handle) + (values nil + (let ((error-code (get-last-error))) + (case error-code + (#.error_file_not_found + sb!unix:enoent) + ((#.error_already_exists #.error_file_exists) + sb!unix:eexist) + (otherwise (- error-code))))) + (progn + ;; FIXME: seeking to the end is not enough for real APPEND + ;; semantics, but it's better than nothing. + ;; -- AK + ;; + ;; On the other hand, the CL spec implies the "better than + ;; nothing" seek-once semantics implemented here, and our + ;; POSIX backend is incorrect in implementing :APPEND as + ;; O_APPEND. Other CL implementations get this right across + ;; platforms. + ;; + ;; Of course, it would be nice if we had :IF-EXISTS + ;; :ATOMICALLY-APPEND separately as an extension, and in + ;; that case, we will have to worry about supporting it + ;; here after all. + ;; + ;; I've tested this only very briefly (on XP and Windows 7), + ;; but my impression is that WriteFile (without documenting + ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the + ;; offset in our overlapped structure, WriteFile seeks to the + ;; end for us. Should we depend on that? How do we communicate + ;; our desire to do so to the runtime? + ;; -- DFL + ;; + (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0)) + (values handle 0)))))) + +(define-alien-routine ("closesocket" close-socket) int (handle handle)) +(define-alien-routine ("shutdown" shutdown-socket) int (handle handle) + (how int)) + +(define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool + (from-process handle) + (from-handle handle) + (to-process handle) + (to-handle handle :out) + (access dword) + (inheritp lispbool) + (options dword)) + +(defconstant +handle-flag-inherit+ 1) +(defconstant +handle-flag-protect-from-close+ 2) + +(define-alien-routine ("SetHandleInformation" set-handle-information) lispbool + (handle handle) + (mask dword) + (flags dword)) + +(define-alien-routine ("GetHandleInformation" get-handle-information) lispbool + (handle handle) + (flags dword :out)) + +(define-alien-routine getsockopt int + (handle handle) + (level int) + (opname int) + (dataword int-ptr :in-out) + (socklen int :in-out)) + +(defconstant sol_socket #xFFFF) +(defconstant so_type #x1008) + +(defun socket-handle-p (handle) + (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes)))) + +(defconstant ebadf 9) + +;;; For sockets, CloseHandle first and closesocket() afterwards is +;;; legal: winsock tracks its handles separately (that's why we have +;;; the problem with simple _close in the first place). +;;; +;;; ...Seems to be the problem on some OSes, though. We could +;;; duplicate a handle and attempt close-socket on a duplicated one, +;;; but it also have some problems... + +(defun unixlike-close (fd) + (if (or (zerop (close-socket fd)) + (close-handle fd)) + t (values nil ebadf))) + +(defconstant +std-input-handle+ -10) +(defconstant +std-output-handle+ -11) +(defconstant +std-error-handle+ -12) + +(defun get-std-handle-or-null (identity) + (let ((handle (alien-funcall + (extern-alien "GetStdHandle" (function handle dword)) + (logand (1- (ash 1 (alien-size dword))) identity)))) + (and (/= handle invalid-handle) + (not (zerop handle)) + handle))) + +(defun get-std-handles () + (values (get-std-handle-or-null +std-input-handle+) + (get-std-handle-or-null +std-output-handle+) + (get-std-handle-or-null +std-error-handle+))) + +(defconstant +duplicate-same-access+ 2) + +(defun duplicate-and-unwrap-fd (fd &key inheritp) + (let ((me (get-current-process))) + (multiple-value-bind (duplicated handle) + (duplicate-handle me (real-get-osfhandle fd) + me 0 inheritp +duplicate-same-access+) + (if duplicated + (prog1 handle (real-crt-close fd)) + (win32-error 'duplicate-and-unwrap-fd))))) + +(define-alien-routine ("CreatePipe" create-pipe) lispbool + (read-pipe handle :out) + (write-pipe handle :out) + (security-attributes (* t)) + (buffer-size dword)) + +(defun windows-pipe () + (multiple-value-bind (created read-handle write-handle) + (create-pipe nil 256) + (if created (values read-handle write-handle) + (win32-error 'create-pipe)))) + +(defun windows-isatty (handle) + (if (= file-type-char (get-file-type handle)) + 1 0)) + +(defun inheritable-handle-p (handle) + (multiple-value-bind (got flags) + (get-handle-information handle) + (if got (plusp (logand flags +handle-flag-inherit+)) + (win32-error 'inheritable-handle-p)))) + +(defun (setf inheritable-handle-p) (allow handle) + (if (set-handle-information handle + +handle-flag-inherit+ + (if allow +handle-flag-inherit+ 0)) + allow + (win32-error '(setf inheritable-handle-p)))) + +(defun sb!unix:unix-dup (fd) + (let ((me (get-current-process))) + (multiple-value-bind (duplicated handle) + (duplicate-handle me fd me 0 t +duplicate-same-access+) + (if duplicated + (values handle 0) + (values nil (- (get-last-error))))))) + +(defun call-with-crt-fd (thunk handle &optional (flags 0)) + (multiple-value-bind (duplicate errno) + (sb!unix:unix-dup handle) + (if duplicate + (let ((fd (real-open-osfhandle duplicate flags))) + (unwind-protect (funcall thunk fd) + (real-crt-close fd))) + (values nil errno)))) + +;;; random seeding + +(define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool + (handle handle) + (length dword) + (buffer (* t))) + +(define-alien-routine (#!-sb-unicode "CryptAcquireContextA" + #!+sb-unicode "CryptAcquireContextW" + %crypt-acquire-context) lispbool + (handle handle :out) + (container system-string) + (provider system-string) + (provider-type dword) + (flags dword)) + +(define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool + (handle handle) + (flags dword)) + +(defun crypt-gen-random (length) + (multiple-value-bind (ok context) + (%crypt-acquire-context nil nil prov-rsa-full + (logior crypt-verifycontext crypt-silent)) + (unless ok + (return-from crypt-gen-random (values nil (get-last-error)))) + (unwind-protect + (let ((data (make-array length :element-type '(unsigned-byte 8)))) + (with-pinned-objects (data) + (if (%crypt-gen-random context length (vector-sap data)) + data + (values nil (get-last-error))))) + (unless (%crypt-release-context context 0) + (win32-error '%crypt-release-context)))))