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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.95 - (show annotations)
Wed Jun 26 11:46:49 2013 UTC (9 months, 3 weeks ago) by mevenson
Branch: MAIN
CVS Tags: HEAD
Changes since 1.94: +1 -1 lines
* swank-abcl.lisp (specializer-direct-methods): Correct symbol definition, allowing SLIME inspector to work again.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 ;;;
3 ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4 ;;;
5 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
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 (require :pprint)
16 (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
17 0.22)
18 () "This file needs ABCL version 0.22 or newer"))
19
20 (defimplementation make-output-stream (write-string)
21 (ext:make-slime-output-stream write-string))
22
23 (defimplementation make-input-stream (read-string)
24 (ext:make-slime-input-stream read-string
25 (make-synonym-stream '*standard-output*)))
26
27 (defimplementation call-with-compilation-hooks (function)
28 (funcall function))
29
30 ;;; swank-mop
31
32 ;;dummies and definition
33
34 (defclass standard-slot-definition ()())
35
36 ;(defun class-finalized-p (class) t)
37
38 (defun slot-definition-documentation (slot)
39 (declare (ignore slot))
40 #+nil (documentation slot 't))
41
42 (defun slot-definition-type (slot)
43 (declare (ignore slot))
44 t)
45
46 (defun class-prototype (class)
47 (declare (ignore class))
48 nil)
49
50 (defun generic-function-declarations (gf)
51 (declare (ignore gf))
52 nil)
53
54 (defun specializer-direct-methods (spec)
55 (mop::class-direct-methods spec))
56
57 (defun slot-definition-name (slot)
58 (mop::slot-definition-name slot))
59
60 (defun class-slots (class)
61 (mop:class-slots class))
62
63 (defun method-generic-function (method)
64 (mop::%method-generic-function method))
65
66 (defun method-function (method)
67 (mop::%method-function method))
68
69 (defun slot-boundp-using-class (class object slotdef)
70 (declare (ignore class))
71 (system::slot-boundp object (slot-definition-name slotdef)))
72
73 (defun slot-value-using-class (class object slotdef)
74 (declare (ignore class))
75 (system::slot-value object (slot-definition-name slotdef)))
76
77 (import-to-swank-mop
78 '( ;; classes
79 cl:standard-generic-function
80 standard-slot-definition ;;dummy
81 cl:method
82 cl:standard-class
83 #+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes
84 'mop)
85 mop::compute-applicable-methods-using-classes
86 ;; standard-class readers
87 mop::class-default-initargs
88 mop::class-direct-default-initargs
89 mop::class-direct-slots
90 mop::class-direct-subclasses
91 mop::class-direct-superclasses
92 mop::eql-specializer
93 mop::class-finalized-p
94 mop:finalize-inheritance
95 cl:class-name
96 mop::class-precedence-list
97 class-prototype ;;dummy
98 class-slots
99 specializer-direct-methods
100 ;; eql-specializer accessors
101 mop::eql-specializer-object
102 ;; generic function readers
103 mop::generic-function-argument-precedence-order
104 generic-function-declarations ;;dummy
105 mop::generic-function-lambda-list
106 mop::generic-function-methods
107 mop::generic-function-method-class
108 mop::generic-function-method-combination
109 mop::generic-function-name
110 ;; method readers
111 method-generic-function
112 method-function
113 mop::method-lambda-list
114 mop::method-specializers
115 mop::method-qualifiers
116 ;; slot readers
117 mop::slot-definition-allocation
118 slot-definition-documentation ;;dummy
119 mop::slot-definition-initargs
120 mop::slot-definition-initform
121 mop::slot-definition-initfunction
122 slot-definition-name
123 slot-definition-type ;;dummy
124 mop::slot-definition-readers
125 mop::slot-definition-writers
126 slot-boundp-using-class
127 slot-value-using-class
128 ))
129
130 ;;;; TCP Server
131
132
133 (defimplementation preferred-communication-style ()
134 :spawn)
135
136 (defimplementation create-socket (host port &key backlog)
137 (ext:make-server-socket port))
138
139 (defimplementation local-port (socket)
140 (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
141
142 (defimplementation close-socket (socket)
143 (ext:server-socket-close socket))
144
145 (defimplementation accept-connection (socket
146 &key external-format buffering timeout)
147 (declare (ignore buffering timeout))
148 (ext:get-socket-stream (ext:socket-accept socket)
149 :element-type (if external-format
150 'character
151 '(unsigned-byte 8))
152 :external-format (or external-format :default)))
153
154 ;;;; UTF8
155
156 ;; faster please!
157 (defimplementation string-to-utf8 (s)
158 (jbytes-to-octets
159 (java:jcall
160 (java:jmethod "java.lang.String" "getBytes" "java.lang.String")
161 s
162 "UTF8")))
163
164 (defimplementation utf8-to-string (u)
165 (java:jnew
166 (java:jconstructor "org.armedbear.lisp.SimpleString"
167 "java.lang.String")
168 (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
169 (octets-to-jbytes u)
170 "UTF8")))
171
172 (defun octets-to-jbytes (octets)
173 (declare (type octets (simple-array (unsigned-byte 8) (*))))
174 (let* ((len (length octets))
175 (bytes (java:jnew-array "byte" len)))
176 (loop for byte across octets
177 for i from 0
178 do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
179 "java.lang.Object" "int" "byte")
180 "java.lang.relect.Array"
181 bytes i byte))
182 bytes))
183
184 (defun jbytes-to-octets (jbytes)
185 (let* ((len (java:jarray-length jbytes))
186 (octets (make-array len :element-type '(unsigned-byte 8))))
187 (loop for i from 0 below len
188 for jbyte = (java:jarray-ref jbytes i)
189 do (setf (aref octets i) jbyte))
190 octets))
191
192 ;;;; External formats
193
194 (defvar *external-format-to-coding-system*
195 '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
196 ((:iso-8859-1 :eol-style :lf)
197 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
198 (:utf-8 "utf-8")
199 ((:utf-8 :eol-style :lf) "utf-8-unix")
200 (:euc-jp "euc-jp")
201 ((:euc-jp :eol-style :lf) "euc-jp-unix")
202 (:us-ascii "us-ascii")
203 ((:us-ascii :eol-style :lf) "us-ascii-unix")))
204
205 (defimplementation find-external-format (coding-system)
206 (car (rassoc-if (lambda (x)
207 (member coding-system x :test #'equal))
208 *external-format-to-coding-system*)))
209
210 ;;;; Unix signals
211
212 (defimplementation getpid ()
213 (handler-case
214 (let* ((runtime
215 (java:jstatic "getRuntime" "java.lang.Runtime"))
216 (command
217 (java:jnew-array-from-array
218 "java.lang.String" #("sh" "-c" "echo $PPID")))
219 (runtime-exec-jmethod
220 ;; Complicated because java.lang.Runtime.exec() is
221 ;; overloaded on a non-primitive type (array of
222 ;; java.lang.String), so we have to use the actual
223 ;; parameter instance to get java.lang.Class
224 (java:jmethod "java.lang.Runtime" "exec"
225 (java:jcall
226 (java:jmethod "java.lang.Object" "getClass")
227 command)))
228 (process
229 (java:jcall runtime-exec-jmethod runtime command))
230 (output
231 (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
232 process)))
233 (java:jcall (java:jmethod "java.lang.Process" "waitFor")
234 process)
235 (loop :with b :do
236 (setq b
237 (java:jcall (java:jmethod "java.io.InputStream" "read")
238 output))
239 :until (member b '(-1 #x0a)) ; Either EOF or LF
240 :collecting (code-char b) :into result
241 :finally (return
242 (parse-integer (coerce result 'string)))))
243 (t () 0)))
244
245 (defimplementation lisp-implementation-type-name ()
246 "armedbear")
247
248 (defimplementation set-default-directory (directory)
249 (let ((dir (sys::probe-directory directory)))
250 (when dir (setf *default-pathname-defaults* dir))
251 (namestring dir)))
252
253
254 ;;;; Misc
255
256 (defimplementation arglist (fun)
257 (cond ((symbolp fun)
258 (multiple-value-bind (arglist present)
259 (sys::arglist fun)
260 (when (and (not present)
261 (fboundp fun)
262 (typep (symbol-function fun)
263 'standard-generic-function))
264 (setq arglist
265 (mop::generic-function-lambda-list (symbol-function fun))
266 present
267 t))
268 (if present arglist :not-available)))
269 (t :not-available)))
270
271 (defimplementation function-name (function)
272 (nth-value 2 (function-lambda-expression function)))
273
274 (defimplementation macroexpand-all (form)
275 (macroexpand form))
276
277 (defimplementation describe-symbol-for-emacs (symbol)
278 (let ((result '()))
279 (flet ((doc (kind &optional (sym symbol))
280 (or (documentation sym kind) :not-documented))
281 (maybe-push (property value)
282 (when value
283 (setf result (list* property value result)))))
284 (maybe-push
285 :variable (when (boundp symbol)
286 (doc 'variable)))
287 (when (fboundp symbol)
288 (maybe-push
289 (cond ((macro-function symbol) :macro)
290 ((special-operator-p symbol) :special-operator)
291 ((typep (fdefinition symbol) 'generic-function)
292 :generic-function)
293 (t :function))
294 (doc 'function)))
295 (maybe-push
296 :class (if (find-class symbol nil)
297 (doc 'class)))
298 result)))
299
300 (defimplementation describe-definition (symbol namespace)
301 (ecase namespace
302 (:variable
303 (describe symbol))
304 ((:function :generic-function)
305 (describe (symbol-function symbol)))
306 (:class
307 (describe (find-class symbol)))))
308
309 (defimplementation describe-definition (symbol namespace)
310 (ecase namespace
311 (:variable
312 (describe symbol))
313 ((:function :generic-function)
314 (describe (symbol-function symbol)))
315 (:class
316 (describe (find-class symbol)))))
317
318
319 ;;;; Debugger
320
321 ;; Copied from swank-sbcl.lisp.
322 ;;
323 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
324 ;; so we have to make sure that the latter gets run when it was
325 ;; established locally by a user (i.e. changed meanwhile.)
326 (defun make-invoke-debugger-hook (hook)
327 (lambda (condition old-hook)
328 (if *debugger-hook*
329 (funcall *debugger-hook* condition old-hook)
330 (funcall hook condition old-hook))))
331
332 (defimplementation call-with-debugger-hook (hook fun)
333 (let ((*debugger-hook* hook)
334 (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
335 (funcall fun)))
336
337 (defimplementation install-debugger-globally (function)
338 (setq *debugger-hook* function)
339 (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
340
341 (defvar *sldb-topframe*)
342
343 (defimplementation call-with-debugging-environment (debugger-loop-fn)
344 (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
345 (*sldb-topframe*
346 (second (member magic-token (sys:backtrace)
347 :key (lambda (frame)
348 (first (sys:frame-to-list frame)))))))
349 (funcall debugger-loop-fn)))
350
351 (defun backtrace (start end)
352 "A backtrace without initial SWANK frames."
353 (let ((backtrace (sys:backtrace)))
354 (subseq (or (member *sldb-topframe* backtrace) backtrace)
355 start end)))
356
357 (defun nth-frame (index)
358 (nth index (backtrace 0 nil)))
359
360 (defimplementation compute-backtrace (start end)
361 (let ((end (or end most-positive-fixnum)))
362 (backtrace start end)))
363
364 (defimplementation print-frame (frame stream)
365 (write-string (sys:frame-to-string frame)
366 stream))
367
368 (defimplementation frame-locals (index)
369 `(,(list :name "??" :id 0 :value "??")))
370
371 #+nil
372 (defimplementation disassemble-frame (index)
373 (disassemble (debugger:frame-function (nth-frame index))))
374
375 (defimplementation frame-source-location (index)
376 (let ((frame (nth-frame index)))
377 (or (source-location (nth-frame index))
378 `(:error ,(format nil "No source for frame: ~a" frame)))))
379
380 #+nil
381 (defimplementation eval-in-frame (form frame-number)
382 (debugger:eval-form-in-context
383 form
384 (debugger:environment-of-frame (nth-frame frame-number))))
385
386 #+nil
387 (defimplementation return-from-frame (frame-number form)
388 (let ((frame (nth-frame frame-number)))
389 (multiple-value-call #'debugger:frame-return
390 frame (debugger:eval-form-in-context
391 form
392 (debugger:environment-of-frame frame)))))
393
394 ;;; XXX doesn't work for frames with arguments
395 #+nil
396 (defimplementation restart-frame (frame-number)
397 (let ((frame (nth-frame frame-number)))
398 (debugger:frame-retry frame (debugger:frame-function frame))))
399
400 ;;;; Compiler hooks
401
402 (defvar *buffer-name* nil)
403 (defvar *buffer-start-position*)
404 (defvar *buffer-string*)
405 (defvar *compile-filename*)
406
407 (in-package :swank-backend)
408
409 (defvar *abcl-signaled-conditions*)
410
411 (defun handle-compiler-warning (condition)
412 (let ((loc (when (and jvm::*compile-file-pathname*
413 system::*source-position*)
414 (cons jvm::*compile-file-pathname* system::*source-position*))))
415 ;; filter condition signaled more than once.
416 (unless (member condition *abcl-signaled-conditions*)
417 (push condition *abcl-signaled-conditions*)
418 (signal 'compiler-condition
419 :original-condition condition
420 :severity :warning
421 :message (format nil "~A" condition)
422 :location (cond (*buffer-name*
423 (make-location
424 (list :buffer *buffer-name*)
425 (list :offset *buffer-start-position* 0)))
426 (loc
427 (destructuring-bind (file . pos) loc
428 (make-location
429 (list :file (namestring (truename file)))
430 (list :position (1+ pos)))))
431 (t
432 (make-location
433 (list :file (namestring *compile-filename*))
434 (list :position 1))))))))
435
436 (defimplementation swank-compile-file (input-file output-file
437 load-p external-format
438 &key policy)
439 (declare (ignore external-format policy))
440 (let ((jvm::*resignal-compiler-warnings* t)
441 (*abcl-signaled-conditions* nil))
442 (handler-bind ((warning #'handle-compiler-warning))
443 (let ((*buffer-name* nil)
444 (*compile-filename* input-file))
445 (multiple-value-bind (fn warn fail)
446 (compile-file input-file :output-file output-file)
447 (values fn warn
448 (and fn load-p
449 (not (load fn)))))))))
450
451 (defimplementation swank-compile-string (string &key buffer position filename
452 policy)
453 (declare (ignore filename policy))
454 (let ((jvm::*resignal-compiler-warnings* t)
455 (*abcl-signaled-conditions* nil))
456 (handler-bind ((warning #'handle-compiler-warning))
457 (let ((*buffer-name* buffer)
458 (*buffer-start-position* position)
459 (*buffer-string* string))
460 (funcall (compile nil (read-from-string
461 (format nil "(~S () ~A)" 'lambda string))))
462 t))))
463
464 #|
465 ;;;; Definition Finding
466
467 (defun find-fspec-location (fspec type)
468 (let ((file (excl::fspec-pathname fspec type)))
469 (etypecase file
470 (pathname
471 (let ((start (scm:find-definition-in-file fspec type file)))
472 (make-location (list :file (namestring (truename file)))
473 (if start
474 (list :position (1+ start))
475 (list :function-name (string fspec))))))
476 ((member :top-level)
477 (list :error (format nil "Defined at toplevel: ~A" fspec)))
478 (null
479 (list :error (format nil "Unkown source location for ~A" fspec))))))
480
481 (defun fspec-definition-locations (fspec)
482 (let ((defs (excl::find-multiple-definitions fspec)))
483 (loop for (fspec type) in defs
484 collect (list fspec (find-fspec-location fspec type)))))
485
486 (defimplementation find-definitions (symbol)
487 (fspec-definition-locations symbol))
488 |#
489
490 (defgeneric source-location (object))
491
492 (defmethod source-location ((symbol symbol))
493 (when (pathnamep (ext:source-pathname symbol))
494 (let ((pos (ext:source-file-position symbol)))
495 `(:location
496 (:file ,(namestring (ext:source-pathname symbol)))
497 ,(if pos
498 (list :position (1+ pos))
499 (list :function-name (string symbol)))
500 (:align t)))))
501
502 (defmethod source-location ((frame sys::java-stack-frame))
503 (destructuring-bind (&key class method file line) (sys:frame-to-list frame)
504 (declare (ignore method))
505 (let ((file (or (find-file-in-path file *source-path*)
506 (let ((f (format nil "~{~a/~}~a"
507 (butlast (split-string class "\\."))
508 file)))
509 (find-file-in-path f *source-path*)))))
510 (and file
511 `(:location ,file (:line ,line) ())))))
512
513 (defmethod source-location ((frame sys::lisp-stack-frame))
514 (destructuring-bind (operator &rest args) (sys:frame-to-list frame)
515 (declare (ignore args))
516 (etypecase operator
517 (function (source-location operator))
518 (list nil)
519 (symbol (source-location operator)))))
520
521 (defmethod source-location ((fun function))
522 (let ((name (function-name fun)))
523 (and name (source-location name))))
524
525 (defun system-property (name)
526 (java:jstatic "getProperty" "java.lang.System" name))
527
528 (defun pathname-parent (pathname)
529 (make-pathname :directory (butlast (pathname-directory pathname))))
530
531 (defun pathname-absolute-p (pathname)
532 (eq (car (pathname-directory pathname)) ':absolute))
533
534 (defun split-string (string regexp)
535 (coerce
536 (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
537 string regexp)
538 'list))
539
540 (defun path-separator ()
541 (java:jfield "java.io.File" "pathSeparator"))
542
543 (defun search-path-property (prop-name)
544 (let ((string (system-property prop-name)))
545 (and string
546 (remove nil
547 (mapcar #'truename
548 (split-string string (path-separator)))))))
549
550 (defun jdk-source-path ()
551 (let* ((jre-home (truename (system-property "java.home")))
552 (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
553 (truename (probe-file src-zip)))
554 (and truename (list truename))))
555
556 (defun class-path ()
557 (append (search-path-property "java.class.path")
558 (search-path-property "sun.boot.class.path")))
559
560 (defvar *source-path*
561 (append (search-path-property "user.dir")
562 (jdk-source-path)
563 ;;(list (truename "/scratch/abcl/src"))
564 )
565 "List of directories to search for source files.")
566
567 (defun zipfile-contains-p (zipfile-name entry-name)
568 (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile"
569 "java.lang.String")
570 zipfile-name)))
571 (java:jcall
572 (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
573 zipfile entry-name)))
574
575 ;; (find-file-in-path "java/lang/String.java" *source-path*)
576 ;; (find-file-in-path "Lisp.java" *source-path*)
577
578 ;; Try fo find FILENAME in PATH. If found, return a file spec as
579 ;; needed by Emacs. We also look in zip files.
580 (defun find-file-in-path (filename path)
581 (labels ((try (dir)
582 (cond ((not (pathname-type dir))
583 (let ((f (probe-file (merge-pathnames filename dir))))
584 (and f `(:file ,(namestring f)))))
585 ((equal (pathname-type dir) "zip")
586 (try-zip dir))
587 (t (error "strange path element: ~s" path))))
588 (try-zip (zip)
589 (let* ((zipfile-name (namestring (truename zip))))
590 (and (zipfile-contains-p zipfile-name filename)
591 `(:dir ,zipfile-name ,filename)))))
592 (cond ((pathname-absolute-p filename) (probe-file filename))
593 (t
594 (loop for dir in path
595 if (try dir) return it)))))
596
597 (defimplementation find-definitions (symbol)
598 (ext:resolve symbol)
599 (let ((srcloc (source-location symbol)))
600 (and srcloc `((,symbol ,srcloc)))))
601
602 #|
603 Uncomment this if you have patched xref.lisp, as in
604 http://article.gmane.org/gmane.lisp.slime.devel/2425
605 Also, make sure that xref.lisp is loaded by modifying the armedbear
606 part of *sysdep-pathnames* in swank.loader.lisp.
607
608 ;;;; XREF
609 (setq pxref:*handle-package-forms* '(cl:in-package))
610
611 (defmacro defxref (name function)
612 `(defimplementation ,name (name)
613 (xref-results (,function name))))
614
615 (defxref who-calls pxref:list-callers)
616 (defxref who-references pxref:list-readers)
617 (defxref who-binds pxref:list-setters)
618 (defxref who-sets pxref:list-setters)
619 (defxref list-callers pxref:list-callers)
620 (defxref list-callees pxref:list-callees)
621
622 (defun xref-results (symbols)
623 (let ((xrefs '()))
624 (dolist (symbol symbols)
625 (push (list symbol (cadar (source-location symbol))) xrefs))
626 xrefs))
627 |#
628
629 ;;;; Inspecting
630 (defmethod emacs-inspect ((o t))
631 (let ((parts (sys:inspected-parts o)))
632 `("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
633 ,@(if parts
634 (loop :for (label . value) :in parts
635 :appending (label-value-line label value))
636 (list "No inspectable parts, dumping output of CL:DESCRIBE:"
637 '(:newline)
638 (with-output-to-string (desc) (describe o desc)))))))
639
640 (defmethod emacs-inspect ((slot mop::slot-definition))
641 `("Name: "
642 (:value ,(mop::%slot-definition-name slot))
643 (:newline)
644 "Documentation:" (:newline)
645 ,@(when (slot-definition-documentation slot)
646 `((:value ,(slot-definition-documentation slot)) (:newline)))
647 "Initialization:" (:newline)
648 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
649 " Form: " ,(if (mop::%slot-definition-initfunction slot)
650 `(:value ,(mop::%slot-definition-initform slot))
651 "#<unspecified>") (:newline)
652 " Function: "
653 (:value ,(mop::%slot-definition-initfunction slot))
654 (:newline)))
655
656 (defmethod emacs-inspect ((f function))
657 `(,@(when (function-name f)
658 `("Name: "
659 ,(princ-to-string (function-name f)) (:newline)))
660 ,@(multiple-value-bind (args present)
661 (sys::arglist f)
662 (when present
663 `("Argument list: "
664 ,(princ-to-string args) (:newline))))
665 (:newline)
666 #+nil,@(when (documentation f t)
667 `("Documentation:" (:newline)
668 ,(documentation f t) (:newline)))
669 ,@(when (function-lambda-expression f)
670 `("Lambda expression:"
671 (:newline) ,(princ-to-string
672 (function-lambda-expression f)) (:newline)))))
673
674 ;;; Although by convention toString() is supposed to be a
675 ;;; non-computationally expensive operation this isn't always the
676 ;;; case, so make its computation a user interaction.
677 (defparameter *to-string-hashtable* (make-hash-table))
678 (defmethod emacs-inspect ((o java:java-object))
679 (let ((to-string (lambda ()
680 (handler-case
681 (setf (gethash o *to-string-hashtable*)
682 (java:jcall "toString" o))
683 (t (e)
684 (setf (gethash o *to-string-hashtable*)
685 (format nil
686 "Could not invoke toString(): ~A"
687 e)))))))
688 (append
689 (if (gethash o *to-string-hashtable*)
690 (label-value-line "toString()" (gethash o *to-string-hashtable*))
691 `((:action "[compute toString()]" ,to-string) (:newline)))
692 (loop :for (label . value) :in (sys:inspected-parts o)
693 :appending (label-value-line label value)))))
694
695 ;;;; Multithreading
696
697 (defimplementation spawn (fn &key name)
698 (threads:make-thread (lambda () (funcall fn)) :name name))
699
700 (defvar *thread-plists* (make-hash-table) ; should be a weak table
701 "A hashtable mapping threads to a plist.")
702
703 (defvar *thread-id-counter* 0)
704
705 (defimplementation thread-id (thread)
706 (threads:synchronized-on *thread-plists*
707 (or (getf (gethash thread *thread-plists*) 'id)
708 (setf (getf (gethash thread *thread-plists*) 'id)
709 (incf *thread-id-counter*)))))
710
711 (defimplementation find-thread (id)
712 (find id (all-threads)
713 :key (lambda (thread)
714 (getf (gethash thread *thread-plists*) 'id))))
715
716 (defimplementation thread-name (thread)
717 (threads:thread-name thread))
718
719 (defimplementation thread-status (thread)
720 (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
721
722 (defimplementation make-lock (&key name)
723 (declare (ignore name))
724 (threads:make-thread-lock))
725
726 (defimplementation call-with-lock-held (lock function)
727 (threads:with-thread-lock (lock) (funcall function)))
728
729 (defimplementation current-thread ()
730 (threads:current-thread))
731
732 (defimplementation all-threads ()
733 (copy-list (threads:mapcar-threads #'identity)))
734
735 (defimplementation thread-alive-p (thread)
736 (member thread (all-threads)))
737
738 (defimplementation interrupt-thread (thread fn)
739 (threads:interrupt-thread thread fn))
740
741 (defimplementation kill-thread (thread)
742 (threads:destroy-thread thread))
743
744 (defstruct mailbox
745 (queue '()))
746
747 (defun mailbox (thread)
748 "Return THREAD's mailbox."
749 (threads:synchronized-on *thread-plists*
750 (or (getf (gethash thread *thread-plists*) 'mailbox)
751 (setf (getf (gethash thread *thread-plists*) 'mailbox)
752 (make-mailbox)))))
753
754 (defimplementation send (thread message)
755 (let ((mbox (mailbox thread)))
756 (threads:synchronized-on mbox
757 (setf (mailbox-queue mbox)
758 (nconc (mailbox-queue mbox) (list message)))
759 (threads:object-notify-all mbox))))
760
761 (defimplementation receive-if (test &optional timeout)
762 (let* ((mbox (mailbox (current-thread))))
763 (assert (or (not timeout) (eq timeout t)))
764 (loop
765 (check-slime-interrupts)
766 (threads:synchronized-on mbox
767 (let* ((q (mailbox-queue mbox))
768 (tail (member-if test q)))
769 (when tail
770 (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
771 (return (car tail)))
772 (when (eq timeout t) (return (values nil t)))
773 (threads:object-wait mbox 0.3))))))
774
775 (defimplementation quit-lisp ()
776 (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5