[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv17820

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
Some workarounds for SBCL on Windows.

* swank-sbcl.lisp (input-available-p): New function.
(wait-for-input): Use it.
([win32] handle-listen, has-buffered-input-p): New.
(temp-file-name, tempnam): Plain tmpnam(3) is next to useless on
Windows use tempnam(3) instead.

--- /project/slime/cvsroot/slime/ChangeLog	2009/06/12 12:13:36	1.1783
+++ /project/slime/cvsroot/slime/ChangeLog	2009/06/14 17:07:03	1.1784
@@ -1,3 +1,13 @@
+2009-06-14  Helmut Eller  <heller at common-lisp.net>
+
+	Some workarounds for SBCL on Windows.
+
+	* swank-sbcl.lisp (input-available-p): New function.
+	(wait-for-input): Use it.
+	([win32] handle-listen, has-buffered-input-p): New.
+	(temp-file-name, tempnam): Plain tmpnam(3) is next to useless on
+	Windows use tempnam(3) instead.
+
 2009-06-12  Geo Carncross  <geocar at gmail.com>
 
 	* swank-ecl.lisp: Support new environment changes in recent ECL/CVS
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/05/09 19:26:00	1.241
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/06/14 17:07:03	1.242
@@ -163,35 +163,84 @@
     (setq *wait-for-input-called* t))
   (let ((*wait-for-input-called* nil))
     (loop
-     (let ((ready (remove-if (lambda (s)
-                               (let ((c (read-char-no-hang s nil :eof)))
-                                 (case c
-                                   ((nil) t)
-                                   ((:eof) nil)
-                                   (t 
-                                    (unread-char c s)
-                                    nil))))
-                             streams)))
+     (let ((ready (remove-if-not #'input-ready-p streams)))
        (when ready (return ready)))
      (when timeout (return nil))
      (when (check-slime-interrupts) (return :interrupt))
-     (when *wait-for-input-called* (return :interrupt))
-     (let* ((f (constantly t))
-            (handlers (loop for s in streams
-                            do (assert (open-stream-p s))
-                            collect (add-one-shot-handler s f))))
-       (unwind-protect
-            (sb-sys:serve-event 0.2)
-         (mapc #'sb-sys:remove-fd-handler handlers))))))
-
-(defun add-one-shot-handler (stream function)
-  (let (handler)
-    (setq handler 
-          (sb-sys:add-fd-handler (sb-sys:fd-stream-fd stream) :input
-                                 (lambda (fd)
-                                   (declare (ignore fd))
-                                   (sb-sys:remove-fd-handler handler)
-                                   (funcall function stream))))))
+            (when *wait-for-input-called* (return :interrupt))
+     (sleep 0.2))))
+
+#-win32
+(defun input-ready-p (stream)
+  (let ((c (read-char-no-hang stream nil :eof)))
+    (etypecase c
+      (character (unread-char c stream) t)
+      (null nil)
+      ((member :eof) t))))
+
+#+win32
+(progn
+  (defun input-ready-p (stream)
+    (or (has-buffered-input-p stream)
+        (handle-listen (sockint::fd->handle 
+                        (sb-impl::fd-stream-fd stream)))))
+
+  (defun has-buffered-input-p (stream)
+    (let ((ibuf (sb-impl::fd-stream-ibuf stream)))
+      (/= (sb-impl::buffer-head ibuf)
+          (sb-impl::buffer-tail ibuf))))
+
+  (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
+      sb-win32:handle)
+  
+  (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
+      sb-alien:int 
+    (event sb-win32:handle))
+  
+  (defconstant +fd-read+ #.(ash 1 0))
+  (defconstant +fd-close+ #.(ash 1 5))
+  
+  (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
+      sb-alien:int 
+    (fd sb-alien:int) 
+    (handle sb-win32:handle)
+    (mask sb-alien:long))
+
+  (sb-alien:load-shared-object "kernel32.dll")
+  (sb-alien:define-alien-routine ("WaitForSingleObjectEx" 
+                                  wait-for-single-object-ex)
+      sb-alien:int
+    (event sb-win32:handle)
+    (milliseconds sb-alien:long)
+    (alertable sb-alien:int))
+
+  ;; see SB-WIN32:HANDLE-LISTEN
+  (defun handle-listen (handle)
+    (sb-alien:with-alien ((avail sb-win32:dword)
+                          (buf (array char #.sb-win32::input-record-size)))
+      (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil 
+                                               (sb-alien:alien-sap
+                                                (sb-alien:addr avail))
+                                               nil))
+        (return-from handle-listen (plusp avail)))
+
+      (unless (zerop (sb-win32:peek-console-input handle
+                                                  (sb-alien:alien-sap buf)
+                                                  sb-win32::input-record-size 
+                                                  (sb-alien:alien-sap 
+                                                   (sb-alien:addr avail))))
+        (return-from handle-listen (plusp avail))))
+
+    (let ((event (wsa-create-event)))
+      (wsa-event-select handle event (logior +fd-read+ +fd-close+))
+      (let ((val (wait-for-single-object-ex event 0 0)))
+        (wsa-close-event event)
+        (unless (= val -1)
+          (return-from handle-listen (zerop val)))))
+
+    nil)
+
+  )
 
 (defvar *external-format-to-coding-system*
   '((:iso-8859-1 
@@ -527,12 +576,14 @@
 ;;;     (compile nil `(lambda () ,(read-from-string string)))
 ;;; did not provide.
 
-(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
-  (dest (* sb-alien:c-string)))
+(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
+    sb-alien:c-string
+  (dir sb-alien:c-string)
+  (prefix sb-alien:c-string))
 
 (defun temp-file-name ()
   "Return a temporary file name to compile strings into."
-  (concatenate 'string (tmpnam nil) ".lisp"))
+  (tempnam nil nil))
 
 (defun get-compiler-policy (default-policy)
   (declare (ignorable default-policy))