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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (show annotations)
Sun Nov 27 21:47:15 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.89: +1 -1 lines
* swank.lisp (create-server): Add a :backlog argument.
(setup-server): Pass it along.

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

  ViewVC Help
Powered by ViewVC 1.1.5