src/code/win32.lisp

   1 ;;;; This file contains Win32 support routines that SBCL needs to
   2 ;;;; implement itself, in addition to those that apply to Win32 in
   3 ;;;; unix.lisp.  In theory, some of these functions might someday be
   4 ;;;; useful to the end user.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!WIN32")
  16
  17 ;;; Alien definitions for commonly used Win32 types.  Woe unto whoever
  18 ;;; tries to untangle this someday for 64-bit Windows.
  19 (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)
  24
  25 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
  26 ;;; to a pointer.
  27 (defconstant invalid-handle -1)
  28
  29 ;;;; Error Handling
  30
  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)
  34
  35 ;;; Flag constants for FORMAT-MESSAGE.
  36 (defconstant format-message-from-system #x1000)
  37
  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
  42   (flags dword)
  43   (source (* t))
  44   (message-id dword)
  45   (language-id dword)
  46   (buffer c-string)
  47   (size dword)
  48   (arguments (* t)))
  49
  50 ;;;; File Handles
  51
  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
  55   (fd int))
  56
  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
  60   (file handle)
  61   (buffer (* t))
  62   (bytes-to-read dword)
  63   (bytes-read (* dword))
  64   (overlapped (* t)))
  65
  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
  69   (file handle)
  70   (buffer (* t))
  71   (bytes-to-write dword)
  72   (bytes-written (* dword))
  73   (overlapped (* t)))
  74
  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
  80   (pipe handle)
  81   (buffer (* t))
  82   (buffer-size dword)
  83   (bytes-read (* dword))
  84   (bytes-avail (* dword))
  85   (bytes-left-this-message (* dword)))
  86
  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
  89 ;;; console.
  90 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
  91   (handle handle))
  92
  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
  97   (handle handle)
  98   (buffer (* t))
  99   (length dword)
 100   (nevents (* dword)))
 101
 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)))
 113
 114     (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail)))
 115       (return-from handle-listen (plusp avail)))
 116
 117     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
 118     ;; HANDLE is a socket.
 119     t))
 120
 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)))
 125     (if handle
 126         (handle-listen handle)
 127         t)))
 128
 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))
 133                (count dword))
 134     (loop
 135      (unless (handle-listen handle)
 136        (return))
 137      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
 138        (return))
 139      (when (< count 1024)
 140        (return)))))
 141
 142 ;;; Clear all available input from a C runtime file handle.
 143 (defun fd-clear-input (fd)
 144   (let ((handle (get-osfhandle fd)))
 145     (when handle
 146       (handle-clear-input handle))))
 147
 148 ;;;; System Functions
 149
 150 ;;; Sleep for MILLISECONDS milliseconds.
 151 (define-alien-routine ("Sleep@4" millisleep) void
 152   (milliseconds dword))
 153
 154 #!+sb-unicode (defvar *ANSI-CP* nil)
 155 #!+sb-unicode (defvar *OEM-CP* nil)
 156
 157 #!+sb-unicode
 158 (defparameter *cp-to-external-format* (make-hash-table))
 159
 160 #!+sb-unicode
 161 (dolist (cp
 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)
 170     ;;775       OEM - Baltic
 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)
 215     ;;10000 MAC - Roman
 216     ;;10001     MAC - Japanese
 217     ;;10002     MAC - Traditional Chinese (Big5)
 218     ;;10003     MAC - Korean
 219     ;;10004     MAC - Arabic
 220     ;;10005     MAC - Hebrew
 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
 226     ;;10021     MAC - Thai
 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
 233     ;;20000     CNS - Taiwan
 234     ;;20001     TCA - Taiwan
 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)
 244     ;;20261     T.61
 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)
 267     ;;21027     (deprecated)
 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
 279     ;;29001     Europa 3
 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
 296     ;;51949     EUC - Korean
 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
 302     ;;57004     ISCII Tamil
 303     ;;57005     ISCII Telugu
 304     ;;57006     ISCII Assamese
 305     ;;57007     ISCII Oriya
 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) *cp-to-external-format*) (cadr cp)))
 313
 314 #!+sb-unicode
 315 (declaim (ftype (function () keyword) ansi-cp))
 316 #!+sb-unicode
 317 (defun ansi-cp ()
 318   (or *ANSI-CP*
 319       (setq *ANSI-CP*
 320         (or
 321           (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
 322                    *cp-to-external-format*)
 323           :LATIN-1))))
 324
 325 #!+sb-unicode
 326 (declaim (ftype (function () keyword) oem-cp))
 327 #!+sb-unicode
 328 (defun oem-cp ()
 329   (or *OEM-CP*
 330       (setq *OEM-CP*
 331         (or
 332           (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
 333                    *cp-to-external-format*)
 334           :LATIN-1))))