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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.74 - (hide annotations)
Sun Sep 20 10:51:50 2009 UTC (4 years, 6 months ago) by trittweiler
Branch: MAIN
Changes since 1.73: +4 -4 lines
	* swank-abcl.lisp (thread-description): Fix typo.
	(set-thread-description): Ditto.
1 heller 1.41 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4     ;;;
5 asimon 1.9 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 asimon 1.9 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11     (in-package :swank-backend)
12    
13     (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require :collect) ;just so that it doesn't spoil the flying letters
15 asimon 1.17 (require :pprint))
16    
17 mevenson 1.73 ;;; The introduction of SYS::*INVOKE-DEBUGGER-HOOK* obliterates the
18     ;;; need for redefining BREAK. The following should thus be removed at
19     ;;; some point in the future.
20     #-#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
21 heller 1.25 (defun sys::break (&optional (format-control "BREAK called")
22     &rest format-arguments)
23 trittweiler 1.72 (let ((sys::*saved-backtrace*
24 mevenson 1.68 #+#.(swank-backend::with-symbol 'backtrace 'sys)
25     (sys:backtrace)
26     #-#.(swank-backend::with-symbol 'backtrace 'sys)
27     (ext:backtrace-as-list)
28     ))
29 asimon 1.20 (with-simple-restart (continue "Return from BREAK.")
30     (invoke-debugger
31     (sys::%make-condition 'simple-condition
32     (list :format-control format-control
33     :format-arguments format-arguments))))
34     nil))
35    
36 heller 1.52 (defimplementation make-output-stream (write-string)
37     (ext:make-slime-output-stream write-string))
38    
39     (defimplementation make-input-stream (read-string)
40 heller 1.53 (ext:make-slime-input-stream read-string
41     (make-synonym-stream '*standard-output*)))
42 heller 1.1
43 aruttenberg 1.34 (defimplementation call-with-compilation-hooks (function)
44     (funcall function))
45    
46 asimon 1.12 ;;; swank-mop
47 asimon 1.13
48 aruttenberg 1.36 ;;dummies and definition
49 asimon 1.15
50 asimon 1.12 (defclass standard-slot-definition ()())
51 asimon 1.15
52 aruttenberg 1.36 ;(defun class-finalized-p (class) t)
53 asimon 1.15
54 trittweiler 1.72 (defun slot-definition-documentation (slot)
55     (declare (ignore slot))
56     #+nil (documentation slot 't))
57    
58     (defun slot-definition-type (slot)
59     (declare (ignore slot))
60     t)
61    
62     (defun class-prototype (class)
63     (declare (ignore class))
64     nil)
65    
66     (defun generic-function-declarations (gf)
67     (declare (ignore gf))
68     nil)
69    
70     (defun specializer-direct-methods (spec)
71     (mop::class-direct-methods spec))
72 aruttenberg 1.36
73     (defun slot-definition-name (slot)
74     (mop::%slot-definition-name slot))
75    
76     (defun class-slots (class)
77     (mop::%class-slots class))
78    
79     (defun method-generic-function (method)
80     (mop::%method-generic-function method))
81    
82     (defun method-function (method)
83     (mop::%method-function method))
84    
85 aruttenberg 1.37 (defun slot-boundp-using-class (class object slotdef)
86 trittweiler 1.72 (declare (ignore class))
87 aruttenberg 1.37 (system::slot-boundp object (slot-definition-name slotdef)))
88    
89     (defun slot-value-using-class (class object slotdef)
90 trittweiler 1.72 (declare (ignore class))
91 aruttenberg 1.37 (system::slot-value object (slot-definition-name slotdef)))
92 asimon 1.12
93     (import-to-swank-mop
94     '( ;; classes
95     cl:standard-generic-function
96     standard-slot-definition ;;dummy
97     cl:method
98     cl:standard-class
99     ;; standard-class readers
100 asimon 1.26 mop::class-default-initargs
101     mop::class-direct-default-initargs
102     mop::class-direct-slots
103     mop::class-direct-subclasses
104     mop::class-direct-superclasses
105     mop::eql-specializer
106 aruttenberg 1.36 mop::class-finalized-p
107 asimon 1.12 cl:class-name
108 asimon 1.26 mop::class-precedence-list
109 asimon 1.14 class-prototype ;;dummy
110 aruttenberg 1.36 class-slots
111     specializer-direct-methods
112 asimon 1.17 ;; eql-specializer accessors
113 asimon 1.26 mop::eql-specializer-object
114 asimon 1.12 ;; generic function readers
115 asimon 1.26 mop::generic-function-argument-precedence-order
116 asimon 1.14 generic-function-declarations ;;dummy
117 asimon 1.26 mop::generic-function-lambda-list
118     mop::generic-function-methods
119     mop::generic-function-method-class
120     mop::generic-function-method-combination
121     mop::generic-function-name
122 asimon 1.12 ;; method readers
123 aruttenberg 1.36 method-generic-function
124     method-function
125 asimon 1.26 mop::method-lambda-list
126     mop::method-specializers
127     mop::method-qualifiers
128 asimon 1.12 ;; slot readers
129 asimon 1.26 mop::slot-definition-allocation
130 asimon 1.13 slot-definition-documentation ;;dummy
131 asimon 1.26 mop::slot-definition-initargs
132     mop::slot-definition-initform
133     mop::slot-definition-initfunction
134 aruttenberg 1.36 slot-definition-name
135 asimon 1.13 slot-definition-type ;;dummy
136 asimon 1.26 mop::slot-definition-readers
137 aruttenberg 1.37 mop::slot-definition-writers
138     slot-boundp-using-class
139     slot-value-using-class
140     ))
141 asimon 1.12
142 heller 1.1 ;;;; TCP Server
143    
144    
145     (defimplementation preferred-communication-style ()
146 mevenson 1.67 #+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
147     :spawn
148     #-#.(cl:if (cl:find-package :threads) '(:and) '(:or))
149     nil
150     )
151 heller 1.1
152     (defimplementation create-socket (host port)
153     (ext:make-server-socket port))
154    
155     (defimplementation local-port (socket)
156     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
157    
158     (defimplementation close-socket (socket)
159     (ext:server-socket-close socket))
160    
161 heller 1.23 (defimplementation accept-connection (socket
162 heller 1.40 &key external-format buffering timeout)
163 trittweiler 1.64 (declare (ignore buffering timeout))
164     (ext:get-socket-stream (ext:socket-accept socket)
165     :external-format external-format))
166    
167     ;;;; External formats
168    
169     (defvar *external-format-to-coding-system*
170     '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
171     ((:iso-8859-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
172     (:utf-8 "utf-8")
173     ((:utf-8 :eol-style :lf) "utf-8-unix")
174     (:euc-jp "euc-jp")
175     ((:euc-jp :eol-style :lf) "euc-jp-unix")
176     (:us-ascii "us-ascii")
177     ((:us-ascii :eol-style :lf) "us-ascii-unix")))
178    
179     (defimplementation find-external-format (coding-system)
180     (car (rassoc-if (lambda (x)
181     (member coding-system x :test #'equal))
182     *external-format-to-coding-system*)))
183 heller 1.1
184     ;;;; Unix signals
185    
186     (defimplementation call-without-interrupts (fn)
187     (funcall fn))
188    
189     (defimplementation getpid ()
190 heller 1.48 (handler-case
191 trittweiler 1.44 (let* ((runtime
192     (java:jstatic "getRuntime" "java.lang.Runtime"))
193     (command
194     (java:jnew-array-from-array
195     "java.lang.String" #("sh" "-c" "echo $PPID")))
196     (runtime-exec-jmethod
197     ;; Complicated because java.lang.Runtime.exec() is
198     ;; overloaded on a non-primitive type (array of
199 heller 1.48 ;; java.lang.String), so we have to use the actual
200     ;; parameter instance to get java.lang.Class
201 trittweiler 1.44 (java:jmethod "java.lang.Runtime" "exec"
202     (java:jcall
203     (java:jmethod "java.lang.Object" "getClass")
204     command)))
205     (process
206     (java:jcall runtime-exec-jmethod runtime command))
207     (output
208 heller 1.48 (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
209 trittweiler 1.44 process)))
210 heller 1.48 (java:jcall (java:jmethod "java.lang.Process" "waitFor")
211     process)
212     (loop :with b :do
213     (setq b
214     (java:jcall (java:jmethod "java.io.InputStream" "read")
215     output))
216     :until (member b '(-1 #x0a)) ; Either EOF or LF
217     :collecting (code-char b) :into result
218     :finally (return
219     (parse-integer (coerce result 'string)))))
220     (t () 0)))
221 heller 1.1
222     (defimplementation lisp-implementation-type-name ()
223     "armedbear")
224    
225     (defimplementation set-default-directory (directory)
226     (let ((dir (sys::probe-directory directory)))
227     (when dir (setf *default-pathname-defaults* dir))
228     (namestring dir)))
229    
230    
231     ;;;; Misc
232    
233 heller 1.40 (defimplementation arglist (fun)
234     (cond ((symbolp fun)
235 mevenson 1.69 (multiple-value-bind (arglist present)
236     (or (sys::arglist fun)
237     (and (fboundp fun)
238     (typep (symbol-function fun) 'standard-generic-function)
239     (let ((it (mop::generic-function-lambda-list (symbol-function fun))))
240     (values it it))))
241 heller 1.40 (if present arglist :not-available)))
242     (t :not-available)))
243 asimon 1.13
244     (defimplementation function-name (function)
245     (nth-value 2 (function-lambda-expression function)))
246 heller 1.1
247     (defimplementation macroexpand-all (form)
248     (macroexpand form))
249    
250     (defimplementation describe-symbol-for-emacs (symbol)
251     (let ((result '()))
252     (flet ((doc (kind &optional (sym symbol))
253     (or (documentation sym kind) :not-documented))
254     (maybe-push (property value)
255     (when value
256     (setf result (list* property value result)))))
257     (maybe-push
258     :variable (when (boundp symbol)
259     (doc 'variable)))
260     (maybe-push
261     :function (if (fboundp symbol)
262     (doc 'function)))
263     (maybe-push
264     :class (if (find-class symbol nil)
265     (doc 'class)))
266     result)))
267    
268    
269     (defimplementation describe-definition (symbol namespace)
270     (ecase namespace
271     (:variable
272     (describe symbol))
273     ((:function :generic-function)
274     (describe (symbol-function symbol)))
275     (:class
276     (describe (find-class symbol)))))
277    
278     (defimplementation describe-definition (symbol namespace)
279     (ecase namespace
280     (:variable
281     (describe symbol))
282     ((:function :generic-function)
283     (describe (symbol-function symbol)))
284     (:class
285     (describe (find-class symbol)))))
286    
287    
288     ;;;; Debugger
289    
290 mevenson 1.73 ;;; Copied from swank-sbcl.lisp.
291     (defun make-invoke-debugger-hook (hook)
292     #'(lambda (condition old-hook)
293     ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
294     ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
295     ;; run when it was established locally by a user (i.e. changed
296     ;; meanwhile.)
297     (if *debugger-hook*
298     (funcall *debugger-hook* condition old-hook)
299     (funcall hook condition old-hook))))
300    
301     (defimplementation call-with-debugger-hook (hook fun)
302     (let ((*debugger-hook* hook)
303     #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
304     (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
305     (funcall fun)))
306    
307     (defimplementation install-debugger-globally (function)
308     (setq *debugger-hook* function)
309     #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
310     (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
311    
312 heller 1.1 (defvar *sldb-topframe*)
313    
314     (defimplementation call-with-debugging-environment (debugger-loop-fn)
315 mevenson 1.68 (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
316     (*sldb-topframe*
317     #+#.(swank-backend::with-symbol 'backtrace 'sys)
318     (second (member magic-token (sys:backtrace)
319     :key #'(lambda (frame)
320     (first (sys:frame-to-list frame)))))
321     #-#.(swank-backend::with-symbol 'backtrace 'sys)
322     (second (member magic-token (ext:backtrace-as-list)
323     :key #'(lambda (frame)
324     (first frame))))
325 trittweiler 1.72 ))
326 heller 1.1 (funcall debugger-loop-fn)))
327    
328 mevenson 1.68 (defun backtrace (start end)
329     "A backtrace without initial SWANK frames."
330     (let ((backtrace
331     #+#.(swank-backend::with-symbol 'backtrace 'sys)
332     (sys:backtrace)
333     #-#.(swank-backend::with-symbol 'backtrace 'sys)
334     (ext:backtrace-as-list)
335     ))
336     (subseq (or (member *sldb-topframe* backtrace) backtrace)
337     start end)))
338    
339 heller 1.1 (defun nth-frame (index)
340 mevenson 1.68 (nth index (backtrace 0 nil)))
341 heller 1.1
342     (defimplementation compute-backtrace (start end)
343     (let ((end (or end most-positive-fixnum)))
344 mevenson 1.68 (backtrace start end)))
345 heller 1.1
346 heller 1.58 (defimplementation print-frame (frame stream)
347 trittweiler 1.74 (write-string
348 mevenson 1.68 #+#.(swank-backend::with-symbol 'backtrace 'sys)
349     (sys:frame-to-string frame)
350     #-#.(swank-backend::with-symbol 'backtrace 'sys)
351     (string-trim '(#\space #\newline) (prin1-to-string frame))
352     stream))
353 heller 1.1
354     (defimplementation frame-locals (index)
355 aruttenberg 1.31 `(,(list :name "??" :id 0 :value "??")))
356 heller 1.25
357 heller 1.1 #+nil
358     (defimplementation disassemble-frame (index)
359     (disassemble (debugger:frame-function (nth-frame index))))
360    
361 heller 1.65 (defimplementation frame-source-location (index)
362 heller 1.1 (list :error (format nil "Cannot find source for frame: ~A"
363     (nth-frame index))))
364    
365     #+nil
366     (defimplementation eval-in-frame (form frame-number)
367     (debugger:eval-form-in-context
368     form
369     (debugger:environment-of-frame (nth-frame frame-number))))
370    
371     #+nil
372     (defimplementation return-from-frame (frame-number form)
373     (let ((frame (nth-frame frame-number)))
374     (multiple-value-call #'debugger:frame-return
375     frame (debugger:eval-form-in-context
376     form
377     (debugger:environment-of-frame frame)))))
378    
379     ;;; XXX doesn't work for frames with arguments
380     #+nil
381     (defimplementation restart-frame (frame-number)
382     (let ((frame (nth-frame frame-number)))
383     (debugger:frame-retry frame (debugger:frame-function frame))))
384    
385     ;;;; Compiler hooks
386    
387     (defvar *buffer-name* nil)
388     (defvar *buffer-start-position*)
389     (defvar *buffer-string*)
390     (defvar *compile-filename*)
391    
392 aruttenberg 1.38 (in-package :swank-backend)
393    
394 heller 1.1 (defun handle-compiler-warning (condition)
395 heller 1.59 (let ((loc (when (and jvm::*compile-file-pathname*
396     system::*source-position*)
397     (cons jvm::*compile-file-pathname* system::*source-position*))))
398     ;; filter condition signaled more than once.
399     (unless (member condition *abcl-signaled-conditions*)
400 aruttenberg 1.38 (push condition *abcl-signaled-conditions*)
401     (signal (make-condition
402     'compiler-condition
403     :original-condition condition
404     :severity :warning
405     :message (format nil "~A" condition)
406     :location (cond (*buffer-name*
407     (make-location
408     (list :buffer *buffer-name*)
409 heller 1.55 (list :offset *buffer-start-position* 0)))
410 aruttenberg 1.38 (loc
411     (destructuring-bind (file . pos) loc
412     (make-location
413     (list :file (namestring (truename file)))
414     (list :position (1+ pos)))))
415     (t
416 heller 1.1 (make-location
417 heller 1.59 (list :file (namestring *compile-filename*))
418 aruttenberg 1.38 (list :position 1)))))))))
419    
420     (defvar *abcl-signaled-conditions*)
421 heller 1.1
422 heller 1.63 (defimplementation swank-compile-file (input-file output-file
423     load-p external-format)
424 heller 1.27 (declare (ignore external-format))
425 aruttenberg 1.38 (let ((jvm::*resignal-compiler-warnings* t)
426     (*abcl-signaled-conditions* nil))
427     (handler-bind ((warning #'handle-compiler-warning))
428     (let ((*buffer-name* nil)
429 heller 1.63 (*compile-filename* input-file))
430     (multiple-value-bind (fn warn fail)
431     (compile-file input-file :output-file output-file)
432 heller 1.56 (values fn warn
433 trittweiler 1.72 (and fn load-p
434     (not (load fn)))))))))
435 heller 1.1
436 heller 1.62 (defimplementation swank-compile-string (string &key buffer position filename
437     policy)
438     (declare (ignore filename policy))
439 aruttenberg 1.38 (let ((jvm::*resignal-compiler-warnings* t)
440     (*abcl-signaled-conditions* nil))
441     (handler-bind ((warning #'handle-compiler-warning))
442     (let ((*buffer-name* buffer)
443     (*buffer-start-position* position)
444     (*buffer-string* string))
445     (funcall (compile nil (read-from-string
446 heller 1.57 (format nil "(~S () ~A)" 'lambda string))))
447     t))))
448 heller 1.1
449     #|
450     ;;;; Definition Finding
451    
452     (defun find-fspec-location (fspec type)
453     (let ((file (excl::fspec-pathname fspec type)))
454     (etypecase file
455     (pathname
456     (let ((start (scm:find-definition-in-file fspec type file)))
457     (make-location (list :file (namestring (truename file)))
458     (if start
459     (list :position (1+ start))
460     (list :function-name (string fspec))))))
461     ((member :top-level)
462     (list :error (format nil "Defined at toplevel: ~A" fspec)))
463     (null
464     (list :error (format nil "Unkown source location for ~A" fspec))))))
465    
466     (defun fspec-definition-locations (fspec)
467     (let ((defs (excl::find-multiple-definitions fspec)))
468     (loop for (fspec type) in defs
469     collect (list fspec (find-fspec-location fspec type)))))
470    
471     (defimplementation find-definitions (symbol)
472     (fspec-definition-locations symbol))
473    
474     |#
475    
476 asimon 1.2 (defun source-location (symbol)
477 asimon 1.24 (when (pathnamep (ext:source-pathname symbol))
478 mevenson 1.69 (let ((pos (ext:source-file-position symbol)))
479     `(((,symbol)
480     (:location
481     (:file ,(namestring (ext:source-pathname symbol)))
482 mevenson 1.71 ,(if pos
483     (list :position (1+ pos))
484 mevenson 1.69 (list :function-name (string symbol)))
485     (:align t)))))))
486 asimon 1.2
487     (defimplementation find-definitions (symbol)
488     (source-location symbol))
489    
490 asimon 1.17 #|
491     Uncomment this if you have patched xref.lisp, as in
492     http://article.gmane.org/gmane.lisp.slime.devel/2425
493     Also, make sure that xref.lisp is loaded by modifying the armedbear
494     part of *sysdep-pathnames* in swank.loader.lisp.
495 asimon 1.2
496 heller 1.1 ;;;; XREF
497 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
498 heller 1.1
499     (defmacro defxref (name function)
500     `(defimplementation ,name (name)
501     (xref-results (,function name))))
502    
503     (defxref who-calls pxref:list-callers)
504     (defxref who-references pxref:list-readers)
505     (defxref who-binds pxref:list-setters)
506     (defxref who-sets pxref:list-setters)
507     (defxref list-callers pxref:list-callers)
508     (defxref list-callees pxref:list-callees)
509    
510     (defun xref-results (symbols)
511     (let ((xrefs '()))
512     (dolist (symbol symbols)
513 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
514 heller 1.1 xrefs))
515     |#
516    
517 asimon 1.15 ;;;; Inspecting
518    
519 heller 1.46 (defmethod emacs-inspect ((slot mop::slot-definition))
520 asimon 1.28 `("Name: " (:value ,(mop::%slot-definition-name slot))
521 asimon 1.15 (:newline)
522     "Documentation:" (:newline)
523     ,@(when (slot-definition-documentation slot)
524     `((:value ,(slot-definition-documentation slot)) (:newline)))
525     "Initialization:" (:newline)
526 asimon 1.28 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
527     " Form: " ,(if (mop::%slot-definition-initfunction slot)
528     `(:value ,(mop::%slot-definition-initform slot))
529 asimon 1.15 "#<unspecified>") (:newline)
530 asimon 1.28 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
531 heller 1.47 (:newline)))
532 asimon 1.16
533 heller 1.46 (defmethod emacs-inspect ((f function))
534 asimon 1.17 `(,@(when (function-name f)
535     `("Name: "
536     ,(princ-to-string (function-name f)) (:newline)))
537     ,@(multiple-value-bind (args present)
538     (sys::arglist f)
539     (when present `("Argument list: " ,(princ-to-string args) (:newline))))
540 asimon 1.16 (:newline)
541     #+nil,@(when (documentation f t)
542     `("Documentation:" (:newline) ,(documentation f t) (:newline)))
543     ,@(when (function-lambda-expression f)
544     `("Lambda expression:"
545 heller 1.47 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
546 asimon 1.15
547 heller 1.1 #|
548    
549 heller 1.46 (defmethod emacs-inspect ((o t))
550 heller 1.1 (let* ((class (class-of o))
551 asimon 1.26 (slots (mop::class-slots class)))
552 heller 1.1 (mapcar (lambda (slot)
553 asimon 1.26 (let ((name (mop::slot-definition-name slot)))
554 heller 1.1 (cons (princ-to-string name)
555     (slot-value o name))))
556 heller 1.47 slots)))
557 heller 1.1 |#
558 asimon 1.15
559 heller 1.1 ;;;; Multithreading
560    
561 mevenson 1.67 #+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
562     (progn
563     (defimplementation spawn (fn &key name)
564     (threads:make-thread (lambda () (funcall fn)) :name name))
565    
566     (defvar *thread-plists* (make-hash-table) ; should be a weak table
567     "A hashtable mapping threads to a plist.")
568    
569     (defvar *thread-id-counter* 0)
570    
571     (defimplementation thread-id (thread)
572     (threads:synchronized-on *thread-plists*
573     (or (getf (gethash thread *thread-plists*) 'id)
574     (setf (getf (gethash thread *thread-plists*) 'id)
575 heller 1.6 (incf *thread-id-counter*)))))
576    
577 mevenson 1.67 (defimplementation find-thread (id)
578     (find id (all-threads)
579 asimon 1.7 :key (lambda (thread)
580 mevenson 1.67 (getf (gethash thread *thread-plists*) 'id))))
581 heller 1.6
582 mevenson 1.67 (defimplementation thread-name (thread)
583     (threads:thread-name thread))
584 heller 1.1
585 mevenson 1.67 (defimplementation thread-status (thread)
586     (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
587 heller 1.1
588 mevenson 1.67 ;; XXX should be a weak hash table
589     (defparameter *thread-description-map* (make-hash-table))
590    
591     (defimplementation thread-description (thread)
592 trittweiler 1.74 (threads:synchronized-on *thread-description-map*
593 mevenson 1.67 (or (gethash thread *thread-description-map*)
594 trittweiler 1.74 "")))
595 mevenson 1.67
596     (defimplementation set-thread-description (thread description)
597 trittweiler 1.74 (threads:synchronized-on *thread-description-map*
598 mevenson 1.67 (setf (gethash thread *thread-description-map*) description)))
599    
600     (defimplementation make-lock (&key name)
601     (declare (ignore name))
602     (threads:make-thread-lock))
603    
604     (defimplementation call-with-lock-held (lock function)
605     (threads:with-thread-lock (lock) (funcall function)))
606    
607     (defimplementation current-thread ()
608     (threads:current-thread))
609    
610     (defimplementation all-threads ()
611     (copy-list (threads:mapcar-threads #'identity)))
612    
613     (defimplementation thread-alive-p (thread)
614     (member thread (all-threads)))
615    
616     (defimplementation interrupt-thread (thread fn)
617     (threads:interrupt-thread thread fn))
618    
619     (defimplementation kill-thread (thread)
620     (threads:destroy-thread thread))
621    
622     (defstruct mailbox
623     (queue '()))
624    
625     (defun mailbox (thread)
626     "Return THREAD's mailbox."
627     (threads:synchronized-on *thread-plists*
628     (or (getf (gethash thread *thread-plists*) 'mailbox)
629     (setf (getf (gethash thread *thread-plists*) 'mailbox)
630     (make-mailbox)))))
631    
632     (defimplementation send (thread message)
633     (let ((mbox (mailbox thread)))
634     (threads:synchronized-on mbox
635     (setf (mailbox-queue mbox)
636     (nconc (mailbox-queue mbox) (list message)))
637     (threads:object-notify-all mbox))))
638    
639     (defimplementation receive-if (test &optional timeout)
640     (let* ((mbox (mailbox (current-thread))))
641     (assert (or (not timeout) (eq timeout t)))
642     (loop
643     (check-slime-interrupts)
644     (threads:synchronized-on mbox
645     (let* ((q (mailbox-queue mbox))
646     (tail (member-if test q)))
647     (when tail
648     (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
649     (return (car tail)))
650     (when (eq timeout t) (return (values nil t)))
651     (threads:object-wait mbox 0.3)))))))
652 heller 1.1
653     (defimplementation quit-lisp ()
654     (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5