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

Diff of /slime/swank-ecl.lisp

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

revision 1.51 by trittweiler, Sun Feb 7 22:33:53 2010 UTC revision 1.52 by trittweiler, Tue Feb 16 11:08:01 2010 UTC
# Line 10  Line 10 
10    
11  (in-package :swank-backend)  (in-package :swank-backend)
12    
13    (eval-when (:compile-toplevel :load-toplevel :execute)
14      (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
15        (when (or (not version) (< (symbol-value version) 100201))
16          (error "~&IMPORTANT:~%  ~
17                  The version of ECL you're using (~A) is too old.~%  ~
18                  Please upgrade to at least 10.2.1.~%  ~
19                  Sorry for the inconvenience.~%~%"
20                 (lisp-implementation-version)))))
21    
22  (declaim (optimize (debug 3)))  (declaim (optimize (debug 3)))
23    
24  (defvar *tmp*)  ;;; Swank-mop
25    
26  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
27    (if (find-package :gray)    (import-from :gray *gray-stream-symbols* :swank-backend)
       (import-from :gray *gray-stream-symbols* :swank-backend)  
       (import-from :ext *gray-stream-symbols* :swank-backend))  
28    
29    (swank-backend::import-swank-mop-symbols :clos    (import-swank-mop-symbols :clos
30      '(:eql-specializer      '(:eql-specializer
31        :eql-specializer-object        :eql-specializer-object
32        :generic-function-declarations        :generic-function-declarations
33        :specializer-direct-methods        :specializer-direct-methods
34        :compute-applicable-methods-using-classes)))        :compute-applicable-methods-using-classes)))
35    
36  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)  (eval-when (:compile-toplevel :load-toplevel :execute)
37    (declare (ignore gf classes))    (when (probe-file "sys:serve-event.fas")
38    (values nil nil))      (require :serve-event)
39        (pushnew :serve-event *features*)))
40    
41    
42  ;;;; TCP Server  ;;;; TCP Server
# Line 53  Line 61 
61    (nth-value 1 (sb-bsd-sockets:socket-name socket)))    (nth-value 1 (sb-bsd-sockets:socket-name socket)))
62    
63  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
64      (when (eq (preferred-communication-style) :fd-handler)
65        (remove-fd-handlers socket))
66    (sb-bsd-sockets:socket-close socket))    (sb-bsd-sockets:socket-close socket))
67    
68  (defimplementation accept-connection (socket  (defimplementation accept-connection (socket
69                                        &key external-format                                        &key external-format
70                                        buffering timeout)                                        buffering timeout)
71    (declare (ignore buffering timeout external-format))    (declare (ignore buffering timeout external-format))
72    (make-socket-io-stream (accept socket)))    (sb-bsd-sockets:socket-make-stream (accept socket)
   
 (defun make-socket-io-stream (socket)  
   (sb-bsd-sockets:socket-make-stream socket  
73                                       :output t                                       :output t
74                                       :input t                                       :input t
75                                       :element-type 'base-char))                                       :element-type 'base-char))
   
76  (defun accept (socket)  (defun accept (socket)
77    "Like socket-accept, but retry on EAGAIN."    "Like socket-accept, but retry on EAGAIN."
78    (loop (handler-case    (loop (handler-case
# Line 74  Line 80 
80            (sb-bsd-sockets:interrupted-error ()))))            (sb-bsd-sockets:interrupted-error ()))))
81    
82  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
83    (values nil))    ;; ECL on Windows does not provide condition-variables
84      (or #+ (and threads (not win32) (not win64)) :spawn
85          #+serve-event :fd-handler
86          nil))
87    
88  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
89    '((:iso-8859-1    '((:iso-8859-1
# Line 89  Line 98 
98    
99  ;;;; Unix signals  ;;;; Unix signals
100    
101    (defvar *original-sigint-handler* #'si:terminal-interrupt)
102    
103  (defimplementation install-sigint-handler (handler)  (defimplementation install-sigint-handler (handler)
104      (declare (function handler))
105    (let ((old-handler (symbol-function 'si:terminal-interrupt)))    (let ((old-handler (symbol-function 'si:terminal-interrupt)))
106      (setf (symbol-function 'si:terminal-interrupt)      (setf (symbol-function 'si:terminal-interrupt)
107            (if (consp handler)            (if (eq handler *original-sigint-handler*)
108                (car handler)                handler
109                (lambda (&rest args)                (lambda (&rest args)
110                  (declare (ignore args))                  (declare (ignore args))
111                  (funcall handler)                  (funcall handler)
112                  (continue))))                  (continue))))
113      (list old-handler)))      old-handler))
114    
115    
116  (defimplementation getpid ()  (defimplementation getpid ()
117    (si:getpid))    (si:getpid))
118    
 #+nil  
119  (defimplementation set-default-directory (directory)  (defimplementation set-default-directory (directory)
120    (ext::chdir (namestring directory))    (ext:chdir (namestring directory))  ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
   ;; Setting *default-pathname-defaults* to an absolute directory  
   ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.  
   (setf *default-pathname-defaults* (ext::getcwd))  
121    (default-directory))    (default-directory))
122    
 #+nil  
123  (defimplementation default-directory ()  (defimplementation default-directory ()
124    (namestring (ext:getcwd)))    (namestring (ext:getcwd)))
125    
# Line 120  Line 127 
127    (ext:quit))    (ext:quit))
128    
129    
130    ;;;; Serve Event Handlers
131    
132    ;;; FIXME: verify this is correct implementation
133    
134    #+serve-event
135    (progn
136    
137    (defun socket-fd (socket)
138      (etypecase socket
139        (fixnum socket)
140        (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
141        (file-stream (si:file-stream-fd socket))))
142    
143    (defvar *descriptor-handlers* (make-hash-table :test 'eql))
144    
145    (defimplementation add-fd-handler (socket fun)
146      (let* ((fd (socket-fd socket))
147             (handler (gethash fd *descriptor-handlers*)))
148        (when handler
149          (serve-event:remove-fd-handler handler))
150        (setf (gethash fd *descriptor-handlers*)
151              (serve-event:add-fd-handler fd :input #'(lambda (x)
152                                                        (declare (ignore x))
153                                                        (funcall fun))))
154        (serve-event:serve-event)))
155    
156    (defimplementation remove-fd-handlers (socket)
157      (let ((handler (gethash (socket-fd socket) *descriptor-handlers*)))
158        (when handler
159          (serve-event:remove-fd-handler handler))))
160    
161    (defimplementation wait-for-input (streams &optional timeout)
162      (assert (member timeout '(nil t)))
163      (loop
164         (let ((ready (remove-if-not #'listen streams)))
165           (when ready (return ready)))
166         ;; (when timeout (return nil))
167         (when (check-slime-interrupts) (return :interrupt))
168         (serve-event:serve-event)))
169    
170    ) ; #+serve-event (progn ...
171    
172    
173  ;;;; Compilation  ;;;; Compilation
174    
175  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
176  (defvar *buffer-start-position*)  (defvar *buffer-start-position*)
 (defvar *buffer-string*)  
 (defvar *compile-filename*)  
177    
178  (defun signal-compiler-condition (&rest args)  (defun signal-compiler-condition (&rest args)
179    (signal (apply #'make-condition 'compiler-condition args)))    (signal (apply #'make-condition 'compiler-condition args)))
180    
181  (defun handle-compiler-warning (condition)  (defun handle-compiler-message (condition)
182    (signal-compiler-condition    ;; ECL emits lots of noise in compiler-notes, like "Invoking
183     :original-condition condition    ;; external command".
184     :message (format nil "~A" condition)    (unless (typep condition 'c::compiler-note)
185     :severity :warning      (signal-compiler-condition
186     :location       :original-condition condition
187     (if *buffer-name*       :message (format nil "~A" condition)
188         (make-location (list :buffer *buffer-name*)       :severity (etypecase condition
189                        (list :offset *buffer-start-position* 0))                   (c:compiler-fatal-error :error)
190         ;; ;; compiler::*current-form*                   (c:compiler-error :error)
191         ;; (if compiler::*current-function*                   (error            :error)
192         ;;     (make-location (list :file *compile-filename*)                   (style-warning    :style-warning)
193         ;;                    (list :function-name                   (warning          :warning))
194         ;;                          (symbol-name       :location (condition-location condition))))
195         ;;                           (slot-value compiler::*current-function*  
196         ;;                                       'compiler::name))))  (defun condition-location (condition)
197         (list :error "No location found.")    (let ((file     (c:compiler-message-file condition))
198             ;; )          (position (c:compiler-message-file-position condition)))
199         )))      (if (and position (not (minusp position)))
200            (if *buffer-name*
201                (make-location `(:buffer ,*buffer-name*)
202                               `(:offset ,*buffer-start-position* ,position)
203                               `(:align t))
204                (make-location `(:file ,(namestring file))
205                               `(:position ,(1+ position))
206                               `(:align t)))
207            (make-error-location "No location found."))))
208    
209  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
210    (handler-bind ((warning #'handle-compiler-warning))    (handler-bind ((c:compiler-message #'handle-compiler-message))
211      (funcall function)))      (funcall function)))
212    
213  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
214                                         load-p external-format)                                         load-p external-format)
215    (declare (ignore external-format))    (declare (ignore external-format))
216    (with-compilation-hooks ()    (with-compilation-hooks ()
217      (let ((*buffer-name* nil)      (compile-file input-file :output-file output-file :load load-p)))
           (*compile-filename* input-file))  
       (compile-file input-file :output-file output-file :load t))))  
218    
219  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
220                                           policy)                                           policy)
221    (declare (ignore filename policy))    (declare (ignore filename policy))
222    (with-compilation-hooks ()    (with-compilation-hooks ()
223      (let ((*buffer-name* buffer)      (let ((*buffer-name* buffer)
224            (*buffer-start-position* position)            (*buffer-start-position* position))
           (*buffer-string* string))  
225        (with-input-from-string (s string)        (with-input-from-string (s string)
226          (not (nth-value 2 (compile-from-stream s :load t)))))))          (not (nth-value 2 (compile-from-stream s :load t)))))))
227    
# Line 236  Line 289 
289      (generic-function (clos:generic-function-name f))      (generic-function (clos:generic-function-name f))
290      (function (si:compiled-function-name f))))      (function (si:compiled-function-name f))))
291    
292  (defimplementation macroexpand-all (form)  ;; FIXME
293    ;;; FIXME! This is not the same as a recursive macroexpansion!  ;; (defimplementation macroexpand-all (form))
   (macroexpand form))  
294    
295  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
296    (let ((result '()))    (let ((result '()))
# Line 276  Line 328 
328       si::set-current-ihs       si::set-current-ihs
329       si::tpl-commands)))       si::tpl-commands)))
330    
331    (defun make-invoke-debugger-hook (hook)
332      (when hook
333        #'(lambda (condition old-hook)
334            ;; Regard *debugger-hook* if set by user.
335            (if *debugger-hook*
336                nil         ; decline, *DEBUGGER-HOOK* will be tried next.
337                (funcall hook condition old-hook)))))
338    
339    (defimplementation install-debugger-globally (function)
340      (setq *debugger-hook* function)
341      (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
342    
343    (defimplementation call-with-debugger-hook (hook fun)
344      (let ((*debugger-hook* hook)
345            (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
346            (*ihs-base* (ihs-top)))
347        (funcall fun)))
348    
349  (defvar *backtrace* '())  (defvar *backtrace* '())
350    
351  (defun in-swank-package-p (x)  (defun in-swank-package-p (x)
# Line 305  Line 375 
375       (declare (ignore position))       (declare (ignore position))
376       (if file (is-swank-source-p file)))))       (if file (is-swank-source-p file)))))
377    
 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)  
 (defmacro find-ihs-top (x)  
   (if (< ext:+ecl-version-number+ 90601)  
       `(si::ihs-top ,x)  
       '(si::ihs-top)))  
   
 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)  
 (defmacro find-ihs-top (x)  
   `(si::ihs-top ,x))  
   
378  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
379    (declare (type function debugger-loop-fn))    (declare (type function debugger-loop-fn))
380    (let* ((*tpl-commands* si::tpl-commands)    (let* ((*tpl-commands* si::tpl-commands)
381           (*ihs-top* (find-ihs-top 'call-with-debugging-environment))           (*ihs-top* (ihs-top))
382           (*ihs-current* *ihs-top*)           (*ihs-current* *ihs-top*)
383           (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))           (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
384           (*frs-top* (frs-top))           (*frs-top* (frs-top))
# Line 337  Line 397 
397                     (unless (si::fixnump name)                     (unless (si::fixnump name)
398                       (push name (third x)))))))                       (push name (third x)))))))
399      (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))      (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
     (setf *tmp* *backtrace*)  
400      (set-break-env)      (set-break-env)
401      (set-current-ihs)      (set-current-ihs)
402      (let ((*ihs-base* *ihs-top*))      (let ((*ihs-base* *ihs-top*))
403        (funcall debugger-loop-fn))))        (funcall debugger-loop-fn))))
404    
 (defimplementation call-with-debugger-hook (hook fun)  
   (let ((*debugger-hook* hook)  
         (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))  
     (funcall fun)))  
   
