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.
19 (define-alien-type int-ptr long)
20 (define-alien-type handle int-ptr)
21 (define-alien-type dword unsigned-long)
22 (define-alien-type bool int)
23 (define-alien-type UINT unsigned-int)
25 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
27 (defconstant invalid-handle -1)
31 ;;; Retrieve the calling thread's last-error code value. The
32 ;;; last-error code is maintained on a per-thread basis.
33 (define-alien-routine ("GetLastError@0" get-last-error) dword)
35 ;;; Flag constants for FORMAT-MESSAGE.
36 (defconstant format-message-from-system #x1000)
38 ;;; Format an error message based on a lookup table. See MSDN for the
39 ;;; full meaning of the all options---most are not used when getting
40 ;;; system error codes.
41 (define-alien-routine ("FormatMessageA@28" format-message) dword
52 ;;; Get the operating system handle for a C file descriptor. Returns
53 ;;; INVALID-HANDLE on failure.
54 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
57 ;;; Read data from a file handle into a buffer. This may be used
58 ;;; synchronously or with "overlapped" (asynchronous) I/O.
59 (define-alien-routine ("ReadFile@20" read-file) bool
63 (bytes-read (* dword))
66 ;;; Write data from a buffer to a file handle. This may be used
67 ;;; synchronously or with "overlapped" (asynchronous) I/O.
68 (define-alien-routine ("WriteFile@20" write-file) bool
71 (bytes-to-write dword)
72 (bytes-written (* dword))
75 ;;; Copy data from a named or anonymous pipe into a buffer without
76 ;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and
77 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
78 ;;; Return TRUE on success, FALSE on failure.
79 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
83 (bytes-read (* dword))
84 (bytes-avail (* dword))
85 (bytes-left-this-message (* dword)))
87 ;;; Flush the console input buffer if HANDLE is a console handle.
88 ;;; Returns true on success, false if the handle does not refer to a
90 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
93 ;;; Read data from the console input buffer without removing it,
94 ;;; without blocking. Buffer should be large enough for LENGTH *
95 ;;; INPUT-RECORD-SIZE bytes.
96 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
102 ;;; Listen for input on a Windows file handle. Unlike UNIX, there
103 ;;; isn't a unified interface to do this---we have to know what sort
104 ;;; of handle we have. Of course, there's no way to actually
105 ;;; introspect it, so we have to try various things until we find
106 ;;; something that works. Returns true if there could be input
107 ;;; available, or false if there is not.
108 (defun handle-listen (handle)
109 (with-alien ((avail dword)
110 (buf (array char #.input-record-size)))
111 (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
112 (return-from handle-listen (plusp avail)))
114 (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail)))
115 (return-from handle-listen (plusp avail)))
117 ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
118 ;; HANDLE is a socket.
121 ;;; Listen for input on a C runtime file handle. Returns true if
122 ;;; there could be input available, or false if there is not.
123 (defun fd-listen (fd)
124 (let ((handle (get-osfhandle fd)))
126 (handle-listen handle)
129 ;;; Clear all available input from a file handle.
130 (defun handle-clear-input (handle)
131 (flush-console-input-buffer handle)
132 (with-alien ((buf (array char 1024))
135 (unless (handle-listen handle)
137 (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
142 ;;; Clear all available input from a C runtime file handle.
143 (defun fd-clear-input (fd)
144 (let ((handle (get-osfhandle fd)))
146 (handle-clear-input handle))))
148 ;;;; System Functions
150 ;;; Sleep for MILLISECONDS milliseconds.
151 (define-alien-routine ("Sleep@4" millisleep) void
152 (milliseconds dword))
154 #!+sb-unicode (defvar *ANSI-CODEPAGE* nil)
155 #!+sb-unicode (defvar *OEM-CODEPAGE* nil)
158 (defparameter *codepage-to-external-format* (make-hash-table))
162 '(;;037 IBM EBCDIC - U.S./Canada
163 (437 :CP437) ;; OEM - United States
164 ;;500 IBM EBCDIC - International
165 ;;708 Arabic - ASMO 708
166 ;;709 Arabic - ASMO 449+, BCON V4
167 ;;710 Arabic - Transparent Arabic
168 ;;720 Arabic - Transparent ASMO
169 ;;737 OEM - Greek (formerly 437G)
171 (850 :CP850) ;; OEM - Multilingual Latin I
172 (852 :CP852) ;; OEM - Latin II
173 (855 :CP855) ;; OEM - Cyrillic (primarily Russian)
174 (857 :CP857) ;; OEM - Turkish
175 ;;858 OEM - Multilingual Latin I + Euro symbol
176 (860 :CP860) ;; OEM - Portuguese
177 (861 :CP861) ;; OEM - Icelandic
178 (862 :CP862) ;; OEM - Hebrew
179 (863 :CP863) ;; OEM - Canadian-French
180 (864 :CP864) ;; OEM - Arabic
181 (865 :CP865) ;; OEM - Nordic
182 (866 :CP866) ;; OEM - Russian
183 (869 :CP869) ;; OEM - Modern Greek
184 ;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2)
185 (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
186 ;;875 IBM EBCDIC - Modern Greek
187 ;;932 ANSI/OEM - Japanese, Shift-JIS
188 ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore)
189 ;;949 ANSI/OEM - Korean (Unified Hangul Code)
190 ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
191 ;;1026 IBM EBCDIC - Turkish (Latin-5)
192 ;;1047 IBM EBCDIC - Latin 1/Open System
193 ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol)
194 ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol)
195 ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
196 ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
197 ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol)
198 ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
199 ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol)
200 ;;1147 IBM EBCDIC - France (20297 + Euro symbol)
201 ;;1148 IBM EBCDIC - International (500 + Euro symbol)
202 ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol)
203 ;;1200 Unicode UCS-2 Little-Endian (BMP of ISO 10646)
204 ;;1201 Unicode UCS-2 Big-Endian
205 (1250 :CP1250) ;; ANSI - Central European
206 (1251 :CP1251) ;; ANSI - Cyrillic
207 (1252 :CP1252) ;; ANSI - Latin I
208 (1253 :CP1253) ;; ANSI - Greek
209 (1254 :CP1254) ;; ANSI - Turkish
210 (1255 :CP1255) ;; ANSI - Hebrew
211 (1256 :CP1256) ;; ANSI - Arabic
212 (1257 :CP1257) ;; ANSI - Baltic
213 (1258 :CP1258) ;; ANSI/OEM - Vietnamese
214 ;;1361 Korean (Johab)
216 ;;10001 MAC - Japanese
217 ;;10002 MAC - Traditional Chinese (Big5)
221 ;;10006 MAC - Greek I
222 (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
223 ;;10008 MAC - Simplified Chinese (GB 2312)
224 ;;10010 MAC - Romania
225 ;;10017 MAC - Ukraine
227 ;;10029 MAC - Latin II
228 ;;10079 MAC - Icelandic
229 ;;10081 MAC - Turkish
230 ;;10082 MAC - Croatia
231 ;;12000 Unicode UCS-4 Little-Endian
232 ;;12001 Unicode UCS-4 Big-Endian
235 ;;20002 Eten - Taiwan
236 ;;20003 IBM5550 - Taiwan
237 ;;20004 TeleText - Taiwan
238 ;;20005 Wang - Taiwan
239 ;;20105 IA5 IRV International Alphabet No. 5 (7-bit)
240 ;;20106 IA5 German (7-bit)
241 ;;20107 IA5 Swedish (7-bit)
242 ;;20108 IA5 Norwegian (7-bit)
243 ;;20127 US-ASCII (7-bit)
245 ;;20269 ISO 6937 Non-Spacing Accent
246 ;;20273 IBM EBCDIC - Germany
247 ;;20277 IBM EBCDIC - Denmark/Norway
248 ;;20278 IBM EBCDIC - Finland/Sweden
249 ;;20280 IBM EBCDIC - Italy
250 ;;20284 IBM EBCDIC - Latin America/Spain
251 ;;20285 IBM EBCDIC - United Kingdom
252 ;;20290 IBM EBCDIC - Japanese Katakana Extended
253 ;;20297 IBM EBCDIC - France
254 ;;20420 IBM EBCDIC - Arabic
255 ;;20423 IBM EBCDIC - Greek
256 ;;20424 IBM EBCDIC - Hebrew
257 ;;20833 IBM EBCDIC - Korean Extended
258 ;;20838 IBM EBCDIC - Thai
259 (20866 :KOI8-R) ;; Russian - KOI8-R
260 ;;20871 IBM EBCDIC - Icelandic
261 ;;20880 IBM EBCDIC - Cyrillic (Russian)
262 ;;20905 IBM EBCDIC - Turkish
263 ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
264 ;;20932 JIS X 0208-1990 & 0121-1990
265 ;;20936 Simplified Chinese (GB2312)
266 ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
268 (21866 :KOI8-U) ;; Ukrainian (KOI8-U)
269 (28591 :LATIN-1) ;; ISO 8859-1 Latin I
270 (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe
271 (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3
272 (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic
273 (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic
274 (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic
275 (28597 :ISO-8859-7) ;; ISO 8859-7 Greek
276 (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
277 (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5
278 (28605 :LATIN-9) ;; ISO 8859-15 Latin 9
280 (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
281 ;;50220 ISO 2022 Japanese with no halfwidth Katakana
282 ;;50221 ISO 2022 Japanese with halfwidth Katakana
283 ;;50222 ISO 2022 Japanese JIS X 0201-1989
284 ;;50225 ISO 2022 Korean
285 ;;50227 ISO 2022 Simplified Chinese
286 ;;50229 ISO 2022 Traditional Chinese
287 ;;50930 Japanese (Katakana) Extended
288 ;;50931 US/Canada and Japanese
289 ;;50933 Korean Extended and Korean
290 ;;50935 Simplified Chinese Extended and Simplified Chinese
291 ;;50936 Simplified Chinese
292 ;;50937 US/Canada and Traditional Chinese
293 ;;50939 Japanese (Latin) Extended and Japanese
294 (51932 :EUC-JP) ;; EUC - Japanese
295 ;;51936 EUC - Simplified Chinese
297 ;;51950 EUC - Traditional Chinese
298 ;;52936 HZ-GB2312 Simplified Chinese
299 ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte)
300 ;;57002 ISCII Devanagari
301 ;;57003 ISCII Bengali
304 ;;57006 ISCII Assamese
306 ;;57008 ISCII Kannada
307 ;;57009 ISCII Malayalam
308 ;;57010 ISCII Gujarati
309 ;;57011 ISCII Punjabi
310 ;;65000 Unicode UTF-7
311 (65001 :UTF8))) ;; Unicode UTF-8
312 (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
315 (declaim (ftype (function () keyword) ansi-codepage))
317 (defun ansi-codepage ()
319 (setq *ANSI-CODEPAGE*
321 (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
322 *codepage-to-external-format*)
326 (declaim (ftype (function () keyword) oem-codepage))
328 (defun oem-codepage ()
332 (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
333 *codepage-to-external-format*)
336 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
337 (declaim (ftype (function () keyword) console-input-codepage))
338 (defun console-input-codepage ()
340 (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
341 *codepage-to-external-format*)
344 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
345 (declaim (ftype (function () keyword) console-output-codepage))
346 (defun console-output-codepage ()
348 (gethash (alien-funcall (extern-alien "GetConsoleOutputCP@0" (function UINT)))
349 *codepage-to-external-format*)