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
  24 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
  25 ;;; to a pointer.
  26 (defconstant invalid-handle -1)
  27
  28 ;;;; Error Handling
  29
  30 ;;; Retrieve the calling thread's last-error code value.  The
  31 ;;; last-error code is maintained on a per-thread basis.
  32 (define-alien-routine ("GetLastError@0" get-last-error) dword)
  33
  34 ;;; Flag constants for FORMAT-MESSAGE.
  35 (defconstant format-message-from-system #x1000)
  36
  37 ;;; Format an error message based on a lookup table.  See MSDN for the
  38 ;;; full meaning of the all options---most are not used when getting
  39 ;;; system error codes.
  40 (define-alien-routine ("FormatMessageA@28" format-message) dword
  41   (flags dword)
  42   (source (* t))
  43   (message-id dword)
  44   (language-id dword)
  45   (buffer c-string)
  46   (size dword)
  47   (arguments (* t)))
  48
  49 ;;;; File Handles
  50
  51 ;;; Get the operating system handle for a C file descriptor.  Returns
  52 ;;; INVALID-HANDLE on failure.
  53 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
  54   (fd int))
  55
  56 ;;; Read data from a file handle into a buffer.  This may be used
  57 ;;; synchronously or with "overlapped" (asynchronous) I/O.
  58 (define-alien-routine ("ReadFile@20" read-file) bool
  59   (file handle)
  60   (buffer (* t))
  61   (bytes-to-read dword)
  62   (bytes-read (* dword))
  63   (overlapped (* t)))
  64
  65 ;;; Write data from a buffer to a file handle.  This may be used
  66 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
  67 (define-alien-routine ("WriteFile@20" write-file) bool
  68   (file handle)
  69   (buffer (* t))
  70   (bytes-to-write dword)
  71   (bytes-written (* dword))
  72   (overlapped (* t)))
  73
  74 ;;; Copy data from a named or anonymous pipe into a buffer without
  75 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
  76 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
  77 ;;; Return TRUE on success, FALSE on failure.
  78 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
  79   (pipe handle)
  80   (buffer (* t))
  81   (buffer-size dword)
  82   (bytes-read (* dword))
  83   (bytes-avail (* dword))
  84   (bytes-left-this-message (* dword)))
  85
  86 ;;; Flush the console input buffer if HANDLE is a console handle.
  87 ;;; Returns true on success, false if the handle does not refer to a
  88 ;;; console.
  89 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
  90   (handle handle))
  91
  92 ;;; Read data from the console input buffer without removing it,
  93 ;;; without blocking.  Buffer should be large enough for LENGTH *
  94 ;;; INPUT-RECORD-SIZE bytes.
  95 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
  96   (handle handle)
  97   (buffer (* t))
  98   (length dword)
  99   (nevents (* dword)))
 100
 101 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
 102 ;;; isn't a unified interface to do this---we have to know what sort
 103 ;;; of handle we have.  Of course, there's no way to actually
 104 ;;; introspect it, so we have to try various things until we find
 105 ;;; something that works.  Returns true if there could be input
 106 ;;; available, or false if there is not.
 107 (defun handle-listen (handle)
 108   (with-alien ((avail dword)
 109                (buf (array char #.input-record-size)))
 110     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
 111       (return-from handle-listen (plusp avail)))
 112
 113     (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail)))
 114       (return-from handle-listen (plusp avail)))
 115
 116     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
 117     ;; HANDLE is a socket.
 118     t))
 119
 120 ;;; Listen for input on a C runtime file handle.  Returns true if
 121 ;;; there could be input available, or false if there is not.
 122 (defun fd-listen (fd)
 123   (let ((handle (get-osfhandle fd)))
 124     (if handle
 125         (handle-listen handle)
 126         t)))
 127
 128 ;;; Clear all available input from a file handle.
 129 (defun handle-clear-input (handle)
 130   (flush-console-input-buffer handle)
 131   (with-alien ((buf (array char 1024))
 132                (count dword))
 133     (loop
 134      (unless (handle-listen handle)
 135        (return))
 136      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
 137        (return))
 138      (when (< count 1024)
 139        (return)))))
 140
 141 ;;; Clear all available input from a C runtime file handle.
 142 (defun fd-clear-input (fd)
 143   (let ((handle (get-osfhandle fd)))
 144     (when handle
 145       (handle-clear-input handle))))
 146
 147 ;;;; System Functions
 148
 149 ;;; Sleep for MILLISECONDS milliseconds.
 150 (define-alien-routine ("Sleep@4" millisleep) void
 151   (milliseconds dword))