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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5