405  (defimplementation compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
406    (when (numberp end)    (when (numberp end)
407      (setf end (min end (length *backtrace*))))      (setf end (min end (length *backtrace*))))
# Line 379  Line 433 
433    (let ((functions '())    (let ((functions '())
434          (blocks '())          (blocks '())
435          (variables '()))          (variables '()))
436      #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)      (setf frame (si::decode-ihs-env (second frame)))
     #.(if (< ext:+ecl-version-number+ 90601)  
         '(setf frame (second frame))  
         '(setf frame (si::decode-ihs-env (second frame))))  
     #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)  
     '(setf frame (second frame))  
437      (dolist (record frame)      (dolist (record frame)
438        (let* ((record0 (car record))        (let* ((record0 (car record))
439               (record1 (cdr record)))               (record1 (cdr record)))
# Line 460  Line 509 
509                         ("Input stream" (two-way-stream-input-stream o))))                         ("Input stream" (two-way-stream-input-stream o))))
510         (ignore-errors (label-value-line*         (ignore-errors (label-value-line*
511                         ("Output stream" (two-way-stream-output-stream o)))))))                         ("Output stream" (two-way-stream-output-stream o)))))))
512      (t      ((si:instancep o)
513       (let* ((cl (si:instance-class o))       (let* ((cl (si:instance-class o))
514              (slots (clos:class-slots cl)))              (slots (clos:class-slots cl)))
515         (list* (format nil "~S is an instance of class ~A~%"         (list* (format nil "~S is an instance of class ~A~%"
516                         o (clos::class-name cl))                        o (clos::class-name cl))
517                 (loop for x in slots append                 (loop for x in slots append
518                      (let* ((name (clos:slot-definition-name x))                      (let* ((name (clos:slot-definition-name x))
519                             (value (clos::slot-value o name)))                             (value (clos::slot-value o name)))
# Line 481  Line 530 
530          `(((defun ,name) ,tmp)))))          `(((defun ,name) ,tmp)))))
531    
532  (defimplementation find-source-location (obj)  (defimplementation find-source-location (obj)
   (setf *tmp* obj)  
533    (or    (or
534     (typecase obj     (typecase obj
535       (function       (function
# Line 492  Line 540 
540                `(:position ,pos)                `(:position ,pos)
541                `(:snippet                `(:snippet
542                  ,(with-open-file (s file)                  ,(with-open-file (s file)
543                       (file-position s pos)
544                                   #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)                     (skip-comments-and-whitespace s)
545                                   (if (< ext:+ecl-version-number+ 90601)                     (read-snippet s))))))))
                                      (skip-toplevel-forms pos s)  
                                      (file-position s pos))  
                                  #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)  
                                  (skip-toplevel-forms pos s)  
                                  (skip-comments-and-whitespace s)  
                                  (read-snippet s))))))))  
546     `(:error ,(format nil "Source definition of ~S not found" obj))))     `(:error ,(format nil "Source definition of ~S not found" obj))))
547    
548  ;;;; Profiling  ;;;; Profiling
549    
550    #+profile
551    (progn
552    
553  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
554    (require 'profile))    (require 'profile))
555    
# Line 531  Line 576 
576  (defimplementation profile-package (package callers methods)  (defimplementation profile-package (package callers methods)
577    (declare (ignore callers methods))    (declare (ignore callers methods))
578    (eval `(profile:profile ,(package-name (find-package package)))))    (eval `(profile:profile ,(package-name (find-package package)))))
579    )                                       ; progn
580    
581  ;;;; Communication-Styles  ;;;; Threads
   
 ;;; :SPAWN  
582    
583  #+threads  #+threads
584  (progn  (progn
   
   ;;; THREAD-PLIST  
   (defvar *thread-plists* (make-hash-table))  
   (defvar *thread-plists-lock*  
     (mp:make-lock :name "thread plists lock"))  
   
   (defun thread-plist (thread)  
     (mp:with-lock (*thread-plists-lock*)  
       ;; FIXME: Do we have to synchronize reads here?  
       (gethash thread *thread-plists*)))  
   
   (defun remove-thread-plist (thread)  
     (mp:with-lock (*thread-plists-lock*)  
       (remhash thread *thread-plists*)))  
   
   (defun put-thread-property (thread property value)  
     (mp:with-lock (*thread-plists-lock*)  
       (setf (getf (gethash thread *thread-plists*) property) value))  
     value)  
   
   ;;; THREAD-ID  
585    (defvar *thread-id-counter* 0)    (defvar *thread-id-counter* 0)
   (defvar *thread-id-counter-lock*  
     (mp:make-lock :name "thread id counter lock"))  
586    
587    (defun next-thread-id ()    (defparameter *thread-id-map* (make-hash-table))
588      (mp:with-lock (*thread-id-counter-lock*)  
589        (incf *thread-id-counter*)))    (defvar *thread-id-map-lock*
590        (mp:make-lock :name "thread id map lock"))
591    
592    (defimplementation spawn (fn &key name)    (defimplementation spawn (fn &key name)
593      (let ((thread (mp:make-process :name name)))      (mp:process-run-function name fn))
594        (put-thread-property thread 'thread-id (next-thread-id))  
595        (mp:process-preset    (defimplementation thread-id (target-thread)
596         thread      (block thread-id
597         #'(lambda ()        (mp:with-lock (*thread-id-map-lock*)
598             ;; ecl doesn't have weak pointers          ;; Does TARGET-THREAD have an id already?
599             (unwind-protect (funcall fn)          (maphash (lambda (id thread-pointer)
600               (remove-thread-plist thread))))                     (let ((thread (si:weak-pointer-value thread-pointer)))
601        (mp:process-enable thread)))                       (cond ((not thread)
602                                (remhash id *thread-id-map*))
603    (defimplementation thread-id (thread)                             ((eq thread target-thread)
604      (or (getf (thread-plist thread) 'thread-id)                              (return-from thread-id id)))))
605          (put-thread-property thread 'thread-id  (next-thread-id))))                   *thread-id-map*)
606            ;; TARGET-THREAD not found in *THREAD-ID-MAP*
607            (let ((id (incf *thread-id-counter*))
608                  (thread-pointer (si:make-weak-pointer target-thread)))
609              (setf (gethash id *thread-id-map*) thread-pointer)
610              id))))
611    
612    (defimplementation find-thread (id)    (defimplementation find-thread (id)
613      (find id (mp:all-processes)      (mp:with-lock (*thread-id-map-lock*)
614            :key #'(lambda (thread)        (let* ((thread-pointer (gethash id *thread-id-map*))
615                     (getf (thread-plist thread) 'thread-id))))               (thread (and thread-pointer (si:weak-pointer-value thread-pointer))))
616            (unless thread
617              (remhash id *thread-id-map*))
618            thread)))
619    
620    (defimplementation thread-name (thread)    (defimplementation thread-name (thread)
621      (mp:process-name thread))      (mp:process-name thread))
622    
623    (defimplementation thread-status (thread)    (defimplementation thread-status (thread)
624      (let ((whostate (process-whostate thread)))      (if (mp:process-active-p thread)
625        (cond (whostate (princ-to-string whostate))          "RUNNING"
626              ((mp:process-active-p thread) "RUNNING")          "STOPPED"))
             (t "STOPPED"))))  
627    
628    (defimplementation make-lock (&key name)    (defimplementation make-lock (&key name)
629      (mp:make-lock :name name))      (mp:make-lock :name name))
# Line 618  Line 647 
647    (defimplementation thread-alive-p (thread)    (defimplementation thread-alive-p (thread)
648      (mp:process-active-p thread))      (mp:process-active-p thread))
649    
650      (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
651      (defvar *mailboxes* (list))
652      (declaim (type list *mailboxes*))
653    
654    (defstruct (mailbox (:conc-name mailbox.))    (defstruct (mailbox (:conc-name mailbox.))
655      (lock (mp:make-lock :name "mailbox lock"))      thread
656      (cvar (mp:make-condition-variable))      (mutex (mp:make-lock))
657        (cvar  (mp:make-condition-variable))
658      (queue '() :type list))      (queue '() :type list))
659    
660    (defun mailbox (thread)    (defun mailbox (thread)
661      "Return THREAD's mailbox."      "Return THREAD's mailbox."
662      (or (getf (thread-plist thread) 'mailbox)      (mp:with-lock (*mailbox-lock*)
663          (put-thread-property thread 'mailbox (make-mailbox))))        (or (find thread *mailboxes* :key #'mailbox.thread)
664              (let ((mb (make-mailbox :thread thread)))
665                (push mb *mailboxes*)
666                mb))))
667    
668    (defimplementation send (thread message)    (defimplementation send (thread message)
669      (let ((mbox (mailbox thread)))      (let* ((mbox (mailbox thread))
670        (mp:with-lock ((mailbox.lock mbox))             (mutex (mailbox.mutex mbox)))
671          (mp:with-lock (mutex)
672          (setf (mailbox.queue mbox)          (setf (mailbox.queue mbox)
673                (nconc (mailbox.queue mbox) (list message)))                (nconc (mailbox.queue mbox) (list message)))
674          (mp:condition-variable-broadcast (mailbox.cvar mbox)))))          (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
675    
676    (defimplementation receive-if (test &optional timeout)    (defimplementation receive-if (test &optional timeout)
677      (let ((mbox (mailbox mp:*current-process*)))      (let* ((mbox (mailbox (current-thread)))
678               (mutex (mailbox.mutex mbox)))
679        (assert (or (not timeout) (eq timeout t)))        (assert (or (not timeout) (eq timeout t)))
680        (loop        (loop
681          (check-slime-interrupts)           (check-slime-interrupts)
682          (mp:with-lock ((mailbox.lock mbox))           (mp:with-lock (mutex)
683            (let* ((q (mailbox.queue mbox))             (let* ((q (mailbox.queue mbox))
684                   (tail (member-if test q)))                    (tail (member-if test q)))
685              (when tail               (when tail
686                (setf (mailbox.queue mbox)                 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
687                      (nconc (ldiff q tail) (cdr tail)))                 (return (car tail))))
688                (return (car tail))))             (when (eq timeout t) (return (values nil t)))
689            (when (eq timeout t) (return (values nil t)))             (mp:condition-variable-timedwait (mailbox.cvar mbox)
690            (mp:condition-variable-timedwait (mailbox.cvar mbox)                                              mutex
691                                             (mailbox.lock mbox)                                              0.2)))))
                                            0.2)))))  
 ) ; #+thread (progn ...  
692    
693      ) ; #+threads (progn ...

Legend:
Removed from v.1.51  
changed lines
  Added in v.1.52

  ViewVC Help
Powered by ViewVC 1.1.5