Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23640/src/code
Modified Files:
fd-stream.lisp toplevel.lisp
Added Files:
win32.lisp
Log Message:
0.9.8.42:
Merge "first round of i/o fixes" (sbcl-devel 2006-01-13
from James Bielman)
... some extended horribleness, mostly isolated horribleness.
--- NEW FILE: win32.lisp ---
;;;; This file contains Win32 support routines that SBCL needs to
;;;; implement itself, in addition to those that apply to Win32 in
;;;; unix.lisp. In theory, some of these functions might someday be
;;;; useful to the end user.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!WIN32")
;;; 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)
(define-alien-type handle int-ptr)
(define-alien-type dword unsigned-long)
(define-alien-type bool int)
;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
;;; to a pointer.
(defconstant invalid-handle -1)
;;;; 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@..." get-last-error) dword)
;;; Flag constants for FORMAT-MESSAGE.
(defconstant format-message-from-system #x1000)
;;; 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@..." format-message) dword
(flags dword)
(source (* t))
(message-id dword)
(language-id dword)
(buffer c-string)
(size dword)
(arguments (* t)))
;;;; File Handles
;;; Get the operating system handle for a C file descriptor. Returns
;;; INVALID-HANDLE on failure.
(define-alien-routine ("_get_osfhandle" get-osfhandle) handle
(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@..." read-file) bool
(file handle)
(buffer (* t))
(bytes-to-read dword)
(bytes-read (* dword))
(overlapped (* t)))
;;; Write data from a buffer to a file handle. This may be used
;;; synchronously or with "overlapped" (asynchronous) I/O.
(define-alien-routine ("WriteFile@..." write-file) bool
(file handle)
(buffer (* t))
(bytes-to-write dword)
(bytes-written (* dword))
(overlapped (* t)))
;;; Copy data from a named or anonymous pipe into a buffer without
;;; 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@..." peek-named-pipe) bool
(pipe handle)
(buffer (* t))
(buffer-size dword)
(bytes-read (* dword))
(bytes-avail (* dword))
(bytes-left-this-message (* dword)))
;;; 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@..." 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@..." peek-console-input) bool
(handle handle)
(buffer (* t))
(length dword)
(nevents (* dword)))
;;; 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
;;; introspect it, so we have to try various things until we find
;;; something that works. Returns true if there could be input
;;; available, or false if there is not.
(defun handle-listen (handle)
(with-alien ((avail dword)
(buf (array char #.input-record-size)))
(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.
t))
;;; Listen for input on a C runtime file handle. Returns true if
;;; there could be input available, or false if there is not.
(defun fd-listen (fd)
(let ((handle (get-osfhandle fd)))
(if handle
(handle-listen handle)
t)))
;;; Clear all available input from a file handle.
(defun handle-clear-input (handle)
(flush-console-input-buffer handle)
(with-alien ((buf (array char 1024))
(count dword))
(loop
(unless (handle-listen handle)
(return))
(when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
(return))
(when (< count 1024)
(return)))))
;;; Clear all available input from a C runtime file handle.
(defun fd-clear-input (fd)
(let ((handle (get-osfhandle fd)))
(when handle
(handle-clear-input handle))))
;;;; System Functions
;;; Sleep for MILLISECONDS milliseconds.
(define-alien-routine ("Sleep@..." millisleep) void
(milliseconds dword))
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.93
retrieving revision 1.94
diff -u -d -r1.93 -r1.94
--- fd-stream.lisp 10 Jan 2006 17:39:29 -0000 1.93
+++ fd-stream.lisp 16 Jan 2006 15:39:58 -0000 1.94
@@ -659,6 +659,12 @@
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) tail))))
(setf (fd-stream-listen stream) nil)
+ #!+win32
+ (unless (sb!win32:fd-listen fd)
+ (unless (sb!sys:wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ (error 'io-timeout :stream stream :direction :read)))
+ #!-win32
(sb!unix:with-restarted-syscall (count errno)
;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
;; into something which uses the not-yet-defined type
@@ -1571,6 +1577,10 @@
(or (not (eql (fd-stream-ibuf-head fd-stream)
(fd-stream-ibuf-tail fd-stream)))
(fd-stream-listen fd-stream)
+ #!+win32
+ (setf (fd-stream-listen fd-stream)
+ (sb!win32:fd-listen (fd-stream-fd fd-stream)))
+ #!-win32
(setf (fd-stream-listen fd-stream)
(eql (sb!unix:with-restarted-syscall ()
(sb!alien:with-alien ((read-fds (sb!alien:struct
@@ -1660,6 +1670,11 @@
(setf (fd-stream-unread fd-stream) nil)
(setf (fd-stream-ibuf-head fd-stream) 0)
(setf (fd-stream-ibuf-tail fd-stream) 0)
+ #!+win32
+ (progn
+ (sb!win32:fd-clear-input (fd-stream-fd fd-stream))
+ (setf (fd-stream-listen fd-stream) nil))
+ #!-win32
(catch 'eof-input-catcher
(loop
(let ((count (sb!unix:with-restarted-syscall ()
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -d -r1.78 -r1.79
--- toplevel.lisp 10 Jan 2006 16:17:07 -0000 1.78
+++ toplevel.lisp 16 Jan 2006 15:39:58 -0000 1.79
@@ -145,6 +145,7 @@
:format-arguments (list n)
:datum n
:expected-type '(real 0)))
+ #!-win32
(multiple-value-bind (sec nsec)
(if (integerp n)
(values n 0)
@@ -152,6 +153,8 @@
(truncate n)
(values sec (truncate frac 1e-9))))
(sb!unix:nanosleep sec nsec))
+ #!+win32
+ (sb!win32:millisleep (truncate (* n 1000)))
nil)
;;;; SCRUB-CONTROL-STACK
|