/[slime]/slime/swank-sbcl.lisp
ViewVC logotype

Diff of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.297 by sboukarev, Fri Dec 2 20:24:03 2011 UTC revision 1.298 by nsiivola, Sat Dec 3 15:31:08 2011 UTC
# Line 179  Line 179 
179    
180  (defvar *wait-for-input-called*)  (defvar *wait-for-input-called*)
181    
 #+(or win32 os-provides-poll)  
182  (defimplementation wait-for-input (streams &optional timeout)  (defimplementation wait-for-input (streams &optional timeout)
183    (assert (member timeout '(nil t)))    (assert (member timeout '(nil t)))
184    (when (boundp '*wait-for-input-called*)    (when (boundp '*wait-for-input-called*)
185      (setq *wait-for-input-called* t))      (setq *wait-for-input-called* t))
186    (let ((*wait-for-input-called* nil))    (let ((*wait-for-input-called* nil))
187      (loop      (loop
188       (let ((ready (remove-if-not #'input-ready-p streams)))        (let ((ready (remove-if-not #'input-ready-p streams)))
189         (when ready (return ready)))          (when ready (return ready)))
190       (when (check-slime-interrupts) (return :interrupt))        (when (check-slime-interrupts)
191       (when *wait-for-input-called* (return :interrupt))          (return :interrupt))
192       #+os-provides-poll        (when *wait-for-input-called*
193       (let ((readable (poll streams () (ecase timeout          (return :interrupt))
194                                          ((nil) nil)        (when timeout
195                                          ((t) 0)))))          (return nil))
196         (when readable (return readable))        (sleep 0.1))))
197         (when timeout (return nil)))  
198    #-win32
199       #-os-provides-poll  (defun input-ready-p (stream)
200       (progn    (or (let ((buffer (sb-impl::fd-stream-ibuf stream)))
201         (when timeout (return nil))          (when buffer
202         (sleep 0.1)))))            (= (sb-impl::buffer-head buffer)
203                 (sb-impl::buffer-tail buffer))))
204  (defun fd-stream-input-buffer-empty-p (stream)        (eq :regular (sb-impl::fd-stream-fd-type stream))
205    (let ((buffer (sb-impl::fd-stream-ibuf stream)))        (not (sb-impl::sysread-may-block-p stream))))
     (or (not buffer)  
         (= (sb-impl::buffer-head buffer)  
            (sb-impl::buffer-tail buffer)))))  
   
 #+os-provides-poll  
 (progn  
   (defun input-ready-p (stream)  
     (not (fd-stream-input-buffer-empty-p stream)))  
   
   (sb-alien:define-alien-type pollfd (sb-alien:struct sb-unix::pollfd))  
   (sb-alien:define-alien-routine ("poll" poll%) sb-alien:int  
     (descs (sb-alien:* pollfd)) (ndescs sb-alien:int) (millis sb-alien:int))  
   
   (defun poll (read-streams write-streams milliseconds)  
     (let* ((rlen (length read-streams))  
            (wlen (length write-streams))  
            (len (+ rlen wlen)))  
       (assert (< len 10))  
       (sb-alien:with-alien ((pollfds (sb-alien:array pollfd 10)))  
         (flet ((set-events (i stream flags)  
                  (symbol-macrolet ((pfd (sb-alien:deref pollfds i)))  
                    (setf (sb-alien:slot pfd 'sb-unix::fd)  
                          (sb-impl::fd-stream-fd stream))  
                    (setf (sb-alien:slot pfd 'sb-unix::events) flags)  
                    (setf (sb-alien:slot pfd 'sb-unix::revents) 0)))  
                (revents? (i)  
                  (let ((revents (sb-alien:slot (sb-alien:deref pollfds i)  
                                                'sb-unix::revents)))  
                    (not (zerop revents)))))  
           (declare (inline set-events revents?))  
           (loop with rflags = (logior sb-unix::pollin  
                                       #+linux #x2000 #|POLLRDHUP|#)  
                 for i below rlen  for s in read-streams  
                 do (set-events i s rflags))  
           (loop for i from rlen below len  for s in write-streams  
                 do (set-events i s sb-unix::pollout))  
           (let* ((timeout (etypecase milliseconds  
                             (null -1)  
                             (integer milliseconds)))  
                  (code (poll% (sb-alien:addr (sb-alien:deref pollfds 0))  
                               len timeout))  
                  (errno (sb-alien:get-errno)))  
             (cond ((zerop code)  
                    (values () ()))  
                   ((plusp code)  
                    (values  
                     (loop for i below rlen  for s in read-streams  
                           if (revents? i) collect s)  
                     (loop for i from rlen below len for s in write-streams  
                           if (revents? i) collect s)))  
                   ((= errno sb-posix:eintr)  
                    :interrupt)  
                   (t  
                    (error "~a" (sb-int:strerror errno)))))))))  
   )  
206    
207  #+win32  #+win32
208  (progn  (progn

Legend:
Removed from v.1.297  
changed lines
  Added in v.1.298

  ViewVC Help
Powered by ViewVC 1.1.5